Repository: trizen/perl-scripts Branch: master Commit: 61e3d7fc8407 Files: 1290 Total size: 4.2 MB Directory structure: gitextract_4x__q3zn/ ├── .gitignore ├── Analyzers/ │ ├── char_counter.pl │ ├── chr_freq.pl │ ├── dieharder.pl │ ├── first_letter_top.pl │ ├── kcal/ │ │ ├── kcal.pl │ │ └── products.csv │ ├── kernel_config_diff.pl │ ├── perl_code_analyzer.pl │ ├── perl_code_spellcheck.pl │ ├── reptop.pl │ ├── text_stats.pl │ ├── unidecode_word_top.pl │ ├── wcer.pl │ └── word_suffix_top.pl ├── Audio/ │ ├── auto-mp3tags.pl │ ├── group_audio_files.pl │ ├── mkv_audio_to_opus.pl │ ├── recompress_audio_track.pl │ ├── rem-mp3tags.pl │ ├── wave-cmp.pl │ └── wave-cmp2.pl ├── Benchmarks/ │ ├── array_range_vs_shift.pl │ ├── compression_algorithms.pl │ ├── json_vs_storable.pl │ ├── schwartzian_transform.pl │ └── types_of_variables.pl ├── Book tools/ │ ├── rosettacode_to_markdown.pl │ └── update_summary.pl ├── Compression/ │ ├── High-level/ │ │ ├── ablz_file_compression.pl │ │ ├── bbwr_file_compression.pl │ │ ├── blzss2_file_compression.pl │ │ ├── blzss_file_compression.pl │ │ ├── brlzss_file_compression.pl │ │ ├── bwac_file_compression.pl │ │ ├── bwad_file_compression.pl │ │ ├── bwlz2_file_compression.pl │ │ ├── bwlz3_file_compression.pl │ │ ├── bwlz_file_compression.pl │ │ ├── bwlza2_file_compression.pl │ │ ├── bwlza_file_compression.pl │ │ ├── bwlzad2_file_compression.pl │ │ ├── bwlzad_file_compression.pl │ │ ├── bwlzb_file_compression.pl │ │ ├── bwlzhd2_file_compression.pl │ │ ├── bwlzhd_file_compression.pl │ │ ├── bwlzss_file_compression.pl │ │ ├── bwrl2_file_compression.pl │ │ ├── bwrm2_file_compression.pl │ │ ├── bwrm_file_compression.pl │ │ ├── bwt2_file_compression.pl │ │ ├── bwt_file_compression.pl │ │ ├── bzip2_file_compression.pl │ │ ├── gzip_file_compression.pl │ │ ├── hblz_file_compression.pl │ │ ├── lz255_file_compression.pl │ │ ├── lz2ss_file_compression.pl │ │ ├── lz4_file_compression.pl │ │ ├── lz772_file_compression.pl │ │ ├── lz77_file_compression.pl │ │ ├── lz77f_file_compression.pl │ │ ├── lzac_file_compression.pl │ │ ├── lzb_file_compression.pl │ │ ├── lzbbw_file_compression.pl │ │ ├── lzbf_file_compression.pl │ │ ├── lzbh_file_compression.pl │ │ ├── lzbw2_file_compression.pl │ │ ├── lzbw3_file_compression.pl │ │ ├── lzbw4_file_compression.pl │ │ ├── lzbw5_file_compression.pl │ │ ├── lzbw_file_compression.pl │ │ ├── lzbwa_file_compression.pl │ │ ├── lzbwad_file_compression.pl │ │ ├── lzbwd_file_compression.pl │ │ ├── lzbwh_file_compression.pl │ │ ├── lzbws_file_compression.pl │ │ ├── lzhd2_file_compression.pl │ │ ├── lzhd_file_compression.pl │ │ ├── lzih_file_compression.pl │ │ ├── lzmrl2_file_compression.pl │ │ ├── lzmrl_file_compression.pl │ │ ├── lzop_file_compression.pl │ │ ├── lzsbw_file_compression.pl │ │ ├── lzss2_file_compression.pl │ │ ├── lzss77_file_compression.pl │ │ ├── lzss_file_compression.pl │ │ ├── lzssf_file_compression.pl │ │ ├── lzssm_file_compression.pl │ │ ├── lzw_file_compression.pl │ │ ├── mblz_file_compression.pl │ │ ├── mbwr_file_compression.pl │ │ ├── mrl_file_compression.pl │ │ ├── mybzip2_file_compression.pl │ │ ├── mygzip_file_compression.pl │ │ ├── mygzipf_file_compression.pl │ │ ├── mylz4_file_compression.pl │ │ ├── mylz4f_file_compression.pl │ │ ├── myzlib_file_compression.pl │ │ ├── rablz_file_compression.pl │ │ ├── rlzss_file_compression.pl │ │ ├── sbwt_file_compression.pl │ │ ├── xz_file_compression.pl │ │ ├── zlib_file_compression.pl │ │ └── zstd_file_compression.pl │ ├── bbwr_file_compression.pl │ ├── bqof_file_compression.pl │ ├── bwac_file_compression.pl │ ├── bwad_file_compression.pl │ ├── bwaz_file_compression.pl │ ├── bwlz2_file_compression.pl │ ├── bwlz_file_compression.pl │ ├── bwlza2_file_compression.pl │ ├── bwlza_file_compression.pl │ ├── bwlzad2_file_compression.pl │ ├── bwlzad_file_compression.pl │ ├── bwlzhd_file_compression.pl │ ├── bwlzss_file_compression.pl │ ├── bwrl2_file_compression.pl │ ├── bwrl_file_compression.pl │ ├── bwrla_file_compression.pl │ ├── bwrlz2_file_compression.pl │ ├── bwrlz_file_compression.pl │ ├── bwrm_file_compression.pl │ ├── bwt2_file_compression.pl │ ├── bwt_file_compression.pl │ ├── bww_file_compression.pl │ ├── bzip2_compressor.pl │ ├── bzip2_decompressor.pl │ ├── bzip2_file_compression.pl │ ├── compress.pl │ ├── gzip2_file_compression.pl │ ├── gzip_block_type_1.pl │ ├── gzip_block_type_1_huffman_only.pl │ ├── gzip_block_type_2.pl │ ├── gzip_block_type_2_huffman_only.pl │ ├── gzip_block_type_2_simple.pl │ ├── gzip_comment.pl │ ├── gzip_decompressor.pl │ ├── gzip_file_compression.pl │ ├── gzip_store.pl │ ├── hfm_file_compression.pl │ ├── lz4_compressor.pl │ ├── lz4_decompressor.pl │ ├── lz4_file_compression.pl │ ├── lz77_file_compression.pl │ ├── lza_file_compression.pl │ ├── lzac_file_compression.pl │ ├── lzaz_file_compression.pl │ ├── lzb2_file_compression.pl │ ├── lzb_file_compression.pl │ ├── lzbf2_file_compression.pl │ ├── lzbf_file_compression.pl │ ├── lzbh_file_compression.pl │ ├── lzbw_file_compression.pl │ ├── lzbwa_file_compression.pl │ ├── lzbwad_file_compression.pl │ ├── lzbwd_file_compression.pl │ ├── lzbwh_file_compression.pl │ ├── lzh_file_compression.pl │ ├── lzhc_file_compression.pl │ ├── lzhd_file_compression.pl │ ├── lzih_file_compression.pl │ ├── lzsa_file_compression.pl │ ├── lzsad_file_compression.pl │ ├── lzsbw_file_compression.pl │ ├── lzss2_file_compression.pl │ ├── lzss_file_compression.pl │ ├── lzssf_file_compression.pl │ ├── lzsst2_file_compression.pl │ ├── lzsst_file_compression.pl │ ├── lzt2_file_compression.pl │ ├── lzt_file_compression.pl │ ├── lzw_file_compression.pl │ ├── mbwr_file_compression.pl │ ├── mra_file_compression.pl │ ├── mrh_file_compression.pl │ ├── mrlz_file_compression.pl │ ├── ppmh_file_compression.pl │ ├── qof_file_compression.pl │ ├── rans_file_compression.pl │ ├── rlac_file_compression.pl │ ├── rlh_file_compression.pl │ ├── tac_file_compression.pl │ ├── tacc_file_compression.pl │ ├── test_compressors.pl │ ├── tzip2_file_compression.pl │ ├── tzip_file_compression.pl │ ├── unzip.pl │ ├── zip.pl │ ├── zlib_compressor.pl │ ├── zlib_decompressor.pl │ └── zlib_file_compression.pl ├── Converters/ │ ├── another_notes_to_markdown.pl │ ├── another_notes_to_material_notes.pl │ ├── any_to_3gp.pl │ ├── ass2srt.pl │ ├── code2pdf.pl │ ├── euler2pdf.pl │ ├── from_hex.pl │ ├── gdbm_to_berkeley.pl │ ├── gitbook2pdf.pl │ ├── gz2xz.pl │ ├── html2pdf.pl │ ├── html2pdf_chromium.pl │ ├── html2text.pl │ ├── json2csv.pl │ ├── markdown2pdf.pl │ ├── markdown2pdf_chromium.pl │ ├── markdown2text.pl │ ├── notepadfree_to_txt.pl │ ├── pod2pdf.pl │ ├── pod2text.pl │ ├── recompress.pl │ ├── unicode2ascii.pl │ ├── vnt2txt_simple.pl │ ├── xml2hash.pl │ ├── xpm_c_to_perl.pl │ ├── xz2gz.pl │ ├── zip2tar.pl │ └── zip2tar_fast.pl ├── Decoders/ │ ├── base64_decoding-tutorial.pl │ ├── cnp_info.pl │ └── named_parameters.pl ├── Digest/ │ ├── brute-force_resistant_hashing.pl │ └── crc32.pl ├── Encoding/ │ ├── adaptive_huffman_coding.pl │ ├── arithmetic_coding.pl │ ├── arithmetic_coding_adaptive_contexts_in_fixed_bits.pl │ ├── arithmetic_coding_adaptive_in_fixed_bits.pl │ ├── arithmetic_coding_anynum.pl │ ├── arithmetic_coding_in_fixed_bits.pl │ ├── arithmetic_coding_mpz.pl │ ├── ascii_encode_decode.pl │ ├── binary_arithmetic_coding.pl │ ├── binary_arithmetic_coding_anynum.pl │ ├── binary_variable_length_run_encoding.pl │ ├── binradix_arithmetic_coding.pl │ ├── binradix_arithmetic_coding_anynum.pl │ ├── burrows-wheeler_file_transform.pl │ ├── burrows-wheeler_transform-n-char_generalization.pl │ ├── burrows-wheeler_transform.pl │ ├── burrows-wheeler_transform_symbolic.pl │ ├── delta_encoding_with_double-elias_coding.pl │ ├── delta_encoding_with_elias_coding.pl │ ├── delta_encoding_with_unary_coding.pl │ ├── delta_rle_elias_encoding.pl │ ├── double-elias_gamma_encoding.pl │ ├── elias_gamma_encoding.pl │ ├── eyes_dropper.pl │ ├── fibonacci_coding.pl │ ├── huffman_coding.pl │ ├── int2bytes.pl │ ├── integers_binary_encoding.pl │ ├── integers_binary_encoding_with_delta_coding.pl │ ├── integers_binary_encoding_with_huffman_coding.pl │ ├── jpeg_transform.pl │ ├── length_encoder.pl │ ├── lz77_encoding.pl │ ├── lz77_encoding_symbolic.pl │ ├── lzss_encoding.pl │ ├── lzss_encoding_hash_table.pl │ ├── lzss_encoding_hash_table_fast.pl │ ├── lzss_encoding_symbolic.pl │ ├── lzt-fast.pl │ ├── lzw_encoding.pl │ ├── math_expr_encoder.pl │ ├── move-to-front_transform.pl │ ├── mtf-delta_encoding.pl │ ├── png_transform.pl │ ├── ppm_encoding.pl │ ├── ppm_encoding_dynamic.pl │ ├── rANS_encoding.pl │ ├── rANS_encoding_mpz.pl │ ├── run_length_with_elias_coding.pl │ ├── string_to_integer_encoding_based_on_primes.pl │ ├── swap_transform.pl │ ├── tlen_encoding.pl │ └── variable_length_run_encoding.pl ├── Encryption/ │ ├── RSA_encryption.pl │ ├── age-lf.pl │ ├── backdoored_rsa_with_x25519.pl │ ├── cbc+xor_file_encrypter.pl │ ├── crypt_rsa.pl │ ├── one-time_pad.pl │ ├── plage.pl │ └── simple_XOR_cipher.pl ├── File Readers/ │ ├── ldump │ ├── multi-file-line-reader.pl │ ├── n_repeated_lines.pl │ └── tailz ├── File Workers/ │ ├── arxiv_pdf_renamer.pl │ ├── auto_extensions.pl │ ├── collect_gifs.pl │ ├── collect_videos.pl │ ├── delete_if_exists.pl │ ├── dir_file_updater.pl │ ├── file-mover.pl │ ├── file_updater.pl │ ├── filename_cmp_del.pl │ ├── keep_this_formats.pl │ ├── make_filenames_portable.pl │ ├── md5_rename.pl │ ├── multiple_backups.pl │ ├── remove_eof_newlines.pl │ ├── split_to_n_lines.pl │ ├── sub_renamer.pl │ ├── timestamp_rename.pl │ ├── undir.pl │ └── unidec_renamer.pl ├── Finders/ │ ├── ampath │ ├── dup_subtr_finder.pl │ ├── fcheck.pl │ ├── fdf │ ├── fdf-attr │ ├── fdf-filename │ ├── file_binsearch.pl │ ├── find_perl_scripts.pl │ ├── find_similar_filenames.pl │ ├── find_similar_filenames_unidec.pl │ ├── fsf.pl │ ├── fsfn.pl │ ├── human-like_finder.pl │ ├── large_file_search.pl │ ├── locatepm │ ├── longest_substring.pl │ ├── mimefind.pl │ ├── model_matching_system.pl │ ├── path_diff.pl │ ├── plocate.pl │ └── similar_files_levenshtein.pl ├── Formatters/ │ ├── ascii_table_csv.pl │ ├── file_columner.pl │ ├── fstab_beautifier.pl │ ├── js_beautify │ ├── reformat_literal_perl_strings.pl │ ├── replace_html_links.pl │ ├── sort_perl_subroutines.pl │ └── word_columner.pl ├── GD/ │ ├── AND_sierpinski_triangle.pl │ ├── LSystem/ │ │ ├── LSystem.pm │ │ ├── Turtle.pm │ │ ├── honeycomb.pl │ │ ├── honeycomb_2.pl │ │ ├── plant.pl │ │ ├── plant_2.pl │ │ ├── plant_3.pl │ │ ├── sierpinski_triangle.pl │ │ └── tree.pl │ ├── XOR_pattern.pl │ ├── abstract_map.pl │ ├── barnsley_fern_fractal.pl │ ├── binary_triangle.pl │ ├── black_star_turtle.pl │ ├── black_yellow_number_triangles.pl │ ├── box_pattern.pl │ ├── chaos_game_pentagon.pl │ ├── chaos_game_tetrahedron.pl │ ├── chaos_game_triangle.pl │ ├── circular_prime_triangle.pl │ ├── circular_triangle.pl │ ├── collatz_triangle.pl │ ├── color_wheel.pl │ ├── complex_square.pl │ ├── congruence_of_squares_triangle.pl │ ├── cuboid_turtle.pl │ ├── cuboid_turtle3.pl │ ├── cuboid_turtle_2.pl │ ├── dancing_shapes.pl │ ├── divisor_circles.pl │ ├── divisor_triangle.pl │ ├── elementary_cellular_automaton_generalized.pl │ ├── fact_exp_primorial_growing.pl │ ├── factor_circles.pl │ ├── factor_triangle.pl │ ├── factorial_turtles.pl │ ├── factors_of_two_triangle.pl │ ├── farey_turnings_plot.pl │ ├── fgraph.pl │ ├── fgraph_precision.pl │ ├── fibonacci_gd.pl │ ├── fibonacci_spirals.pl │ ├── generator_turtle.pl │ ├── geometric_shapes.pl │ ├── goldbach_conjecture_possibilities.pl │ ├── horsie_art.pl │ ├── julia_set.pl │ ├── julia_set_complex.pl │ ├── julia_set_random.pl │ ├── julia_set_rperl.pl │ ├── koch_snowflakes.pl │ ├── langton_s_ant_gd.pl │ ├── line_pattern_triangles.pl │ ├── magic_triangle.pl │ ├── mandelbrot_like_set.pl │ ├── mandelbrot_like_set_gcomplex.pl │ ├── mathematical_butt.pl │ ├── mathematical_shapes.pl │ ├── mirror_shells.pl │ ├── moebius_walking_line.pl │ ├── number_triangles.pl │ ├── numeric_circles.pl │ ├── pascal-fibonacci_triangle.pl │ ├── pascal_powers_of_two_triangle.pl │ ├── pascal_s_triangle_multiples.pl │ ├── pascal_special_triangle.pl │ ├── pattern_triangle.pl │ ├── peacock_triangles.pl │ ├── pi_abstract_art.pl │ ├── pi_turtle.pl │ ├── prime_consecutive_sums.pl │ ├── prime_gaps.pl │ ├── prime_rectangles.pl │ ├── prime_stripe_triangle.pl │ ├── prime_triangle_90deg.pl │ ├── pythagoras_tree.pl │ ├── random_abstract_art.pl │ ├── random_abstract_art_2.pl │ ├── random_langton_s_ant.pl │ ├── random_looking_pattern_triangle.pl │ ├── random_machinery_art.pl │ ├── random_noise_triangle.pl │ ├── random_turtles.pl │ ├── real_shell.pl │ ├── recursive_squares.pl │ ├── regular_poligons.pl │ ├── reversed_prime_triangles.pl │ ├── right_triangle_primes.pl │ ├── sandpiles.pl │ ├── sierpinski_fibonacci_triangle.pl │ ├── sierpinski_triangle.pl │ ├── spinning_shapes.pl │ ├── spiral_matrix_primes.pl │ ├── spiral_tree.pl │ ├── square_of_circles.pl │ ├── star_turtle.pl │ ├── stern_brocot_shapes.pl │ ├── triangle_factors.pl │ ├── triangle_primes.pl │ ├── triangle_primes_2.pl │ ├── triangle_primes_irregular.pl │ ├── trizen_fan_turtle.pl │ ├── trizen_flat_logo.pl │ ├── trizen_new_logo.pl │ ├── trizen_old_logo.pl │ ├── trizen_text_art.pl │ ├── tupper_s_self-referential_formula.pl │ ├── wavy_triangle.pl │ ├── zeta_real_half_terms.pl │ └── zig-zag_primes.pl ├── GTK+/ │ ├── mouse_position.pl │ └── tray-file-browser.pl ├── Game solvers/ │ ├── asciiplanes-player-v2.pl │ ├── asciiplanes-player.pl │ ├── dice_game_solver.pl │ ├── peg-solitaire-solver │ ├── reaction_time_test.pl │ ├── reflex_sheep_game.pl │ ├── sudoku_dice_game_solver.pl │ ├── sudoku_generator.pl │ ├── sudoku_solver.pl │ ├── sudoku_solver_backtracking.pl │ ├── sudoku_solver_iterative.pl │ ├── sudoku_solver_stack.pl │ └── visual_memory_test.pl ├── Games/ │ ├── arrow-key_drawer.pl │ ├── asciiplanes │ └── snake_game.pl ├── Generators/ │ ├── bernoulli_numbers_formulas.pl │ ├── faulhaber_s_formula_symbolic.pl │ ├── faulhaber_s_formulas_expanded.pl │ ├── faulhaber_s_formulas_expanded_2.pl │ ├── faulhaber_s_formulas_generator.pl │ ├── parsing_and_code_gen.pl │ ├── powers_of_factorial.pl │ ├── random_lsystem_generator.pl │ ├── semiprime_equationization_C_generator.pl │ ├── semiprime_equationization_Perl_generator.pl │ └── zeta_2n_generator.pl ├── Greppers/ │ ├── marif │ ├── mime_types.pl │ ├── mp3grep.pl │ ├── scgrep │ └── unigrep.pl ├── HAL/ │ ├── HAL3736/ │ │ ├── HAL3736.memory │ │ └── HAL3736.pl │ ├── HAL8212/ │ │ ├── HAL8212.memory │ │ └── HAL8212.pl │ └── HAL9000/ │ ├── HAL9000.memory │ └── HAL9000.pl ├── Image/ │ ├── 2x_zoom.pl │ ├── add_exif_info.pl │ ├── bitmap_monochrome_encoding_decoding.pl │ ├── bwt_horizontal_transform.pl │ ├── bwt_rgb_horizontal_transform.pl │ ├── bwt_rgb_vertical_transform.pl │ ├── bwt_vertical_transform.pl │ ├── collage.pl │ ├── complex_transform.pl │ ├── cyan_vision.pl │ ├── darken_image.pl │ ├── diff_negative.pl │ ├── edge_detector.pl │ ├── extract_jpegs.pl │ ├── fractal_frame.pl │ ├── fractal_frame_transparent.pl │ ├── gd_png2jpg.pl │ ├── gd_similar_images.pl │ ├── gd_star_trails.pl │ ├── gif2webp.pl │ ├── horizontal_scrambler.pl │ ├── image-hard-rotate.pl │ ├── image-unpack.pl │ ├── image2ascii.pl │ ├── image2audio.pl │ ├── image2digits.pl │ ├── image2html.pl │ ├── image2matrix.pl │ ├── image2mozaic.pl │ ├── image2png.pl │ ├── image2prime.pl │ ├── image_metadata_clone.pl │ ├── imager_similar_images.pl │ ├── img-autocrop-avg.pl │ ├── img-autocrop-whitebg.pl │ ├── img-autocrop.pl │ ├── img_composition.pl │ ├── img_rewrite.pl │ ├── julia_transform.pl │ ├── lookalike_images.pl │ ├── magick_png2jpg.pl │ ├── magick_similar_images.pl │ ├── magick_star_trails.pl │ ├── matrix_visual.pl │ ├── mirror_images.pl │ ├── mtf_horizontal_transform.pl │ ├── mtf_vertical_transform.pl │ ├── nearest_neighbor_interpolation.pl │ ├── optimize_images.pl │ ├── optimize_images_littleutils.pl │ ├── outguess-png-imager.pl │ ├── outguess-png.pl │ ├── photo_mosaic_from_images.pl │ ├── qhi_decoder.pl │ ├── qhi_encoder.pl │ ├── qoi_decoder.pl │ ├── qoi_encoder.pl │ ├── qzst_decoder.pl │ ├── qzst_encoder.pl │ ├── recompress_images.pl │ ├── remove_sensitive_exif_tags.pl │ ├── resize_images.pl │ ├── rgb_dump.pl │ ├── sharp_2x_zoom.pl │ ├── slideshow.pl │ ├── vertical_scrambler.pl │ ├── visualize_binary.pl │ ├── webp2png.pl │ ├── zuper_image_decoder.pl │ └── zuper_image_encoder.pl ├── JAPH/ │ ├── alien_japh.pl │ ├── alpha_ascii_japh.pl │ ├── alpha_japh.pl │ ├── alpha_japh_2.pl │ ├── alpha_japh_3.pl │ ├── arrow_japh.pl │ ├── barewords_japh.pl │ ├── cubic_japh.pl │ ├── invisible_japh.pl │ ├── japh_from_ambiguity.pl │ ├── japh_from_auto-quoted_keywords.pl │ ├── japh_from_escapes.pl │ ├── japh_from_escapes_2.pl │ ├── japh_from_eval_subst.pl │ ├── japh_from_keywords.pl │ ├── japh_from_pod.pl │ ├── japh_from_poetry.pl │ ├── japh_from_punctuation_chars.pl │ ├── japh_from_subs.pl │ ├── japh_from_the_deep.pl │ ├── japh_variable.pl │ ├── japh_variables.pl │ ├── japh_variables_2.pl │ ├── leet_japh.pl │ ├── length_obfuscation.pl │ ├── log_japh.pl │ ├── log_japh_2.pl │ ├── non-alphanumeric_japh.pl │ ├── re_eval_japh.pl │ ├── slash_r_japh.pl │ ├── ternary_japh.pl │ ├── up_and_down.pl │ ├── vec_japh.pl │ └── vec_japh_2.pl ├── LICENSE ├── Lingua/ │ ├── en_phoneme.pl │ ├── lingua_ro_numbers.pl │ ├── poetry_from_poetry.pl │ ├── poetry_from_poetry_with_variations.pl │ ├── random_poetry_generator.pl │ └── rus_translit.pl ├── Math/ │ ├── 1_over_n_is_finite.pl │ ├── 1_over_n_period_length.pl │ ├── BPSW_primality_test.pl │ ├── BPSW_primality_test_mpz.pl │ ├── LUP_decomposition.pl │ ├── MBE_factorization_method.pl │ ├── PSW_primality_test.pl │ ├── PSW_primality_test_mpz.pl │ ├── RSA_PRNG.pl │ ├── RSA_example.pl │ ├── additive_binomial.pl │ ├── additive_partitions.pl │ ├── alexandrian_integers.pl │ ├── almost_prime_divisors.pl │ ├── almost_prime_divisors_recursive.pl │ ├── almost_prime_numbers.pl │ ├── almost_prime_numbers_in_range.pl │ ├── almost_prime_numbers_in_range_mpz.pl │ ├── almost_prime_numbers_in_range_v2.pl │ ├── almost_primes_from_factor_list.pl │ ├── almost_primes_in_range_from_factor_list.pl │ ├── area_of_triangle.pl │ ├── arithmetic_derivative.pl │ ├── arithmetic_expressions.pl │ ├── arithmetic_geometric_mean_complex.pl │ ├── arithmetic_sum_closed_form.pl │ ├── ascii_cuboid.pl │ ├── ascii_julia_set.pl │ ├── ascii_mandelbrot_set.pl │ ├── batir_factorial_asymptotic_formula_mpfr.pl │ ├── bell_numbers.pl │ ├── bell_numbers_mpz.pl │ ├── bernoulli_denominators.pl │ ├── bernoulli_denominators_records.pl │ ├── bernoulli_numbers.pl │ ├── bernoulli_numbers_from_factorials.pl │ ├── bernoulli_numbers_from_factorials_mpq.pl │ ├── bernoulli_numbers_from_factorials_mpz.pl │ ├── bernoulli_numbers_from_factorials_visual.pl │ ├── bernoulli_numbers_from_primes.pl │ ├── bernoulli_numbers_from_primes_gmpf.pl │ ├── bernoulli_numbers_from_primes_mpfr.pl │ ├── bernoulli_numbers_from_primes_ntheory.pl │ ├── bernoulli_numbers_from_tangent_numbers.pl │ ├── bernoulli_numbers_from_zeta.pl │ ├── bernoulli_numbers_ramanujan_congruences.pl │ ├── bernoulli_numbers_ramanujan_congruences_unreduced.pl │ ├── bernoulli_numbers_recursive.pl │ ├── bernoulli_numbers_recursive_2.pl │ ├── bernoulli_numbers_seidel.pl │ ├── bi-unitary_divisors.pl │ ├── binary_gcd_algorithm.pl │ ├── binary_gcd_algorithm_mpz.pl │ ├── binary_multiplier.pl │ ├── binary_prime_encoder.pl │ ├── binary_prime_encoder_fast.pl │ ├── binary_prime_sieve_mpz.pl │ ├── binary_splitting_product.pl │ ├── binomial_sum_with_imaginary_term.pl │ ├── binomial_theorem.pl │ ├── bitstring_prime_sieve_mpz.pl │ ├── bitstring_prime_sieve_vec.pl │ ├── both_truncatable_primes_in_base.pl │ ├── brazilian_primes_constant.pl │ ├── brown_numbers.pl │ ├── carmichael_factorization_method.pl │ ├── carmichael_factorization_method_generalized.pl │ ├── carmichael_numbers_from_multiple.pl │ ├── carmichael_numbers_from_multiple_mpz.pl │ ├── carmichael_numbers_from_multiple_recursive_mpz.pl │ ├── carmichael_numbers_generation_erdos_method.pl │ ├── carmichael_numbers_generation_erdos_method_dynamic_programming.pl │ ├── carmichael_numbers_in_range.pl │ ├── carmichael_numbers_in_range_from_prime_factors.pl │ ├── carmichael_numbers_in_range_mpz.pl │ ├── carmichael_numbers_random.pl │ ├── carmichael_strong_fermat_pseudoprimes_in_range.pl │ ├── carmichael_strong_fermat_pseudoprimes_in_range_mpz.pl │ ├── cartesian_product_iter.pl │ ├── cartesian_product_rec.pl │ ├── cauchy_numbers_of_first_type.pl │ ├── chebyshev_factorization_method.pl │ ├── chebyshev_factorization_method_mpz.pl │ ├── chernick-carmichael_numbers.pl │ ├── chernick-carmichael_numbers_below_limit.pl │ ├── chernick-carmichael_polynomials.pl │ ├── chernick-carmichael_with_n_factors_sieve.pl │ ├── chinese_factorization_method.pl │ ├── coin_change.pl │ ├── collatz_function.pl │ ├── complex_exponentiation_in_real_numbers.pl │ ├── complex_logarithm_in_real_numbers.pl │ ├── complex_modular_multiplicative_inverse.pl │ ├── complex_zeta_in_real_numbers.pl │ ├── congruence_of_powers_factorization_method.pl │ ├── consecutive_partitions.pl │ ├── continued_fraction_expansion_of_sqrt_of_n.pl │ ├── continued_fraction_expansion_of_sqrt_of_n_mpz.pl │ ├── continued_fraction_factorization_method.pl │ ├── continued_fractions.pl │ ├── continued_fractions_for_e.pl │ ├── continued_fractions_for_nth_roots.pl │ ├── continued_fractions_for_pi.pl │ ├── continued_fractions_for_square_roots.pl │ ├── continued_fractions_prime_constant.pl │ ├── convergent_series.pl │ ├── cosmic_calendar.pl │ ├── count_of_brilliant_numbers.pl │ ├── count_of_cube-full_numbers.pl │ ├── count_of_integers_with_gpf_of_n_equals_p.pl │ ├── count_of_integers_with_lpf_of_n_equals_p.pl │ ├── count_of_inverse_tau_in_range.pl │ ├── count_of_k-almost_primes.pl │ ├── count_of_k-omega_primes.pl │ ├── count_of_k-powerfree_numbers.pl │ ├── count_of_k-powerful_numbers.pl │ ├── count_of_k-powerful_numbers_in_range.pl │ ├── count_of_perfect_powers.pl │ ├── count_of_prime_power.pl │ ├── count_of_prime_signature_numbers.pl │ ├── count_of_rough_numbers.pl │ ├── count_of_rough_numbers_recursive.pl │ ├── count_of_smooth_numbers.pl │ ├── count_of_smooth_numbers_memoized.pl │ ├── count_of_smooth_numbers_mpz.pl │ ├── count_of_smooth_numbers_mpz_2.pl │ ├── count_of_smooth_numbers_with_k_factors.pl │ ├── count_of_squarefree_k-almost_primes.pl │ ├── count_of_squarefree_numbers.pl │ ├── count_subtriangles.pl │ ├── cube-full_numbers.pl │ ├── cuboid.pl │ ├── cyclotomic_factorization_method.pl │ ├── cyclotomic_factorization_method_2.pl │ ├── cyclotomic_polynomial.pl │ ├── definite_integral_numerical_approximation.pl │ ├── dickson_linear_forms_prime_sieve.pl │ ├── dickson_linear_forms_prime_sieve_in_range.pl │ ├── dickson_linear_forms_prime_sieve_in_range_2.pl │ ├── difference_of_k_powers.pl │ ├── difference_of_powers_factorization_method.pl │ ├── difference_of_three_squares_solutions.pl │ ├── difference_of_two_squares_solutions.pl │ ├── digits_to_number_subquadratic_algorithm.pl │ ├── digits_to_number_subquadratic_algorithm_mpz.pl │ ├── dirichlet_hyperbola_method.pl │ ├── discrete_logarithm_pollard_rho.pl │ ├── discrete_logarithm_pollard_rho_mpz.pl │ ├── discrete_root.pl │ ├── divisors_descending_lazy.pl │ ├── divisors_lazy.pl │ ├── divisors_lazy_fast.pl │ ├── divisors_less_than_k.pl │ ├── divisors_of_factorial_below_limit.pl │ ├── divisors_of_factorial_in_range_iterator.pl │ ├── dixon_factorization_method.pl │ ├── e_from_binomial.pl │ ├── e_primorial.pl │ ├── ecm_factorization_method.pl │ ├── elementary_cellular_automaton_generalized.pl │ ├── elliptic-curve_factorization_method.pl │ ├── elliptic-curve_factorization_method_with_B2_stage.pl │ ├── elliptic-curve_factorization_method_with_B2_stage_mpz.pl │ ├── equally_spaced_squares_solutions.pl │ ├── esthetic_numbers.pl │ ├── ethiopian_multiplication.pl │ ├── ethiopian_multiplication_binary.pl │ ├── even_fermat_pseudoprimes_in_range.pl │ ├── even_squarefree_fermat_pseudoprimes_in_range.pl │ ├── exponential_divisors.pl │ ├── factorial_difference_of_prime_squares.pl │ ├── factorial_dsc_algorithm.pl │ ├── factorial_expansion_of_reciprocals.pl │ ├── factorial_from_primes.pl │ ├── factorial_from_primes_simple.pl │ ├── factorial_from_primorials.pl │ ├── factorial_from_trinomial_coefficients.pl │ ├── factorial_in_half_steps.pl │ ├── factorions_in_base_n.pl │ ├── factorization_with_difference_of_prime_factors.pl │ ├── farey_rational_approximation.pl │ ├── faulhaber_s_formula.pl │ ├── fermat_factorization_method.pl │ ├── fermat_factorization_method_2.pl │ ├── fermat_frobenius_quadratic_primality_test.pl │ ├── fermat_overpseudoprimes_generation.pl │ ├── fermat_overpseudoprimes_in_range.pl │ ├── fermat_pseudoprimes_from_multiple.pl │ ├── fermat_pseudoprimes_from_multiple_mpz.pl │ ├── fermat_pseudoprimes_generation.pl │ ├── fermat_pseudoprimes_generation_2.pl │ ├── fermat_pseudoprimes_generation_3.pl │ ├── fermat_pseudoprimes_in_range.pl │ ├── fermat_pseudoprimes_in_range_mpz.pl │ ├── fermat_superpseudoprimes_generation.pl │ ├── fibonacci_closed_form.pl │ ├── fibonacci_closed_form_2.pl │ ├── fibonacci_encoding.pl │ ├── fibonacci_factorization_method.pl │ ├── fibonacci_k-th_order.pl │ ├── fibonacci_k-th_order_efficient_algorithm.pl │ ├── fibonacci_k-th_order_fast.pl │ ├── fibonacci_k-th_order_odd_primes_indices.pl │ ├── fibonacci_number_fast.pl │ ├── fibonacci_polynomials_closed_form.pl │ ├── fibonacci_pseudoprimes_generation.pl │ ├── find_least_common_denominator.pl │ ├── floor_and_ceil_functions_fourier_series.pl │ ├── flt_factorization_method.pl │ ├── fraction_approximation.pl │ ├── fraction_to_decimal_expansion.pl │ ├── fractional_pi.pl │ ├── frobenius_pseudoprimes_generation.pl │ ├── fubini_numbers.pl │ ├── fubini_numbers_2.pl │ ├── fubini_numbers_recursive.pl │ ├── function_graph.pl │ ├── function_inverse_binary_search.pl │ ├── gamma_function.pl │ ├── gaussian_divisors.pl │ ├── gaussian_factors.pl │ ├── gaussian_integers_sum.pl │ ├── general_binary_multiplier.pl │ ├── goldbach_conjecture_2n_prime.pl │ ├── goldbach_conjecture_increasing_primes.pl │ ├── goldbach_conjecture_possibilities.pl │ ├── goldbach_conjecture_random_primes.pl │ ├── golomb_s_sequence.pl │ ├── greatest_common_unitary_divisor.pl │ ├── hamming_numbers.pl │ ├── harmonic_numbers.pl │ ├── harmonic_numbers_from_digamma.pl │ ├── harmonic_numbers_from_powers.pl │ ├── harmonic_numbers_from_powers_mpz.pl │ ├── harmonic_prime_powers.pl │ ├── hybrid_prime_factorization.pl │ ├── infinitary_divisors.pl │ ├── inverse_of_bernoulli_numbers.pl │ ├── inverse_of_euler_totient.pl │ ├── inverse_of_factorial.pl │ ├── inverse_of_factorial_stirling.pl │ ├── inverse_of_fibonacci.pl │ ├── inverse_of_multiplicative_functions.pl │ ├── inverse_of_p_adic_valuation.pl │ ├── inverse_of_sigma_function.pl │ ├── inverse_of_sigma_function_fast.pl │ ├── inverse_of_sigma_function_generalized.pl │ ├── inverse_of_usigma_function.pl │ ├── inverse_tau_in_range.pl │ ├── invert_transform_of_factorials.pl │ ├── is_absolute_euler_pseudoprime.pl │ ├── is_almost_prime.pl │ ├── is_bfsw_pseudoprime.pl │ ├── is_chernick_carmichael_number.pl │ ├── is_even_perfect.pl │ ├── is_even_perfect_2.pl │ ├── is_even_perfect_3.pl │ ├── is_extra_bfsw_pseudoprime.pl │ ├── is_omega_prime.pl │ ├── is_perfect_power.pl │ ├── is_smooth_over_product.pl │ ├── is_squarefree_over_product.pl │ ├── is_sum_of_two_cubes.pl │ ├── is_sum_of_two_squares.pl │ ├── iterative_difference_of_central_divisors_to_reach_zero.pl │ ├── k-imperfect_numbers.pl │ ├── k-odd-powerful_numbers.pl │ ├── k-powerful_numbers.pl │ ├── k-powerful_numbers_in_range.pl │ ├── karatsuba_multiplication.pl │ ├── kempner_binomial_numbers.pl │ ├── klein_J_invariant_and_modular_lambda.pl │ ├── lambert_W_function.pl │ ├── lambert_W_function_complex.pl │ ├── lanczos_approximation.pl │ ├── least_k_such_that_k_times_k-th_prime_is_greater_than_10_to_the_n.pl │ ├── least_nonresidue.pl │ ├── legendary_question_six.pl │ ├── length_of_shortest_addition_chain.pl │ ├── lerch_zeta_function.pl │ ├── logarithmic_integral_asymptotic_formula.pl │ ├── logarithmic_root.pl │ ├── logarithmic_root_complex.pl │ ├── logarithmic_root_in_two_variables.pl │ ├── logarithmic_root_mpfr.pl │ ├── long_division.pl │ ├── long_multiplication.pl │ ├── lucas-carmichael_numbers_from_multiple.pl │ ├── lucas-carmichael_numbers_from_multiple_mpz.pl │ ├── lucas-carmichael_numbers_in_range.pl │ ├── lucas-carmichael_numbers_in_range_from_prime_factors.pl │ ├── lucas-carmichael_numbers_in_range_mpz.pl │ ├── lucas-miller_factorization_method.pl │ ├── lucas-pocklington_primality_proving.pl │ ├── lucas-pratt_primality_proving.pl │ ├── lucas-pratt_prime_records.pl │ ├── lucas_factorization_method.pl │ ├── lucas_factorization_method_generalized.pl │ ├── lucas_pseudoprimes_generation.pl │ ├── lucas_pseudoprimes_generation_erdos_method.pl │ ├── lucas_sequences_U_V.pl │ ├── lucas_sequences_U_V_mpz.pl │ ├── lucas_theorem.pl │ ├── magic_3-gon_ring.pl │ ├── magic_5-gon_ring.pl │ ├── map_num.pl │ ├── matrix_determinant_bareiss.pl │ ├── matrix_path_2-ways_best.pl │ ├── matrix_path_2-ways_greedy.pl │ ├── matrix_path_3-ways_best.pl │ ├── matrix_path_3-ways_diagonal_best.pl │ ├── matrix_path_3-ways_greedy.pl │ ├── matrix_path_4-ways_best.pl │ ├── matrix_path_4-ways_best_2.pl │ ├── matrix_path_4-ways_best_3.pl │ ├── matrix_path_4-ways_greedy.pl │ ├── maximum_product_of_parts_bisection.pl │ ├── maximum_square_remainder.pl │ ├── meissel_lehmer_prime_count.pl │ ├── mertens_function.pl │ ├── mertens_function_fast.pl │ ├── miller-rabin_deterministic_primality_test.pl │ ├── miller-rabin_deterministic_primality_test_mpz.pl │ ├── miller-rabin_factorization_method.pl │ ├── modular_bell_numbers.pl │ ├── modular_bell_numbers_mpz.pl │ ├── modular_binomial.pl │ ├── modular_binomial_fast.pl │ ├── modular_binomial_faster.pl │ ├── modular_binomial_faster_mpz.pl │ ├── modular_binomial_faster_mpz_2.pl │ ├── modular_binomial_ntheory.pl │ ├── modular_binomial_small_k.pl │ ├── modular_binomial_small_k_faster.pl │ ├── modular_cyclotomic_polynomial.pl │ ├── modular_factorial.pl │ ├── modular_factorial_crt.pl │ ├── modular_factorial_crt_mpz.pl │ ├── modular_fibonacci.pl │ ├── modular_fibonacci_anynum.pl │ ├── modular_fibonacci_cassini.pl │ ├── modular_fibonacci_cassini_fast.pl │ ├── modular_fibonacci_fast_mpz.pl │ ├── modular_fibonacci_mpz.pl │ ├── modular_fibonacci_polynomial.pl │ ├── modular_fibonacci_polynomial_2.pl │ ├── modular_hyperoperation.pl │ ├── modular_inverse.pl │ ├── modular_k-th_root_all_solutions.pl │ ├── modular_k-th_root_all_solutions_fast.pl │ ├── modular_k-th_root_all_solutions_fast_mpz.pl │ ├── modular_k-th_root_all_solutions_mpz.pl │ ├── modular_lucas_numbers.pl │ ├── modular_lucas_sequence_V.pl │ ├── modular_lucas_sequences_U_V.pl │ ├── modular_pseudo_square_root.pl │ ├── modular_pseudo_square_root_2.pl │ ├── modular_sigma_of_unitary_divisors_of_factorial.pl │ ├── modular_square_root.pl │ ├── modular_square_root_2.pl │ ├── modular_square_root_3.pl │ ├── modular_square_root_all_solutions.pl │ ├── modular_square_root_all_solutions_cipolla.pl │ ├── multi_sqrt_nums.pl │ ├── multinomial_coefficient.pl │ ├── multinomial_coefficient_from_binomial.pl │ ├── multiplicative_partitions.pl │ ├── multisets.pl │ ├── multivariate_gamma_function.pl │ ├── mysterious_sum-pentagonal_numbers.pl │ ├── mysterious_sum-pentagonal_numbers_2.pl │ ├── n_dimensional_circles.pl │ ├── near-power_factorization_method.pl │ ├── newton_s_method.pl │ ├── newton_s_method_recursive.pl │ ├── next_palindrome.pl │ ├── next_palindrome_from_non-palindrome.pl │ ├── next_palindrome_in_base.pl │ ├── next_power_of_two.pl │ ├── nth_composite.pl │ ├── nth_digit_of_fraction.pl │ ├── nth_prime_approx.pl │ ├── nth_root_good_rational_approximations.pl │ ├── nth_root_recurrence_constant.pl │ ├── nth_smooth_number.pl │ ├── number2expression.pl │ ├── number_of_conditional_GCDs.pl │ ├── number_of_connected_permutations.pl │ ├── number_of_partitions_into_2_distinct_positive_cubes.pl │ ├── number_of_partitions_into_2_distinct_positive_squares.pl │ ├── number_of_partitions_into_2_nonnegative_cubes.pl │ ├── number_of_partitions_into_2_positive_squares.pl │ ├── number_of_representations_as_sum_of_3_triangles.pl │ ├── number_of_representations_as_sum_of_four_squares.pl │ ├── number_of_representations_as_sum_of_two_squares.pl │ ├── number_to_digits_subquadratic_algorithm.pl │ ├── number_to_digits_subquadratic_algorithm_mpz.pl │ ├── numbers_with_pow_2_divisors.pl │ ├── omega_prime_divisors.pl │ ├── omega_prime_numbers_in_range.pl │ ├── omega_prime_numbers_in_range_mpz.pl │ ├── omega_prime_numbers_in_range_simple.pl │ ├── order_factorization_method.pl │ ├── palindrome_iteration.pl │ ├── partial_sums_of_dedekind_psi_function.pl │ ├── partial_sums_of_euler_totient_function.pl │ ├── partial_sums_of_euler_totient_function_fast.pl │ ├── partial_sums_of_euler_totient_function_fast_2.pl │ ├── partial_sums_of_euler_totient_function_times_k.pl │ ├── partial_sums_of_euler_totient_function_times_k_to_the_m.pl │ ├── partial_sums_of_exponential_prime_omega_functions.pl │ ├── partial_sums_of_gcd-sum_function.pl │ ├── partial_sums_of_gcd-sum_function_fast.pl │ ├── partial_sums_of_gcd-sum_function_faster.pl │ ├── partial_sums_of_generalized_gcd-sum_function.pl │ ├── partial_sums_of_gpf.pl │ ├── partial_sums_of_inverse_moebius_transform_of_dedekind_function.pl │ ├── partial_sums_of_jordan_totient_function.pl │ ├── partial_sums_of_jordan_totient_function_fast.pl │ ├── partial_sums_of_jordan_totient_function_times_k_to_the_m.pl │ ├── partial_sums_of_lcm_count_function.pl │ ├── partial_sums_of_liouville_function.pl │ ├── partial_sums_of_lpf.pl │ ├── partial_sums_of_n_over_k-almost_prime_divisors.pl │ ├── partial_sums_of_powerfree_numbers.pl │ ├── partial_sums_of_powerfree_part.pl │ ├── partial_sums_of_prime_bigomega_function.pl │ ├── partial_sums_of_prime_omega_function.pl │ ├── partial_sums_of_sigma0_function.pl │ ├── partial_sums_of_sigma_function.pl │ ├── partial_sums_of_sigma_function_times_k.pl │ ├── partial_sums_of_sigma_function_times_k_to_the_m.pl │ ├── partitions_count.pl │ ├── partitions_count_abs.pl │ ├── partitions_count_simple.pl │ ├── pascal-fibonacci_triangle.pl │ ├── pascal_s_triangle_multiples.pl │ ├── pattern_mixing.pl │ ├── pell_cfrac_factorization.pl │ ├── pell_factorization.pl │ ├── pell_factorization_anynum.pl │ ├── perfect_numbers.pl │ ├── period_of_continued_fraction_for_square_roots.pl │ ├── period_of_continued_fraction_for_square_roots_mpz.pl │ ├── period_of_continued_fraction_for_square_roots_ntheory.pl │ ├── phi-finder_factorization_method.pl │ ├── pi_from_infinity.pl │ ├── pisano_periods.pl │ ├── pisano_periods_efficient_algorithm.pl │ ├── pocklington-pratt_primality_proving.pl │ ├── pollard-strassen_factorization_method.pl │ ├── pollard_p-1_factorization.pl │ ├── pollard_rho_exp_factorization.pl │ ├── pollard_rho_factorization.pl │ ├── polygonal_numbers.pl │ ├── polygonal_representations.pl │ ├── polynomial_interpolation.pl │ ├── power_divisors.pl │ ├── power_of_factorial_ramanujan.pl │ ├── power_unitary_divisors.pl │ ├── powerfree_divisors.pl │ ├── powers_of_primes_in_factorial.pl │ ├── powers_of_primes_modulus_in_factorial.pl │ ├── prime_41.pl │ ├── prime_abundant_sequences.pl │ ├── prime_count_smooth_sum.pl │ ├── prime_counting_from_almost_primes.pl │ ├── prime_counting_from_squarefree_almost_primes.pl │ ├── prime_counting_liouville_formula.pl │ ├── prime_counting_mertens_formula.pl │ ├── prime_factorization_concept.pl │ ├── prime_factors_of_binomial_coefficients.pl │ ├── prime_factors_of_binomial_product.pl │ ├── prime_factors_of_factorial.pl │ ├── prime_factors_of_superfactorial_and_hyperfactorial.pl │ ├── prime_formulas.pl │ ├── prime_functions_in_terms_of_zeros_of_zeta.pl │ ├── prime_numbers_generator.pl │ ├── prime_omega_function_generalized.pl │ ├── prime_quadratic_polynomial_analyzer.pl │ ├── prime_quadratic_polynomials.pl │ ├── prime_signature_numbers_in_range.pl │ ├── prime_summation.pl │ ├── prime_zeta.pl │ ├── primes_diff.pl │ ├── primes_sum_of_pair_product.pl │ ├── primitive_sum_of_two_squares.pl │ ├── primorial_deflation.pl │ ├── pseudo_square_root.pl │ ├── pythagorean_triples.pl │ ├── quadratic-integer_factorization_method.pl │ ├── quadratic-integer_factorization_method_mpz.pl │ ├── quadratic_frobenius_primality_test.pl │ ├── quadratic_frobenius_pseudoprimes_generation.pl │ ├── quadratic_polynomial_in_terms_of_its_zeros.pl │ ├── ramanujan_sum.pl │ ├── ramanujan_sum_fast.pl │ ├── random_carmichael_fibonacci_pseudoprimes.pl │ ├── random_integer_factorization.pl │ ├── random_miller-rabin_pseudoprimes.pl │ ├── range_map.pl │ ├── rational_approximations.pl │ ├── rational_continued_fractions.pl │ ├── rational_prime_product.pl │ ├── rational_summation_of_fractions.pl │ ├── reciprocal_cycle_length.pl │ ├── rectangle_sides_from_area_and_diagonal.pl │ ├── rectangle_sides_from_diagonal_angles.pl │ ├── rectangle_sides_from_one_diagonal_angle.pl │ ├── recursive_matrix_multiplication.pl │ ├── rest_calc.pl │ ├── reversed_number_triangle.pl │ ├── reversed_number_triangles.pl │ ├── riemann_prime-counting_function.pl │ ├── riemann_s_J_function.pl │ ├── roots_on_the_rise.pl │ ├── secant_numbers.pl │ ├── semiprime_equationization.pl │ ├── semiprime_equationization_uncached.pl │ ├── sequence_analyzer.pl │ ├── sequence_closed_form.pl │ ├── sequence_polynomial_closed_form.pl │ ├── sieve_of_eratosthenes.pl │ ├── sigma0_of_factorial.pl │ ├── sigma_function.pl │ ├── sigma_of_factorial.pl │ ├── sigma_of_product_of_binomials.pl │ ├── sigma_p_adic.pl │ ├── siqs_factorization.pl │ ├── smallest_carmichael_divisible_by_n.pl │ ├── smallest_k-gonal_inverse.pl │ ├── smallest_k-gonal_inverse_brute_force.pl │ ├── smallest_lucas-carmichael_divisible_by_n.pl │ ├── smallest_number_with_at_least_n_divisors.pl │ ├── smallest_number_with_n_divisors.pl │ ├── smarandache_function.pl │ ├── smooth_numbers_generalized.pl │ ├── solutions_to_x_squared_equals_-1_mod_n.pl │ ├── solutions_to_x_squared_equals_1_mod_n.pl │ ├── solutions_to_x_squared_equals_a_mod_n.pl │ ├── solve_congruence_equation_example.pl │ ├── solve_cubic_equation.pl │ ├── solve_cubic_equation_real.pl │ ├── solve_modular_cubic_equation.pl │ ├── solve_modular_quadratic_equation.pl │ ├── solve_pell_equation.pl │ ├── solve_pell_equation_fast.pl │ ├── solve_pell_equation_generalized.pl │ ├── solve_pell_equation_simple.pl │ ├── solve_quadratic_diophantine_reciprocals.pl │ ├── solve_reciprocal_pythagorean_equation.pl │ ├── solve_sequence.pl │ ├── sophie_germain_factorization_method.pl │ ├── sorting_algorithms.pl │ ├── sphere_volume.pl │ ├── sqrt_mod_p_tonelli-shanks_mpz.pl │ ├── square_divisors.pl │ ├── square_product_subsets.pl │ ├── square_root_convergents.pl │ ├── square_root_method.pl │ ├── square_root_modulo_n_tonelli-shanks.pl │ ├── squarefree_almost_prime_divisors.pl │ ├── squarefree_almost_primes_from_factor_list.pl │ ├── squarefree_almost_primes_in_range.pl │ ├── squarefree_almost_primes_in_range_from_factor_list.pl │ ├── squarefree_almost_primes_in_range_mpz.pl │ ├── squarefree_divisors.pl │ ├── squarefree_fermat_overpseudoprimes_in_range.pl │ ├── squarefree_fermat_pseudoprimes_in_range.pl │ ├── squarefree_fermat_pseudoprimes_in_range_mpz.pl │ ├── squarefree_lucas_U_pseudoprimes_in_range.pl │ ├── squarefree_strong_fermat_pseudoprimes_in_range.pl │ ├── squarefree_strong_fermat_pseudoprimes_in_range_mpz.pl │ ├── squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range.pl │ ├── squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range_mpz.pl │ ├── stern_brocot_encoding.pl │ ├── stern_brocot_sequence.pl │ ├── strong_fermat_pseudoprimes_in_range.pl │ ├── strong_fermat_pseudoprimes_in_range_mpz.pl │ ├── sub-unit_squares.pl │ ├── sum_factorial.pl │ ├── sum_of_an_even_number_of_positive_squares.pl │ ├── sum_of_digits.pl │ ├── sum_of_digits_subquadratic_algorithm.pl │ ├── sum_of_digits_subquadratic_algorithm_mpz.pl │ ├── sum_of_k-powerful_numbers_in_range.pl │ ├── sum_of_natural_powers_in_constant_base.pl │ ├── sum_of_perfect_powers.pl │ ├── sum_of_prime-power_exponents_of_factorial.pl │ ├── sum_of_prime-power_exponents_of_product_of_binomials.pl │ ├── sum_of_prime_powers.pl │ ├── sum_of_primes_generalized.pl │ ├── sum_of_sigma.pl │ ├── sum_of_sigma_2.pl │ ├── sum_of_the_number_of_divisors.pl │ ├── sum_of_the_number_of_divisors_of_gcd_x_y.pl │ ├── sum_of_the_number_of_unitary_divisors.pl │ ├── sum_of_the_sum_of_divisors.pl │ ├── sum_of_three_cubes_problem.pl │ ├── sum_of_triangular_numbers_solutions.pl │ ├── sum_of_two_primes.pl │ ├── sum_of_two_squares_all_solutions.pl │ ├── sum_of_two_squares_all_solutions_2.pl │ ├── sum_of_two_squares_all_solutions_tonelli-shanks.pl │ ├── sum_of_two_squares_multiple_solutions.pl │ ├── sum_of_two_squares_solution.pl │ ├── sum_remainders.pl │ ├── super_pandigital_numbers.pl │ ├── tangent_numbers.pl │ ├── trial_division_fast.pl │ ├── triangle_hyperoperation.pl │ ├── triangle_interior_angles.pl │ ├── tribonacci_primality_test.pl │ ├── trip2mars.pl │ ├── unique_permutations.pl │ ├── unitary_divisors.pl │ ├── unitary_divisors_fast.pl │ ├── unitary_squarefree_divisors.pl │ ├── wilson_prime_formula.pl │ ├── yahtzee.pl │ ├── zequals.pl │ ├── zeta_2n.pl │ ├── zeta_for_primes.pl │ ├── zeta_function.pl │ └── zeta_prime_count_approx.pl ├── Media/ │ └── wimp-viewer ├── Microphone/ │ ├── Alsa/ │ │ └── raw_from_microphone.pl │ └── Julius/ │ ├── julius_voice_control_concept.pl │ └── voice_control.pl ├── Monitoring/ │ └── file-monitor ├── Other/ │ ├── concatenation_weirdness.pl │ ├── lexical_subs_recursion_bug.pl │ ├── tail_recursion.pl │ └── yafu_factorization.pl ├── README.md ├── Regex/ │ ├── positive-negative_matching.pl │ ├── prime_regexp.pl │ ├── regex_optimizer_in_source.pl │ ├── regex_pair_factors.pl │ └── regexp_to_strings.pl ├── Search/ │ ├── binary_search.pl │ ├── binary_search_ge.pl │ └── binary_search_le.pl ├── Shell/ │ └── execute_perl_scripts.pl ├── Simulation/ │ └── 100_prisoners_riddle.pl ├── Socket/ │ └── chat_server.pl ├── Sort/ │ ├── binsertion_sorting_algorithm.pl │ └── dream_sort.pl ├── Subtitle/ │ ├── srt-delay │ ├── srt_assembler.pl │ └── srt_fix.pl ├── Text/ │ ├── abs_string.pl │ ├── all_substrings.pl │ ├── change-encoding.pl │ ├── group_alike_words.pl │ ├── jaro-winkler_distance.pl │ ├── levenshtein_distance_iter.pl │ ├── levenshtein_distance_rec.pl │ ├── markov_chain_text_generator.pl │ ├── orthogonal_text_scrambling.pl │ ├── orthogonal_text_scrambling_double.pl │ ├── repeated_substrings.pl │ ├── search_by_prefix.pl │ ├── sim_end_words.pl │ ├── smartWordWrap.pl │ ├── smartWordWrap_lazy.pl │ ├── smartWordWrap_simple.pl │ ├── unique_prefixes.pl │ ├── word_roots.pl │ └── word_unscrambler.pl ├── Time/ │ ├── calendar.pl │ └── contdown.pl ├── Video/ │ ├── sponsor-free.pl │ ├── video_concat_ffmpeg.pl │ └── video_split_ffmpeg.pl ├── Visualisators/ │ ├── binview.pl │ ├── disk-stats.pl │ ├── dnscrypt_stats.pl │ ├── greycmd.pl │ ├── human-finder-visual.pl │ ├── lz_visual.pl │ ├── matrix_path_2-ways_best.pl │ ├── matrix_path_3-ways_best.pl │ ├── matrix_path_3-ways_greedy.pl │ ├── pview │ ├── random_finder_visual.pl │ ├── triangle_sub-string_finder.pl │ ├── visual_lz77_compression.pl │ └── visual_sudoku_dice_solver.pl └── update_readme.pl ================================================ FILE CONTENTS ================================================ ================================================ FILE: .gitignore ================================================ /blib/ /.build/ _build/ cover_db/ inc/ Build !Build/ Build.bat .last_cover_stats /Makefile /Makefile.old /MANIFEST.bak /META.yml /META.json /MYMETA.* nytprof.out /pm_to_blib *.o *.bs Math/convergent_series.db Research/ ================================================ FILE: Analyzers/char_counter.pl ================================================ #!/usr/bin/perl # Author: Trizen # Count and list the unique characters within a file. use strict; use warnings; use open IO => ':utf8', ':std'; my $file = shift @ARGV; die "usage: $0 file\n" unless -f $file; my %hash; open my $fh, '<', $file; while (defined(my $l = getc $fh)) { next if exists $hash{$l}; $hash{$l} = (); } close $fh; { local $, = ' '; print '-' x 80 . "\n"; print my (@list) = (sort { lc $a cmp lc $b } keys %hash); print "\n" . '-' x 80 . "\n"; print unpack('C*', join('', @list)); print "\n" . '-' x 80 . "\n"; } printf "\n** Unique characters used: %d\n\n", scalar keys %hash; ================================================ FILE: Analyzers/chr_freq.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 March 2012 # https://github.com/trizen # Count Character Frequency in a file use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; my %table; my %memoize; my %white_spaces = ( ord("\r") => q{\r}, ord("\n") => q{\n}, ord("\f") => q{\f}, ord("\t") => q{\t}, ord(" ") => q{' '}, ); my $file = shift // $0; open my $fh, '<', $file or die "Unable to open $file: $!"; while (defined(my $char = getc $fh)) { ++$table{ $memoize{$char} // do { $memoize{$char} = ord $char; } }; } close $fh; $= = 80; format STDOUT_TOP = CHR ORD USED ----------------------------------- . my $key; format STDOUT = @>> @>>>>>> @>>>>>> $white_spaces{$key} // chr $key, $key, $table{$key} . foreach $key (sort { $table{$b} <=> $table{$a} } keys %table) { write; } say "\nUnique characters used: ", scalar keys %table; ================================================ FILE: Analyzers/dieharder.pl ================================================ #!/usr/bin/perl # ## Test Perl's pseudorandom number generator with `dieharder`. # # usage: # perl dieharder.pl > rand.txt && dieharder -g 202 -f rand.txt -a use 5.014; use strict; use warnings; my $seed = srand(); my $count = 1e6; my $bits = 32; print <<"EOT"; #================================================================== # generator lcg seed = $seed #================================================================== type: d count: $count numbit: $bits EOT my $max = 2**$bits; for (1 .. $count) { say int(rand($max)); } ================================================ FILE: Analyzers/first_letter_top.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 June 2016 # Website: https://github.com/trizen # Make a top with the first letters of each word in a given text. # usage: cat file.txt | perl first_letter_top.pl use 5.014; use strict; use warnings; use List::Util qw(sum); use open IO => ':utf8', ':std'; my %table; foreach my $word (split(' ', do { local $/; <> })) { if ($word =~ /^[^\pL]*(\pL)/) { $table{lc($1)}++; } } my $max = sum(values %table); foreach my $key (sort { $table{$b} <=> $table{$a} } keys %table) { printf("%s -> %3d (%5.2f%%)\n", $key, $table{$key}, $table{$key} / $max * 100); } ================================================ FILE: Analyzers/kcal/kcal.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 13 February 2015 # Website: https://github.com/trizen # Analyze a CSV list of products based on their values. # (the energy expressed in kcal/100g divided by the price/100g) use 5.010; use strict; use autodie; use warnings; use Text::CSV; my $input_file = shift() // 'products.csv'; sub process_products_file { my ($file) = @_; my $csv = Text::CSV->new( { allow_whitespace => 1, sep_char => ',', } ) or die "Cannot use CSV: " . Text::CSV->error_diag(); open my $fh, '<:encoding(UTF-8)', $file; my @columns = map { lc(s/\W.*//rs) } @{$csv->getline($fh)}; $csv->column_names(@columns); my @products; while (my $row = $csv->getline_hr($fh)) { push @products, {%{$row}, value => $row->{kcal} / $row->{price}}; } return @products; } my @products = process_products_file($input_file); my @sorted_products = sort { $b->{value} <=> $a->{value} } @products; foreach my $product (@sorted_products) { printf("%-35s%-10g%-10g(%g)\n", $product->{name}, $product->{kcal}, $product->{price}, $product->{value}); } ================================================ FILE: Analyzers/kcal/products.csv ================================================ name, kcal/100g, price/100g Milk (1.5% fat),44,0.3 Dark chocolate (50% cacao),519,2.7 Mustard,178,0.93 Mountain dew,52,0.54 Sour cream (12% fat),131,0.7 Sour cream (20% fat),207,0.9 Pearl barley,352,0.3 Corn flour,350,0.2 Pufuleti,427,1.2 Beer,40,0.37 Chocolate (30% cacao),521,2.45 Yogurt (2.5% fat),51,0.38 Fish eggs,553,1.53 Strong beer,53,0.4 Eggs,130,0.86 Wheat flakes,304,0.4 Pork meat,541,2.4 Ice cream,226,1.6 ================================================ FILE: Analyzers/kernel_config_diff.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 16 March 2013 # https://github.com/trizen # List activated options from config_2, which are # not activated in config_1, or have different values. # Will print them in CSV format. use 5.010; use strict; use autodie; use warnings; use Text::CSV qw(); $#ARGV == 1 or die <<"USAGE"; usage: $0 [config_1] [config_2] USAGE my ($config_1, $config_2) = @ARGV; sub parse_option { my ($line) = @_; if ($line =~ /^(CONFIG_\w+)=(.*)$/) { return $1, $2; } elsif ($line =~ /^# (CONFIG_\w+) is not set$/) { return $1, undef; } elsif ($line =~ /^\W*CONFIG_\w/) { die "ERROR: Can't parse line: $line\n"; } return; } my %table; { open my $fh, '<', $config_1; while (<$fh>) { my ($name, $value) = parse_option($_); $name // next; $table{$name} = $value; } } { my $csv = Text::CSV->new({binary => 1, eol => "\n"}) or die "Cannot use CSV: " . Text::CSV->error_diag(); $csv->print(\*STDOUT, ["OPTION NAME", $config_1, $config_2]); open my $fh, '<', $config_2; while (<$fh>) { my ($name, $value) = parse_option($_); $name // next; if (defined $value) { if (not defined $table{$name}) { $csv->print(\*STDOUT, [$name, (exists $table{$name} ? "is not set" : "-"), $value]); } else { if ($table{$name} ne $value) { $csv->print(\*STDOUT, [$name, $table{$name}, $value]); } } } } } ================================================ FILE: Analyzers/perl_code_analyzer.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 04 January 2015 # Website: https://github.com/trizen # ## Analyze your Perl code and see whether you are or not a true Perl hacker! # # More info about this script: # https://trizenx.blogspot.com/2015/01/perl-code-analyzer.html use utf8; use 5.010; use strict; use warnings; use IPC::Open2 qw(open2); use Encode qw(encode_utf8 decode_utf8); use Getopt::Long qw(GetOptions); use Algorithm::Diff qw(LCS_length); use Perl::Tokenizer qw(perl_tokens); my $strict_level = 1; my %ignored_types; sub help { my ($code) = @_; print <<"HELP"; usage: $0 [options] [file] [...] options: --strict [level] : sets the strictness level (default: $strict_level) Valid strict levels: >= 1 : ignores strings, PODs, comments, spaces and semicolons >= 2 : ignores round parentheses >= 3 : ignores here-documents, (q|qq|qw|qx) quoted strings >= 4 : ignores hex and binary literal numbers If level=0, any stricture will be disabled. HELP exit($code // 0); } GetOptions('strict=i' => \$strict_level, 'help|h' => sub { help(0) },) or die("Error in command line arguments\n"); @ARGV || help(2); if ($strict_level >= 1) { @ignored_types{ qw( pod data comment vertical_space horizontal_space other_space semicolon double_quoted_string single_quoted_string ) } = (); } if ($strict_level >= 2) { @ignored_types{ qw( parenthesis_open parenthesis_close ) } = (); } if ($strict_level >= 3) { @ignored_types{ qw( heredoc heredoc_beg q_string qq_string qw_string qx_string ) } = (); } if ($strict_level >= 4) { @ignored_types{ qw( hex_number binary_number ) } = (); } sub deparse { my ($code) = @_; local (*CHLD_IN, *CHLD_OUT); my $pid = open2(\*CHLD_OUT, \*CHLD_IN, $^X, '-MO=Deparse', '-T'); print CHLD_IN encode_utf8($code); close(CHLD_IN); my $deparsed = do { local $/; decode_utf8(); }; waitpid($pid, 0); my $child_exit_status = $? >> 8; if ($child_exit_status != 0) { die "B::Deparse failed with code: $child_exit_status\n"; } return $deparsed; } sub get_tokens { my ($code) = @_; my @tokens; perl_tokens { my ($token) = @_; if (not exists $ignored_types{$token}) { push @tokens, $token; } } $code; return @tokens; } foreach my $script (@ARGV) { print STDERR "=> Analyzing: $script\n"; my $code = do { open my $fh, '<:utf8', $script; local $/; <$fh>; }; my $d_code = eval { deparse($code) }; $@ && do { warn $@; next }; my @types = get_tokens($code); my @d_types = get_tokens($d_code); if (@types == 0 or @d_types == 0) { warn "This script seems to be empty! Skipping...\n"; next; } my $len = LCS_length(\@types, \@d_types) - abs(@types - @d_types); my $score = (100 - ($len / @types * 100)); if ($score >= 60) { printf("WOW!!! We have here a score of %.2f! This is obfuscation, isn't it?\n", $score); } elsif ($score >= 40) { printf("Outstanding! This code seems to be written by a true legend! Score: %.2f\n", $score); } elsif ($score >= 20) { printf("Amazing! This code is very unique! Score: %.2f\n", $score); } elsif ($score >= 15) { printf("Excellent! This code is written by a true Perl hacker. Score: %.2f\n", $score); } elsif ($score >= 10) { printf("Awesome! This code is written by a Perl expert. Score: %.2f\n", $score); } elsif ($score >= 5) { printf("Just OK! We have a score of %.2f! This is production code, isn't it?\n", $score); } else { printf("What is this? I guess it is some baby Perl code, isn't it? Score: %.2f\n", $score); } } ================================================ FILE: Analyzers/perl_code_spellcheck.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 29 January 2017 # https://github.com/trizen # Checks English words for spelling errors in Perl code. # It tries to minimize false positives as much as possible. use 5.014; use strict; use warnings; use Text::Hunspell; use List::Util qw(max); use File::Find qw(find); use Encode qw(decode_utf8); use Perl::Tokenizer qw(perl_tokens); use Text::JaroWinkler qw(strcmp95); use Getopt::Long qw(GetOptions :config no_ignore_case); binmode(STDOUT, ':utf8'); my $similarity = 90 / 100; my $min_word_len = 6; my $aggressive = 0; my $non_word_split = 0; my $scan_cats = 'com,str'; sub help { my ($code) = @_; my $p = sprintf('%.0f', $similarity * 100); print <<"HELP"; usage: $0 [options] [files] Options: -m --minimum=f : minimum length for words (default: $min_word_len) -p --percentage=f : minimum similarity percentage (default: $p) -W --W-split! : split by non-word characters (default: by space) -s --scan=s : categories of tokens to scan (default: "$scan_cats") All the possible categories for --scan are: pod : scan pod sections (including __END__) str : scan strings (including here-documents) com : scan comments var : scan variable names sub : scan subroutine declarations bar : scan barewords (including subroutine/method calls) all : scan all categories Example: $0 --scan=pod,com --percentage=75 /my/script.pl HELP exit($code); } my $percentage; GetOptions( 'm|minimum=i' => \$min_word_len, 'p|percentage=f' => \$percentage, 's|scan=s' => \$scan_cats, 'W|W-split!' => \$non_word_split, 'h|help' => sub { help(0) }, ) or die("Error in command line arguments"); my $scan_pod = $scan_cats =~ /\bpod/; my $scan_strings = $scan_cats =~ /\bstr/; my $scan_comments = $scan_cats =~ /\bcom/; my $scan_variables = $scan_cats =~ /\bvar/; my $scan_subroutines = $scan_cats =~ /\bsub/; my $scan_barewords = $scan_cats =~ /\bbar/; if ($scan_cats =~ /\ball/) { $scan_pod = 1; $scan_strings = 1; $scan_comments = 1; $scan_variables = 1; $scan_subroutines = 1; $scan_barewords = 1; } if ( not $scan_pod and not $scan_strings and not $scan_comments and not $scan_variables and not $scan_subroutines and not $scan_barewords) { die "Invalid value for `--scan`: <<$scan_cats>>"; } if (defined $percentage) { $similarity = $percentage / 100; } #<<< my $speller = Text::Hunspell->new( "/usr/share/hunspell/en_US.aff", "/usr/share/hunspell/en_US.dic", ) or die "Can't create the speller object: $!"; #>>> @ARGV || help(2); @ARGV = reverse(@ARGV); while (@ARGV) { my %seen; my $file = pop @ARGV; if (-d $file) { find { no_chdir => 1, wanted => sub { if (-f($_) and /\.p[lm]\z/) { push @ARGV, $_; } }, } => $file; next; } $file = decode_utf8($file); open my $fh, '<:encoding(UTF-8)', $file or next; local $SIG{__WARN__} = sub { }; my $code = eval { local $/; <$fh> } // next; say "\n** Scanning: $file"; perl_tokens { my ($token, $i, $j) = @_; my $string; if ($scan_strings) { if ($token eq 'q_string') { $string = substr($code, $i + 2, $j - $i - 3); } elsif ( $token eq 'qq_string' or $token eq 'qw_string') { $string = substr($code, $i + 3, $j - $i - 4); } elsif ( $token eq 'double_quoted_string' or $token eq 'single_quoted_string') { $string = substr($code, $i + 1, $j - $i - 2); } elsif ($token eq 'heredoc') { $string = substr($code, $i, $j - $i); $string =~ s/.*\K\R.*//s; } } if ($scan_comments) { if ($token eq 'comment') { $string = substr($code, $i + 1, $j - $i - 1); } } if ($scan_pod) { if ( $token eq 'pod' or $token eq 'data') { $string = substr($code, $i, $j - $i); } } if ($scan_variables) { if ($token eq 'var_name') { $string = substr($code, $i, $j - $i); } } if ($scan_subroutines) { if ($token eq 'sub_name') { $string = substr($code, $i, $j - $i); } } if ($scan_barewords) { if ($token eq 'bare_word') { $string = substr($code, $i, $j - $i); } } if (defined $string) { foreach my $word ( $non_word_split ? split(/[^\pL]+/, $string) : split(' ', $string) ) { if (!$non_word_split) { $word =~ s/^[^\pL]+//; $word =~ s/[^\pL]+\z//; } $word !~ /^[\pL]+\z/ and next; length($word) < $min_word_len and next; $seen{$word}++ and next; $speller->check($word) and next; my @suggestions = $speller->suggest($word); if ( @suggestions and lc($suggestions[0]) ne lc($word) and $suggestions[0] !~ / /) { my $score = strcmp95($suggestions[0], $word, max(length($suggestions[0]), length($word))); if ($score >= $similarity) { printf "[%.2f] %-20s => [%s]\n", $score, $word, join(', ', @suggestions); } } } } } $code; } ================================================ FILE: Analyzers/reptop.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 29 November 2011 # Edit: 03 November 2012 # https://github.com/trizen # Find how many times each word exists in a file. use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; use Getopt::Long qw(GetOptions :config no_ignore_case); my $word; # count for a particular word my $regex; # split by regex my $lowercase; # lowercase words my $top = 0; # top of repeated words my $length = 1; # mimimum length of a word sub usage { print <<"HELP"; usage: $0: [options] \nOptions: -B : deactivate word match boundary (default: on) -L : lowercase every word (default: off) -w=s : show how many times a word repeats in the list -t=i : show a top list of 'i' words (default: $top) -l=i : minimum length of a valid word (default: $length) -r=s : split by a regular expression (default: \\W+)\n HELP exit 0; } usage() unless @ARGV; my $no_boundary; GetOptions( 'word|w=s' => \$word, 'top|t=i' => \$top, 'regex|r=s' => \$regex, 'no-boundary|B' => \$no_boundary, 'L|lowercase!' => \$lowercase, 'length|l=i' => \$length, 'help|h|usage' => \&usage, ); my $boundary = $no_boundary ? '' : '\\b'; $regex = defined $regex ? qr/$regex/ : qr/\W+/; foreach my $file (grep { -f } @ARGV) { my $file_content; open my $fh, '<:encoding(UTF-8)', $file or die "Unable to open file '$file': $!\n"; read $fh, $file_content, -s $file; close $fh; if ($lowercase) { $file_content = lc $file_content; } study $file_content; if (defined($word)) { my $i = 0; ++$i while $file_content =~ /$boundary\Q$word\E$boundary/go; printf "Word '%s' repeats %d time%s in the list.\n", $word, $i, ($i == 1 ? '' : 's'); next; } my %uniq; @uniq{split($regex, $file_content)} = (); my @out; foreach my $word (keys %uniq) { next unless length $word >= $length; my $i = 0; ++$i while $file_content =~ /$boundary\Q$word\E$boundary/g; push @out, [$i, $word]; } my $i = 0; my @sorted = sort { $b->[0] <=> $a->[0] } @out; my $max = length $sorted[0][0]; print "> $file\n"; foreach my $out (@sorted) { printf "%*s -> %s\n", $max, $out->[0], $out->[1]; last if $top and ++$i == $top; } } ================================================ FILE: Analyzers/text_stats.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 15 June 2013 # https://github.com/trizen # ## This script will compare the repetition of words from different authors. # ## Example: # perl text_stats.pl shake_1.txt shake_2.txt - twain_1.txt twain_2.txt # # The above example compares the files from two authors. # If the first author written more words than the second one, # the script will estimate the repetition of words from the second author # as if it wrote the same amounts of words as the first author. # # You can provide as many authors as you want, separated by a dash argument (-). use 5.010; use strict; use autodie; use warnings; use open IO => 'utf8'; use Text::Unidecode qw(unidecode); my @authors = []; while (@ARGV) { my $file = shift @ARGV; if ($file eq '-') { push @authors, []; next; } -f $file or do { warn "$0: '$file' is not a file!\n"; next }; push @{$authors[-1]}, $file; } my %table; foreach my $author_files (@authors) { foreach my $file (@{$author_files}) { open my $fh, '<', $file; while (<$fh>) { s{[^\-'[:^punct:]]+}{ }g; # try to comment out this line my @words = split(' ', unidecode(lc)); s{^[[:punct:]]+}{}, s{[[:punct:]]+\z}{} for @words; /^\w/ && /\w\z/ && $table{$author_files}{$_}++ for @words; } } } my %data; my @lens; foreach my $i (0 .. $#authors) { my $author = $authors[$i]; my $words = $table{$author}; while (my ($word, $cnt) = each %{$words}) { $data{$word} //= [(0) x $i]; push @{$data{$word}}, $cnt; } push @lens, scalar keys %{$words}; } my @ratios = (1); foreach my $i (1 .. $#lens) { push @ratios, $lens[$i] / $lens[$i-1]; } print join(',', "WORD", (map { qq["AUTHOR $_"] } 1 .. $#authors + 1)), "\n"; foreach my $key (sort { $data{$b}[0] <=> $data{$a}[0] } keys %data) { my @row; foreach my $i (0 .. $#authors) { push @row, sprintf("%0.f", ($data{$key}[$i] // 0) / $ratios[$i]); } print join(',', qq["$key"], @row), "\n"; } ================================================ FILE: Analyzers/unidecode_word_top.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 11 March 2013 # https://github.com/trizen # usage: perl unidecode_word_top.pl [file] use 5.010; use strict; use autodie; use warnings; use Text::Unidecode qw(unidecode); open my $fh, '<:encoding(UTF-8)', shift; my %table; while (<$fh>) { my @words = split(' ', unidecode(lc $_)); s{^[[:punct:]]+}{}, s{[[:punct:]]+\z}{} for @words; /^\w/ && /\w\z/ && $table{$_}++ for @words; } foreach my $key (sort { $table{$b} <=> $table{$a} || $a cmp $b } keys %table) { printf "%-50s%4s\n", $key, $table{$key}; } ================================================ FILE: Analyzers/wcer.pl ================================================ #!/usr/bin/perl # Count words in a text file # Coded by Trizen under GPL. # usage: cat file.txt | perl wcer # perl wcer file.txt my $x = 0; while (<>) {$x+=split' '} print STDOUT "$x\n"; exit 0; ================================================ FILE: Analyzers/word_suffix_top.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 05 April 2015 # https://github.com/trizen # Word suffix top use 5.014; use autodie; use warnings; use Text::Unidecode qw(unidecode); my %top; my $file = shift() // die "usage: $0 file [suffix len]\n"; my $i = shift() // 3; my $total = 0; { open my $fh, '<:utf8', $file; while (<$fh>) { s/[_\W]+\z//; if (/(\w{$i})\z/) { ++$top{lc(unidecode($1))}; ++$total; } } close $fh; } my $lonely = 0; foreach my $key (sort { $top{$b} <=> $top{$a} or $a cmp $b } keys %top) { printf("%s%10s%10.02f%%\n", $key, $top{$key}, $top{$key} / $total * 100); ++$lonely if ($top{$key} == 1); } printf "\n** Unique suffixes: %.02f%%\n", $lonely / $total * 100; ================================================ FILE: Audio/auto-mp3tags.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 15 August 2011 # Edit: 11 August 2019 # https://github.com/trizen # Adds auto-tags to MP3 audio files in a given directory and its subdirectories. use 5.010; use strict; use warnings; use MP3::Tag; use File::Find qw(find); use File::Copy qw(copy); use File::Temp qw(tempfile); use File::Basename qw(basename); use Encode qw(encode_utf8 decode_utf8); my @files = grep { -e $_ } @ARGV; die "Usage: $0 \n" unless @files; my @mp3_files; find(\&wanted_files, @files); sub wanted_files { my $file = $File::Find::name; push @mp3_files, $file if $file =~ /\.mp3\z/i; } foreach my $filename (@mp3_files) { say "Processing: $filename"; my (undef, $tmpfile) = tempfile(basename($filename) . ' - XXXXXX', TMPDIR => 1); unlink($tmpfile); $tmpfile =~ s/ - .{6}\z//; copy($filename, $tmpfile); my $mp3 = 'MP3::Tag'->new($tmpfile); my @fields = qw(artist album title comment); $mp3->config(write_v24 => 1); $mp3->autoinfo; $mp3->update_tags({map { $_ => decode_utf8($mp3->$_) } @fields}); $mp3->close; unlink($filename); copy($tmpfile, $filename); unlink($tmpfile); } ================================================ FILE: Audio/group_audio_files.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 11 August 2019 # https://github.com/trizen # Group MP3 files in directories based on their artist name. # Example: # Foo - abc.mp3 # Foo - xyz.mp3 # Both files will be moved in a new directory named "Foo". # The directory "Foo" is created in the current working directory from which the script is executed. use 5.016; use strict; use warnings; binmode(STDOUT, ':utf8'); use Encode qw(decode_utf8); use Text::Unidecode qw(unidecode); use File::Find qw(find); use File::Copy qw(move); use File::Basename qw(basename); use File::Spec::Functions qw(catdir catfile curdir); use List::Util qw(sum); use List::UtilsBy qw(max_by); my $file_formats = qr{\.(?:mp3|mp4|webm|mkv|opus|ogg|oga)\z}i; # file formats my (@files) = grep { -e $_ } @ARGV; if (not @files) { die "usage: $0 [dir]\n"; } my @audio_files; find(\&wanted_files, @files); sub wanted_files { my $file = $File::Find::name; push @audio_files, $file if ($file =~ $file_formats); } if (@audio_files) { say ":: Found ", scalar(@audio_files), " audio files..."; } else { say ":: No file found..."; } my %groups; foreach my $filename (@audio_files) { my $basename = decode_utf8(basename($filename)); my $artist; if ($basename =~ /^[\d\s.\-–]*(.+?) -/) { $artist = $1; } elsif ($basename =~ /^[\d\s.\-–]*(.+?)-/) { $artist = $1; } else { next; } # Remove extra whitespace $artist = join(' ', split(' ', $artist)); # Unidecode key and remove whitespace my $key = join('', split(' ', unidecode(CORE::fc($artist)))); $key =~ s/[[:punct:]]+//g; # remove any punctuation characters $key =~ s/\d+//g; # remove any digits if ($key eq '' or $artist eq '') { next; } push @{$groups{$key}{files}}, { filepath => $filename, basename => $basename, }; ++$groups{$key}{artists}{$artist}; } while (my ($key, $group) = each %groups) { my $files = $group->{files}; my $artists = $group->{artists}; sum(values %$artists) > 1 or next; # ignore single files my $common_name = max_by { $artists->{$_} } sort { $a cmp $b } keys %$artists; foreach my $file (@{$files}) { my $group_dir = catdir(curdir(), $common_name); if (not -e $group_dir) { mkdir($group_dir) || do { warn "[!] Can't create directory `$group_dir`: $!\n"; next; }; } if (not -d $group_dir) { warn "[!] Not a directory: $group_dir\n"; next; } my $target = catfile($group_dir, $file->{basename}); if (not -e $target) { say "[*] Moving file `$file->{basename}` into `$common_name` directory..."; move($file->{filepath}, $target) || warn "[!] Failed to move: $!\n"; } } } ================================================ FILE: Audio/mkv_audio_to_opus.pl ================================================ #!/usr/bin/perl # Convert MKV audio files to OPUS files, in a given directory (and its subdirectories). # Requires `ffmpeg` and `exiftool`. use 5.036; use File::Find qw(find); use File::Temp qw(mktemp); use File::Copy qw(move); use File::Basename qw(dirname basename); use File::Spec::Functions qw(catfile); use Getopt::Long qw(GetOptions); my $bitrate = 96; sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [files | directories] options: -b --bitrate=i : output bitrate in kbps (default: $bitrate) -h --help : display this message and exit EOT exit($exit_code); } GetOptions('b|bitrate=i' => \$bitrate, 'h|help' => sub { usage(0) },) or die("Error in command line arguments"); sub is_mkv_audio ($file) { my $res = `exiftool \Q$file\E`; $? == 0 or return; defined($res) or return; $res =~ m{^MIME\s+Type\s*:\s*audio/x-matroska}mi; } sub convert ($file) { my $tmpfile = mktemp("tempXXXXXXXXXXX") . '.opus'; say ":: Temporary file: $tmpfile"; system("ffmpeg", '-loglevel', 'warning', "-i", $file, "-b:a", $bitrate . "K", $tmpfile); $? == 0 or do { unlink($tmpfile); return; }; my $dir = dirname($file); my $basename = basename($file) =~ s{\.\w+\z}{.opus}r; my $new_file = catfile($dir, $basename); unlink($file) or return; say ":: Moving: $tmpfile -> $new_file"; move($tmpfile, $new_file); } my @dirs = @ARGV; @dirs || usage(1); find( { wanted => sub { if (-f $_ and is_mkv_audio($_)) { say ":: Converting: $_"; convert($_); } }, }, @dirs ); ================================================ FILE: Audio/recompress_audio_track.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 06 September 2023 # https://github.com/trizen # Make video files smaller, by recompressing the audio track to the OPUS format (40kbps), using ffmpeg. # Requires the following tools: # ffmpeg # exiftool # Usage: # perl recompress_audio_track.pl [files | directories] use 5.036; use File::Temp qw(mktemp); use File::Find qw(find); use File::Copy qw(move); use File::Basename qw(dirname basename); use File::Spec::Functions qw(catfile); sub is_video_file ($file) { my $res = `exiftool \Q$file\E`; $? == 0 or return; defined($res) or return; $res =~ m{^MIME\s+Type\s*:\s*video/}mi; } sub recompress_audio_track ($video_file) { say ":: Extracting audio track..."; my $orig_audio_file = mktemp("tempXXXXXXXXXXX") . '.mkv'; system("ffmpeg", "-loglevel", "warning", "-i", $video_file, "-vn", "-acodec", "copy", $orig_audio_file); $? == 0 or do { unlink($orig_audio_file); return; }; say ":: Recompressing audio track..."; my $new_audio_file = mktemp("tempXXXXXXXXXXX") . '.opus'; system("ffmpeg", "-loglevel", "warning", "-i", $orig_audio_file, "-vn", "-sn", "-dn", "-c:a", "libopus", "-b:a", "40K", $new_audio_file); $? == 0 or do { unlink($new_audio_file); return; }; # When the original file is smaller, keep the original file if ((-s $orig_audio_file) <= (-s $new_audio_file)) { say ":: The original audio track is smaller... Will keep it..."; unlink($new_audio_file); $new_audio_file = $orig_audio_file; } say ":: Merging the recompressed audio track with the video..."; my $new_video_file = mktemp("tempXXXXXXXXXXX") . '.mkv'; system("ffmpeg", "-loglevel", "warning", "-i", $video_file, "-i", $new_audio_file, "-map_metadata", "0", "-map", "0:v", "-map", "1:a", "-map", "0:s?", "-c", "copy", $new_video_file); $? == 0 or do { unlink($new_audio_file); unlink($new_video_file); return; }; my $dir = dirname($video_file); my $basename = basename($video_file) =~ s{\.\w+\z}{.mkv}r; my $final_video_file = catfile($dir, $basename); if ($final_video_file !~ /\.mkv\z/) { $final_video_file .= '.mkv'; } my $original_size = -s $orig_audio_file; my $new_size = -s $new_audio_file; printf(":: Saved: %.2f MB (%.2f%%)\n", ($original_size - $new_size) / 1024**2, ($original_size - $new_size) / $original_size * 100); unlink($video_file); unlink($new_audio_file); unlink($orig_audio_file); move($new_video_file, $final_video_file); } my @dirs = @ARGV; if (not @dirs) { die "usage: $0 [files | directories]\n"; } find( { wanted => sub { if (-f $_ and is_video_file($_)) { say "\n:: Processing: $_"; recompress_audio_track($_); } }, }, @dirs ); ================================================ FILE: Audio/rem-mp3tags.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 15 August 2011 # Edit: 11 August 2019 # https://github.com/trizen # Removes tags of MP3 audio files in a given directory and its subdirectories. use 5.010; use strict; use warnings; use MP3::Tag; use File::Find qw(find); use File::Copy qw(copy); use File::Temp qw(tempfile); use File::Basename qw(basename); my (@files) = grep { -e $_ } @ARGV; die "Usage: $0 \n" unless @files; my $quiet = scalar grep { /^--?(?:q|quiet)\z/ } @ARGV; my @mp3_files; find(\&wanted_files, @files); sub wanted_files { my $file = $File::Find::name; push @mp3_files, $file if $file =~ /\.mp3\z/i; } foreach my $filename (@mp3_files) { my (undef, $tmpfile) = tempfile(basename($filename) . ' - XXXXXX', TMPDIR => 1); unlink($tmpfile); $tmpfile =~ s/ - .{6}\z//; copy($filename, $tmpfile); my $mp3 = 'MP3::Tag'->new($tmpfile); $mp3->get_tags; my $had_tags = 0; if (exists $mp3->{'ID3v1'}) { say "[ID3v1] Removing tag: $filename" unless $quiet; $mp3->{'ID3v1'}->remove_tag; $had_tags = 1; } if (exists $mp3->{'ID3v2'}) { say "[ID3v2] Removing tag: $filename" unless $quiet; $mp3->{'ID3v2'}->remove_tag; $had_tags = 1; } $mp3->close; if ($had_tags) { unlink($filename); copy($tmpfile, $filename); } unlink($tmpfile); } ================================================ FILE: Audio/wave-cmp.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 22 March 2015 # Website: https://github.com/trizen # Find similar audio files by comparing their waveforms. # Review: # https://trizenx.blogspot.com/2015/03/similar-audio-files.html # ## The waveform is processed block by block: # _________________________________________ # |_____|_____|_____|_____|_____|_____|_____| # |_____|_____|_____|_____|_____|_____|_____| # |_____|_____|_____|_____|_____|_____|_____| # |_____|_____|_____|_____|_____|_____|_____| # # Each block has a distinct number of white pixels, which are collected # inside an array and constitute the unique fingerprint of the waveform. # # Now, each block value is compared with the corresponding value # of another fingerprint. If the difference from all blocks is within # the allowed deviation, then the audio files are marked as similar. # # In the end, the similar files are reported to the standard output. # Requirements: # - ffmpeg: https://ffmpeg.org/ # - wav2png: https://github.com/beschulz/wav2png use utf8; use 5.010; use strict; use autodie; use warnings; require GD; GD::Image->trueColor(1); require GDBM_File; use List::Util qw(sum); use Getopt::Long qw(GetOptions); use File::Find qw(find); use File::Temp qw(tempdir); use File::Path qw(make_path); use File::Spec::Functions qw(catfile catdir); require Digest::MD5; my $ctx = Digest::MD5->new; my $pkgname = 'wave-cmp'; my $version = 0.01; my $deviation = 5; my ($width, $height) = (1800, 300); my ($div_x, $div_y) = (10, 2); sub help { my ($code) = @_; print <<"EOT"; usage: $0 [options] [dirs|files] => Waveform generation -w --width=i : width of the waveform (default: $width) -h --height=i : height of the waveform (default: $height) => Waveform processing -x --x-div=i : divisions along the X-axis (default: $div_x) -y --y-div=i : divisions along the Y-axis (default: $div_y) -d --deviation=i : tolerance deviation value (default: $deviation) --help : print this message and exit --version : print the version number and exit example: $0 --deviation=6 ~/Music EOT exit($code); } sub version { print "$pkgname $version\n"; exit 0; } GetOptions( 'w|width=i' => \$width, 'h|height=i' => \$height, 'x|x-div=i' => \$div_x, 'y|y-div=i' => \$div_y, 'd|deviation=i' => \$deviation, 'help' => sub { help(0) }, 'v|version' => \&version, ) or die("Error in command line arguments"); my $sq_x = int($width / $div_x); my $sq_y = int($height / $div_y); my $limit_x = $width - $sq_x; my $limit_y = int($height / 2) - $sq_y; # analyze only the first half # Source: https://en.wikipedia.org/wiki/Audio_file_format#List_of_formats my @audio_formats = qw( 3gp act aiff aac amr au awb dct dss flac gsm m4a m4p mp3 mpc ogg oga opus ra rm raw sln tta vox wav wma wv webm ); my $audio_formats_re = do { local $" = '|'; qr/\.(?:@audio_formats)\z/i; }; my $home_dir = $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($<))[7] || `echo -n ~`; my $xdg_config_home = catdir($home_dir, '.config'); my $cache_dir = catdir($xdg_config_home, $pkgname); my $cache_db = catfile($cache_dir, 'fp.db'); if (not -d $cache_dir) { make_path($cache_dir); } my $tmpdir = tempdir(CLEANUP => 1); tie my %db, 'GDBM_File', $cache_db, &GDBM_File::GDBM_WRCREAT, 0640; # #-- execute the ffmpeg and wave2png commands and return the waveform PNG data # sub generate_waveform { my ($file, $output) = @_; #<<< # Using sox (currently broken) # 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`; #>>> my $tmpfile = catfile($tmpdir, $file . '.wav'); system("ffmpeg", "-loglevel", "quiet", "-i", $file, $tmpfile); $? == 0 or return; my $waveform = `wav2png -w $width -h $height -f 000000ff -b ffffff00 -o /dev/stdout \Q$tmpfile\E`; unlink($tmpfile); return $waveform; } # #-- return the md5 hex digest of the content of a file # sub md5_file { my ($file) = @_; open my $fh, '<:raw', $file; $ctx->addfile($fh); $ctx->hexdigest; } # #-- take image data as input and return a fingerprint array ref # sub generate_fingerprint { my ($image_data) = @_; $image_data eq '' and return; state %rgb_cache; # cache the RGB values of pixels my @fingerprint; my $image = GD::Image->new($image_data) // return; for (my $i = 0 ; $i <= $limit_x ; $i += $sq_x) { for (my $j = 0 ; $j <= $limit_y ; $j += $sq_y) { my $fill = 0; foreach my $x ($i .. $i + $sq_x - 1) { foreach my $y ($j .. $j + $sq_y - 1) { my $index = $image->getPixel($x, $y); my $rgb = $rgb_cache{$index} //= [$image->rgb($index)]; $fill++ if $rgb->[0] == 255; # check only the value of red } } push @fingerprint, $fill; } } return \@fingerprint; } # #-- fetch or generate the fingerprint for a given audio file # sub fingerprint { my ($audio_file) = @_; state $local_cache = {}; return $local_cache->{$audio_file} if exists $local_cache->{$audio_file}; my $md5 = md5_file($audio_file); my $key = "$width/$height/$div_x/$div_y/$md5"; if (not exists $db{$key}) { my $image_data = generate_waveform($audio_file) // return; my $fingerprint = generate_fingerprint($image_data) // return; $db{$key} = join(':', @{$fingerprint}); return ($local_cache->{$audio_file} = $fingerprint); } $local_cache->{$audio_file} //= [split /:/, $db{$key}]; } # #-- compare two fingerprints and return true if they are alike # sub alike_fingerprints { my ($a1, $a2) = @_; foreach my $i (0 .. $#{$a1}) { my $value = abs($a1->[$i] - $a2->[$i]) / ($sq_x * $sq_y) * 100; return if $value > $deviation; } return 1; } # #-- compare two audio files and return true if they are alike # sub alike_files { my ($file1, $file2) = @_; my $fp1 = fingerprint($file1) // return; my $fp2 = fingerprint($file2) // return; alike_fingerprints($fp1, $fp2); } # #-- find and call $code with a group of similar audio files # sub find_similar_audio_files { my $code = shift; my @files; find { no_chdir => 1, wanted => sub { /$audio_formats_re/ || return; lstat; (-f _) && (not -l _) && push @files, $_; } } => @_; my %groups; my %seen; my $limit = $#files; foreach my $i (0 .. $limit) { foreach my $j ($i + 1 .. $limit) { next if $seen{$files[$j]}; if (alike_files($files[$i], $files[$j])) { $groups{$i} //= [$files[$i]]; $seen{$files[$j]}++; push @{$groups{$i}}, $files[$j]; } } if (exists $groups{$i}) { $code->(delete $groups{$i}); } } } # #-- print a group of files followed by an horizontal line # sub print_group { my ($group) = @_; foreach my $file (sort { (lc($a) cmp lc($b)) || ($a cmp $b) } @{$group}) { say $file; } say "-" x 80; } @ARGV || help(2); find_similar_audio_files(\&print_group, @ARGV); ================================================ FILE: Audio/wave-cmp2.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 22 March 2015 # Edit: 04 September 2015 # Website: https://github.com/trizen # Find similar audio files by comparing their waveforms. # Review: # https://trizenx.blogspot.com/2015/03/similar-audio-files.html # Requirements: # - ffmpeg: https://ffmpeg.org # - wav2png: https://github.com/beschulz/wav2png use utf8; use 5.022; use strict; use autodie; use warnings; use experimental 'bitwise'; require GD; GD::Image->trueColor(1); require GDBM_File; use List::Util qw(sum); use Getopt::Long qw(GetOptions); use File::Find qw(find); use File::Temp qw(tempdir); use File::Path qw(make_path); use File::Spec::Functions qw(catfile catdir); require Digest::MD5; my $ctx = Digest::MD5->new; my $pkgname = 'wave-cmp2'; my $version = 0.02; # Mark files as similar based on this percentage my $percentage = 75; # The size of the waveform my ($width, $height) = (1800, 300); sub help { my ($code) = @_; print <<"EOT"; usage: $0 [options] [dirs|files] => Waveform generation -w --width=i : width of the waveform (default: $width) -h --height=i : height of the waveform (default: $height) => Waveform processing -p --percentage=i : minimum percentage of similarity (default: $percentage) --help : print this message and exit --version : print the version number and exit example: $0 --percentage=80 ~/Music EOT exit($code); } sub version { print "$pkgname $version\n"; exit 0; } GetOptions( 'w|width=i' => \$width, 'h|height=i' => \$height, 'p|percentage=i' => \$percentage, 'help' => sub { help(0) }, 'v|version' => \&version, ) or die("Error in command line arguments"); my $size = $width * $height; # Source: https://en.wikipedia.org/wiki/Audio_file_format#List_of_formats my @audio_formats = qw( 3gp act aiff aac amr au awb dct dss flac gsm m4a m4p mp3 mpc ogg oga opus ra rm raw sln tta vox wav wma wv webm ); my $audio_formats_re = do { local $" = '|'; qr/\.(?:@audio_formats)\z/i; }; my $home_dir = $ENV{HOME} || $ENV{LOGDIR} || (getpwuid($<))[7] || `echo -n ~`; my $xdg_config_home = catdir($home_dir, '.config'); my $cache_dir = catdir($xdg_config_home, $pkgname); my $cache_db = catfile($cache_dir, 'fp.db'); if (not -d $cache_dir) { make_path($cache_dir); } my $tmpdir = tempdir(CLEANUP => 1); tie my %db, 'GDBM_File', $cache_db, &GDBM_File::GDBM_WRCREAT, 0640; # #-- execute the ffmpeg and wave2png commands and return the waveform PNG data # sub generate_waveform { my ($file, $output) = @_; #<<< # Using sox (currently broken) # 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`; #>>> my $tmpfile = catfile($tmpdir, $file . '.wav'); system("ffmpeg", "-loglevel", "quiet", "-i", $file, $tmpfile); $? == 0 or return; my $waveform = `wav2png -w $width -h $height -f 000000ff -b ffffff00 -o /dev/stdout \Q$tmpfile\E`; unlink($tmpfile); return $waveform; } # #-- return the md5 hex digest of the content of a file # sub md5_file { my ($file) = @_; open my $fh, '<:raw', $file; $ctx->addfile($fh); $ctx->hexdigest; } #<<< # #-- compare two fingerprints and return the similarity percentage # sub alike_percentage { ((($_[0] ^. $_[1]) =~ tr/\0//) / $size)**2 * 100; } #>>> # #-- compute the average value of a pixel # sub avg { ($_[0] + $_[1] + $_[2]) / 3; } # #-- take image data as input and return the fingerprint as string # sub generate_fingerprint { my ($image_data) = @_; $image_data eq '' and return; my $img = GD::Image->new($image_data) // return; my @averages; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { push @averages, avg($img->rgb($img->getPixel($x, $y))); } } my $avg = sum(@averages) / @averages; join('', map { $_ < $avg ? 1 : 0 } @averages); } # #-- fetch or generate the fingerprint for a given audio file # sub fingerprint { my ($audio_file) = @_; state $local_cache = {}; return $local_cache->{$audio_file} if exists $local_cache->{$audio_file}; my $md5 = md5_file($audio_file); my $key = "$width/$height/$md5"; if (not exists $db{$key}) { my $image_data = generate_waveform($audio_file) // return; my $fingerprint = generate_fingerprint($image_data) // return; $db{$key} = pack('B*', $fingerprint); return ($local_cache->{$audio_file} = $fingerprint); } $local_cache->{$audio_file} //= unpack('B*', $db{$key}); } # #-- find and call $code with a group of similar audio files # sub find_similar_audio_files(&@) { my $callback = shift; my @files; find { no_chdir => 1, wanted => sub { (/$audio_formats_re/o && -f) || return; push @files, { fingerprint => fingerprint($_) // return, filename => $_, }; } } => @_; # ## Populate the %alike hash # my %alike; foreach my $i (0 .. $#files - 1) { for (my $j = $i + 1 ; $j <= $#files ; $j++) { my $p = alike_percentage($files[$i]{fingerprint}, $files[$j]{fingerprint}); if ($p >= $percentage) { $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p; $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p; } } } # ## Group the files # my @alike; foreach my $root ( map { $_->[0] } sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) } map { my $keys = keys(%{$alike{$_}}); my $avg = sum(values(%{$alike{$_}})) / $keys; [$_, $keys, $avg] } keys %alike ) { my @group = keys(%{$alike{$root}}); if (@group) { my $avg = 0; $avg += delete($alike{$_}{$root}) for @group; push @alike, {score => $avg / @group, files => [$root, @group]}; } } # ## Callback each group # my %seen; foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) { (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next; $callback->($group->{score}, $group->{files}); } return 1; } @ARGV || help(2); find_similar_audio_files { my ($score, $files) = @_; printf("=> Similarity: %.0f%%\n", $score), say join("\n", @{$files}); say "-" x 80; } @ARGV; ================================================ FILE: Benchmarks/array_range_vs_shift.pl ================================================ #!/usr/bin/perl use 5.014; use Benchmark qw(cmpthese); package Foo { sub new { bless {}, __PACKAGE__; } sub call_me { } sub bar { $_[0]->call_me(@_[1 .. $#_]); } sub baz { shift(@_)->call_me(@_); } } my $obj = Foo->new(); cmpthese( -1, { with_shift => sub { $obj->baz(1, 2, 3, 4, 5); $obj->baz(); $obj->baz(1); $obj->baz(1, 2); }, with_range => sub { $obj->bar(1, 2, 3, 4, 5); $obj->bar(); $obj->bar(1); $obj->bar(1, 2); }, } ); __END__ Rate with_range with_shift with_range 721308/s -- -33% with_shift 1071850/s 49% -- ================================================ FILE: Benchmarks/compression_algorithms.pl ================================================ #!/usr/bin/perl # Rough performance comparison of some compression modules on a given file given as an argument. use 5.010; use strict; use warnings; use Time::HiRes qw(gettimeofday tv_interval); my $data_str = do { open(my $fh, '<:raw', $ARGV[0] // $0) or die "Can't open file <<$ARGV[0]>> for reading: $!"; local $/; <$fh>; }; say "Raw : ", length($data_str); say ''; eval { my $t0 = [gettimeofday]; require IO::Compress::Gzip; IO::Compress::Gzip::gzip(\$data_str, \my $data_gzip); say "Gzip: ", length($data_gzip); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::Bzip2; IO::Compress::Bzip2::bzip2(\$data_str, \my $data_bzip2); say "Bzip: ", length($data_bzip2); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::RawDeflate; IO::Compress::RawDeflate::rawdeflate(\$data_str, \my $data_raw_deflate); say "RDef: ", length($data_raw_deflate); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::Deflate; IO::Compress::Deflate::deflate(\$data_str, \my $data_deflate); say "Defl: ", length($data_deflate); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::Zip; IO::Compress::Zip::zip(\$data_str, \my $data_zip); say "Zip : ", length($data_zip); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::Lzf; IO::Compress::Lzf::lzf(\$data_str, \my $data_lzf); say "Lzf : ", length($data_lzf); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::Lzip; IO::Compress::Lzip::lzip(\$data_str, \my $data_lzip); say "Lzip: ", length($data_lzip); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::Lzop; IO::Compress::Lzop::lzop(\$data_str, \my $data_lzop); say "Lzop: ", length($data_lzop); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; eval { my $t0 = [gettimeofday]; require IO::Compress::Zstd; IO::Compress::Zstd::zstd(\$data_str, \my $data_zstd); say "Zstd: ", length($data_zstd); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; 0 && eval { my $t0 = [gettimeofday]; require IO::Compress::Brotli; my $data_bro = IO::Compress::Brotli::bro($data_str); say "Brot: ", length($data_bro); say "Time: ", tv_interval($t0, [gettimeofday]); say ''; }; ================================================ FILE: Benchmarks/json_vs_storable.pl ================================================ #!/usr/bin/perl # Speed comparison of JSON::XS vs Storable. # Result: # Storable is significantly faster for both encoding and decoding of data. use 5.014; use strict; use warnings; use Storable qw(freeze thaw); use JSON::XS qw(encode_json decode_json); use LWP::Simple qw(get); use Benchmark qw(cmpthese); my $info = { content => get("https://github.com/"), description => "GitHub is where people build software. More than 73 million people use GitHub to discover, fork, and contribute to over 200 million projects.", id => "2df61d3f", keywords => undef, score => 2, title => "This is a test", url => "https://github.com/", }; my $storable = freeze($info); my $json = encode_json($info); say "# Decoding speed:\n"; cmpthese( -1, { json => sub { my $data = decode_json($json); }, storable => sub { my $data = thaw($storable); }, } ); say "\n# Encoding speed:\n"; cmpthese( -1, { json => sub { my $data = encode_json($info); }, storable => sub { my $data = freeze($info); }, } ); __END__ # Decoding speed: Rate json storable json 2327/s -- -94% storable 41533/s 1685% -- # Encoding speed: Rate json storable json 1541/s -- -93% storable 21721/s 1309% -- ================================================ FILE: Benchmarks/schwartzian_transform.pl ================================================ #!/usr/bin/perl # Performance comparison of Schwartzian transform. # See also: # https://en.wikipedia.org/wiki/Schwartzian_transform use 5.010; use Benchmark qw(cmpthese); my @alpha = map { chr($_) } 32 .. 127; my @arr = ( map { join('', map { $alpha[rand @alpha] } 1 .. 140) } 1 .. 100 ); cmpthese( -1, { schwartz => sub { my @sorted = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [lc($_), $_] } @arr; @sorted; }, without_schwartz => sub { my @sorted = sort { lc($a) cmp lc($b) } @arr; @sorted; }, } ); __END__ Rate without_schwartz schwartz without_schwartz 4403/s -- -53% schwartz 9309/s 111% -- ================================================ FILE: Benchmarks/types_of_variables.pl ================================================ #!/usr/bin/perl # Performance comparison between `state`, `my` and global variables. use 5.010; use Benchmark qw(cmpthese); cmpthese( -1, { my => sub { my $x = rand(1); $x + 1; }, state => sub { state $x; $x = rand(1); $x + 1; }, global => sub { $main::global = rand(1); $main::global + 1; } } ); __END__ Rate my global state my 12105605/s -- -17% -44% global 14563555/s 20% -- -32% state 21462081/s 77% 47% -- ================================================ FILE: Book tools/rosettacode_to_markdown.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 24 April 2015 # Edit: 09 December 2023 # Website: https://github.com/trizen # Extract markdown code from each task for a given programming language. use utf8; use 5.020; use strict; use autodie; use warnings; use experimental qw(signatures); use Text::Tabs qw(expand); use Encode qw(decode_utf8); use Getopt::Long qw(GetOptions); use File::Path qw(make_path); use LWP::UserAgent::Cached qw(); use URI::Escape qw(uri_unescape uri_escape); use HTML::Entities qw(decode_entities); use File::Spec::Functions qw(catfile catdir); binmode(STDOUT, ':utf8'); binmode(STDERR, ':utf8'); sub escape_markdown ($t) { $t =~ s{([*_`])}{\\$1}g; return $t; } sub escape_lang ($s) { $s =~ s/\s/_/gr; # replace whitespace with underscores } sub _ulist ($s) { $s =~ s{
  • (.*?)
    • }{* $1\n}gsr; } sub _olist ($s) { my $i = 1; $s =~ s{
  • (.*?)
    • }{$i++ . '. ' . "$1\n"}egsr; } sub tags_to_markdown ($t, $escape = 0) { my $out = ''; until ($t =~ /\G\z/gc) { if ($t =~ m{\G}gc) { $out .= "\n"; } elsif ($t =~ m{\G(.*?)}gcs) { $out .= "**" . tags_to_markdown($1, 1) . "**"; } elsif ($t =~ m{\G(.*?)}gcs) { $out .= "*" . tags_to_markdown($1, 1) . "*"; } elsif ($t =~ m{\G(.*?)}gcs) { $out .= "`" . decode_entities($1) . "`"; } elsif ($t =~ m{\G(.*?)}gcs) { $out .= "`" . decode_entities($1) . "`"; } elsif ($t =~ m{\G(.*?)}gcs) { my ($url, $label) = ($1, $2); if ($url =~ m{^/}) { $url = 'https://rosettacode.org' . $url; } $label = tags_to_markdown($label); $out .= "[$label]($url)"; } elsif ($t =~ m{\G()}gc) { my $html = $1; $html =~ s{ src="\K/mw/}{https://rosettacode.org/mw/}; $html =~ s{ srcset=".*?"}{}; $out .= $html; } elsif ($t =~ m{\G}gsc; if ($t =~ m{\G}gc) { $out .= '![image](https://rosettacode.org' . decode_entities($1) . ')'; } else { warn "[!] Failed to parse math meta class!\n"; } } elsif ($t =~ m{\G
      (.*?)
    }gcs) { $out .= _ulist(tags_to_markdown($1, 1)); } elsif ($t =~ m{\G
      (.*?)
    }gcs) { $out .= _olist(tags_to_markdown($1, 1)); } elsif ($t =~ /\G([^<]+)/gc) { $out .= $escape ? escape_markdown($1) : $1; } elsif ($t =~ /\G(.)/gcs) { $out .= $escape ? escape_markdown($1) : $1; } } return $out; } sub strip_tags ($s) { $s =~ s/<.*?>//gsr; # remove HTML tags } sub strip_space ($s) { unpack('A*', $s =~ s/^\s+//r); # remove leading and trailing whitespace } sub extract_tasks ($content, $lang) { my $i = index($content, qq{

    Pages in category "$lang"

    }); if ($i == -1) { warn "[!] Can't find any tasks for language: <$lang>!\n"; return; } my $tasks_content = substr($content, $i); my @tasks; while ($tasks_content =~ m{(.+?)}g) { my ($task, $label) = ($1, $2); last if $task eq 'Special:Categories'; push @tasks, { name => decode_utf8(uri_unescape($task)), title => $label, }; } return \@tasks; } sub extract_all_tasks ($main_url, $path_url, $lang) { my $lwp_uc = LWP::UserAgent->new( show_progress => 1, agent => '', timeout => 60, ); my $tasks_url = $main_url . $path_url; my $resp = $lwp_uc->get($tasks_url); $resp->is_success || die $resp->status_line; my $content = $resp->decoded_content; my $tasks = extract_tasks($content, $lang); my @all_tasks = @$tasks; if ($content =~ m{next page}) { push @all_tasks, __SUB__->($main_url, $1, $lang); } return @all_tasks; } sub extract_lang ($content, $lang, $lang_alias = $lang) { my $header = sub { qq{}; }; my $i = index($content, $header->($lang)); # Try with the language escaped if ($i == -1) { $i = index($content, $header->(escape_lang($lang))); } # Try with the language alias if ($i == -1) { $i = index($content, $header->($lang_alias)); } # Try with the language alias escaped if ($i == -1) { $i = index($content, $header->(escape_lang($lang_alias))); } # Give up if ($i == -1) { warn "[!] Can't find language: <$lang>\n"; return; } my $j = index($content, '

    ', $i); if ($j == -1) { $j = index($content, '
    ', $i); } if ($j == -1) { state $x = 0; if (++$x <= 3) { warn "[!] Position `j` will point at the end of the page...\n"; } $j = length($content); } $i = index($content, '

    ', $i); if ($i == -1) { warn "[!] Can't find the end of the header!\n"; return; } $i += 5; # past the end of the header my $part = strip_space(substr($content, $i, $j - $i)); # remove }{}gsi; # replace [email protected] with 'email@example.net' $part =~ s{}{email\@example.net}gsi; my @data; until ($part =~ /\G\z/gc) { if ($part =~ m{\G
    (.+)
    }gc) { # old way push @data, { code => { lang => $1, data => $2, } }; } elsif ($part =~ m{\G
    (.*?)
    }sgc) { # new way push @data, { code => { lang => $1, data => $2, } }; } elsif ($part =~ m{\G(.*?)}sgc) { push @data, { header => { n => $1, data => $2, } }; } elsif ($part =~ m{\G

    (.*?)

    }sgc) { push @data, { text => { tag => 'p', data => $1, }, }; } elsif ($part =~ m{\G]*>(.*?)}sgc) { push @data, { text => { tag => 'pre', data => $1, } }; } elsif ($part =~ m{\G(.)}sgc) { @data && exists($data[-1]{unknown}) ? ($data[-1]{unknown}{data} .= $1) : (push @data, {unknown => {data => $1}}); } } return \@data; } sub to_html ($lang_data) { my $text = ''; foreach my $item (@{$lang_data}) { if (exists $item->{text}) { $text .= qq{<$item->{text}{tag}>$item->{text}{data}{text}{tag}>}; } elsif (exists $item->{code}) { $text .= qq{
    $item->{code}{data}
    }; } } return $text; } sub to_markdown ($lang_data) { my $text = ''; my $has_output = 1; foreach my $item (@{$lang_data}) { if (exists $item->{header}) { my $n = $item->{header}{n}; my $data = $item->{header}{data}; my $t = strip_tags(tags_to_markdown(strip_space($data), 1)); $t =~ s/\[\[edit\].*//s; $text .= "\n\n" . ('#' x $n) . ' ' . $t . "\n\n"; } elsif (exists $item->{text}) { my $data = $item->{text}{data}; my $tag = $item->{text}{tag}; if ($tag eq 'p') { my $t = tags_to_markdown(strip_space($data), 1); $text .= "\n\n" . $t . "\n\n"; $has_output = 1; } elsif ($tag eq 'pre') { my $t = decode_entities($data); $t =~ s/^(?:\R)+//; $t =~ s/(?:\R)+\z//; $t = join("\n", expand(split(/\R/, $t))); $text .= "\n#### Output:" if !$has_output; $text .= "\n```\n$t\n```\n"; } } elsif (exists $item->{code}) { my $code = decode_entities(strip_tags(tags_to_markdown($item->{code}{data}))); my $lang = $item->{code}{lang}; $code =~ s/\[(\w+)\]\(https?:.*?\)/$1/g; $code =~ s{(?:\R)+\z}{}; $text .= "```$lang\n$code\n```\n"; $has_output = 0; } } return strip_space($text); } sub write_to_file ($base_dir, $name, $markdown, $overwrite = 0) { # Remove parenthesis $name =~ tr/()//d; # Substitute bad characters #$name =~ tr{-A-Za-z0-9[]'*_/À-ÿ}{_}c; $name =~ s{[^\pL\pN\[\]'*/\-]+}{ }g; # Replace multiple spaces with a single underscore $name = join('_', split(' ', $name)); my $char = uc(substr($name, 0, 1)); my $dir = catdir($base_dir, $char); # Remove directory paths from name (if any) if ($name =~ s{^(.*)/}{}) { my $dirname = $1; $dir = catdir($dir, map { $_ eq 'Sorting_Algorithms' ? 'Sorting_algorithms' : $_ } split(/\//, $dirname)); } # Create directory if it doesn't exists if (not -d $dir) { make_path($dir) or do { warn "[!] Can't create path `$dir`: $!\n"; return; }; } my $file = catfile($dir, "$name.md"); if (not $overwrite) { return 1 if -e $file; # Don't overwrite existent files } say "** Creating file: $file"; open(my $fh, '>:encoding(UTF-8)', $file) or do { warn "[!] Can't create file `$file`: $!"; return; }; print {$fh} $markdown; close $fh; } # ## MAIN # my $cache_dir = 'cache'; my $lang = 'Sidef'; my $lang_alias = undef; my $overwrite = 0; my $base_dir = 'programming_tasks'; my $main_url = 'https://rosettacode.org'; sub usage { print <<"EOT"; usage: $0 [options] options: --lang=s : the programming language name (default: $lang) --base-dir=s : where to save the files (default: $base_dir) --overwrite! : overwrite existent files (default: $overwrite) --cache-dir=s : cache directory (default: $cache_dir) --main-url=s : main URL (default: $main_url) --help : print this message and exit example: $0 --lang=Perl --base-dir=perl_tasks EOT exit; } GetOptions( 'cache-dir=s' => \$cache_dir, 'L|language=s' => \$lang, 'base-dir=s' => \$base_dir, 'main-url=s' => \$main_url, 'overwrite!' => \$overwrite, 'help' => \&usage, ) or die "[!] Error in command line arguments!"; if (not -d $cache_dir) { mkdir($cache_dir); } my $lwp = LWP::UserAgent::Cached->new( timeout => 60, show_progress => 1, agent => '', cache_dir => $cache_dir, nocache_if => sub { my ($response) = @_; my $code = $response->code; return 1 if ($code >= 300); # do not cache any bad response return 1 if ($code == 401); # don't cache an unauthorized response return 1 if ($response->request->method ne 'GET'); # cache only GET requests return; }, ); { my $accepted_encodings = HTTP::Message::decodable(); $lwp->default_header('Accept-Encoding' => $accepted_encodings); require LWP::ConnCache; my $cache = LWP::ConnCache->new; $cache->total_capacity(undef); # no limit $lwp->conn_cache($cache); } my @tasks = extract_all_tasks($main_url, '/wiki/' . escape_lang($lang), $lang); sub my_uri_escape ($path) { $path =~ s/([?'+])/uri_escape($1)/egr; } foreach my $task (@tasks) { my $name = $task->{name}; my $title = $task->{title}; my $url = "$main_url/wiki/" . my_uri_escape($name); my $resp = $lwp->get($url); if ($resp->is_success) { my $content = $resp->decoded_content; my $lang_data = extract_lang($content, $lang, $lang_alias) // do { $lwp->uncache; next }; my $header = "[1]: $url\n\n" . "# [$title][1]\n\n"; my $markdown = $header . to_markdown($lang_data) . "\n"; write_to_file($base_dir, $name, $markdown, $overwrite); } else { warn "[" . $resp->status_line . "] Can't fetch: $url\n"; } } ================================================ FILE: Book tools/update_summary.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 24 April 2015 # Website: https://github.com/trizen # Add a given directory to a given section in SUMMARY.md (for gitbooks) use 5.014; use strict; use autodie; use warnings; use Cwd qw(getcwd); use File::Basename qw(basename dirname); use File::Spec::Functions qw(rel2abs); sub add_section { my ($name, $section, $file) = @_; my ($before, $middle, $after); open my $fh, '<', $file; while (defined(my $line = <$fh>)) { if ($line =~ /^(\*\h+\Q$name\E)\h*$/ || $line =~ m{^(\*\h+\[\Q$name\E\](?:\(.*\))?)\h*$}) { $middle = "$1\n"; say "** Found section: <<<$1>>>"; while (defined(my $line = <$fh>)) { if ($line =~ /^\S/) { $after = $line; } } } else { if (defined $after) { $after .= $line; } else { $before .= $line; } } } close $fh; open my $out_fh, '>', $file; print {$out_fh} $before . $middle . $section . $after; close $out_fh; } my $summary_file = 'SUMMARY.md'; my $main_dir = 'programming_tasks'; my $section_name = 'Programming tasks'; { my @root; sub make_section { my ($name, $dir, $spaces) = @_; my $cwd = getcwd(); chdir $dir; my @files = map { {name => $_, path => rel2abs($_)} } glob('*'); # sorting for free chdir $cwd; my $make_section_url = sub { my ($name) = @_; join('/', basename($main_dir), @root, $name); }; my %ignored; my $section = ''; foreach my $file (@files) { my $title = $file->{name} =~ s/_/ /gr; if (-d $file->{path}) { if (-e "$file->{path}.md") { my $url_path = $make_section_url->("$file->{name}.md"); $section .= (' ' x $spaces) . "* [\u$title]($url_path)\n"; $ignored{"$file->{name}.md"}++; # ignore this file later } else { $section .= (' ' x $spaces) . "* $title\n"; } push @root, $file->{name}; $section .= make_section($file->{name}, $file->{path}, $spaces + 4); } else { next if $dir eq $main_dir; next if $ignored{$file->{name}}; my $naked_name = $file->{name} =~ s/\.md\z//ir; my $naked_title = $title =~ s/\.md\z//ir; my $url_path = $make_section_url->($file->{name}); $section .= (' ' x $spaces) . "* [\u$naked_title]($url_path)\n"; } } pop @root; return $section; } } my $section = make_section($section_name, $main_dir, 3); my $section_content = add_section($section_name, $section, $summary_file); say "** All done!"; ================================================ FILE: Compression/High-level/ablz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 31 July 2024 # https://github.com/trizen # Compress/decompress files using Adaptive Binary Coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'ABLZ', VERSION => '0.01', FORMAT => 'ablz', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 8 * 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = unpack('B*', abc_encode(string2symbols($chunk))); my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($bits); my $ubits = pack('C*', @$uncompressed); my $rem = length($ubits) % 8; my $str = pack('B*', $ubits); print $out_fh chr($rem); print $out_fh mrl_compress_symbolic($str); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $rem = ord getc $fh; my $str = symbols2string(mrl_decompress_symbolic($fh)); my $ubits = unpack('B*', $str); if ($rem != 0) { $ubits = substr($ubits, 0, -(8 - $rem)); } my $uncompressed = [unpack('C*', $ubits)]; my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $bits = lz77_decode($uncompressed, $distances, $lengths, $matches); print $out_fh symbols2string(abc_decode(pack('B*', $bits))); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bbwr_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 04 July 2024 # https://github.com/trizen # Compress/decompress files using Binary Burrows-Wheeler Transform (BWT) + Binary Variable Run-Length Encoding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Data Compression (Summer 2023) - Lecture 5 - Basic Techniques # https://youtube.com/watch?v=TdFWb8mL5Gk use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BBWR', VERSION => '0.01', FORMAT => 'bbwr', CHUNK_SIZE => 1 << 13, # larger values == better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my $bits = unpack('B*', $chunk); my $vrle1 = binary_vrl_encode($bits); if (length($vrle1) < length($bits)) { printf "Doing early VLR, saving %s bits\n", length($bits) - length($vrle1); print $out_fh chr(1); } else { print $out_fh chr(0); $vrle1 = $bits; } my ($bwt, $idx) = bwt_encode($vrle1); my $vrle2 = binary_vrl_encode($bwt); say "BWT index: $idx"; print $out_fh pack('N', $idx); print $out_fh pack('N', length($vrle2)); print $out_fh pack('B*', $vrle2); } sub decompression ($fh, $out_fh) { my $compressed_byte = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $bits_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "BWT index = $idx"; my $bwt = binary_vrl_decode(read_bits($fh, $bits_len)); my $data = bwt_decode($bwt, $idx); if ($compressed_byte == 1) { $data = binary_vrl_decode($data); } print $out_fh pack('B*', $data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/blzss2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 29 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZ4-like) on bits + Huffman coding + Bzip2 on the literals. # Good at compressing data where there are patterns on bits, but not at byte boundaries (e.g.: variable-bit encoded data). use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BLZSS2', VERSION => '0.01', FORMAT => 'blzss2', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = unpack('B*', $chunk); my ($uncompressed, $distances, $lengths, $matches) = do { local $Compression::Util::LZ_MIN_LEN = 8 * 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression lz77_encode($bits); }; my $ubits = pack('C*', @$uncompressed); my $rem = length($ubits) % 8; my $str = pack('B*', $ubits); print $out_fh chr($rem); print $out_fh mrl_compress_symbolic($str, \&lzss_compress_symbolic); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $rem = ord getc $fh; my $str = symbols2string(mrl_decompress_symbolic($fh, \&lzss_decompress_symbolic)); my $ubits = unpack('B*', $str); if ($rem != 0) { $ubits = substr($ubits, 0, -(8 - $rem)); } my $uncompressed = [unpack('C*', $ubits)]; my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $bits = lz77_decode($uncompressed, $distances, $lengths, $matches); print $out_fh pack('B*', $bits); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/blzss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 25 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZ4-like) on bits + Huffman coding. # Good at compressing data where there are patterns on bits, but not at byte boundaries (e.g.: variable-bit encoded data). use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BLZSS', VERSION => '0.01', FORMAT => 'blzss', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = unpack('B*', $chunk); my ($uncompressed, $distances, $lengths, $matches) = do { local $Compression::Util::LZ_MIN_LEN = 8 * 5; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression lz77_encode($bits); }; my $ubits = pack('C*', @$uncompressed); my $rem = length($ubits) % 8; my $str = pack('B*', $ubits); print $out_fh chr($rem); print $out_fh mrl_compress_symbolic($str, \&lzss_compress_symbolic); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $rem = ord getc $fh; my $str = symbols2string(mrl_decompress_symbolic($fh, \&lzss_decompress_symbolic)); my $ubits = unpack('B*', $str); if ($rem != 0) { $ubits = substr($ubits, 0, -(8 - $rem)); } my $uncompressed = [unpack('C*', $ubits)]; my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $bits = lz77_decode($uncompressed, $distances, $lengths, $matches); print $out_fh pack('B*', $bits); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/brlzss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 25 July 2024 # https://github.com/trizen # Compress/decompress files using Binary RLE + LZ77 compression (LZ4-like) + Huffman coding. # Good at compressing data where there are patterns on bits, but not at byte boundaries (e.g.: variable-bit encoded data). use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BRLZSS', VERSION => '0.01', FORMAT => 'brlzss', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = unpack('B*', $chunk); my $rle = binary_vrl_encode($bits); if (length($rle) >= length($bits)) { print $out_fh chr(0); printf("Without binary VRLE: %s >= %s\n", length($rle), length($bits)); $rle = $bits; } else { print $out_fh chr(1); printf("With binary VRLE: %s < %s\n", length($rle), length($bits)); } my ($uncompressed, $distances, $lengths, $matches) = do { local $Compression::Util::LZ_MIN_LEN = 8 * 3; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression lz77_encode($rle); }; my $ubits = pack('C*', @$uncompressed); print $out_fh chr(length($ubits) % 8); my $str = pack('B*', $ubits); print $out_fh mrl_compress_symbolic($str, \&lzss_compress_symbolic); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $with_vrle = ord getc($fh); my $rem = ord getc($fh); my $str = symbols2string(mrl_decompress_symbolic($fh, \&lzss_decompress_symbolic)); my $ubits = unpack('B*', $str); if ($rem != 0) { $ubits = substr($ubits, 0, -(8 - $rem)); } my $uncompressed = [unpack('C*', $ubits)]; my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $rle = lz77_decode($uncompressed, $distances, $lengths, $matches); my $bits = $with_vrle ? binary_vrl_decode($rle) : $rle; print $out_fh pack('B*', $bits); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwac_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 13 April 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Arithmetic Coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWAC', VERSION => '0.02', FORMAT => 'bwac', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh bwt_compress($chunk, \&create_ac_entry); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh bwt_decompress($fh, \&decode_ac_entry); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwad_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 21 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Adaptive Arithmetic Coding (in fixed bits). # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWAD', VERSION => '0.02', FORMAT => 'bwad', CHUNK_SIZE => 1 << 17, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh bwt_compress($chunk, \&create_adaptive_ac_entry); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh bwt_decompress($fh, \&decode_adaptive_ac_entry); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlz2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 13 April 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression + Symbolic Bzip2. # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZ2', VERSION => '0.01', FORMAT => 'bwlz2', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes, 254)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, \@alphabet); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = zrle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); print $out_fh lzss_compress(pack('C*', @$enc_bytes), \&bwt_compress_symbolic); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $dec = lzss_decompress($fh, \&bwt_decompress_symbolic); my $bytes = [unpack('C*', $dec)]; if ($rle_encoded) { $bytes = zrle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, $alphabet); print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx)))); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the files close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlz3_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 02 May 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + ZRLE + LZHD compression. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZ3', VERSION => '0.01', FORMAT => 'bwlz3', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my $lzb = do { local $Compression::Util::LZ_MIN_LEN = 512; lzb_compress($chunk); }; my @chunk_bytes = unpack('C*', $lzb); my $data = rle4_encode(\@chunk_bytes, scalar(@chunk_bytes)); my ($bwt, $idx) = bwt_encode_symbolic($data); my ($enc_bytes, $alphabet) = mtf_encode($bwt); $enc_bytes = zrle_encode($enc_bytes); print $out_fh pack('N', $idx); print $out_fh encode_alphabet($alphabet); print $out_fh lz77_compress_symbolic($enc_bytes); } sub decompression ($fh, $out_fh) { my $idx = bytes2int($fh, 4); my $alphabet = decode_alphabet($fh); my $symbols = lz77_decompress_symbolic($fh); $symbols = zrle_decode($symbols); $symbols = mtf_decode($symbols, $alphabet); print $out_fh lzb_decompress(symbols2string(rle4_decode(bwt_decode_symbolic($symbols, $idx)))); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the files close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 21 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZ', VERSION => '0.05', FORMAT => 'bwlz', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(5); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes, 254)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, \@alphabet); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = zrle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); print $out_fh lzss_compress(pack('C*', @$enc_bytes)); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $dec = lzss_decompress($fh); my $bytes = [unpack('C*', $dec)]; if ($rle_encoded) { $bytes = zrle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, $alphabet); print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx)))); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the files close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlza2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZHD variant) + Arithmetic Coding (in fixed bits). # Encoding the distances using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(uniq max); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZA2', VERSION => '0.01', FORMAT => 'bwlza2', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lzad_compression ($chunk, $out_fh) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh create_ac_entry($uncompressed); print $out_fh create_ac_entry($lengths); print $out_fh create_ac_entry($matches); print $out_fh obh_encode($distances, \&create_ac_entry); } sub lzad_decompression ($fh) { my $uncompressed = decode_ac_entry($fh); my $lengths = decode_ac_entry($fh); my $matches = decode_ac_entry($fh); my $distances = obh_decode($fh, \&decode_ac_entry); return lz77_decode($uncompressed, $distances, $lengths, $matches); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes, 254)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = zrle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzad_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $bytes = string2symbols(lzad_decompression($fh)); if ($rle_encoded) { $bytes = zrle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlza_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 21 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Arithmetic Coding (in fixed bits). # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZA', VERSION => '0.03', FORMAT => 'bwlza', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(3); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes, 254)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, \@alphabet); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = zrle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); print $out_fh lzss_compress(pack('C*', @$enc_bytes), \&create_ac_entry); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $dec = lzss_decompress($fh, \&decode_ac_entry); my $bytes = [unpack('C*', $dec)]; if ($rle_encoded) { $bytes = zrle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, $alphabet); print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx)))); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlzad2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZHD variant) + Adaptive Arithmetic Coding (in fixed bits). # Encoding the distances using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZAD2', VERSION => '0.01', FORMAT => 'bwlzad2', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lzhd_compression ($chunk, $out_fh) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh create_ac_entry($uncompressed); print $out_fh create_ac_entry($lengths); print $out_fh create_ac_entry($matches); print $out_fh abc_encode($distances); } sub lzhd_decompression ($fh) { my $uncompressed = decode_ac_entry($fh); my $lengths = decode_ac_entry($fh); my $matches = decode_ac_entry($fh); my $distances = abc_decode($fh); return lz77_decode($uncompressed, $distances, $lengths, $matches); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = zrle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzhd_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $bytes = string2symbols(lzhd_decompression($fh)); if ($rle_encoded) { $bytes = zrle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx)))); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlzad_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 07 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Adaptive Arithmetic Coding (in fixed bits). # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZAD', VERSION => '0.01', FORMAT => 'bwlzad', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); use constant INITIAL_FREQ => 1; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes, 254)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, \@alphabet); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = zrle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); print $out_fh lzss_compress(pack('C*', @$enc_bytes), \&create_adaptive_ac_entry); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $bytes = [unpack('C*', lzss_decompress($fh, \&decode_adaptive_ac_entry))]; if ($rle_encoded) { $bytes = zrle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, $alphabet); print $out_fh symbols2string(rle4_decode(string2symbols(bwt_decode(pack('C*', @$bytes), $idx)))); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlzb_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 03 June 2024 # https://github.com/trizen # Compress/decompress files using byte-aligned LZ77 compression (LZSS) + Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZB', VERSION => '0.01', FORMAT => 'bwlzb', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(5); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { local $Compression::Util::LZ_MIN_LEN = 64; my $rle4 = symbols2string(rle4_encode(string2symbols($chunk))); my $lzb = lzb_compress($rle4); my ($bwt, $idx) = bwt_encode($lzb); my ($mtf, $alphabet) = mtf_encode(string2symbols($bwt)); my $rle = zrle_encode($mtf); my $enc = pack('N', $idx) . encode_alphabet($alphabet) . create_huffman_entry($rle); print $out_fh $enc; } sub decompression ($fh, $out_fh) { my $idx = bytes2int($fh, 4); my $alphabet = decode_alphabet($fh); my $rle = decode_huffman_entry($fh); my $mtf = zrle_decode($rle); my $bwt = symbols2string(mtf_decode($mtf, $alphabet)); my $lzb = bwt_decode($bwt, $idx); my $rle4 = lzb_decompress($lzb); my $data = symbols2string(rle4_decode(string2symbols($rle4))); print $out_fh $data; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the files close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlzhd2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 25 July 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler transform (BWT) + Run-length Encoding (RLE) + LZ77 compression (LZ4-like) + Move-to-front + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZHD2', VERSION => '0.01', FORMAT => 'bwlzhd2', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my $rle4 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4)); say "BWT index = $idx"; my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($bwt); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh pack('N', $idx); print $out_fh mrl_compress_symbolic($uncompressed); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $bwt = lz77_decode($uncompressed, $distances, $lengths, $matches); my @rle4 = unpack('C*', bwt_decode($bwt, $idx)); print $out_fh symbols2string(rle4_decode(\@rle4)); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlzhd_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler transform (BWT) + Run-length Encoding (RLE) + LZ77 compression (LZHD variant) + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZHD', VERSION => '0.02', FORMAT => 'bwlzhd', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my $rle4 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4)); $bwt = pack('C*', @{rle4_encode([unpack('C*', $bwt)])}); say "BWT index = $idx"; my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($bwt); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh pack('N', $idx); print $out_fh mrl_compress_symbolic($uncompressed); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh); my $rle4 = lz77_decode($uncompressed, $distances, $lengths, $matches); my $bwt = symbols2string(rle4_decode(string2symbols($rle4))); my @rle4 = unpack('C*', bwt_decode($bwt, $idx)); print $out_fh symbols2string(rle4_decode(\@rle4)); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwlzss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 21 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZSS) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWLZSS', VERSION => '0.01', FORMAT => 'bwlzss', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my $rle4 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4)); print $out_fh pack('N', $idx); print $out_fh lzss_compress($bwt, \&mrl_compress_symbolic); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $bwt = lzss_decompress($fh, \&mrl_decompress_symbolic); my $rle4 = bwt_decode($bwt, $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwrl2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 13 April 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWRL2', VERSION => '0.01', FORMAT => 'bwrl2', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub VLR_encoding ($bytes) { my $uncompressed = ''; my $bitstream = ''; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; $uncompressed .= chr($c); if ($v == 1) { $bitstream .= '0'; } else { my $t = sprintf('%b', $v); $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } return ($uncompressed, pack('B*', $bitstream)); } sub VLR_decoding ($uncompressed, $bits_fh) { my $decoded = ''; my $buffer = ''; foreach my $c (@$uncompressed) { my $bl = 0; while (read_bit($bits_fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { $decoded .= chr($c) x oct('0b1' . join('', map { read_bit($bits_fh, \$buffer) } 1 .. $bl)); } else { $decoded .= chr($c); } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(symbols2string(rle4_encode($chunk))); my ($uncompressed, $lengths) = VLR_encoding(string2symbols($bwt)); print $out_fh pack('N', $idx); print $out_fh mrl_compress_symbolic($uncompressed, sub ($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); print $out_fh create_huffman_entry(rle4_encode(string2symbols($lengths))); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $idx = bytes2int($fh, 4); my $uncompressed = mrl_decompress_symbolic($fh, sub ($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) }); open my $len_fh, '+>:raw', \my $lengths; print $len_fh symbols2string(rle4_decode(decode_huffman_entry($fh))); seek($len_fh, 0, 0); my $dec = VLR_decoding($uncompressed, $len_fh); print $out_fh symbols2string(rle4_decode(bwt_decode($dec, $idx))); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwrm2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 13 April 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Run-Length encoding + MTF + ZRLE + Bzip2 on lengths. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWRM2', VERSION => '0.01', FORMAT => 'bwrm2', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub VLR_encoding ($bytes) { my @lengths; my @uncompressed; my $rle = run_length($bytes, 256); foreach my $cv (@$rle) { my ($c, $v) = @$cv; push @uncompressed, $c; push @lengths, $v - 1; } return (\@uncompressed, \@lengths); } sub VLR_decoding ($uncompressed, $lengths) { my $decoded = ''; foreach my $i (0 .. $#{$uncompressed}) { my $c = $uncompressed->[$i]; my $len = $lengths->[$i]; if ($len > 0) { $decoded .= chr($c) x ($len + 1); } else { $decoded .= chr($c); } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(symbols2string(rle4_encode($chunk))); my ($uncompressed, $lengths) = VLR_encoding(string2symbols($bwt)); print $out_fh pack('N', $idx); print $out_fh mrl_compress_symbolic($uncompressed, \&lzss_compress_symbolic); print $out_fh bwt_compress(pack('C*', @$lengths)); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); my $uncompressed = mrl_decompress_symbolic($fh, \&lzss_decompress_symbolic); my $lengths = bwt_decompress($fh); my $dec = VLR_decoding($uncompressed, string2symbols($lengths)); print $out_fh symbols2string(rle4_decode(bwt_decode($dec, $idx))); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwrm_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 13 April 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Run-Length encoding + MTF + ZRLE. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWRM', VERSION => '0.01', FORMAT => 'bwrm', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub VLR_encoding ($bytes) { my @lengths; my @uncompressed; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; push @uncompressed, $c; push @lengths, $v - 1; } return (\@uncompressed, \@lengths); } sub VLR_decoding ($uncompressed, $lengths) { my $decoded = ''; foreach my $i (0 .. $#{$uncompressed}) { my $c = $uncompressed->[$i]; my $len = $lengths->[$i]; if ($len > 0) { $decoded .= chr($c) x ($len + 1); } else { $decoded .= chr($c); } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(symbols2string(rle4_encode($chunk))); my ($uncompressed, $lengths) = VLR_encoding(string2symbols($bwt)); print $out_fh pack('N', $idx); print $out_fh mrl_compress_symbolic($uncompressed, \&lzss_compress_symbolic); print $out_fh create_huffman_entry(rle4_encode($lengths)); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); my $uncompressed = mrl_decompress_symbolic($fh, \&lzss_decompress_symbolic); my $lengths = rle4_decode(decode_huffman_entry($fh)); my $dec = VLR_decoding($uncompressed, $lengths); print $out_fh symbols2string(rle4_decode(bwt_decode($dec, $idx))); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwt2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-To-Front transform (MTF) + Run-length encoding (RLE) + Bzip2. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWT2', VERSION => '0.01', FORMAT => 'bwt2', CHUNK_SIZE => 1 << 17, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh bwt_compress($chunk, sub ($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh bwt_decompress($fh, sub ($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) }); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bwt_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 21 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'BWT', VERSION => '0.02', FORMAT => 'bwt', CHUNK_SIZE => 1 << 17, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh bwt_compress($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh bwt_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/bzip2_file_compression.pl ================================================ #!/usr/bin/perl # Compress files using Bzip2. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use IO::Compress::Bzip2 qw(bzip2); use IO::Uncompress::Bunzip2 qw(bunzip2); use constant { PKGNAME => 'BZIP2', VERSION => '0.01', FORMAT => 'bz2', }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data bzip2($fh, $out_fh) or die "compression error"; # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; bunzip2($fh, $out_fh) or die "decompression error"; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/gzip_file_compression.pl ================================================ #!/usr/bin/perl # Compress files using Gzip. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use IO::Compress::Gzip qw(gzip); use IO::Uncompress::Gunzip qw(gunzip); use constant { PKGNAME => 'GZIP', VERSION => '0.01', FORMAT => 'gz', }; sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data gzip($fh, $out_fh) or die "compression error"; # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; gunzip($fh, $out_fh) or die "decompression error"; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/hblz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 31 July 2024 # https://github.com/trizen # Compress/decompress files using Huffman coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'HBLZ', VERSION => '0.01', FORMAT => 'hblz', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = unpack('B*', create_huffman_entry(string2symbols($chunk))); my ($uncompressed, $distances, $lengths, $matches) = do { local $Compression::Util::LZ_MIN_LEN = 8 * 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression lz77_encode($bits); }; my $ubits = pack('C*', @$uncompressed); my $rem = length($ubits) % 8; my $str = pack('B*', $ubits); print $out_fh chr($rem); print $out_fh mrl_compress_symbolic($str, \&lzss_compress_symbolic); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $rem = ord getc $fh; my $str = symbols2string(mrl_decompress_symbolic($fh, \&lzss_decompress_symbolic)); my $ubits = unpack('B*', $str); if ($rem != 0) { $ubits = substr($ubits, 0, -(8 - $rem)); } my $uncompressed = [unpack('C*', $ubits)]; my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $bits = lz77_decode($uncompressed, $distances, $lengths, $matches); print $out_fh symbols2string(decode_huffman_entry(pack('B*', $bits))); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lz255_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 01 September 2024 # https://github.com/trizen # Compress/decompress files using LZSS compression + MRL + Huffman coding, using a maximum match distance of 255. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZ255', VERSION => '0.01', FORMAT => 'lz255', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; print $out_fh lzss_compress($chunk, \&mrl_compress); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzss_decompress($fh, \&mrl_decompress_symbolic); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lz2ss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 23 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZ4-like) + LZSS compression. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZ2SS', VERSION => '0.01', FORMAT => 'lz2ss', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lz77_compress($chunk, sub ($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lz77_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) }); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lz4_file_compression.pl ================================================ #!/usr/bin/perl # Compress files using LZ4. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compress::LZ4Frame qw(); use constant { PKGNAME => 'LZ4', VERSION => '0.01', FORMAT => 'lz4', }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh Compress::LZ4Frame::compress( do { local $/; <$fh>; } ); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh Compress::LZ4Frame::decompress( do { local $/; <$fh>; } ); # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lz772_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 23 July 2024 # https://github.com/trizen # Compress/decompress files using two rounds of LZ77 compression (LZ4-like). use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZ772', VERSION => '0.01', FORMAT => 'lz772', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lz77_compress($chunk, sub($s) { lz77_compress_symbolic($s, \&mrl_compress_symbolic) }); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lz77_decompress($fh, sub($s) { lz77_decompress_symbolic($s, \&mrl_decompress_symbolic) }); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lz77_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZ77', VERSION => '0.01', FORMAT => 'lz77', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lz77_compress($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lz77_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lz77f_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 23 July 2024 # https://github.com/trizen # Compress/decompress files using fast LZ77 compression + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZ77F', VERSION => '0.01', FORMAT => 'lz77f', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lz77_compress($chunk, \&create_huffman_entry, \&lzss_encode_fast); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lz77_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzac_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Arithmetic Coding (in fixed bits). # Encoding the distances/indices using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZAC', VERSION => '0.02', FORMAT => 'lzac', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh mrl_compress_symbolic($uncompressed, \&create_ac_entry); print $out_fh create_ac_entry($lengths); print $out_fh create_ac_entry($matches); print $out_fh obh_encode($distances, \&create_ac_entry); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = mrl_decompress_symbolic($fh, \&decode_ac_entry); my $lengths = decode_ac_entry($fh); my $matches = decode_ac_entry($fh); my $distances = obh_decode($fh, \&decode_ac_entry); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzb_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZB', VERSION => '0.01', FORMAT => 'lzb', CHUNK_SIZE => 1 << 18, }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = ~0; # maximum match length local $Compression::Util::LZ_MAX_DIST = (1 << 16) - 1; # maximum match distance local $Compression::Util::LZ_MAX_CHAIN_LEN = 32; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzb_compress($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzb_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbbw_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 04 June 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Bzip2 + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBBW', VERSION => '0.01', FORMAT => 'lzbbw', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh bwt_compress(symbols2string($uncompressed), sub($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = string2symbols(bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) })); my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbf_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables -- fast variant), using a byte-aligned encoding, similar to LZ4. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBF', VERSION => '0.01', FORMAT => 'lzbf', CHUNK_SIZE => 1 << 18, }; local $Compression::Util::LZ_MIN_LEN = 5; # minimum match length local $Compression::Util::LZ_MAX_LEN = ~0; # maximum match length local $Compression::Util::LZ_MAX_DIST = (1 << 16) - 1; # maximum match distance # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzb_compress($chunk, \&lzss_encode_fast); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzb_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 24 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using ideas from LZ4, combined with Huffman Coding. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBH', VERSION => '0.01', FORMAT => 'lzbh', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = ~0; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 32; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression($chunk, $out_fh) { my ($literals, $distances, $lengths) = lzss_encode($chunk); my $literals_end = $#{$literals}; my @symbols; my @len_symbols; my @match_symbols; my @dist_symbols; for (my $i = 0 ; $i <= $literals_end ; ++$i) { my $j = $i; while ($i <= $literals_end and defined($literals->[$i])) { ++$i; } my $literals_length = $i - $j; my $dist = $distances->[$i] // 0; my $match_len = $lengths->[$i] // 0; my $len_byte = 0; $len_byte |= ($literals_length >= 7 ? 7 : $literals_length) << 5; $len_byte |= ($match_len >= 31 ? 31 : $match_len); $literals_length -= 7; $match_len -= 31; push @match_symbols, $len_byte; while ($literals_length >= 0) { push @len_symbols, ($literals_length >= 255 ? 255 : $literals_length); $literals_length -= 255; } push @symbols, @{$literals}[$j .. $i - 1]; while ($match_len >= 0) { push @match_symbols, ($match_len >= 255 ? 255 : $match_len); $match_len -= 255; } push @dist_symbols, $dist; } print $out_fh create_huffman_entry(\@symbols); print $out_fh delta_encode(\@len_symbols); print $out_fh create_huffman_entry(\@match_symbols); print $out_fh obh_encode(\@dist_symbols); } sub decompression($fh, $out_fh) { my $data = ''; my $symbols = decode_huffman_entry($fh); my $len_symbols = delta_decode($fh); my $match_symbols = decode_huffman_entry($fh); my $dist_symbols = obh_decode($fh); while (@$symbols) { my $len_byte = shift(@$match_symbols); my $literals_length = $len_byte >> 5; my $match_len = $len_byte & 0b11111; if ($literals_length == 7) { while (1) { my $byte_len = shift(@$len_symbols); $literals_length += $byte_len; last if $byte_len != 255; } } my $literals = ''; if ($literals_length > 0) { $literals = pack("C*", splice(@$symbols, 0, $literals_length)); } if ($match_len == 31) { while (1) { my $byte_len = shift(@$match_symbols); $match_len += $byte_len; last if $byte_len != 255; } } my $offset = shift(@$dist_symbols); $data .= $literals; if ($offset == 1) { $data .= substr($data, -1) x $match_len; } elsif ($offset >= $match_len) { $data .= substr($data, length($data) - $offset, $match_len); } else { foreach my $i (1 .. $match_len) { $data .= substr($data, length($data) - $offset, 1); } } } print $out_fh $data; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbw2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 September 2023 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(uniq); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBW2', VERSION => '0.01', FORMAT => 'lzbw2', COMPRESSED_BYTE => chr(1), UNCOMPRESSED_BYTE => chr(0), CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths_str = ''; my $matches_str = ''; my $uncompressed_str = ''; my @sizes; my @distances_block; open my $uc_fh, '>:raw', \$uncompressed_str; open my $len_fh, '>:raw', \$lengths_str; open my $match_fh, '>:raw', \$matches_str; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes); print $out_fh bwt_compress($uncompressed_str, sub($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); print $out_fh bwt_compress($lengths_str); print $out_fh bwt_compress($matches_str); my $ratio = uniq(@distances_block) / @distances_block * 100; say "Dist ratio: $ratio"; if ($ratio < 10) { print $out_fh COMPRESSED_BYTE; print $out_fh bwt_compress(symbols2string(\@distances_block)); } else { print $out_fh UNCOMPRESSED_BYTE; print $out_fh obh_encode(\@distances_block); } @sizes = (); @distances_block = (); open $uc_fh, '>:raw', \$uncompressed_str; open $len_fh, '>:raw', \$lengths_str; open $match_fh, '>:raw', \$matches_str; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$literals)); say "Est. ratio: ", $est_ratio, " (", scalar(@$literals), " uncompressed bytes)"; push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches)); print $uc_fh pack('C*', @$literals); print $len_fh pack('C*', @$lengths); print $match_fh pack('C*', @$matches); push @distances_block, @$distances; if (length($uncompressed_str) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh)}; my @uncompressed = unpack('C*', bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) })); my @lengths = unpack('C*', bwt_decompress($fh)); my @matches = unpack('C*', bwt_decompress($fh)); my @distances = @{(getc($fh) eq COMPRESSED_BYTE) ? bwt_decompress_symbolic($fh) : obh_decode($fh)}; while (@uncompressed) { my $literals_size = shift(@sizes) // die "decompression error"; my $distances_size = shift(@sizes) // die "decompression error"; my $lengths_size = shift(@sizes) // die "decompression error"; my $matches_size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size); my @lengths_chunk = splice(@lengths, 0, $lengths_size); my @matches_chunk = splice(@matches, 0, $matches_size); my @distances_chunk = splice(@distances, 0, $distances_size); scalar(@uncompressed_chunk) == $literals_size or die "decompression error"; scalar(@lengths_chunk) == $lengths_size or die "decompression error"; scalar(@matches_chunk) == $matches_size or die "decompression error"; scalar(@distances_chunk) == $distances_size or die "decompression error"; print $out_fh lz77_decode(\@uncompressed_chunk, \@distances_chunk, \@lengths_chunk, \@matches_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbw3_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 29 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Bzip2, with maximum distance limited to 255. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBW3', VERSION => '0.01', FORMAT => 'lzbw3', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(4); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); print $out_fh bwt_compress(symbols2string($uncompressed), sub($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); print $out_fh create_huffman_entry($lengths); print $out_fh bwt_compress(symbols2string($matches)); print $out_fh bwt_compress(symbols2string($distances)); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = bwt_decompress_symbolic($fh, sub($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) }); my $lengths = decode_huffman_entry($fh); my $matches = bwt_decompress_symbolic($fh); my $distances = bwt_decompress_symbolic($fh); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbw4_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 01 September 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + MRL + BWT + Huffman coding, using a maximum match distance of 255. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBW4', VERSION => '0.01', FORMAT => 'lzbw4', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = do { local $Compression::Util::LZ_MAX_DIST = 255; lz77_encode($chunk); }; my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh mrl_compress($uncompressed); print $out_fh fibonacci_encode($lengths); print $out_fh bwt_compress(symbols2string($matches)); print $out_fh bwt_compress(symbols2string($distances)); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = fibonacci_decode($fh); my $matches = bwt_decompress_symbolic($fh); my $distances = bwt_decompress_symbolic($fh); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbw5_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 04 September 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + MRL + Huffman coding. # Encoding the distances with BWT + Huffman coding and LZSS + MRL. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBW5', VERSION => '0.01', FORMAT => 'lzbw5', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = do { local $Compression::Util::LZ_MAX_DIST = (1 << 16) - 1; lz77_encode($chunk); }; my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh mrl_compress($uncompressed); print $out_fh fibonacci_encode($lengths); print $out_fh lzss_compress(symbols2string($matches)); my @byte0; my @byte1; foreach my $dist (@$distances) { push @byte0, $dist >> 8; push @byte1, $dist & 0xff; } print $out_fh bwt_compress(symbols2string(\@byte0)); print $out_fh lzss_compress(symbols2string(\@byte1), \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = fibonacci_decode($fh); my $matches = lzss_decompress_symbolic($fh); my $byte0 = bwt_decompress_symbolic($fh); my $byte1 = lzss_decompress_symbolic($fh, \&mrl_decompress_symbolic); my @distances; foreach my $i (0 .. $#$byte0) { push @distances, ($byte0->[$i] << 8) | $byte1->[$i]; } print $out_fh lz77_decode($uncompressed, \@distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbw_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 September 2023 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBW', VERSION => '0.01', FORMAT => 'lzbw', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths_str = ''; my $matches_str = ''; my $uncompressed_str = ''; my @sizes; my @distances_block; open my $uc_fh, '>:raw', \$uncompressed_str; open my $len_fh, '>:raw', \$lengths_str; open my $match_fh, '>:raw', \$matches_str; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes); print $out_fh bwt_compress($uncompressed_str); print $out_fh bwt_compress($lengths_str); print $out_fh bwt_compress($matches_str); print $out_fh bwt_compress(symbols2string(\@distances_block)); @sizes = (); @distances_block = (); open $uc_fh, '>:raw', \$uncompressed_str; open $len_fh, '>:raw', \$lengths_str; open $match_fh, '>:raw', \$matches_str; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$literals)); say "Est. ratio: ", $est_ratio, " (", scalar(@$literals), " uncompressed bytes)"; push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches)); print $uc_fh pack('C*', @$literals); print $len_fh pack('C*', @$lengths); print $match_fh pack('C*', @$matches); push @distances_block, @$distances; if (length($uncompressed_str) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh)}; my @uncompressed = unpack('C*', bwt_decompress($fh)); my @lengths = unpack('C*', bwt_decompress($fh)); my @matches = unpack('C*', bwt_decompress($fh)); my @distances = unpack('C*', bwt_decompress($fh)); while (@uncompressed) { my $literals_size = shift(@sizes) // die "decompression error"; my $distances_size = shift(@sizes) // die "decompression error"; my $lengths_size = shift(@sizes) // die "decompression error"; my $matches_size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size); my @lengths_chunk = splice(@lengths, 0, $lengths_size); my @matches_chunk = splice(@matches, 0, $matches_size); my @distances_chunk = splice(@distances, 0, $distances_size); scalar(@uncompressed_chunk) == $literals_size or die "decompression error"; scalar(@lengths_chunk) == $lengths_size or die "decompression error"; scalar(@matches_chunk) == $matches_size or die "decompression error"; scalar(@distances_chunk) == $distances_size or die "decompression error"; print $out_fh lz77_decode(\@uncompressed_chunk, \@distances_chunk, \@lengths_chunk, \@matches_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbwa_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 September 2023 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Arithmetic Coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBWA', VERSION => '0.01', FORMAT => 'lzbwa', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths_str = ''; my $matches_str = ''; my $uncompressed_str = ''; my @sizes; my @distances_block; open my $uc_fh, '>:raw', \$uncompressed_str; open my $len_fh, '>:raw', \$lengths_str; open my $match_fh, '>:raw', \$matches_str; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes); print $out_fh bwt_compress( $uncompressed_str, sub ($s) { lzss_compress_symbolic($s, sub ($s) { mrl_compress_symbolic($s, \&create_ac_entry) }); } ); print $out_fh bwt_compress($lengths_str, \&create_ac_entry); print $out_fh bwt_compress($matches_str, \&create_ac_entry); print $out_fh bwt_compress(symbols2string(\@distances_block), \&create_ac_entry); @sizes = (); @distances_block = (); open $uc_fh, '>:raw', \$uncompressed_str; open $len_fh, '>:raw', \$lengths_str; open $match_fh, '>:raw', \$matches_str; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$literals)); say "Est. ratio: ", $est_ratio, " (", scalar(@$literals), " uncompressed bytes)"; push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches)); print $uc_fh pack('C*', @$literals); print $len_fh pack('C*', @$lengths); print $match_fh pack('C*', @$matches); push @distances_block, @$distances; if (length($uncompressed_str) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh)}; my @uncompressed = unpack( 'C*', bwt_decompress( $fh, sub ($s) { lzss_decompress_symbolic($s, sub ($s) { mrl_decompress_symbolic($s, \&decode_ac_entry) }); } ) ); my @lengths = unpack('C*', bwt_decompress($fh, \&decode_ac_entry)); my @matches = unpack('C*', bwt_decompress($fh, \&decode_ac_entry)); my @distances = unpack('C*', bwt_decompress($fh, \&decode_ac_entry)); while (@uncompressed) { my $literals_size = shift(@sizes) // die "decompression error"; my $distances_size = shift(@sizes) // die "decompression error"; my $lengths_size = shift(@sizes) // die "decompression error"; my $matches_size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size); my @lengths_chunk = splice(@lengths, 0, $lengths_size); my @matches_chunk = splice(@matches, 0, $matches_size); my @distances_chunk = splice(@distances, 0, $distances_size); scalar(@uncompressed_chunk) == $literals_size or die "decompression error"; scalar(@lengths_chunk) == $lengths_size or die "decompression error"; scalar(@matches_chunk) == $matches_size or die "decompression error"; scalar(@distances_chunk) == $distances_size or die "decompression error"; print $out_fh lz77_decode(\@uncompressed_chunk, \@distances_chunk, \@lengths_chunk, \@matches_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbwad_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 September 2023 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Adaptive Arithmetic Coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBWAD', VERSION => '0.01', FORMAT => 'lzbwad', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths_str = ''; my $matches_str = ''; my $uncompressed_str = ''; my @sizes; my @distances_block; open my $uc_fh, '>:raw', \$uncompressed_str; open my $len_fh, '>:raw', \$lengths_str; open my $match_fh, '>:raw', \$matches_str; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes); print $out_fh bwt_compress( $uncompressed_str, sub ($s) { lzss_compress_symbolic($s, sub ($s) { mrl_compress_symbolic($s, \&create_adaptive_ac_entry) }); } ); print $out_fh bwt_compress($lengths_str, \&create_adaptive_ac_entry); print $out_fh bwt_compress($matches_str, \&create_adaptive_ac_entry); print $out_fh bwt_compress(symbols2string(\@distances_block), \&create_adaptive_ac_entry); @sizes = (); @distances_block = (); open $uc_fh, '>:raw', \$uncompressed_str; open $len_fh, '>:raw', \$lengths_str; open $match_fh, '>:raw', \$matches_str; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$literals)); say "Est. ratio: ", $est_ratio, " (", scalar(@$literals), " uncompressed bytes)"; push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches)); print $uc_fh pack('C*', @$literals); print $len_fh pack('C*', @$lengths); print $match_fh pack('C*', @$matches); push @distances_block, @$distances; if (length($uncompressed_str) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh)}; my @uncompressed = unpack( 'C*', bwt_decompress( $fh, sub ($s) { lzss_decompress_symbolic($s, sub ($s) { mrl_decompress_symbolic($s, \&decode_adaptive_ac_entry) }); } ) ); my @lengths = unpack('C*', bwt_decompress($fh, \&decode_adaptive_ac_entry)); my @matches = unpack('C*', bwt_decompress($fh, \&decode_adaptive_ac_entry)); my @distances = unpack('C*', bwt_decompress($fh, \&decode_adaptive_ac_entry)); while (@uncompressed) { my $literals_size = shift(@sizes) // die "decompression error"; my $distances_size = shift(@sizes) // die "decompression error"; my $lengths_size = shift(@sizes) // die "decompression error"; my $matches_size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size); my @lengths_chunk = splice(@lengths, 0, $lengths_size); my @matches_chunk = splice(@matches, 0, $matches_size); my @distances_chunk = splice(@distances, 0, $distances_size); scalar(@uncompressed_chunk) == $literals_size or die "decompression error"; scalar(@lengths_chunk) == $lengths_size or die "decompression error"; scalar(@matches_chunk) == $matches_size or die "decompression error"; scalar(@distances_chunk) == $distances_size or die "decompression error"; print $out_fh lz77_decode(\@uncompressed_chunk, \@distances_chunk, \@lengths_chunk, \@matches_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbwd_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 07 September 2023 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBWD', VERSION => '0.01', FORMAT => 'lzbwd', CHUNK_SIZE => 1 << 16, # higher value = better compression MAX_INT => oct('0b' . ('1' x 32)), }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub encode_integers ($integers) { my @symbols; my $offset_bits = ''; foreach my $dist (@$integers) { foreach my $i (0 .. $#DISTANCE_SYMBOLS) { if ($DISTANCE_SYMBOLS[$i][0] > $dist) { push @symbols, $i - 1; if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) { $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]); } last; } } } return (pack('C*', @symbols), pack('B*', $offset_bits)); } sub decode_integers ($symbols, $fh) { my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths_str = ''; my $matches_str = ''; my $uncompressed_str = ''; my @sizes; my @distances_chunk; open my $uc_fh, '>:raw', \$uncompressed_str; open my $len_fh, '>:raw', \$lengths_str; open my $match_fh, '>:raw', \$matches_str; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes); print $out_fh bwt_compress($uncompressed_str, sub($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); print $out_fh bwt_compress($lengths_str); print $out_fh bwt_compress($matches_str); print $out_fh bwt_compress(symbols2string(\@distances_chunk)); @sizes = (); @distances_chunk = (); open $uc_fh, '>:raw', \$uncompressed_str; open $len_fh, '>:raw', \$lengths_str; open $match_fh, '>:raw', \$matches_str; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$literals)); say "Est. ratio: ", $est_ratio, " (", scalar(@$literals), " uncompressed bytes)"; push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches)); print $uc_fh pack('C*', @$literals); print $len_fh pack('C*', @$lengths); print $match_fh pack('C*', @$matches); push @distances_chunk, @$distances; if (length($uncompressed_str) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh)}; my @uncompressed = unpack('C*', bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) })); my @lengths = unpack('C*', bwt_decompress($fh)); my @matches = unpack('C*', bwt_decompress($fh)); my @distances = unpack('C*', bwt_decompress($fh)); while (@uncompressed) { my $literals_size = shift(@sizes) // die "decompression error"; my $distances_size = shift(@sizes) // die "decompression error"; my $lengths_size = shift(@sizes) // die "decompression error"; my $matches_size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size); my @lengths_chunk = splice(@lengths, 0, $lengths_size); my @matches_chunk = splice(@matches, 0, $matches_size); my @distances_chunk = splice(@distances, 0, $distances_size); scalar(@uncompressed_chunk) == $literals_size or die "decompression error"; scalar(@lengths_chunk) == $lengths_size or die "decompression error"; scalar(@matches_chunk) == $matches_size or die "decompression error"; scalar(@distances_chunk) == $distances_size or die "decompression error"; print $out_fh lz77_decode(\@uncompressed_chunk, \@distances_chunk, \@lengths_chunk, \@matches_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbwh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 07 September 2023 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBWH', VERSION => '0.01', FORMAT => 'lzbwh', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths_str = ''; my $matches_str = ''; my $uncompressed_str = ''; my @sizes; my @distances_block; open my $uc_fh, '>:raw', \$uncompressed_str; open my $len_fh, '>:raw', \$lengths_str; open my $match_fh, '>:raw', \$matches_str; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes); print $out_fh bwt_compress($uncompressed_str, sub ($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); print $out_fh bwt_compress($lengths_str); print $out_fh bwt_compress($matches_str); print $out_fh bwt_compress(symbols2string(\@distances_block)); @sizes = (); @distances_block = (); open $uc_fh, '>:raw', \$uncompressed_str; open $len_fh, '>:raw', \$lengths_str; open $match_fh, '>:raw', \$matches_str; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MAX_DIST = 255; my ($literals, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$literals)); say "Est. ratio: ", $est_ratio, " (", scalar(@$literals), " uncompressed bytes)"; push(@sizes, scalar(@$literals), scalar(@$distances), scalar(@$lengths), scalar(@$matches)); print $uc_fh pack('C*', @$literals); print $len_fh pack('C*', @$lengths); print $match_fh pack('C*', @$matches); push @distances_block, @$distances; if (length($uncompressed_str) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh)}; my @uncompressed = unpack('C*', bwt_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) })); my @lengths = unpack('C*', bwt_decompress($fh)); my @matches = unpack('C*', bwt_decompress($fh)); my @distances = unpack('C*', bwt_decompress($fh)); while (@uncompressed) { my $literals_size = shift(@sizes) // die "decompression error"; my $distances_size = shift(@sizes) // die "decompression error"; my $lengths_size = shift(@sizes) // die "decompression error"; my $matches_size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $literals_size); my @lengths_chunk = splice(@lengths, 0, $lengths_size); my @matches_chunk = splice(@matches, 0, $matches_size); my @distances_chunk = splice(@distances, 0, $distances_size); scalar(@uncompressed_chunk) == $literals_size or die "decompression error"; scalar(@lengths_chunk) == $lengths_size or die "decompression error"; scalar(@matches_chunk) == $matches_size or die "decompression error"; scalar(@distances_chunk) == $distances_size or die "decompression error"; print $out_fh lz77_decode(\@uncompressed_chunk, \@distances_chunk, \@lengths_chunk, \@matches_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzbws_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 25 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + symbolic Bzip2 (MRL variant). use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZBWS', VERSION => '0.01', FORMAT => 'lzbws', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lz77_compress($chunk, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lz77_decompress($fh, \&mrl_decompress_symbolic); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzhd2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 01 September 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + MRL + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach + MRL compression. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZHD2', VERSION => '0.01', FORMAT => 'lzhd2', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh mrl_compress($uncompressed); print $out_fh fibonacci_encode($lengths); print $out_fh lzss_compress(symbols2string($matches)); print $out_fh obh_encode($distances, \&mrl_compress); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = fibonacci_decode($fh); my $matches = lzss_decompress_symbolic($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzhd_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZHD', VERSION => '0.02', FORMAT => 'lzhd', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh mrl_compress_symbolic($uncompressed); print $out_fh fibonacci_encode($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = fibonacci_decode($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzih_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 13 June 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Huffman coding. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZIH', VERSION => '0.04', FORMAT => 'lzih', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(4); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh mrl_compress_symbolic($uncompressed); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh abc_encode($distances); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = abc_decode($fh); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzmrl2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 25 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Move to front + RLE + Huffman coding. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZMRL2', VERSION => '0.01', FORMAT => 'lzmrl2', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($uncompressed, $distances, $lengths, $matches) = lz77_encode($chunk); my $est_ratio = length($chunk) / (4 * scalar(@$uncompressed)); say(scalar(@$uncompressed), ' -> ', $est_ratio); print $out_fh mrl_compress_symbolic($uncompressed); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = mrl_decompress_symbolic($fh); my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); print $out_fh lz77_decode($uncompressed, $distances, $lengths, $matches); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzmrl_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 23 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Move-to-front + RLE + Huffman coding. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZMRL', VERSION => '0.01', FORMAT => 'lzmrl', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lz77_compress($chunk, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lz77_decompress($fh, \&mrl_decompress_symbolic); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzop_file_compression.pl ================================================ #!/usr/bin/perl # Compress files using Lzop. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use IO::Compress::Lzop qw(lzop); use IO::Uncompress::UnLzop qw(unlzop); use constant { PKGNAME => 'LZOP', VERSION => '0.01', FORMAT => 'lzo', }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data lzop($fh, $out_fh) or die "compression error"; # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; unlzop($fh, $out_fh) or die "decompression error"; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzsbw_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 11 April 2024 # https://github.com/trizen # Compress/decompress files using LZSS + Bzip2 (MRL variant). use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZSBW', VERSION => '0.01', FORMAT => 'lzsbw', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($literals, $distances, $lengths) = lzss_encode($chunk); my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances)); say scalar(@$literals), ' -> ', $est_ratio; print $out_fh deflate_encode($literals, $distances, $lengths, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($literals, $distances, $lengths) = deflate_decode($fh, \&mrl_decompress_symbolic); print $out_fh lzss_decode($literals, $distances, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzss2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 23 July 2024 # https://github.com/trizen # Compress/decompress files using two rounds of LZ77 compression (LZSS variant). # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZSSM', VERSION => '0.01', FORMAT => 'lzssm', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzss_compress($chunk, sub($s) { lzss_compress_symbolic($s, \&mrl_compress_symbolic) }); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzss_decompress($fh, sub($s) { lzss_decompress_symbolic($s, \&mrl_decompress_symbolic) }); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzss77_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 23 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant) + LZ77 compression. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZSSM', VERSION => '0.01', FORMAT => 'lzssm', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzss_compress($chunk, sub($s) { lz77_compress_symbolic($s, \&mrl_compress_symbolic) }); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzss_decompress($fh, sub($s) { lz77_decompress_symbolic($s, \&mrl_decompress_symbolic) }); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 21 March 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZSS', VERSION => '0.01', FORMAT => 'lzss', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzss_compress($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzss_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzssf_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 21 March 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables -- fast version) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZSSF', VERSION => '0.01', FORMAT => 'lzssf', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 5; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzss_compress($chunk, \&create_huffman_entry, \&lzss_encode_fast); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzss_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzssm_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 23 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant) + Move-to-front + RLE + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZSSM', VERSION => '0.01', FORMAT => 'lzssm', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzss_compress($chunk, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzss_decompress($fh, \&mrl_decompress_symbolic); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/lzw_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 08 December 2022 # Edit: 15 June 2023 # https://github.com/trizen # Compress/decompress files using LZW compression. # See also: # https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'LZW', VERSION => '0.03', FORMAT => 'lzw', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(3); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzw_compress($chunk); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh lzw_decompress($fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mblz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 31 July 2024 # https://github.com/trizen # Compress/decompress files using Move-to-front + Adaptive Binary Coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'MBLZ', VERSION => '0.01', FORMAT => 'mblz', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 8 * 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = unpack('B*', mrl_compress_symbolic(string2symbols($chunk))); my ($uncompressed, $lengths, $matches, $distances) = lz77_encode($bits); my $ubits = pack('C*', @$uncompressed); my $rem = length($ubits) % 8; my $str = pack('B*', $ubits); print $out_fh chr($rem); print $out_fh bwt_compress($str); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $rem = ord getc $fh; my $str = bwt_decompress($fh); my $ubits = unpack('B*', $str); if ($rem != 0) { $ubits = substr($ubits, 0, -(8 - $rem)); } my $uncompressed = [unpack('C*', $ubits)]; my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $bits = lz77_decode($uncompressed, $lengths, $matches, $distances); print $out_fh symbols2string(mrl_decompress_symbolic(pack('B*', $bits))); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mbwr_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 13 April 2024 # https://github.com/trizen # Compress/decompress files using Move-to-Front Transform (MTF) + Burrows-Wheeler Transform (BWT) + Run-length encoding (RLE) + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'MBWR', VERSION => '0.01', FORMAT => 'mbwr', CHUNK_SIZE => 1 << 17, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($chunk, $out_fh) { my ($mtf, $alphabet) = mtf_encode($chunk); print $out_fh encode_alphabet($alphabet); print $out_fh bwt_compress(symbols2string($mtf)); } sub decompression ($fh, $out_fh) { my $alphabet = decode_alphabet($fh); my $mtf = string2symbols(bwt_decompress($fh)); my $data = mtf_decode($mtf, $alphabet); print $out_fh symbols2string($data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mrl_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 August 2024 # https://github.com/trizen # Compress/decompress files using Move-to-front + RLE + Huffman coding. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'MRL', VERSION => '0.01', FORMAT => 'mrl', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh mrl_compress($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh mrl_decompress($fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mybzip2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Edit: 21 August 2024 # https://github.com/trizen # Compress/decompress files using Bzip2 from Compression::Util. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use IO::Uncompress::Bunzip2 qw(bunzip2); use constant { PKGNAME => 'BZIP2', VERSION => '0.01', FORMAT => 'bz2', }; sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh bzip2_compress($fh); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $enc = do { local $/; <$fh>; }; my $dec = bzip2_decompress($enc); bunzip2(\$enc, \my $dec2) or die "decompression error"; if ($dec ne $dec2) { die "Failed to decompress correctly"; } print $out_fh $dec; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mygzip_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Edit: 22 August 2024 # https://github.com/trizen # Compress/decompress files using GZIP from Compression::Util. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use IO::Uncompress::Gunzip qw(gunzip); use constant { PKGNAME => 'GZIP', VERSION => '0.01', FORMAT => 'gz', }; sub usage($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh gzip_compress($fh); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $enc = do { local $/; <$fh>; }; my $dec = gzip_decompress($enc); gunzip(\$enc, \my $dec2) or die "decompression error"; if ($dec ne $dec2) { die "Failed to decompress correctly"; } print $out_fh $dec; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mygzipf_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Edit: 22 August 2024 # https://github.com/trizen # Compress/decompress files using Gzip from Compression::Util. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use IO::Uncompress::Gunzip qw(gunzip); use constant { PKGNAME => 'GZIP', VERSION => '0.01', FORMAT => 'gz', }; sub usage($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh gzip_compress($fh, \&lzss_encode_fast); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $enc = do { local $/; <$fh>; }; my $dec = gzip_decompress($enc); gunzip(\$enc, \my $dec2) or die "decompression error"; if ($dec ne $dec2) { die "Failed to decompress correctly"; } print $out_fh $dec; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mylz4_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Edit: 25 August 2024 # https://github.com/trizen # Compress/decompress files using LZ4 from Compression::Util. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use Compress::LZ4Frame qw(); use constant { PKGNAME => 'LZ4', VERSION => '0.01', FORMAT => 'lz4', }; sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh lz4_compress($fh); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $enc = do { local $/; <$fh>; }; my $dec = lz4_decompress($enc); my $dec2 = Compress::LZ4Frame::decompress($enc); if ($dec ne $dec2) { die "Decompression error"; } print $out_fh $dec; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/mylz4f_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Edit: 25 August 2024 # https://github.com/trizen # Compress/decompress files using LZ4 from Compression::Util (with fast LZ-parsing). # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use Compress::LZ4Frame qw(); use constant { PKGNAME => 'LZ4', VERSION => '0.01', FORMAT => 'lz4', }; sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh lz4_compress($fh, \&lzss_encode_fast); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $enc = do { local $/; <$fh>; }; my $dec = lz4_decompress($enc); my $dec2 = Compress::LZ4Frame::decompress($enc); if ($dec ne $dec2) { die "Decompression error"; } print $out_fh $dec; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/myzlib_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Edit: 06 November 2024 # https://github.com/trizen # Compress/decompress files using ZLIB from Compression::Util. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use Compress::Zlib qw(); use constant { PKGNAME => 'ZLIB', VERSION => '0.01', FORMAT => 'zlib', }; sub usage($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh zlib_compress($fh); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $enc = do { local $/; <$fh>; }; my $dec = zlib_decompress($enc); my $dec2 = Compress::Zlib::uncompress($enc); if ($dec ne $dec2) { die "Failed to decompress correctly"; } print $out_fh $dec; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/rablz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 31 July 2024 # https://github.com/trizen # Compress/decompress files using RLE4 + Adaptive Binary Coding, followed by LZ77 compression (LZ4-like) on bits + Bzip2 on the literals. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'RABLZ', VERSION => '0.01', FORMAT => 'rablz', CHUNK_SIZE => 1 << 18, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = unpack('B*', abc_encode(rle4_encode(string2symbols($chunk)))); my ($uncompressed, $distances, $lengths, $matches) = do { local $Compression::Util::LZ_MIN_LEN = 8 * 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression lz77_encode($bits); }; my $ubits = pack('C*', @$uncompressed); my $rem = length($ubits) % 8; my $str = pack('B*', $ubits); print $out_fh chr($rem); print $out_fh mrl_compress_symbolic($str, \&lzss_compress_symbolic); print $out_fh create_huffman_entry($lengths); print $out_fh create_huffman_entry($matches); print $out_fh obh_encode($distances, \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $rem = ord getc $fh; my $str = symbols2string(mrl_decompress_symbolic($fh, \&lzss_decompress_symbolic)); my $ubits = unpack('B*', $str); if ($rem != 0) { $ubits = substr($ubits, 0, -(8 - $rem)); } my $uncompressed = [unpack('C*', $ubits)]; my $lengths = decode_huffman_entry($fh); my $matches = decode_huffman_entry($fh); my $distances = obh_decode($fh, \&mrl_decompress_symbolic); my $bits = lz77_decode($uncompressed, $distances, $lengths, $matches); print $out_fh symbols2string(rle4_decode(abc_decode(pack('B*', $bits)))); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/rlzss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 25 July 2024 # https://github.com/trizen # Compress/decompress files using RLE4 + LZ77 compression (LZSS variant) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use constant { PKGNAME => 'RLZSS', VERSION => '0.01', FORMAT => 'rlzss', CHUNK_SIZE => 1 << 18, # higher value = better compression }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = 1 << 15; # maximum match length local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # higher value = better compression # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh lzss_compress(symbols2string(rle4_encode($chunk)), \&mrl_compress_symbolic); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh symbols2string(rle4_decode(lzss_decompress($fh, \&mrl_decompress_symbolic))); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/sbwt_file_compression.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 09 November 2024 # https://github.com/trizen # Compress/decompress files using SWAP transform + LZB + Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compression::Util qw(:all); use POSIX qw(ceil); use constant { PKGNAME => 'SBWT', VERSION => '0.01', FORMAT => 'sbwt', CHUNK_SIZE => 1 << 17, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub swap_transform ($text, $extra = 1) { my @bits; my @arr = unpack('C*', $text); my $k = 0; foreach my $i (1 .. $#arr) { if ($arr[$i] < $arr[$i - 1 - $k]) { push @bits, 1; unshift @arr, splice(@arr, $i, 1); ++$k if $extra; } else { push @bits, 0; } } return (pack('C*', @arr), \@bits); } sub reverse_swap_transform ($text, $bits) { my @arr = unpack('C*', $text); for (my $i = $#arr ; $i >= 0 ; --$i) { if ($bits->[$i - 1] == 1) { splice(@arr, $i, 0, shift(@arr)); } } pack('C*', @arr); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { local $Compression::Util::LZ_MIN_LEN = 512; my ($t, $bits) = swap_transform(lzb_compress($chunk, \&lzss_encode_fast), 0); my $vrle_bits = binary_vrl_encode(join('', @$bits)); if (length($vrle_bits) < scalar @$bits) { say STDERR "With VLRE: ", length($vrle_bits), " < ", scalar(@$bits); print $out_fh chr(1); } else { say STDERR "Without VRLE: ", length($vrle_bits), " > ", scalar(@$bits); $vrle_bits = join('', @$bits); print $out_fh chr(0); } print $out_fh pack('N', length $vrle_bits); my ($bwt, $idx) = bwt_encode($t); print $out_fh pack('B*', $vrle_bits); my ($mtf, $alphabet) = mtf_encode(string2symbols($bwt)); my $rle = zrle_encode($mtf); print $out_fh (pack('N', $idx) . encode_alphabet($alphabet) . create_huffman_entry($rle)); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $with_vrle = ord(getc($fh)); my $bits_len = bytes2int($fh, 4); my $bits = read_bits($fh, $bits_len); $bits = binary_vrl_decode($bits) if $with_vrle; my $idx = bytes2int($fh, 4); my $alphabet = decode_alphabet($fh); my $rle = decode_huffman_entry($fh); my $mtf = zrle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $data = bwt_decode(pack('C*', @$bwt), $idx); print $out_fh lzb_decompress(reverse_swap_transform($data, [split(//, $bits)])); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/xz_file_compression.pl ================================================ #!/usr/bin/perl # Compress files using XZ/LZMA. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use IO::Compress::Xz qw(xz); use IO::Uncompress::UnXz qw(unxz); use constant { PKGNAME => 'XZ', VERSION => '0.01', FORMAT => 'xz', }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data xz($fh, $out_fh) or die "compression error"; # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; unxz($fh, $out_fh) or die "decompression error"; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/zlib_file_compression.pl ================================================ #!/usr/bin/perl # Compress files using Gzip. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Compress::Zlib qw(compress uncompress); use File::Slurper qw(read_binary); use constant { PKGNAME => 'ZLIB', VERSION => '0.01', FORMAT => 'zlib', }; sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data print $out_fh compress(read_binary($input)); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh uncompress(read_binary($input)); close $out_fh; } main(); exit(0); ================================================ FILE: Compression/High-level/zstd_file_compression.pl ================================================ #!/usr/bin/perl # Compress files using Zstandard. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use IO::Compress::Zstd qw(zstd); use IO::Uncompress::UnZstd qw(unzstd); use constant { PKGNAME => 'ZSTD', VERSION => '0.01', FORMAT => 'zst', }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Compress data zstd($fh, $out_fh) or die "compression error"; # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; unzstd($fh, $out_fh) or die "decompression error"; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bbwr_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Binary Burrows-Wheeler Transform (BWT) + Binary Variable Run-Length Encoding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Data Compression (Summer 2023) - Lecture 5 - Basic Techniques # https://youtube.com/watch?v=TdFWb8mL5Gk use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BBWR', VERSION => '0.02', FORMAT => 'bbwr', CHUNK_SIZE => 1 << 13, # larger values == better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub binary_vrl_encoding ($str) { my @bits = split(//, $str); my $bitstring = $bits[0]; foreach my $rle (@{run_length(\@bits)}) { my ($c, $v) = @$rle; if ($v == 1) { $bitstring .= '0'; } else { my $t = sprintf('%b', $v - 1); $bitstring .= join('', '1' x length($t), '0', substr($t, 1)); } } return $bitstring; } sub binary_vrl_decoding ($bitstring) { my $decoded = ''; my $bit = substr($bitstring, 0, 1, ''); while ($bitstring ne '') { $decoded .= $bit; my $bl = 0; while (substr($bitstring, 0, 1, '') eq '1') { ++$bl; } if ($bl > 0) { $decoded .= $bit x oct('0b1' . join('', map { substr($bitstring, 0, 1, '') } 1 .. $bl - 1)); } $bit = ($bit eq '1' ? '0' : '1'); } return $decoded; } sub compression ($chunk, $out_fh) { my $bits = unpack('B*', $chunk); my $vrle1 = binary_vrl_encoding($bits); if (length($vrle1) < length($bits)) { printf "Doing early VLR, saving %s bits\n", length($bits) - length($vrle1); print $out_fh chr(1); } else { print $out_fh chr(0); $vrle1 = $bits; } my ($bwt, $idx) = bwt_encode($vrle1); my $vrle2 = binary_vrl_encoding($bwt); say "BWT index: $idx"; print $out_fh pack('N', $idx); print $out_fh pack('N', length($vrle2)); print $out_fh pack('B*', $vrle2); } sub decompression ($fh, $out_fh) { my $compressed_byte = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $bits_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "BWT index = $idx"; my $bwt = binary_vrl_decoding(read_bits($fh, $bits_len)); my $data = bwt_decode($bwt, $idx); if ($compressed_byte == 1) { $data = binary_vrl_decoding($data); } print $out_fh pack('B*', $data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bqof_file_compression.pl ================================================ #!/usr/bin/perl # A general purpose lossless compressor, based on ideas from the QOI compressor. (+BWT) # See also: # https://qoiformat.org/ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(max); use Getopt::Std qw(getopts); binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); use constant { PKGNAME => 'BQOF', FORMAT => 'bqof', VERSION => '0.01', CHUNK_SIZE => 1 << 17, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub qof_encoder ($string) { use constant { QOI_OP_RGB => 0b1111_1110, QOI_OP_DIFF => 0b01_000_000, QOI_OP_RUN => 0b11_000_000, QOI_OP_LUMA => 0b10_000_000, }; my $run = 0; my $px = 0; my $prev_px = -1; my $rle4 = rle4_encode(string2symbols($string)); my ($bwt, $idx) = bwt_encode(symbols2string($rle4)); my @bytes; my @table = (0) x 64; my @chars = unpack('C*', $bwt); push @bytes, unpack('C*', pack('N', $idx)); while (@chars) { $px = shift(@chars); if ($px == $prev_px) { if (++$run == 62) { push @bytes, QOI_OP_RUN | ($run - 1); $run = 0; } } else { if ($run > 0) { push @bytes, (QOI_OP_RUN | ($run - 1)); $run = 0; } my $hash = $px % 64; my $index_px = $table[$hash]; if ($px == $index_px) { push @bytes, $hash; } else { $table[$hash] = $px; my $diff = $px - $prev_px; if ($diff > -33 and $diff < 32) { push(@bytes, QOI_OP_DIFF | ($diff + 32)); } else { push(@bytes, QOI_OP_RGB, $px); } } } $prev_px = $px; } if ($run > 0) { push(@bytes, QOI_OP_RUN | ($run - 1)); } create_huffman_entry(\@bytes); } sub qof_decoder ($fh) { use constant { QOI_OP_RGB => 0b1111_1110, QOI_OP_DIFF => 0b01_000_000, QOI_OP_RUN => 0b11_000_000, QOI_OP_LUMA => 0b10_000_000, QOI_OP_INDEX => 0b00_000_000, }; my $run = 0; my $px = -1; my @bytes; my @table = ((0) x 64); my $index = 0; my @symbols = @{decode_huffman_entry($fh)}; my $idx = unpack('N', pack('C*', map { $symbols[$index++] } 1 .. 4)); while (1) { if ($run > 0) { --$run; } else { my $byte = $symbols[$index++] // last; if ($byte == QOI_OP_RGB) { # OP RGB $px = $symbols[$index++]; } elsif (($byte >> 6) == (QOI_OP_INDEX >> 6)) { # OP INDEX $px = $table[$byte]; } elsif (($byte >> 6) == (QOI_OP_DIFF >> 6)) { # OP DIFF $px += ($byte & 0b00_111_111) - 32; } elsif (($byte >> 6) == (QOI_OP_RUN >> 6)) { # OP RUN $run = ($byte & 0b00_111_111); } $table[$px % 64] = $px; } push @bytes, $px; } my $bwt = pack('C*', @bytes); my $rle4 = string2symbols(bwt_decode($bwt, $idx)); return symbols2string(rle4_decode($rle4)); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh qof_encoder($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh qof_decoder($fh); } # Close the file close $fh; close $out_fh; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } main(); exit(0); ================================================ FILE: Compression/bwac_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 06 February 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Arithmetic Coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWAC', VERSION => '0.02', FORMAT => 'bwac', # BWT settings CHUNK_SIZE => 1 << 17, LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; say "Max symbol: $max_symbol\n"; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len\n"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_ac_entry($rle, $out_fh); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_ac_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwad_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 06 February 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Adaptive Arithmetic Coding (in fixed bits). # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWAD', VERSION => '0.02', FORMAT => 'bwad', CHUNK_SIZE => 1 << 17, LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); use constant INITIAL_FREQ => 1; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub _create_adaptive_cfreq ($freq_value, $max_symbol) { my $T = 0; my (@cf, @freq); foreach my $i (0 .. $max_symbol) { $freq[$i] = $freq_value; $cf[$i] = $T; $T += $freq_value; $cf[$i + 1] = $T; } return (\@freq, \@cf, $T); } sub increment_freq ($c, $max_symbol, $freq, $cf) { ++$freq->[$c]; my $T = $cf->[$c]; foreach my $i ($c .. $max_symbol) { $cf->[$i] = $T; $T += $freq->[$i]; $cf->[$i + 1] = $T; } return $T; } sub adaptive_ac_encode ($bytes_arr) { my $enc = ''; my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1); my $max_symbol = max(@bytes) // 0; my ($freq, $cf, $T) = _create_adaptive_cfreq(INITIAL_FREQ, $max_symbol); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; $T = increment_freq($c, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, $max_symbol); } sub adaptive_ac_decode ($fh, $max_symbol) { my ($freq, $cf, $T) = _create_adaptive_cfreq(INITIAL_FREQ, $max_symbol); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); while (1) { my $w = ($high + 1) - $low; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = 0; foreach my $j (0 .. $max_symbol) { if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) { $i = $j; last; } } last if ($i == $max_symbol); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; $T = increment_freq($i, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: ($high > ${\MAX})"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_adaptive_ac_entry ($bytes, $out_fh) { my ($enc, $max_symbol) = adaptive_ac_encode($bytes); say "Max symbol: $max_symbol\n"; print $out_fh delta_encode([$max_symbol, length($enc)], 1); print $out_fh pack("B*", $enc); } sub decode_adaptive_ac_entry ($fh) { my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)}; say "Encoded length: $enc_len\n"; if ($enc_len > 0) { my $bits = read_bits($fh, $enc_len); open my $bits_fh, '<:raw', \$bits; return adaptive_ac_decode($bits_fh, $max_symbol); } return []; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_adaptive_ac_entry($rle, $out_fh); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_adaptive_ac_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwaz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 14 July 2023 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Arithmetic Coding (big-integer version). # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(sum max uniq); use Math::GMPz; use constant { PKGNAME => 'BWAZ', VERSION => '0.01', FORMAT => 'bwaz', CHUNK_SIZE => 1 << 16, LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub cumulative_freq ($freq) { my %cf; my $total = 0; foreach my $c (sort { $a <=> $b } keys %$freq) { $cf{$c} = $total; $total += $freq->{$c}; } return %cf; } sub ac_encode ($bytes_arr) { my @chars = @$bytes_arr; # The frequency characters my %freq; ++$freq{$_} for @chars; # Create the cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = Math::GMPz->new(scalar @chars); # Lower bound my $L = Math::GMPz->new(0); # Product of all frequencies my $pf = Math::GMPz->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { Math::GMPz::Rmpz_mul($L, $L, $base); Math::GMPz::Rmpz_addmul_ui($L, $pf, $cf{$c}); Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c}); } # Upper bound Math::GMPz::Rmpz_add($L, $L, $pf); # Compute the power for left shift my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1; # Set $enc to (U-1) divided by 2^pow Math::GMPz::Rmpz_sub_ui($L, $L, 1); Math::GMPz::Rmpz_div_2exp($L, $L, $pow); # Remove any divisibility by 2 if ($L > 0 and Math::GMPz::Rmpz_even_p($L)) { $pow += Math::GMPz::Rmpz_remove($L, $L, Math::GMPz->new(2)); } my $bin = Math::GMPz::Rmpz_get_str($L, 2); return ($bin, $pow, \%freq); } sub ac_decode ($bits, $pow2, $freq) { # Decode the bits into an integer my $enc = Math::GMPz->new($bits, 2); Math::GMPz::Rmpz_mul_2exp($enc, $enc, $pow2); my $base = sum(values %$freq) // 0; if ($base == 0) { return []; } elsif ($base == 1) { return [keys %$freq]; } # Create the cumulative frequency table my %cf = cumulative_freq($freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } my $div = Math::GMPz::Rmpz_init(); my @dec; # Decode the input number for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) { Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow); my $c = $dict{$div}; my $fv = $freq->{$c}; my $cv = $cf{$c}; Math::GMPz::Rmpz_submul_ui($enc, $pow, $cv); Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv); push @dec, $c; } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $pow, $freq) = ac_encode($bytes); my @freqs; my $max_symbol = max(keys %$freq) // 0; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, $pow; push @freqs, length($enc); say "Max symbol: $max_symbol\n"; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my $pow2 = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len\n"; my $bits = read_bits($fh, $bits_len); if ($bits_len > 0) { return ac_decode($bits, $pow2, \%freq); } return []; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_ac_entry($rle, $out_fh); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_ac_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlz2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression + Symbolic Bzip2. # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use POSIX qw(ceil log2); use constant { PKGNAME => 'BWLZ2', VERSION => '0.01', FORMAT => 'bwlz2', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub encode_alphabet_symbolic ($alphabet) { return delta_encode([@$alphabet]); } sub decode_alphabet_symbolic ($fh) { return delta_decode($fh); } sub bz2_compression_symbolic ($symbols, $out_fh) { my ($bwt, $idx) = bwt_encode_symbolic($symbols); say "BWT index = $idx"; my @bytes = @$bwt; my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet_symbolic(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression_symbolic ($fh) { my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet_symbolic($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $data = bwt_decode_symbolic($bwt, $idx); return $data; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } bz2_compression_symbolic(\@len_symbols, $out_fh); bz2_compression_symbolic(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = bz2_decompression_symbolic($fh); my $dist_symbols = bz2_decompression_symbolic($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort_symbolic ($s) { # O(n) space (slowish) my @cyclic = @$s; my $len = scalar(@cyclic); my $rle = 1; foreach my $i (1 .. $len - 1) { if ($cyclic[$i] != $cyclic[$i - 1]) { $rle = 0; last; } } $rle && return [0 .. $len - 1]; [ sort { my ($i, $j) = ($a, $b); while ($cyclic[$i] == $cyclic[$j]) { $i %= $len if (++$i >= $len); $j %= $len if (++$j >= $len); } $cyclic[$i] <=> $cyclic[$j]; } 0 .. $len - 1 ]; } sub bwt_encode_symbolic ($s) { my $bwt = bwt_sort_symbolic($s); my @ret = map { $s->[$_ - 1] } @$bwt; my $idx = 0; foreach my $i (@$bwt) { $i || last; ++$idx; } return (\@ret, $idx); } sub bwt_decode_symbolic ($bwt, $idx) { # fast inversion my @tail = @$bwt; my @head = sort { $a <=> $b } @tail; my @indices; foreach my $i (0 .. $#tail) { push @{$indices[$tail[$i]]}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices[$v]}); } my @dec; my $i = $idx; for (1 .. scalar(@head)) { push @dec, $head[$i]; $i = $table[$i]; } return \@dec; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub lzss_compression ($chunk, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say "\nEst. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub lzss_decompression ($fh) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); lz77_decompression($uncompressed, $indices, $lengths); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = rle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzss_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $bytes = [unpack('C*', lzss_decompression($fh))]; if ($rle_encoded) { $bytes = rle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 20 June 2023 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use POSIX qw(ceil log2); use constant { PKGNAME => 'BWLZ', VERSION => '0.05', FORMAT => 'bwlz', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(5); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub lzss_compression ($data, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($data, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($data) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say "\nEst. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub lzss_decompression ($fh) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); lz77_decompression($uncompressed, $indices, $lengths); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = rle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzss_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $dec = lzss_decompression($fh); my $bytes = [unpack('C*', $dec)]; if ($rle_encoded) { $bytes = rle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlza2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZHD variant) + Arithmetic Coding (in fixed bits). # Encoding the distances using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq sum); use constant { PKGNAME => 'BWLZA2', VERSION => '0.01', FORMAT => 'bwlza2', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]); $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; say "Max symbol: $max_symbol"; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub encode_distances ($distances, $out_fh) { my @symbols; my $offset_bits = ''; foreach my $dist (@$distances) { my $i = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; push @symbols, $i; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } create_ac_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub decode_distances ($fh) { my $symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub lzhd_compression ($chunk, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say(scalar(@uncompressed), ' -> ', $est_ratio); create_ac_entry(\@uncompressed, $out_fh); create_ac_entry(\@lengths, $out_fh); encode_distances(\@indices, $out_fh); } sub lzhd_decompression ($fh) { my $uncompressed = decode_ac_entry($fh); my $lengths = decode_ac_entry($fh); my $indices = decode_distances($fh); return lz77_decompression($uncompressed, $indices, $lengths); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = rle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzhd_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $bytes = [unpack('C*', lzhd_decompression($fh))]; if ($rle_encoded) { $bytes = rle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlza_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 06 February 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Arithmetic Coding (in fixed bits). # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq sum); use POSIX qw(ceil log2); use constant { PKGNAME => 'BWLZA', VERSION => '0.03', FORMAT => 'bwlza', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(3); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; say "Max symbol: $max_symbol"; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_ac_entry(\@len_symbols, $out_fh); create_ac_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_ac_entry($fh); my $dist_symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub lzss_compression ($data, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($data, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($data) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say "\nEst. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub lzss_decompression ($fh) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); lz77_decompression($uncompressed, $indices, $lengths); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = rle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzss_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $dec = lzss_decompression($fh); my $bytes = [unpack('C*', $dec)]; if ($rle_encoded) { $bytes = rle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlzad2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZHD variant) + Adaptive Arithmetic Coding (in fixed bits). # Encoding the distances using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq sum); use constant { PKGNAME => 'BWLZAD2', VERSION => '0.01', FORMAT => 'bwlzad2', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); use constant INITIAL_FREQ => 1; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]); $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq_value, $max_symbol) { my $T = 0; my (@cf, @freq); foreach my $i (0 .. $max_symbol) { $freq[$i] = $freq_value; $cf[$i] = $T; $T += $freq_value; $cf[$i + 1] = $T; } return (\@freq, \@cf, $T); } sub increment_freq ($c, $max_symbol, $freq, $cf) { ++$freq->[$c]; my $T = $cf->[$c]; foreach my $i ($c .. $max_symbol) { $cf->[$i] = $T; $T += $freq->[$i]; $cf->[$i + 1] = $T; } return $T; } sub ac_encode ($bytes_arr) { my $enc = ''; my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1); my $max_symbol = max(@bytes) // 0; my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; $T = increment_freq($c, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, $max_symbol); } sub ac_decode ($fh, $max_symbol) { my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); while (1) { my $w = ($high + 1) - $low; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = 0; foreach my $j (0 .. $max_symbol) { if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) { $i = $j; last; } } last if ($i == $max_symbol); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; $T = increment_freq($i, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: ($high > ${\MAX})"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $max_symbol) = ac_encode($bytes); print $out_fh delta_encode([$max_symbol, length($enc)], 1); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)}; say "Encoded length: $enc_len"; if ($enc_len > 0) { my $bits = read_bits($fh, $enc_len); open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, $max_symbol); } return []; } sub encode_distances ($distances, $out_fh) { my @symbols; my $offset_bits = ''; foreach my $dist (@$distances) { my $i = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; push @symbols, $i; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } create_ac_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub decode_distances ($fh) { my $symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub lzhd_compression ($chunk, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say(scalar(@uncompressed), ' -> ', $est_ratio); create_ac_entry(\@uncompressed, $out_fh); create_ac_entry(\@lengths, $out_fh); encode_distances(\@indices, $out_fh); } sub lzhd_decompression ($fh) { my $uncompressed = decode_ac_entry($fh); my $lengths = decode_ac_entry($fh); my $indices = decode_distances($fh); return lz77_decompression($uncompressed, $indices, $lengths); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = rle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzhd_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $bytes = [unpack('C*', lzhd_decompression($fh))]; if ($rle_encoded) { $bytes = rle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlzad_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 07 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-front transform (MTF) + LZ77 compression (LZSS) + Adaptive Arithmetic Coding (in fixed bits). # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq sum); use POSIX qw(ceil log2); use constant { PKGNAME => 'BWLZAD', VERSION => '0.01', FORMAT => 'bwlzad', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); use constant INITIAL_FREQ => 1; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq_value, $max_symbol) { my $T = 0; my (@cf, @freq); foreach my $i (0 .. $max_symbol) { $freq[$i] = $freq_value; $cf[$i] = $T; $T += $freq_value; $cf[$i + 1] = $T; } return (\@freq, \@cf, $T); } sub increment_freq ($c, $max_symbol, $freq, $cf) { ++$freq->[$c]; my $T = $cf->[$c]; foreach my $i ($c .. $max_symbol) { $cf->[$i] = $T; $T += $freq->[$i]; $cf->[$i + 1] = $T; } return $T; } sub ac_encode ($bytes_arr) { my $enc = ''; my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1); my $max_symbol = max(@bytes) // 0; my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; $T = increment_freq($c, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, $max_symbol); } sub ac_decode ($fh, $max_symbol) { my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); while (1) { my $w = ($high + 1) - $low; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = 0; foreach my $j (0 .. $max_symbol) { if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) { $i = $j; last; } } last if ($i == $max_symbol); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; $T = increment_freq($i, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: ($high > ${\MAX})"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $max_symbol) = ac_encode($bytes); print $out_fh delta_encode([$max_symbol, length($enc)], 1); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)}; say "Encoded length: $enc_len"; if ($enc_len > 0) { my $bits = read_bits($fh, $enc_len); open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, $max_symbol); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_ac_entry(\@len_symbols, $out_fh); create_ac_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_ac_entry($fh); my $dist_symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub lzss_compression ($chunk, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say "\nEst. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub lzss_decompression ($fh) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); lz77_decompression($uncompressed, $indices, $lengths); } sub compression ($chunk, $out_fh) { my @chunk_bytes = unpack('C*', $chunk); my $data = pack('C*', @{rle4_encode(\@chunk_bytes)}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = rle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } print $out_fh pack('N', $idx); print $out_fh encode_alphabet(\@alphabet); lzss_compression(pack('C*', @$enc_bytes), $out_fh); } sub decompression ($fh, $out_fh) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $bytes = [unpack('C*', lzss_decompression($fh))]; if ($rle_encoded) { $bytes = rle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlzhd_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler transform (BWT) + Run-length Encoding (RLE) + LZ77 compression (LZHD variant) + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'BWLZHD', VERSION => '0.01', FORMAT => 'bwlzhd', LOOKAHEAD_LEN => 128, CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); foreach my $k (keys %$rev_dict) { $rev_dict->{$k} = chr($rev_dict->{$k}); } my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return ''; } sub encode_distances ($distances, $out_fh) { my @symbols; my $offset_bits = ''; foreach my $dist (@$distances) { my $i = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; push @symbols, $i; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } create_huffman_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub decode_distances ($fh) { my @symbols = unpack('C*', decode_huffman_entry($fh)); my $bits_len = 0; foreach my $i (@symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub compression ($chunk, $out_fh) { my $rle4 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4)); $bwt = pack('C*', @{rle4_encode([unpack('C*', $bwt)])}); say "BWT index = $idx"; my (@uncompressed, @indices, @lengths); lz77_compression($bwt, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say(scalar(@uncompressed), ' -> ', $est_ratio); print $out_fh pack('N', $idx); create_huffman_entry(\@uncompressed, $out_fh); create_huffman_entry(\@lengths, $out_fh); encode_distances(\@indices, $out_fh); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my @uncompressed = split(//, decode_huffman_entry($fh)); my @lengths = unpack('C*', decode_huffman_entry($fh)); my $indices = decode_distances($fh); my $rle4 = lz77_decompression(\@uncompressed, $indices, \@lengths); my $bwt = pack('C*', @{rle4_decode([unpack('C*', $rle4)])}); my @rle4 = unpack('C*', bwt_decode($bwt, $idx)); print $out_fh pack('C*', @{rle4_decode(\@rle4)}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwlzss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZ77 compression (LZSS) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use POSIX qw(ceil log2); use constant { PKGNAME => 'BWLZSS', VERSION => '0.01', FORMAT => 'bwlzss', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub lzss_compression ($data, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($data, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($data) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say "\nEst. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub lzss_decompression ($fh) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); lz77_decompression($uncompressed, $indices, $lengths); } sub compression ($chunk, $out_fh) { my $rle4 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4)); print $out_fh pack('N', $idx); lzss_compression($bwt, $out_fh); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $bwt = lzss_decompression($fh); my $rle4 = bwt_decode($bwt, $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwrl2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 29 February 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Bzip2. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWRL2', VERSION => '0.01', FORMAT => 'bwrl2', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh, $with_bwt = 0) { my @bytes = $with_bwt ? do { my ($bwt, $idx) = bwt_encode(pack('C*', @$chunk)); say "BWT index = $idx"; print $out_fh pack('N', $idx); unpack('C*', $bwt); } : @$chunk; my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle4 = rle4_encode($mtf); my $rle = rle_encode($rle4); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh, $with_bwt = 0) { my $idx = $with_bwt ? unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)) : 0; my $alphabet = decode_alphabet($fh); say "BWT index = $idx" if $with_bwt; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $rle4 = rle_decode($rle); my $mtf = rle4_decode($rle4); my $bwt = mtf_decode($mtf, $alphabet); my @bytes = $with_bwt ? unpack('C*', bwt_decode(pack('C*', @$bwt), $idx)) : @$bwt; print $out_fh pack('C*', @bytes); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub VLR_encoding ($bytes) { my $uncompressed = ''; my $bitstream = ''; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; $uncompressed .= $c; if ($v == 1) { $bitstream .= '0'; } else { my $t = sprintf('%b', $v); $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } return ($uncompressed, pack('B*', $bitstream)); } sub VLR_decoding ($uncompressed, $bits_fh) { my $decoded = ''; my $buffer = ''; foreach my $c (@$uncompressed) { my $bl = 0; while (read_bit($bits_fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \$buffer) } 1 .. $bl)); } else { $decoded .= $c; } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])})); my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]); print $out_fh pack('N', $idx); bz2_compression([unpack('C*', $uncompressed)], $out_fh); bz2_compression([unpack('C*', $lengths)], $out_fh, 1); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = ''; my $lengths = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '+>:raw', \$lengths; my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh, 1); # lengths seek($len_fh, 0, 0); my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])}); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwrl_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Bzip2. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWRL', VERSION => '0.01', FORMAT => 'bwrl', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub VLR_encoding ($bytes) { my $uncompressed = ''; my $bitstream = ''; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; $uncompressed .= $c; if ($v == 1) { $bitstream .= '0'; } else { my $t = sprintf('%b', $v); $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } return ($uncompressed, pack('B*', $bitstream)); } sub VLR_decoding ($uncompressed, $bits_fh) { my $decoded = ''; my $buffer = ''; foreach my $c (@$uncompressed) { my $bl = 0; while (read_bit($bits_fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \$buffer) } 1 .. $bl)); } else { $decoded .= $c; } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])})); my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]); print $out_fh pack('N', $idx); bz2_compression($uncompressed, $out_fh); bz2_compression($lengths, $out_fh); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = ''; my $lengths = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '+>:raw', \$lengths; my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh); # lengths seek($len_fh, 0, 0); my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])}); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwrla_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 23 February 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + Bzip2 (with Arithmetic Coding). # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWRLA', VERSION => '0.01', FORMAT => 'bwrla', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; say "Max symbol: $max_symbol\n"; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len\n"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_ac_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_ac_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub VLR_encoding ($bytes) { my $uncompressed = ''; my $bitstream = ''; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; $uncompressed .= $c; if ($v == 1) { $bitstream .= '0'; } else { my $t = sprintf('%b', $v); $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } return ($uncompressed, pack('B*', $bitstream)); } sub VLR_decoding ($uncompressed, $bits_fh) { my $decoded = ''; my $buffer = ''; foreach my $c (@$uncompressed) { my $bl = 0; while (read_bit($bits_fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \$buffer) } 1 .. $bl)); } else { $decoded .= $c; } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])})); my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]); print $out_fh pack('N', $idx); bz2_compression($uncompressed, $out_fh); bz2_compression($lengths, $out_fh); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = ''; my $lengths = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '+>:raw', \$lengths; my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh); # lengths seek($len_fh, 0, 0); my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])}); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwrlz2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + LZSS + Bzip2. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use POSIX qw(ceil log2); use constant { PKGNAME => 'BWRLZ2', VERSION => '0.01', FORMAT => 'bwrlz2', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } bz2_compression_symbolic(\@len_symbols, $out_fh); bz2_compression_symbolic(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = bz2_decompression_symbolic($fh); my $dist_symbols = bz2_decompression_symbolic($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub bwt_sort_symbolic ($s) { # O(n) space (slowish) my @cyclic = @$s; my $len = scalar(@cyclic); my $rle = 1; foreach my $i (1 .. $len - 1) { if ($cyclic[$i] != $cyclic[$i - 1]) { $rle = 0; last; } } $rle && return [0 .. $len - 1]; [ sort { my ($i, $j) = ($a, $b); while ($cyclic[$i] == $cyclic[$j]) { $i %= $len if (++$i >= $len); $j %= $len if (++$j >= $len); } $cyclic[$i] <=> $cyclic[$j]; } 0 .. $len - 1 ]; } sub bwt_encode_symbolic ($s) { my $bwt = bwt_sort_symbolic($s); my @ret = map { $s->[$_ - 1] } @$bwt; my $idx = 0; foreach my $i (@$bwt) { $i || last; ++$idx; } return (\@ret, $idx); } sub bwt_decode_symbolic ($bwt, $idx) { # fast inversion my @tail = @$bwt; my @head = sort { $a <=> $b } @tail; my @indices; foreach my $i (0 .. $#tail) { push @{$indices[$tail[$i]]}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices[$v]}); } my @dec; my $i = $idx; for (1 .. scalar(@head)) { push @dec, $head[$i]; $i = $table[$i]; } return \@dec; } sub encode_alphabet_symbolic ($alphabet) { return delta_encode([@$alphabet]); } sub decode_alphabet_symbolic ($fh) { return delta_decode($fh); } sub bz2_compression_symbolic ($symbols, $out_fh) { my ($bwt, $idx) = bwt_encode_symbolic($symbols); my @bytes = @$bwt; my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet_symbolic(\@alphabet); say "BWT index = $idx"; say "Max symbol: ", max(@alphabet) // 0; my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression_symbolic ($fh) { my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet_symbolic($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $data = bwt_decode_symbolic($bwt, $idx); return $data; } sub lzss_compression ($chunk, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub lzss_decompression ($fh, $out_fh) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub VLR_encoding ($bytes) { my $uncompressed = ''; my $bitstream = ''; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; $uncompressed .= $c; if ($v == 1) { $bitstream .= '0'; } else { my $t = sprintf('%b', $v); $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } return ($uncompressed, pack('B*', $bitstream)); } sub VLR_decoding ($uncompressed, $bits_fh) { my $decoded = ''; my $buffer = ''; foreach my $c (@$uncompressed) { my $bl = 0; while (read_bit($bits_fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \$buffer) } 1 .. $bl)); } else { $decoded .= $c; } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])})); my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]); print $out_fh pack('N', $idx); lzss_compression($uncompressed, $out_fh); lzss_compression($lengths, $out_fh); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = ''; my $lengths = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '+>:raw', \$lengths; my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); lzss_decompression($fh, $uc_fh); # uncompressed lzss_decompression($fh, $len_fh); # lengths seek($len_fh, 0, 0); my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])}); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwrlz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 29 February 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Variable Run-Length encoding + LZSS. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use POSIX qw(ceil log2); use constant { PKGNAME => 'BWRLZ', VERSION => '0.01', FORMAT => 'bwrlz', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub lzss_compression ($chunk, $out_fh) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub lzss_decompression ($fh, $out_fh) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub VLR_encoding ($bytes) { my $uncompressed = ''; my $bitstream = ''; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; $uncompressed .= $c; if ($v == 1) { $bitstream .= '0'; } else { my $t = sprintf('%b', $v); $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } return ($uncompressed, pack('B*', $bitstream)); } sub VLR_decoding ($uncompressed, $bits_fh) { my $decoded = ''; my $buffer = ''; foreach my $c (@$uncompressed) { my $bl = 0; while (read_bit($bits_fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { $decoded .= $c x oct('0b1' . join('', map { read_bit($bits_fh, \$buffer) } 1 .. $bl)); } else { $decoded .= $c; } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])})); my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]); print $out_fh pack('N', $idx); lzss_compression($uncompressed, $out_fh); lzss_compression($lengths, $out_fh); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = ''; my $lengths = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '+>:raw', \$lengths; my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); lzss_decompression($fh, $uc_fh); # uncompressed lzss_decompression($fh, $len_fh); # lengths seek($len_fh, 0, 0); my $dec = VLR_decoding([split(//, $uncompressed)], $len_fh); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])}); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwrm_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 September 2023 # Edit: 29 February 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Run-Length encoding + MTF + ZRLE. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWRM', VERSION => '0.01', FORMAT => 'bwrm', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta), "\n"; my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh, $with_bwt = 0) { my @bytes = $with_bwt ? do { my ($bwt, $idx) = bwt_encode(pack('C*', @$chunk)); say "BWT index = $idx"; print $out_fh pack('N', $idx); unpack('C*', $bwt); } : @$chunk; my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle4 = rle4_encode($mtf); my $rle = rle_encode($rle4); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh, $with_bwt = 0) { my $idx = $with_bwt ? unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)) : 0; my $alphabet = decode_alphabet($fh); say "BWT index = $idx" if $with_bwt; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $rle4 = rle_decode($rle); my $mtf = rle4_decode($rle4); my $bwt = mtf_decode($mtf, $alphabet); my @bytes = $with_bwt ? unpack('C*', bwt_decode(pack('C*', @$bwt), $idx)) : @$bwt; print $out_fh pack('C*', @bytes); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value and $result[-1][1] < 256) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub VLR_encoding ($bytes) { my @lengths; my @uncompressed; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; push @uncompressed, ord($c); push @lengths, $v - 1; } return (\@uncompressed, \@lengths); } sub VLR_decoding ($uncompressed, $lengths) { my $decoded = ''; foreach my $i (0 .. $#{$uncompressed}) { my $c = $uncompressed->[$i]; my $len = $lengths->[$i]; if ($len > 0) { $decoded .= $c x ($len + 1); } else { $decoded .= $c; } } return $decoded; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($bwt, $idx) = bwt_encode(pack('C*', @{rle4_encode([unpack('C*', $chunk)])})); my ($uncompressed, $lengths) = VLR_encoding([split(//, $bwt)]); print $out_fh pack('N', $idx); bz2_compression($uncompressed, $out_fh); create_huffman_entry(rle4_encode($lengths), $out_fh); } close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = ''; open my $uc_fh, '>:raw', \$uncompressed; my $idx = unpack('N', join('', map { getc($fh) // die "decompression error" } 1 .. 4)); bz2_decompression($fh, $uc_fh); # uncompressed my $lengths = rle4_decode(decode_huffman_entry($fh)); my $dec = VLR_decoding([split(//, $uncompressed)], $lengths); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode($dec, $idx))])}); } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwt2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-To-Front transform (MTF) + Run-length encoding (RLE) + Bzip2. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWT2', VERSION => '0.01', FORMAT => 'bwt2', CHUNK_SIZE => 1 << 17, LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bwt_sort_symbolic ($s) { # O(n) space (slowish) my @cyclic = @$s; my $len = scalar(@cyclic); my $rle = 1; foreach my $i (1 .. $len - 1) { if ($cyclic[$i] != $cyclic[$i - 1]) { $rle = 0; last; } } $rle && return [0 .. $len - 1]; [ sort { my ($i, $j) = ($a, $b); while ($cyclic[$i] == $cyclic[$j]) { $i %= $len if (++$i >= $len); $j %= $len if (++$j >= $len); } $cyclic[$i] <=> $cyclic[$j]; } 0 .. $len - 1 ]; } sub bwt_encode_symbolic ($s) { my $bwt = bwt_sort_symbolic($s); my @ret = map { $s->[$_ - 1] } @$bwt; my $idx = 0; foreach my $i (@$bwt) { $i || last; ++$idx; } return (\@ret, $idx); } sub bwt_decode_symbolic ($bwt, $idx) { # fast inversion my @tail = @$bwt; my @head = sort { $a <=> $b } @tail; my @indices; foreach my $i (0 .. $#tail) { push @{$indices[$tail[$i]]}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices[$v]}); } my @dec; my $i = $idx; for (1 .. scalar(@head)) { push @dec, $head[$i]; $i = $table[$i]; } return \@dec; } sub encode_alphabet_symbolic ($alphabet) { return delta_encode([@$alphabet]); } sub decode_alphabet_symbolic ($fh) { return [@{delta_decode($fh)}]; } sub bz2_compression_symbolic ($symbols, $out_fh) { my $rle4 = rle4_encode($symbols); my ($bwt, $idx) = bwt_encode_symbolic($rle4); my @bytes = @$bwt; my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet_symbolic(\@alphabet); say "BWT index = $idx"; say "Max symbol: ", max(@alphabet) // 0; my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression_symbolic ($fh) { my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet_symbolic($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $data = bwt_decode_symbolic($bwt, $idx); return rle4_decode($data); } sub compression ($chunk, $out_fh) { my $rle4 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; my @alphabet2 = sort { $a <=> $b } uniq(@$rle); my $mtf2 = mtf_encode([@$rle], [@alphabet2]); my $rle2 = rle4_encode($mtf2); my @alphabet3 = sort { $a <=> $b } uniq(@$rle2); my $mtf3 = mtf_encode([@$rle2], [@alphabet3]); print $out_fh encode_alphabet_symbolic(\@alphabet2); print $out_fh encode_alphabet_symbolic(\@alphabet3); bz2_compression_symbolic($mtf3, $out_fh); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $alphabet2 = decode_alphabet_symbolic($fh); my $alphabet3 = decode_alphabet_symbolic($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $mtf3 = bz2_decompression_symbolic($fh); my $rle2 = mtf_decode($mtf3, $alphabet3); my $mtf2 = rle4_decode($rle2); my $rle = mtf_decode($mtf2, $alphabet2); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bwt_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 25 February 2026 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + Move-to-Front Transform + Run-length encoding + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # Implementation featuring: # 1. BWT ENCODE - O(n * LOOKAHEAD_LEN) space # 2. HUFFMAN TREE – O(n log n) binary min-heap priority queue. # 3. HUFFMAN DECODE – O(n · avg_code_len) trie traversal. # 4. BWT INVERSION – O(n) counting-sort for the next-table. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWT', VERSION => '0.03', FORMAT => 'bwt', CHUNK_SIZE => 1 << 17, # 128 KiB LOOKAHEAD_LEN => 128, }; use constant SIGNATURE => uc(FORMAT) . chr(2); # --------------------------------------------------------------------------- # CLI boilerplate # --------------------------------------------------------------------------- sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive ($fh) { if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # --------------------------------------------------------------------------- # Bit-level I/O # --------------------------------------------------------------------------- sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } $data = substr($data, 0, $bits_len) if (length($data) > $bits_len); return $data; } # --------------------------------------------------------------------------- # Delta coding # --------------------------------------------------------------------------- sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift @$integers, scalar(@$integers); while (@$integers) { my $curr = shift @$integers; push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . ($d < 0 ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . ($d < 0 ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $sign = read_bit($fh, \$buffer); my $bl = 0; ++$bl while read_bit($fh, \$buffer) eq '1'; my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($sign eq '1' ? 1 : -1) * ($int - 1); } else { my $sign = read_bit($fh, \$buffer); my $n = 0; ++$n while read_bit($fh, \$buffer) eq '1'; my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($sign eq '1' ? $d : -$d); } $len = pop(@deltas) if $k == 0; } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # --------------------------------------------------------------------------- # Huffman – binary min-heap priority queue # --------------------------------------------------------------------------- sub _heap_push ($heap, $item) { push @$heap, $item; my $i = $#$heap; while ($i > 0) { my $p = ($i - 1) >> 1; last if ($heap->[$p][1] <= $heap->[$i][1]); @{$heap}[$p, $i] = @{$heap}[$i, $p]; $i = $p; } } sub _heap_pop ($heap) { return pop @$heap if (@$heap == 1); my $top = $heap->[0]; $heap->[0] = pop @$heap; my $n = scalar @$heap; my $i = 0; while (1) { my $s = $i; my $l = 2 * $i + 1; my $r = $l + 1; $s = $l if ($l < $n && $heap->[$l][1] < $heap->[$s][1]); $s = $r if ($r < $n && $heap->[$r][1] < $heap->[$s][1]); last if $s == $i; @{$heap}[$i, $s] = @{$heap}[$s, $i]; $i = $s; } return $top; } sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } sub mktree_from_freq ($freq) { my @heap; _heap_push(\@heap, [$_, $freq->{$_}]) for sort { $a <=> $b } keys %$freq; while (@heap > 1) { my $x = _heap_pop(\@heap); my $y = _heap_pop(\@heap); _heap_push(\@heap, [[$x, $y], $x->[1] + $y->[1]]); } if (@heap == 1 && !ref $heap[0][0]) { @heap = ([[$heap[0]], $heap[0][1]]); } return walk($heap[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } # --------------------------------------------------------------------------- # Huffman decode via trie traversal # --------------------------------------------------------------------------- sub _build_trie ($rev_h) { my $root = {}; for my $code (keys %$rev_h) { my $node = $root; for my $bit (split //, $code) { $node->{$bit} //= {}; $node = $node->{$bit}; } $node->{sym} = $rev_h->{$code}; } return $root; } sub huffman_decode ($bits, $rev_h) { my $root = _build_trie($rev_h); my @result; my $node = $root; foreach my $i (0 .. length($bits) - 1) { my $bit = substr($bits, $i, 1); $node = $node->{$bit}; if (exists $node->{sym}) { push @result, $node->{sym}; $node = $root; } } return \@result; } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; push @freqs, ($freq{$_} // 0) for 0 .. $max_symbol; print $out_fh delta_encode(\@freqs); print $out_fh pack('N', length($enc)); print $out_fh pack('B*', $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; for my $i (0 .. $#freqs) { $freq{$i} = $freqs[$i] if $freqs[$i]; } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; return ( ($enc_len > 0) ? huffman_decode(read_bits($fh, $enc_len), $rev_dict) : [] ); } # --------------------------------------------------------------------------- # Move-to-Front # --------------------------------------------------------------------------- sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); for my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift @$alphabet, splice(@$alphabet, $index, 1); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; for my $p (@$encoded) { push @S, $alphabet->[$p]; unshift @$alphabet, splice(@$alphabet, $p, 1); } return \@S; } # --------------------------------------------------------------------------- # BWT construction # --------------------------------------------------------------------------- sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || do { my ($cmp, $s_len) = (0, LOOKAHEAD_LEN << 2); while (1) { ($cmp = substr($double_s, $a->[1], $s_len) cmp substr($double_s, $b->[1], $s_len)) && last; $s_len <<= 1; } $cmp; } } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } # --------------------------------------------------------------------------- # BWT inversion with counting sort # --------------------------------------------------------------------------- sub bwt_decode ($bwt, $idx) { my @L = unpack('C*', $bwt); my $n = scalar @L; my @freq = (0) x 256; $freq[$_]++ for @L; my @cumul = (0) x 257; $cumul[$_ + 1] = $cumul[$_] + $freq[$_] for 0 .. 255; my @next; my @cnt = (0) x 256; for my $i (0 .. $n - 1) { $next[$cumul[$L[$i]] + $cnt[$L[$i]]++] = $i; } my @dec; my $i = $idx; for (1 .. $n) { $i = $next[$i]; push @dec, $L[$i]; } return pack('C*', @dec); } # --------------------------------------------------------------------------- # Run-length encoding stages # --------------------------------------------------------------------------- sub rle4_encode ($bytes) { my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; ++$i; while ($run < 255 && $i <= $end && $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, ($prev) x $run; } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end && $bytes->[$i] == 0) { ++$run; ++$i } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } push @rle, $bytes->[$i] + 1 if $i <= $end; } return \@rle; } sub rle_decode ($rle) { my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 || $k == 1) { my $run = 1; while ($i <= $end && ($k == 0 || $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } push @dec, $k - 1 if $i <= $end; } return \@dec; } # --------------------------------------------------------------------------- # Alphabet encoding / decoding # --------------------------------------------------------------------------- sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; $enc |= 1 << $_ for grep { exists $table{$i + $_} } 0 .. 31; if ($enc == 0) { $populated <<= 1 } else { ($populated <<= 1) |= 1; push @marked, $enc } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); return chr($populated) . $delta; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift @populated) { my $m = shift @$marked; for my $j (0 .. 31) { push @alphabet, $i + $j if $m & 1; $m >>= 1; } } } return \@alphabet; } # --------------------------------------------------------------------------- # Top-level compression / decompression passes # --------------------------------------------------------------------------- sub compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # --------------------------------------------------------------------------- # File-level entry points # --------------------------------------------------------------------------- sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh SIGNATURE; while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } close $out_fh; } sub decompress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } close $fh; close $out_fh; } main(); exit 0; ================================================ FILE: Compression/bww_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 June 2023 # Edit: 16 June 2023 # https://github.com/trizen # Compress/decompress files using Burrows-Wheeler Transform (BWT) + LZW compression. # See also: # https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'BWW', VERSION => '0.02', FORMAT => 'bww', CHUNK_SIZE => 1 << 17, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked]); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } # Compress a string to a list of output symbols sub compress ($uncompressed) { # Build the dictionary my $dict_size = 256; my %dictionary; foreach my $i (0 .. $dict_size - 1) { $dictionary{chr($i)} = $i; } my $w = ''; my @result; foreach my $c (split(//, $uncompressed)) { my $wc = $w . $c; if (exists $dictionary{$wc}) { $w = $wc; } else { push @result, $dictionary{$w}; # Add wc to the dictionary $dictionary{$wc} = $dict_size++; $w = $c; } } # Output the code for w if ($w ne '') { push @result, $dictionary{$w}; } return \@result; } # Decompress a list of output ks to a string sub decompress ($compressed) { # Build the dictionary my $dict_size = 256; my @dictionary = map { chr($_) } 0 .. $dict_size - 1; my $w = $dictionary[$compressed->[0]]; my $result = $w; foreach my $j (1 .. $#{$compressed}) { my $k = $compressed->[$j]; my $entry = ($k < $dict_size) ? $dictionary[$k] : ($k == $dict_size) ? ($w . substr($w, 0, 1)) : die "Bad compressed k: $k"; $result .= $entry; # Add w+entry[0] to the dictionary push @dictionary, $w . substr($entry, 0, 1); ++$dict_size; $w = $entry; } return $result; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub elias_encoding ($integers) { my $bitstring = ''; foreach my $k (scalar(@$integers), @$integers) { if ($k == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', $k + 1); my $l = length($t); my $L = sprintf('%b', $l); $bitstring .= ('1' x (length($L) - 1)) . '0' . substr($L, 1) . substr($t, 1); } } pack('B*', $bitstring); } sub elias_decoding ($fh) { my @ints; my $len = 0; my $buffer = ''; for (my $k = 0 ; $k <= $len ; ++$k) { my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); if ($bl > 0) { my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @ints, $int - 1; } else { push @ints, 0; } if ($k == 0) { $len = pop(@ints); } } return \@ints; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; my $compressed = elias_encoding([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]); my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($fh) { my $ints = elias_decoding($fh); my $half = scalar(@$ints) >> 1; my @counts; foreach my $i (0 .. ($half - 1)) { push @counts, [$ints->[$i], $ints->[$half + $i]]; } my $bits_len = 0; foreach my $pair (@counts) { my ($blen, $len) = @$pair; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @integers; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @integers, oct('0b' . $chunk); } } return \@integers; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my $data = pack('C*', @{rle4_encode([unpack('C*', $chunk)])}); my ($bwt, $idx) = bwt_encode($data); my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); say "# symbols : ", scalar(@alphabet), "\n"; my $enc_bytes = mtf_encode(\@bytes, [@alphabet]); if (max(@$enc_bytes) < 255) { print $out_fh chr(1); $enc_bytes = rle_encode($enc_bytes); } else { print $out_fh chr(0); $enc_bytes = rle4_encode($enc_bytes); } my $lzw = compress(pack('C*', @$enc_bytes)); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; print $out_fh encode_integers($lzw); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $rle_encoded = ord(getc($fh) // die "error"); my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet($fh); my $lzw = decode_integers($fh); my $bytes = [unpack('C*', decompress($lzw))]; if ($rle_encoded) { $bytes = rle_decode($bytes); } else { $bytes = rle4_decode($bytes); } $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @{rle4_decode([unpack('C*', bwt_decode(pack('C*', @$bytes), $idx))])}); } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/bzip2_compressor.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 20 August 2024 # https://github.com/trizen # A very basic Bzip2 compressor. # References: # BZIP2: Format Specification, by Joe Tsai # https://github.com/dsnet/compress/blob/master/doc/bzip2-format.pdf use 5.036; use POSIX qw(ceil); use List::Util qw(max); use Compression::Util qw(:all); use constant {CHUNK_SIZE => 1 << 17}; local $| = 1; binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); sub encode_mtf_alphabet($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 16) { my $enc = 0; foreach my $j (0 .. 15) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } $populated <<= 1; if ($enc > 0) { $populated |= 1; push @marked, $enc; } } say STDERR sprintf("Populated: %016b", $populated); say STDERR "Marked: (@marked)"; return ($populated, \@marked); } sub encode_code_lengths($dict) { my @lengths; foreach my $symbol (0 .. max(keys %$dict) // 0) { if (exists($dict->{$symbol})) { push @lengths, length($dict->{$symbol}); } else { die "Incomplete Huffman tree not supported"; push @lengths, 0; } } say STDERR "Code lengths: (@lengths)"; my $deltas = deltas(\@lengths); say STDERR "Code lengths deltas: (@$deltas)"; my $bitstring = int2bits(shift(@$deltas), 5) . '0'; foreach my $d (@$deltas) { $bitstring .= (($d > 0) ? ('10' x $d) : ('11' x abs($d))) . '0'; } say STDERR "Deltas bitstring: $bitstring"; return $bitstring; } my $s = "Hello, World!\n"; my $fh; if (-t STDIN) { open $fh, "<:raw", \$s; } else { $fh = \*STDIN; } print "BZh"; my $level = 9; if ($level <= 0 or $level > 9) { die "Invalid level value: $level"; } print $level; my $block_header_bitstring = unpack("B48", "1AY&SY"); my $block_footer_bitstring = unpack("B48", "\27rE8P\x90"); my $bitstring = ''; my $stream_crc32 = 0; while (!eof($fh)) { read($fh, (my $chunk), CHUNK_SIZE); $bitstring .= $block_header_bitstring; my $crc32 = crc32(pack 'B*', unpack 'b*', $chunk); say STDERR "CRC32: $crc32"; $crc32 = oct('0b' . int2bits_lsb($crc32, 32)); say STDERR "Bzip2-CRC32: $crc32"; $stream_crc32 = ($crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff; $bitstring .= int2bits($crc32, 32); $bitstring .= '0'; # not randomized my $rle4 = rle4_encode($chunk); ##say STDERR "RLE4: (@$rle4)"; my ($bwt, $bwt_idx) = bwt_encode(symbols2string($rle4)); $bitstring .= int2bits($bwt_idx, 24); my ($mtf, $alphabet) = mtf_encode($bwt); ##say STDERR "MTF: (@$mtf)"; say STDERR "MTF Alphabet: (@$alphabet)"; my ($populated, $marked) = encode_mtf_alphabet($alphabet); $bitstring .= int2bits($populated, 16); $bitstring .= int2bits_lsb($_, 16) for @$marked; my @zrle = reverse @{zrle_encode([reverse @$mtf])}; ##say STDERR "ZRLE: @zrle"; my $eob = scalar(@$alphabet) + 1; # end-of-block symbol say STDERR "EOB symbol: $eob"; push @zrle, $eob; my ($dict) = huffman_from_symbols([@zrle, 0 .. $eob - 1]); my $num_sels = ceil(scalar(@zrle) / 50); say STDERR "Number of selectors: $num_sels"; $bitstring .= int2bits(2, 3); $bitstring .= int2bits($num_sels, 15); $bitstring .= '0' x $num_sels; $bitstring .= encode_code_lengths($dict) x 2; $bitstring .= join('', @{$dict}{@zrle}); } $bitstring .= $block_footer_bitstring; $bitstring .= int2bits($stream_crc32, 32); print pack("B*", $bitstring); ================================================ FILE: Compression/bzip2_decompressor.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 19 August 2024 # https://github.com/trizen # A very basic Bzip2 decompressor. # References: # BZIP2: Format Specification, by Joe Tsai # https://github.com/dsnet/compress/blob/master/doc/bzip2-format.pdf # # Pyflate, by Paul Sladen # http://www.paul.sladen.org/projects/pyflate/ use 5.036; use List::Util qw(max); use Compression::Util qw(:all); local $| = 1; binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); my $s = ''; $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" $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" $s .= "BZh91AY&SY\xE9\xA6L\xBE\0\0\20\xC9\x80\n\20\2\xE0?\xFB\x8B0" . " \0\x89\fE2i\xA3&\x9A\3A)\xEA\"'\xA8h\3\xD4\xD3gxRZ\4\x8C\xDA'g,\x88\xD5\xA6" . "\x9C\xEA\xC4\30wWy\xE4\xD7\xC0\x95\xF9L\x89\5\x936'\xED\x95a\22o%B\x90\x93" . "T\xAF\xFD\xE6\xEA)\x8D\x90\x82\xB5\x9E\x89Z\xD7X\xB19\x9D0\xC9\21s\x9E\x95" . "\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 my $fh; if (-t STDIN) { open $fh, "<:raw", \$s; } else { $fh = \*STDIN; } while (!eof($fh)) { my $buffer = ''; (bytes2int($fh, 2) == 0x425a and getc($fh) eq 'h') or die "Not a valid Bzip2 archive"; my $level = getc($fh) + 0; if (not $level) { die "invalid level"; } say STDERR "Compression level: $level"; my $stream_crc32 = 0; while (!eof($fh)) { my $block_magic = pack "B48", join('', map { read_bit($fh, \$buffer) } 1 .. 48); if ($block_magic eq "1AY&SY") { # BlockHeader say STDERR "Block header detected"; my $crc32 = bits2int($fh, 32, \$buffer); say STDERR "CRC32 = $crc32"; my $randomized = read_bit($fh, \$buffer); $randomized == 0 or die "randomized not supported"; my $bwt_idx = bits2int($fh, 24, \$buffer); say STDERR "BWT index: $bwt_idx"; my @alphabet; my $l1 = bits2int($fh, 16, \$buffer); for my $i (0 .. 15) { if ($l1 & (0x8000 >> $i)) { my $l2 = bits2int($fh, 16, \$buffer); for my $j (0 .. 15) { if ($l2 & (0x8000 >> $j)) { push @alphabet, 16 * $i + $j; } } } } say STDERR "MTF alphabet: (@alphabet)"; my $num_trees = bits2int($fh, 3, \$buffer); say STDERR "Number or trees: $num_trees"; my $num_sels = bits2int($fh, 15, \$buffer); say STDERR "Number of selectors: $num_sels"; my @idxs; for (1 .. $num_sels) { my $i = 0; while (read_bit($fh, \$buffer)) { $i += 1; ($i < $num_trees) or die "error"; } push @idxs, $i; } my $sels = mtf_decode(\@idxs, [0 .. $num_trees - 1]); say STDERR "Selectors: (@$sels)"; my $MaxHuffmanBits = 20; my $num_syms = scalar(@alphabet) + 2; my @trees; for (1 .. $num_trees) { my @clens; my $clen = bits2int($fh, 5, \$buffer); for (1 .. $num_syms) { while (1) { ($clen > 0 and $clen <= $MaxHuffmanBits) or warn "Invalid code length: $clen!\n"; if (not read_bit($fh, \$buffer)) { last; } $clen -= read_bit($fh, \$buffer) ? 1 : -1; } push @clens, $clen; } push @trees, \@clens; say STDERR "Code lengths: (@clens)"; } foreach my $tree (@trees) { my $maxLen = max(@$tree); my $sum = 1 << $maxLen; for my $clen (@$tree) { $sum -= (1 << $maxLen) >> $clen; } $sum == 0 or warn "incomplete tree detected: (@$tree)\n"; } my @huffman_trees = map { (huffman_from_code_lengths($_))[1] } @trees; my $eob = @alphabet + 1; my @zrle; my $code = ''; my $sel_idx = 0; my $tree = $huffman_trees[$sels->[$sel_idx]]; my $decoded = 50; while (!eof($fh)) { $code .= read_bit($fh, \$buffer); if (length($code) > $MaxHuffmanBits) { die "[!] Something went wrong: length of LL code `$code` is > $MaxHuffmanBits.\n"; } if (exists($tree->{$code})) { my $sym = $tree->{$code}; if ($sym == $eob) { # end of block marker say STDERR "EOB detected: $sym"; last; } push @zrle, $sym; $code = ''; if (--$decoded <= 0) { if (++$sel_idx <= $#$sels) { $tree = $huffman_trees[$sels->[$sel_idx]]; } else { die "No more selectors"; # should not happen } $decoded = 50; } } } ##say STDERR "ZRLE: (@zrle)"; my @mtf = reverse @{zrle_decode([reverse @zrle])}; ##say STDERR "MTF: (@mtf)"; my $bwt = symbols2string mtf_decode(\@mtf, \@alphabet); ## say "BWT: ($bwt, $bwt_idx)"; my $rle4 = string2symbols bwt_decode($bwt, $bwt_idx); my $data = rle4_decode($rle4); my $dec = symbols2string($data); my $new_crc32 = oct('0b' . int2bits_lsb(crc32(pack('b*', unpack('B*', $dec))), 32)); say STDERR "Computed CRC32: $new_crc32"; if ($crc32 != $new_crc32) { warn "CRC32 error: $crc32 (stored) != $new_crc32 (actual)\n"; } $stream_crc32 = ($new_crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff; print $dec; } elsif ($block_magic eq "\27rE8P\x90") { # BlockFooter say STDERR "Block footer detected"; my $stored_stream_crc32 = bits2int($fh, 32, \$buffer); say STDERR "Stream CRC32: $stored_stream_crc32"; if ($stream_crc32 != $stored_stream_crc32) { warn "Stream CRC32 error: $stored_stream_crc32 (stored) != $stream_crc32 (actual)\n"; } $buffer = ''; last; } else { die "Unknown block magic: $block_magic"; } } say STDERR "End of container"; } say STDERR "End of input"; ================================================ FILE: Compression/bzip2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 25 August 2024 # https://github.com/trizen # A valid Bzip2 file compressor/decompressor. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # BZIP2: Format Specification, by Joe Tsai # https://github.com/dsnet/compress/blob/master/doc/bzip2-format.pdf # # Pyflate, by Paul Sladen # http://www.paul.sladen.org/projects/pyflate/ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(max); use Getopt::Std qw(getopts); binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); use constant { FORMAT => 'bz2', CHUNK_SIZE => 900_000, # 900KB blocks for level 9 (standard bzip2) }; sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub encode_code_lengths($dict) { my @lengths; foreach my $symbol (0 .. max(keys %$dict) // 0) { if (exists($dict->{$symbol})) { push @lengths, length($dict->{$symbol}); } else { die "Incomplete Huffman tree not supported"; push @lengths, 0; } } say STDERR "Code lengths: (@lengths)"; my $deltas = deltas(\@lengths); say STDERR "Code lengths deltas: (@$deltas)"; my $bitstring = int2bits(shift(@$deltas), 5) . '0'; foreach my $d (@$deltas) { $bitstring .= (($d > 0) ? ('10' x $d) : ('11' x abs($d))) . '0'; } say STDERR "Deltas bitstring: $bitstring"; return $bitstring; } sub my_bzip2_compress($fh, $out_fh) { print $out_fh "BZh"; my $level = 9; if ($level <= 0 or $level > 9) { die "Invalid level value: $level"; } print $out_fh $level; my $block_header_bitstring = unpack("B48", "1AY&SY"); my $block_footer_bitstring = unpack("B48", "\27rE8P\x90"); my $bitstring = ''; my $stream_crc32 = 0; while (!eof($fh)) { read($fh, (my $chunk), CHUNK_SIZE); $bitstring .= $block_header_bitstring; my $crc32 = crc32(pack 'B*', unpack 'b*', $chunk); say STDERR "CRC32: $crc32"; $crc32 = oct('0b' . int2bits_lsb($crc32, 32)); say STDERR "Bzip2-CRC32: $crc32"; $stream_crc32 = ($crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff; $bitstring .= int2bits($crc32, 32); $bitstring .= '0'; # not randomized my $rle4 = rle4_encode($chunk); ##say STDERR "RLE4: (@$rle4)"; my ($bwt, $bwt_idx) = bwt_encode(symbols2string($rle4)); $bitstring .= int2bits($bwt_idx, 24); my ($mtf, $alphabet) = mtf_encode($bwt); ##say STDERR "MTF: (@$mtf)"; say STDERR "MTF Alphabet: (@$alphabet)"; $bitstring .= unpack('B*', encode_alphabet_256($alphabet)); my @zrle = reverse @{zrle_encode([reverse @$mtf])}; ##say STDERR "ZRLE: @zrle"; my $eob = scalar(@$alphabet) + 1; # end-of-block symbol say STDERR "EOB symbol: $eob"; push @zrle, $eob; # Split ZRLE data into groups of 50 symbols my @groups; for (my $i = 0 ; $i < @zrle ; $i += 50) { my $end = $i + 49; $end = $#zrle if $end > $#zrle; push @groups, [@zrle[$i .. $end]]; } my $num_groups = scalar(@groups); # Determine number of Huffman tables based on number of groups my $num_trees = ($num_groups <= 1) ? 2 : ($num_groups < 200) ? 3 : ($num_groups < 600) ? 4 : ($num_groups < 1200) ? 5 : 6; say STDERR "Number of trees: $num_trees"; # Initial assignment: distribute groups roughly evenly across tables my @assignments; for my $gi (0 .. $#groups) { my $t = int($gi * $num_trees / $num_groups); $t = $num_trees - 1 if $t >= $num_trees; push @assignments, $t; } # Full symbol range to ensure complete Huffman trees my @all_syms = (0 .. $eob); # Iterative optimization of table assignments my @dicts; for (1 .. 10) { # Build symbol list for each table (with full symbol range as baseline) my @sym_lists; for my $t (0 .. $num_trees - 1) { push @sym_lists, [@all_syms]; # Start with all symbols for complete tree } for my $gi (0 .. $#groups) { # Add symbols multiple times to increase their weight in frequency calculation push @{$sym_lists[$assignments[$gi]]}, (@{$groups[$gi]}) x 2; # Double weight } # Build Huffman tables from frequencies @dicts = map { (huffman_from_symbols($_))[0] } @sym_lists; # Re-assign each group to the best-fitting table my @new_assignments; for my $gi (0 .. $#groups) { my ($best_t, $best_cost) = (0, 9**9**9); for my $t (0 .. $num_trees - 1) { my $cost = 0; $cost += length($dicts[$t]{$_} // '') for @{$groups[$gi]}; ($best_t, $best_cost) = ($t, $cost) if $cost < $best_cost; } push @new_assignments, $best_t; } last if "@new_assignments" eq "@assignments"; @assignments = @new_assignments; } my $num_sels = $num_groups; say STDERR "Number of selectors: $num_sels"; $bitstring .= int2bits($num_trees, 3); $bitstring .= int2bits($num_sels, 15); # MTF-encode selectors and write as unary codes my @mtf_list = (0 .. $num_trees - 1); for my $sel (@assignments) { my $pos = 0; $pos++ while $mtf_list[$pos] != $sel; $bitstring .= '1' x $pos . '0'; splice(@mtf_list, $pos, 1); unshift @mtf_list, $sel; } # Write all Huffman tables $bitstring .= encode_code_lengths($_) for @dicts; # Encode symbols group by group using the assigned tables for my $gi (0 .. $#groups) { $bitstring .= join('', @{$dicts[$assignments[$gi]]}{@{$groups[$gi]}}); } print $out_fh pack('B*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); } $bitstring .= $block_footer_bitstring; $bitstring .= int2bits($stream_crc32, 32); print $out_fh pack("B*", $bitstring); return 1; } sub my_bzip2_decompress($fh, $out_fh) { while (!eof($fh)) { my $buffer = ''; (bytes2int($fh, 2) == 0x425a and getc($fh) eq 'h') or die "Not a valid Bzip2 archive"; my $level = getc($fh) + 0; if (not $level) { die "invalid level"; } say STDERR "Compression level: $level"; my $stream_crc32 = 0; while (!eof($fh)) { my $block_magic = pack "B48", join('', map { read_bit($fh, \$buffer) } 1 .. 48); if ($block_magic eq "1AY&SY") { # BlockHeader say STDERR "Block header detected"; my $crc32 = bits2int($fh, 32, \$buffer); say STDERR "CRC32 = $crc32"; my $randomized = read_bit($fh, \$buffer); $randomized == 0 or die "randomized not supported"; my $bwt_idx = bits2int($fh, 24, \$buffer); say STDERR "BWT index: $bwt_idx"; my @alphabet; my $l1 = bits2int($fh, 16, \$buffer); for my $i (0 .. 15) { if ($l1 & (0x8000 >> $i)) { my $l2 = bits2int($fh, 16, \$buffer); for my $j (0 .. 15) { if ($l2 & (0x8000 >> $j)) { push @alphabet, 16 * $i + $j; } } } } say STDERR "MTF alphabet: (@alphabet)"; my $num_trees = bits2int($fh, 3, \$buffer); say STDERR "Number or trees: $num_trees"; my $num_sels = bits2int($fh, 15, \$buffer); say STDERR "Number of selectors: $num_sels"; my @idxs; for (1 .. $num_sels) { my $i = 0; while (read_bit($fh, \$buffer)) { $i += 1; ($i < $num_trees) or die "error"; } push @idxs, $i; } my $sels = mtf_decode(\@idxs, [0 .. $num_trees - 1]); say STDERR "Selectors: (@$sels)"; my $MaxHuffmanBits = 20; my $num_syms = scalar(@alphabet) + 2; my @trees; for (1 .. $num_trees) { my @clens; my $clen = bits2int($fh, 5, \$buffer); for (1 .. $num_syms) { while (1) { ($clen > 0 and $clen <= $MaxHuffmanBits) or warn "Invalid code length: $clen!\n"; if (not read_bit($fh, \$buffer)) { last; } $clen -= read_bit($fh, \$buffer) ? 1 : -1; } push @clens, $clen; } push @trees, \@clens; say STDERR "Code lengths: (@clens)"; } foreach my $tree (@trees) { my $maxLen = max(@$tree); my $sum = 1 << $maxLen; for my $clen (@$tree) { $sum -= (1 << $maxLen) >> $clen; } $sum == 0 or warn "incomplete tree detected: (@$tree)\n"; } my @huffman_trees = map { (huffman_from_code_lengths($_))[1] } @trees; my $eob = @alphabet + 1; my @zrle; my $code = ''; my $sel_idx = 0; my $tree = $huffman_trees[$sels->[$sel_idx]]; my $decoded = 50; while (!eof($fh)) { $code .= read_bit($fh, \$buffer); if (length($code) > $MaxHuffmanBits) { die "[!] Something went wrong: length of LL code `$code` is > $MaxHuffmanBits.\n"; } if (exists($tree->{$code})) { my $sym = $tree->{$code}; if ($sym == $eob) { # end of block marker say STDERR "EOB detected: $sym"; last; } push @zrle, $sym; $code = ''; if (--$decoded <= 0) { if (++$sel_idx <= $#$sels) { $tree = $huffman_trees[$sels->[$sel_idx]]; } else { die "No more selectors"; # should not happen } $decoded = 50; } } } ##say STDERR "ZRLE: (@zrle)"; my @mtf = reverse @{zrle_decode([reverse @zrle])}; ##say STDERR "MTF: (@mtf)"; my $bwt = symbols2string mtf_decode(\@mtf, \@alphabet); ## say "BWT: ($bwt, $bwt_idx)"; my $rle4 = string2symbols bwt_decode($bwt, $bwt_idx); my $data = rle4_decode($rle4); my $dec = symbols2string($data); my $new_crc32 = oct('0b' . int2bits_lsb(crc32(pack('b*', unpack('B*', $dec))), 32)); say STDERR "Computed CRC32: $new_crc32"; if ($crc32 != $new_crc32) { warn "CRC32 error: $crc32 (stored) != $new_crc32 (actual)\n"; } $stream_crc32 = ($new_crc32 ^ (0xffffffff & ((0xffffffff & ($stream_crc32 << 1)) | (($stream_crc32 >> 31) & 0x1)))) & 0xffffffff; print $out_fh $dec; } elsif ($block_magic eq "\27rE8P\x90") { # BlockFooter say STDERR "Block footer detected"; my $stored_stream_crc32 = bits2int($fh, 32, \$buffer); say STDERR "Stream CRC32: $stored_stream_crc32"; if ($stream_crc32 != $stored_stream_crc32) { warn "Stream CRC32 error: $stored_stream_crc32 (stored) != $stream_crc32 (actual)\n"; } $buffer = ''; last; } else { die "Unknown block magic: $block_magic"; } } say STDERR "End of container"; } say STDERR "End of input"; return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_bzip2_decompress($in_fh, $out_fh) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_bzip2_compress($in_fh, $out_fh) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } main(); exit(0); ================================================ FILE: Compression/compress.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 May 2023 # https://github.com/trizen # A basic implementation of the UNIX `compress` tool, creating a .Z compressed file, using LZW compression. # This implementation reads from STDIN and outputs to STDOUT: # perl compress.pl < input.txt > output.Z # Reference: # Data Compression (Summer 2023) - Lecture 4 - The Unix 'compress' Program # https://youtube.com/watch?v=1cJL9Va80Pk # See also: # https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch use 5.036; use constant { BUFFER_SIZE => 8 * 512, # must be a multiple of 8 MAGIC_SIGNATURE => "\x1f\x9d\x90", }; sub compress ($in_fh, $out_fh) { binmode($in_fh, ':raw'); binmode($out_fh, ':raw'); print {$out_fh} MAGIC_SIGNATURE; my $dict_size = 256; my %dictionary = (map { (chr($_), $_) } 0 .. $dict_size - 1); ++$dict_size; # 256 is the 'RESET' marker my $num_bits = 9; my $max_bits = 16; my $max_bits_size = (1 << $num_bits); my $max_dict_size = (1 << $max_bits); my $bitstream = ''; my $bitstream_size = 0; my sub output_index ($symbol) { $bitstream .= reverse(sprintf('%0*b', $num_bits, $dictionary{$symbol})); $bitstream_size += $num_bits; if ($bitstream_size % BUFFER_SIZE == 0) { print {$out_fh} pack("b*", $bitstream); $bitstream = ''; $bitstream_size = 0; } } my $w = ''; while (defined(my $c = getc($in_fh))) { my $wc = $w . $c; if (exists($dictionary{$wc})) { $w = $wc; } else { output_index($w); if ($dict_size < $max_dict_size) { $dictionary{$wc} = $dict_size++; if ($dict_size > $max_bits_size) { ++$num_bits; $max_bits_size <<= 1; } } $w = $c; } } if ($w ne '') { output_index($w); } if ($bitstream ne '') { print {$out_fh} pack('b*', $bitstream); } return 1; } compress(\*STDIN, \*STDOUT); ================================================ FILE: Compression/gzip2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 May 2024 # Edit: 06 November 2024 # https://github.com/trizen # A valid Gzip file compressor/decompressor, generating DEFLATE blocks of type 0, 1 or 2, whichever is smaller. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(all min max); use Getopt::Std qw(getopts); use constant { FORMAT => 'gz', CHUNK_SIZE => (1 << 15) - 1, }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # how many recent positions to remember in LZ parsing local $Compression::Util::VERBOSE = 1; my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables(); sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } ################# # GZIP COMPRESSOR ################# sub my_gzip_compress ($in_fh, $out_fh) { print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $crc32 = 0; my $bitstring = ''; if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . '0000000'; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { $crc32 = crc32($chunk, $crc32); $total_length += length($chunk); my ($literals, $distances, $lengths) = lzss_encode($chunk); $bitstring .= eof($in_fh) ? '1' : '0'; my $bt1_bitstring = deflate_create_block_type_1($literals, $distances, $lengths); # When block type 1 is larger than the input, then we have random uncompressible data: use block type 0 if ((length($bt1_bitstring) >> 3) > length($chunk) + 5) { say STDERR ":: Using block type: 0"; $bitstring .= '00'; print $out_fh pack('b*', $bitstring); # pads to a byte print $out_fh pack('b*', deflate_create_block_type_0_header($chunk)); print $out_fh $chunk; $bitstring = ''; next; } my $bt2_bitstring = deflate_create_block_type_2($literals, $distances, $lengths); # When block type 2 is larger than block type 1, then we may have very small data if (length($bt2_bitstring) > length($bt1_bitstring)) { say STDERR ":: Using block type: 1"; $bitstring .= $bt1_bitstring; } else { say STDERR ":: Using block type: 2"; $bitstring .= $bt2_bitstring; } print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh pack('b*', int2bits_lsb($crc32, 32)); print $out_fh pack('b*', int2bits_lsb($total_length, 32)); return 1; } ################### # GZIP DECOMPRESSOR ################### sub my_gzip_decompress ($in_fh, $out_fh) { my $MAGIC = (getc($in_fh) // die "error") . (getc($in_fh) // die "error"); if ($MAGIC ne pack('C*', 0x1f, 0x8b)) { die "Not a valid Gzip container!\n"; } my $CM = getc($in_fh) // die "error"; # 0x08 = DEFLATE my $FLAGS = ord(getc($in_fh) // die "error"); # flags my $MTIME = join('', map { getc($in_fh) // die "error" } 1 .. 4); # modification time my $XFLAGS = getc($in_fh) // die "error"; # extra flags my $OS = getc($in_fh) // die "error"; # 0x03 = Unix if ($CM ne chr(0x08)) { die "Only DEFLATE compression method is supported (0x08)! Got: 0x", sprintf('%02x', ord($CM)); } # Reference: # https://web.archive.org/web/20240221024029/https://forensics.wiki/gzip/ my $has_filename = 0; my $has_comment = 0; my $has_header_checksum = 0; my $has_extra_fields = 0; if ($FLAGS & 0x08) { $has_filename = 1; } if ($FLAGS & 0x10) { $has_comment = 1; } if ($FLAGS & 0x02) { $has_header_checksum = 1; } if ($FLAGS & 0x04) { $has_extra_fields = 1; } if ($has_extra_fields) { my $size = bytes2int_lsb($in_fh, 2); read($in_fh, (my $extra_field_data), $size) // die "can't read extra field data: $!"; say STDERR ":: Extra field data: $extra_field_data"; } if ($has_filename) { my $filename = read_null_terminated($in_fh); # filename say STDERR ":: Filename: $filename"; } if ($has_comment) { my $comment = read_null_terminated($in_fh); # comment say STDERR ":: Comment: $comment"; } if ($has_header_checksum) { my $header_checksum = bytes2int_lsb($in_fh, 2); say STDERR ":: Header checksum: $header_checksum"; } my $crc32 = 0; my $actual_length = 0; my $buffer = ''; my $search_window = ''; while (1) { my $is_last = read_bit_lsb($in_fh, \$buffer); my $chunk = deflate_extract_next_block($in_fh, \$buffer, \$search_window); print $out_fh $chunk; $crc32 = crc32($chunk, $crc32); $actual_length += length($chunk); last if $is_last; } $buffer = ''; # discard any padding bits my $stored_crc32 = bits2int_lsb($in_fh, 32, \$buffer); my $actual_crc32 = $crc32; say STDERR ''; if ($stored_crc32 != $actual_crc32) { print STDERR "[!] The CRC32 does not match: $actual_crc32 (actual) != $stored_crc32 (stored)\n"; } else { print STDERR ":: CRC32 value: $actual_crc32\n"; } my $stored_length = bits2int_lsb($in_fh, 32, \$buffer); if ($stored_length != $actual_length) { print STDERR "[!] The length does not match: $actual_length (actual) != $stored_length (stored)\n"; } else { print STDERR ":: Total length: $actual_length\n"; } if (eof($in_fh)) { print STDERR "\n:: Reached the end of the file.\n"; } else { print STDERR "\n:: There is something else in the container! Trying to recurse!\n\n"; __SUB__->($in_fh, $out_fh); } } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_gzip_decompress($in_fh, $out_fh) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_gzip_compress($in_fh, $out_fh) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } main(); exit(0); ================================================ FILE: Compression/gzip_block_type_1.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2024 # Edit: 05 April 2024 # https://github.com/trizen # Create a valid Gzip container, using DEFLATE's Block Type 1: LZSS + fixed-length prefix codes. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use constant {CHUNK_SIZE => (1 << 18) - 1,}; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # how many recent positions to remember in LZ parsing my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my $input = $ARGV[0] // die "usage: $0 [input] [output.gz]\n"; my $output = $ARGV[1] // (basename($input) . '.gz'); open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $crc32 = 0; my $bitstring = ''; my $block_type = '10'; # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes my @code_lengths = (0) x 288; foreach my $i (0 .. 143) { $code_lengths[$i] = 8; } foreach my $i (144 .. 255) { $code_lengths[$i] = 9; } foreach my $i (256 .. 279) { $code_lengths[$i] = 7; } foreach my $i (280 .. 287) { $code_lengths[$i] = 8; } my ($dict) = huffman_from_code_lengths(\@code_lengths); my ($dist_dict) = huffman_from_code_lengths([(5) x 32]); my ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables(); if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . $dict->{256}; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { my $chunk_len = length($chunk); my $is_last = eof($in_fh) ? '1' : '0'; my $block_header = join('', $is_last, $block_type); $bitstring .= $block_header; my ($literals, $indices, $lengths) = lzss_encode($chunk); foreach my $k (0 .. $#$literals) { if ($lengths->[$k] == 0) { $bitstring .= $dict->{$literals->[$k]}; next; } my $len = $lengths->[$k]; my $dist = $indices->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; $bitstring .= $dict->{$len_idx + 256 - 1}; $bitstring .= int2bits_lsb($len - $min, $bits) if ($bits > 0); } { my $dist_idx = find_deflate_index($dist, $DISTANCE_SYMBOLS); my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; $bitstring .= $dist_dict->{$dist_idx - 1}; $bitstring .= int2bits_lsb($dist - $min, $bits) if ($bits > 0); } } $bitstring .= $dict->{256}; # end-of-block symbol my $bits_len = length($bitstring); print $out_fh pack('b*', substr($bitstring, 0, $bits_len - ($bits_len % 8), '')); $crc32 = crc32($chunk, $crc32); $total_length += $chunk_len; } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh pack('b*', int2bits_lsb($crc32, 32)); print $out_fh pack('b*', int2bits_lsb($total_length, 32)); close $in_fh; close $out_fh; ================================================ FILE: Compression/gzip_block_type_1_huffman_only.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2024 # Edit: 05 April 2024 # https://github.com/trizen # Create a valid Gzip container, using DEFLATE's Block Type 1 with fixed-length prefix codes only, without LZSS. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use constant { CHUNK_SIZE => 0xffff, # 2^16 - 1 }; my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my $input = $ARGV[0] // die "usage: $0 [input] [output.gz]\n"; my $output = $ARGV[1] // (basename($input) . '.gz'); open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $crc32 = 0; my $bitstring = ''; my $block_type = '10'; # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes my @code_lengths = (0) x 288; foreach my $i (0 .. 143) { $code_lengths[$i] = 8; } foreach my $i (144 .. 255) { $code_lengths[$i] = 9; } foreach my $i (256 .. 279) { $code_lengths[$i] = 7; } foreach my $i (280 .. 287) { $code_lengths[$i] = 8; } my ($dict) = huffman_from_code_lengths(\@code_lengths); if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . $dict->{256}; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { my $chunk_len = length($chunk); my $is_last = eof($in_fh) ? '1' : '0'; my $block_header = join('', $is_last, $block_type); $bitstring .= $block_header; $bitstring .= huffman_encode([unpack('C*', $chunk), 256], $dict); print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); $crc32 = crc32($chunk, $crc32); $total_length += $chunk_len; } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh pack('b*', int2bits_lsb($crc32, 32)); print $out_fh pack('b*', int2bits_lsb($total_length, 32)); close $in_fh; close $out_fh; ================================================ FILE: Compression/gzip_block_type_2.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2024 # Edit: 11 April 2024 # https://github.com/trizen # Create a valid Gzip container, using DEFLATE's Block Type 2: LZSS + dynamic prefix codes. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(all min max); use constant {CHUNK_SIZE => (1 << 15) - 1,}; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # how many recent positions to remember in LZ parsing my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my $input = $ARGV[0] // die "usage: $0 [input] [output.gz]\n"; my $output = $ARGV[1] // (basename($input) . '.gz'); sub code_length_encoding ($dict) { my @lengths; foreach my $symbol (0 .. max(keys %$dict) // 0) { if (exists($dict->{$symbol})) { push @lengths, length($dict->{$symbol}); } else { push @lengths, 0; } } my $size = scalar(@lengths); my $rl = run_length(\@lengths); my $offset_bits = ''; my @CL_symbols; foreach my $pair (@$rl) { my ($v, $run) = @$pair; while ($v == 0 and $run >= 3) { if ($run >= 11) { push @CL_symbols, 18; $run -= 11; $offset_bits .= int2bits_lsb(min($run, 127), 7); $run -= 127; } if ($run >= 3 and $run < 11) { push @CL_symbols, 17; $run -= 3; $offset_bits .= int2bits_lsb(min($run, 7), 3); $run -= 7; } } if ($v == 0) { push(@CL_symbols, (0) x $run) if ($run > 0); next; } push @CL_symbols, $v; $run -= 1; while ($run >= 3) { push @CL_symbols, 16; $run -= 3; $offset_bits .= int2bits_lsb(min($run, 3), 2); $run -= 3; } push(@CL_symbols, ($v) x $run) if ($run > 0); } return (\@CL_symbols, $size, $offset_bits); } sub cl_encoded_bitstring ($cl_dict, $cl_symbols, $offset_bits) { my $bitstring = ''; foreach my $cl_symbol (@$cl_symbols) { $bitstring .= $cl_dict->{$cl_symbol}; if ($cl_symbol == 16) { $bitstring .= substr($offset_bits, 0, 2, ''); } elsif ($cl_symbol == 17) { $bitstring .= substr($offset_bits, 0, 3, ''); } elsif ($cl_symbol == 18) { $bitstring .= substr($offset_bits, 0, 7, ''); } } return $bitstring; } sub create_cl_dictionary (@cl_symbols) { my @keys; my $freq = frequencies(\@cl_symbols); while (1) { my ($cl_dict) = huffman_from_freq($freq); # The CL codes must have at most 7 bits return $cl_dict if all { length($_) <= 7 } values %$cl_dict; if (scalar(@keys) == 0) { @keys = sort { $freq->{$b} <=> $freq->{$a} } keys %$freq; } # Scale down the frequencies and try again foreach my $k (@keys) { if ($freq->{$k} > 1) { $freq->{$k} >>= 1; } else { last; } } } } open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $crc32 = 0; my $bitstring = ''; my $block_type = '01'; # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes my @CL_order = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); my ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables(); if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . '0000000'; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { my $chunk_len = length($chunk); my $is_last = eof($in_fh) ? '1' : '0'; my $block_header = join('', $is_last, $block_type); my ($literals, $distances, $lengths) = lzss_encode($chunk); my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $k (0 .. $#$literals) { if ($lengths->[$k] == 0) { push @len_symbols, $literals->[$k]; next; } my $len = $lengths->[$k]; my $dist = $distances->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @len_symbols, [$len_idx + 256 - 1, $bits]; $offset_bits .= int2bits_lsb($len - $min, $bits) if ($bits > 0); } { my $dist_idx = find_deflate_index($dist, $DISTANCE_SYMBOLS); my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @dist_symbols, [$dist_idx - 1, $bits]; $offset_bits .= int2bits_lsb($dist - $min, $bits) if ($bits > 0); } } push @len_symbols, 256; # end-of-block marker my ($dict) = huffman_from_symbols([map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @len_symbols]); my ($dist_dict) = huffman_from_symbols([map { $_->[0] } @dist_symbols]); my ($LL_code_lengths, $LL_cl_len, $LL_offset_bits) = code_length_encoding($dict); my ($distance_code_lengths, $distance_cl_len, $distance_offset_bits) = code_length_encoding($dist_dict); my $cl_dict = create_cl_dictionary(@$LL_code_lengths, @$distance_code_lengths); my @CL_code_lenghts; foreach my $symbol (0 .. 18) { if (exists($cl_dict->{$symbol})) { push @CL_code_lenghts, length($cl_dict->{$symbol}); } else { push @CL_code_lenghts, 0; } } # Put the CL codes in the required order @CL_code_lenghts = @CL_code_lenghts[@CL_order]; while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) { pop @CL_code_lenghts; } my $CL_code_lengths_bitstring = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts); my $LL_code_lengths_bitstring = cl_encoded_bitstring($cl_dict, $LL_code_lengths, $LL_offset_bits); my $distance_code_lengths_bitstring = cl_encoded_bitstring($cl_dict, $distance_code_lengths, $distance_offset_bits); # (5 bits) HLIT = (number of LL code entries present) - 257 my $HLIT = $LL_cl_len - 257; # (5 bits) HDIST = (number of distance code entries present) - 1 my $HDIST = $distance_cl_len - 1; # (4 bits) HCLEN = (number of CL code entries present) - 4 my $HCLEN = scalar(@CL_code_lenghts) - 4; $block_header .= int2bits_lsb($HLIT, 5); $block_header .= int2bits_lsb($HDIST, 5); $block_header .= int2bits_lsb($HCLEN, 4); $block_header .= $CL_code_lengths_bitstring; $block_header .= $LL_code_lengths_bitstring; $block_header .= $distance_code_lengths_bitstring; $bitstring .= $block_header; foreach my $symbol (@len_symbols) { if (ref($symbol) eq 'ARRAY') { my ($len, $len_offset) = @$symbol; $bitstring .= $dict->{$len}; $bitstring .= substr($offset_bits, 0, $len_offset, '') if ($len_offset > 0); my ($dist, $dist_offset) = @{shift(@dist_symbols)}; $bitstring .= $dist_dict->{$dist}; $bitstring .= substr($offset_bits, 0, $dist_offset, '') if ($dist_offset > 0); } else { $bitstring .= $dict->{$symbol}; } } print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); $crc32 = crc32($chunk, $crc32); $total_length += $chunk_len; } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh pack('b*', int2bits_lsb($crc32, 32)); print $out_fh pack('b*', int2bits_lsb($total_length, 32)); close $in_fh; close $out_fh; ================================================ FILE: Compression/gzip_block_type_2_huffman_only.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2024 # Edit: 09 April 2024 # https://github.com/trizen # Create a valid Gzip container, using DEFLATE's Block Type 2 with dynamic prefix codes only, without LZSS. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(uniq); use constant { CHUNK_SIZE => (1 << 15) - 1, # 2^15 - 1 }; my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my $input = $ARGV[0] // die "usage: $0 [input] [output.gz]\n"; my $output = $ARGV[1] // (basename($input) . '.gz'); open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $crc32 = 0; my $bitstring = ''; my $block_type = '01'; # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes my @CL_order = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . '0000000'; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { my $chunk_len = length($chunk); my $is_last = eof($in_fh) ? '1' : '0'; my $block_header = join('', $is_last, $block_type); my @symbols = (unpack('C*', $chunk), 256); my ($dict, $rev_dict) = huffman_from_symbols(\@symbols); my @LL_code_lengths; foreach my $symbol (0 .. 285) { if (exists($dict->{$symbol})) { push @LL_code_lengths, length($dict->{$symbol}); } else { push @LL_code_lengths, 0; } } while (scalar(@LL_code_lengths) > 1 and $LL_code_lengths[-1] == 0) { pop @LL_code_lengths; } my @distance_code_lengths; foreach my $symbol (0 .. 29) { push @distance_code_lengths, 0; } while (scalar(@distance_code_lengths) > 1 and $distance_code_lengths[-1] == 0) { pop @distance_code_lengths; } my @CL_code; foreach my $length (uniq(@LL_code_lengths, @distance_code_lengths)) { push @CL_code, $length; } my ($cl_dict) = huffman_from_symbols(\@CL_code); my @CL_code_lenghts; foreach my $symbol (0 .. 18) { if (exists($cl_dict->{$symbol})) { push @CL_code_lenghts, length($cl_dict->{$symbol}); } else { push @CL_code_lenghts, 0; } } # Put the CL codes in the required order @CL_code_lenghts = @CL_code_lenghts[@CL_order]; while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) { pop @CL_code_lenghts; } my $CL_code_lengths_bitstring = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts); my $LL_code_lengths_bitstring = join('', map { $cl_dict->{$_} } @LL_code_lengths); my $distance_code_lengths_bitstring = join('', map { $cl_dict->{$_} } @distance_code_lengths); # (5 bits) HLIT = (number of LL code entries present) - 257 my $HLIT = scalar(@LL_code_lengths) - 257; # (5 bits) HDIST = (number of distance code entries present) - 1 my $HDIST = scalar(@distance_code_lengths) - 1; # (4 bits) HCLEN = (number of CL code entries present) - 4 my $HCLEN = scalar(@CL_code_lenghts) - 4; $block_header .= int2bits_lsb($HLIT, 5); $block_header .= int2bits_lsb($HDIST, 5); $block_header .= int2bits_lsb($HCLEN, 4); $block_header .= $CL_code_lengths_bitstring; $block_header .= $LL_code_lengths_bitstring; $block_header .= $distance_code_lengths_bitstring; $bitstring .= $block_header; $bitstring .= huffman_encode(\@symbols, $dict); print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); $crc32 = crc32($chunk, $crc32); $total_length += $chunk_len; } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh pack('b*', int2bits_lsb($crc32, 32)); print $out_fh pack('b*', int2bits_lsb($total_length, 32)); close $in_fh; close $out_fh; ================================================ FILE: Compression/gzip_block_type_2_simple.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2024 # Edit: 09 April 2024 # https://github.com/trizen # Create a valid Gzip container, using DEFLATE's Block Type 2: LZSS + dynamic prefix codes. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(uniq); use constant {CHUNK_SIZE => (1 << 15) - 1,}; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # how many recent positions to remember in LZ parsing my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my $input = $ARGV[0] // die "usage: $0 [input] [output.gz]\n"; my $output = $ARGV[1] // (basename($input) . '.gz'); open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $crc32 = 0; my $bitstring = ''; my $block_type = '01'; # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes my @CL_order = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); my ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables(); if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . '0000000'; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { my $chunk_len = length($chunk); my $is_last = eof($in_fh) ? '1' : '0'; my $block_header = join('', $is_last, $block_type); my ($literals, $distances, $lengths) = lzss_encode($chunk); my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $k (0 .. $#$literals) { if ($lengths->[$k] == 0) { push @len_symbols, $literals->[$k]; next; } my $len = $lengths->[$k]; my $dist = $distances->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @len_symbols, [$len_idx + 256 - 1, $bits]; $offset_bits .= int2bits_lsb($len - $min, $bits) if ($bits > 0); } { my $dist_idx = find_deflate_index($dist, $DISTANCE_SYMBOLS); my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @dist_symbols, [$dist_idx - 1, $bits]; $offset_bits .= int2bits_lsb($dist - $min, $bits) if ($bits > 0); } } push @len_symbols, 256; # end-of-block marker my ($dict) = huffman_from_symbols([map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @len_symbols]); my ($dist_dict) = huffman_from_symbols([map { $_->[0] } @dist_symbols]); my @LL_code_lengths; foreach my $symbol (0 .. 285) { if (exists($dict->{$symbol})) { push @LL_code_lengths, length($dict->{$symbol}); } else { push @LL_code_lengths, 0; } } while (scalar(@LL_code_lengths) > 1 and $LL_code_lengths[-1] == 0) { pop @LL_code_lengths; } my @distance_code_lengths; foreach my $symbol (0 .. 29) { if (exists($dist_dict->{$symbol})) { push @distance_code_lengths, length($dist_dict->{$symbol}); } else { push @distance_code_lengths, 0; } } while (scalar(@distance_code_lengths) > 1 and $distance_code_lengths[-1] == 0) { pop @distance_code_lengths; } my @CL_code = uniq(@LL_code_lengths, @distance_code_lengths); my ($cl_dict) = huffman_from_symbols(\@CL_code); my @CL_code_lenghts; foreach my $symbol (0 .. 18) { if (exists($cl_dict->{$symbol})) { push @CL_code_lenghts, length($cl_dict->{$symbol}); } else { push @CL_code_lenghts, 0; } } # Put the CL codes in the required order @CL_code_lenghts = @CL_code_lenghts[@CL_order]; while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) { pop @CL_code_lenghts; } my $CL_code_lengths_bitstring = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts); my $LL_code_lengths_bitstring = join('', @{$cl_dict}{@LL_code_lengths}); my $distance_code_lengths_bitstring = join('', @{$cl_dict}{@distance_code_lengths}); # (5 bits) HLIT = (number of LL code entries present) - 257 my $HLIT = scalar(@LL_code_lengths) - 257; # (5 bits) HDIST = (number of distance code entries present) - 1 my $HDIST = scalar(@distance_code_lengths) - 1; # (4 bits) HCLEN = (number of CL code entries present) - 4 my $HCLEN = scalar(@CL_code_lenghts) - 4; $block_header .= int2bits_lsb($HLIT, 5); $block_header .= int2bits_lsb($HDIST, 5); $block_header .= int2bits_lsb($HCLEN, 4); $block_header .= $CL_code_lengths_bitstring; $block_header .= $LL_code_lengths_bitstring; $block_header .= $distance_code_lengths_bitstring; $bitstring .= $block_header; foreach my $symbol (@len_symbols) { if (ref($symbol) eq 'ARRAY') { my ($len, $len_offset) = @$symbol; $bitstring .= $dict->{$len}; $bitstring .= substr($offset_bits, 0, $len_offset, '') if ($len_offset > 0); my ($dist, $dist_offset) = @{shift(@dist_symbols)}; $bitstring .= $dist_dict->{$dist}; $bitstring .= substr($offset_bits, 0, $dist_offset, '') if ($dist_offset > 0); } else { $bitstring .= $dict->{$symbol}; } } print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); $crc32 = crc32($chunk, $crc32); $total_length += $chunk_len; } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh pack('b*', int2bits_lsb($crc32, 32)); print $out_fh pack('b*', int2bits_lsb($total_length, 32)); close $in_fh; close $out_fh; ================================================ FILE: Compression/gzip_comment.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 21 January 2024 # https://github.com/trizen # Add and extract a GZIP comment, given a ".gz" file. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # GZIP file format specification version 4.3 # https://datatracker.ietf.org/doc/html/rfc1952 use 5.036; use Getopt::Std qw(getopts); use MIME::Base64 qw(encode_base64 decode_base64); use constant { CHUNK_SIZE => 0xffff, # 2^16 - 1 }; getopts('ebho:', \my %opts); sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.gz] [comment.txt]" options: -o : output file -e : extract comment -b : base64 encoding / decoding of the comment -h : print this message and exit example: # Add comment to "input.gz" from "file.txt" (base64-encoded) perl $0 -o output.gz -b input.gz file.txt # Extract comment from "input.gz" (base64-decoded) perl $0 -o comment.txt -eb input.gz EOT exit $exit_code; } sub read_null_terminated ($in_fh) { my $string = ''; while (1) { my $c = getc($in_fh) // die "Invalid gzip data"; last if $c eq "\0"; $string .= $c; } return $string; } sub extract_comment ($input_gz, $output_file) { open my $in_fh, '<:raw', $input_gz or die "Can't open file <<$input_gz>> for reading: $!"; my $MAGIC = (getc($in_fh) // die "error") . (getc($in_fh) // die "error"); if ($MAGIC ne pack('C*', 0x1f, 0x8b)) { die "Not a Gzip file: $input_gz\n"; } my $CM = getc($in_fh) // die "error"; # 0x08 = DEFLATE my $FLAGS = getc($in_fh) // die "error"; # flags my $MTIME = join('', map { getc($in_fh) // die "error" } 1 .. 4); # modification time my $XFLAGS = getc($in_fh) // die "error"; # extra flags my $OS = getc($in_fh) // die "error"; # 0x03 = Unix my $has_filename = 0; if ((ord($FLAGS) & 0b0000_1000) != 0) { say STDERR "Has filename."; $has_filename = 1; } if ((ord($FLAGS) & 0b0001_0000) != 0) { say STDERR "Has comment."; } else { die "No comment was found.\n"; } if ($has_filename) { read_null_terminated($in_fh); # filename } my $comment = read_null_terminated($in_fh); my $out_fh; if (defined($output_file)) { open $out_fh, '>:raw', $output_file or die "Can't open file <<$output_file>> for writing: $!"; } else { $out_fh = \*STDOUT; } if ($opts{b}) { $comment = decode_base64($comment); } print $out_fh $comment; } sub add_comment ($input_gz, $comment_file, $output_gz) { if (!defined($output_gz)) { if ($input_gz =~ /\.tar\.gz\z/) { $output_gz = "output.tar.gz"; } elsif ($input_gz =~ /\.tgz\z/) { $output_gz = "output.tgz"; } else { $output_gz = "output.gz"; } } if (-e $output_gz) { die "Output file <<$output_gz>> already exists!\n"; } open my $in_fh, '<:raw', $input_gz or die "Can't open file <<$input_gz>> for reading: $!"; open my $comment_fh, '<:raw', $comment_file or die "Can't open file <<$comment_file>> for reading: $!"; my $MAGIC = (getc($in_fh) // die "error") . (getc($in_fh) // die "error"); if ($MAGIC ne pack('C*', 0x1f, 0x8b)) { die "Not a Gzip file: $input_gz\n"; } my $CM = getc($in_fh) // die "error"; # 0x08 = DEFLATE my $FLAGS = getc($in_fh) // die "error"; # flags my $MTIME = join('', map { getc($in_fh) // die "error" } 1 .. 4); # modification time my $XFLAGS = getc($in_fh) // die "error"; # extra flags my $OS = getc($in_fh) // die "error"; # 0x03 = Unix open my $out_fh, '>:raw', $output_gz or die "Can't open file <<$output_gz>> for writing: $!"; print $out_fh $MAGIC, $CM, chr(ord($FLAGS) | 0b0001_0000), $MTIME, $XFLAGS, $OS; my $has_filename = 0; my $has_comment = 0; if ((ord($FLAGS) & 0b0000_1000) != 0) { say STDERR "Has filename."; $has_filename = 1; } else { say STDERR "Has no filename."; } if ((ord($FLAGS) & 0b0001_0000) != 0) { say STDERR "Has comment."; $has_comment = 1; } else { say STDERR "Has no existing comment."; } if ($has_filename) { my $filename = read_null_terminated($in_fh); # filename print $out_fh $filename . "\0"; } if ($has_comment) { say STDERR "Replacing existing comment."; read_null_terminated($in_fh); # remove existing comment } else { say STDERR "Adding comment from file."; } my $comment = do { local $/; <$comment_fh>; }; if ($opts{b}) { $comment = encode_base64($comment); } print $out_fh $comment; print $out_fh "\0"; # Copy the rest of the gzip file while (read($in_fh, (my $chunk), CHUNK_SIZE)) { print $out_fh $chunk; } return 1; } if ($opts{h}) { usage(0); } my $input_gz = shift(@ARGV) // usage(2); if ($opts{e}) { extract_comment($input_gz, $opts{o}); } else { my $comment_file = shift(@ARGV) // usage(2); add_comment($input_gz, $comment_file, $opts{o}); } ================================================ FILE: Compression/gzip_decompressor.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2024 # Edit: 14 April 2024 # https://github.com/trizen # Decompress GZIP files (.gz). # DEFLATE's block type 0, 1 and 2 are all supported. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use List::Util qw(max); use Compression::Util qw(:all); local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing sub extract_block_type_0 ($in_fh, $buffer) { my $len = bits2int_lsb($in_fh, 16, $buffer); my $nlen = bits2int_lsb($in_fh, 16, $buffer); my $expected_nlen = (~$len) & 0xffff; if ($expected_nlen != $nlen) { die "[!] The ~length value is not correct: $nlen (actual) != $expected_nlen (expected)\n"; } else { print STDERR ":: Chunk length: $len\n"; } read($in_fh, (my $chunk), $len); return $chunk; } my ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS) = make_deflate_tables(); sub decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window) { my $data = ''; my $code = ''; my $max_ll_code_len = max(map { length($_) } keys %$rev_dict); my $max_dist_code_len = max(map { length($_) } keys %$dist_rev_dict); while (1) { $code .= read_bit_lsb($in_fh, $buffer); if (length($code) > $max_ll_code_len) { die "[!] Something went wrong: length of LL code `$code` is > $max_ll_code_len.\n"; } if (exists($rev_dict->{$code})) { my $symbol = $rev_dict->{$code}; if ($symbol <= 255) { $data .= chr($symbol); $$search_window .= chr($symbol); } elsif ($symbol == 256) { # end-of-block marker $code = ''; last; } else { # LZSS decoding my ($length, $LL_bits) = @{$LENGTH_SYMBOLS->[$symbol - 256 + 1]}; $length += bits2int_lsb($in_fh, $LL_bits, $buffer) if ($LL_bits > 0); my $dist_code = ''; while (1) { $dist_code .= read_bit_lsb($in_fh, $buffer); if (length($dist_code) > $max_dist_code_len) { die "[!] Something went wrong: length of distance code `$dist_code` is > $max_dist_code_len.\n"; } if (exists($dist_rev_dict->{$dist_code})) { last; } } my ($dist, $dist_bits) = @{$DISTANCE_SYMBOLS->[$dist_rev_dict->{$dist_code} + 1]}; $dist += bits2int_lsb($in_fh, $dist_bits, $buffer) if ($dist_bits > 0); if ($dist == 1) { $$search_window .= substr($$search_window, -1) x $length; } elsif ($dist >= $length) { # non-overlapping matches $$search_window .= substr($$search_window, length($$search_window) - $dist, $length); } else { # overlapping matches foreach my $i (1 .. $length) { $$search_window .= substr($$search_window, length($$search_window) - $dist, 1); } } $data .= substr($$search_window, -$length); } $code = ''; } } if ($code ne '') { die "[!] Something went wrong: code `$code` is not empty!\n"; } return $data; } sub extract_block_type_1 ($in_fh, $buffer, $search_window) { state $rev_dict; state $dist_rev_dict; if (!defined($rev_dict)) { my @code_lengths = (0) x 288; foreach my $i (0 .. 143) { $code_lengths[$i] = 8; } foreach my $i (144 .. 255) { $code_lengths[$i] = 9; } foreach my $i (256 .. 279) { $code_lengths[$i] = 7; } foreach my $i (280 .. 287) { $code_lengths[$i] = 8; } (undef, $rev_dict) = huffman_from_code_lengths(\@code_lengths); (undef, $dist_rev_dict) = huffman_from_code_lengths([(5) x 32]); } decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window); } sub decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $size) { my @lengths; my $code = ''; while (1) { $code .= read_bit_lsb($in_fh, $buffer); if (length($code) > 7) { die "[!] Something went wrong: length of CL code `$code` is > 7.\n"; } if (exists($CL_rev_dict->{$code})) { my $CL_symbol = $CL_rev_dict->{$code}; if ($CL_symbol <= 15) { push @lengths, $CL_symbol; } elsif ($CL_symbol == 16) { push @lengths, ($lengths[-1]) x (3 + bits2int_lsb($in_fh, 2, $buffer)); } elsif ($CL_symbol == 17) { push @lengths, (0) x (3 + bits2int_lsb($in_fh, 3, $buffer)); } elsif ($CL_symbol == 18) { push @lengths, (0) x (11 + bits2int_lsb($in_fh, 7, $buffer)); } else { die "Unknown CL symbol: $CL_symbol\n"; } $code = ''; last if (scalar(@lengths) >= $size); } } if (scalar(@lengths) != $size) { die "Something went wrong: size $size (expected) != ", scalar(@lengths); } if ($code ne '') { die "Something went wrong: code `$code` is not empty!"; } return @lengths; } sub extract_block_type_2 ($in_fh, $buffer, $search_window) { # (5 bits) HLIT = (number of LL code entries present) - 257 my $HLIT = bits2int_lsb($in_fh, 5, $buffer) + 257; # (5 bits) HDIST = (number of distance code entries present) - 1 my $HDIST = bits2int_lsb($in_fh, 5, $buffer) + 1; # (4 bits) HCLEN = (number of CL code entries present) - 4 my $HCLEN = bits2int_lsb($in_fh, 4, $buffer) + 4; say STDERR ":: Number of LL codes: $HLIT"; say STDERR ":: Number of dist codes: $HDIST"; say STDERR ":: Number of CL codes: $HCLEN"; my @CL_code_lenghts = (0) x 19; my @CL_order = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); foreach my $i (0 .. $HCLEN - 1) { $CL_code_lenghts[$CL_order[$i]] = bits2int_lsb($in_fh, 3, $buffer); } say STDERR ":: CL code lengths: @CL_code_lenghts"; my (undef, $CL_rev_dict) = huffman_from_code_lengths(\@CL_code_lenghts); my @LL_CL_lengths = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HLIT); my @dist_CL_lengths = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HDIST); my (undef, $LL_rev_dict) = huffman_from_code_lengths(\@LL_CL_lengths); my (undef, $dist_rev_dict) = huffman_from_code_lengths(\@dist_CL_lengths); decode_huffman($in_fh, $buffer, $LL_rev_dict, $dist_rev_dict, $search_window); } sub extract ($in_fh, $output_file, $defined_output_file) { my $MAGIC = (getc($in_fh) // die "error") . (getc($in_fh) // die "error"); if ($MAGIC ne pack('C*', 0x1f, 0x8b)) { die "Not a valid Gzip container!\n"; } my $CM = getc($in_fh) // die "error"; # 0x08 = DEFLATE my $FLAGS = ord(getc($in_fh) // die "error"); # flags my $MTIME = join('', map { getc($in_fh) // die "error" } 1 .. 4); # modification time my $XFLAGS = getc($in_fh) // die "error"; # extra flags my $OS = getc($in_fh) // die "error"; # 0x03 = Unix if ($CM ne chr(0x08)) { die "Only DEFLATE compression method is supported (0x08)! Got: 0x", sprintf('%02x', ord($CM)); } # Reference: # https://web.archive.org/web/20240221024029/https://forensics.wiki/gzip/ my $has_filename = 0; my $has_comment = 0; my $has_header_checksum = 0; my $has_extra_fields = 0; if ($FLAGS & 0x08) { $has_filename = 1; } if ($FLAGS & 0x10) { $has_comment = 1; } if ($FLAGS & 0x02) { $has_header_checksum = 1; } if ($FLAGS & 0x04) { $has_extra_fields = 1; } if ($has_extra_fields) { my $size = bytes2int_lsb($in_fh, 2); read($in_fh, (my $extra_field_data), $size) // die "can't read extra field data: $!"; say STDERR ":: Extra field data: $extra_field_data"; } if ($has_filename) { my $filename = read_null_terminated($in_fh); # filename say STDERR ":: Filename: ", $filename; if (not $defined_output_file) { $output_file = $filename; } } if ($has_comment) { my $comment = read_null_terminated($in_fh); # comment say STDERR ":: Comment: $comment"; } if ($has_header_checksum) { my $header_checksum = bytes2int_lsb($in_fh, 2); say STDERR ":: Header checksum: $header_checksum"; } my $out_fh = ref($output_file) eq 'GLOB' ? $output_file : undef; if (!defined($out_fh)) { open $out_fh, '>:raw', $output_file or die "Can't create file <<$output_file>>: $!"; } my $crc32 = 0; my $actual_length = 0; my $buffer = ''; my $search_window = ''; my $window_size = $Compression::Util::LZ_MAX_DIST; while (1) { my $is_last = read_bit_lsb($in_fh, \$buffer); my $block_type = bits2int_lsb($in_fh, 2, \$buffer); my $chunk = ''; if ($block_type == 0) { say STDERR "\n:: Extracting block of type 0"; $buffer = ''; # pad to a byte $chunk = extract_block_type_0($in_fh, \$buffer); $search_window .= $chunk; } elsif ($block_type == 1) { say STDERR "\n:: Extracting block of type 1"; $chunk = extract_block_type_1($in_fh, \$buffer, \$search_window); } elsif ($block_type == 2) { say STDERR "\n:: Extracting block of type 2"; $chunk = extract_block_type_2($in_fh, \$buffer, \$search_window); } else { die "[!] Unknown block of type: $block_type"; } print $out_fh $chunk; $crc32 = crc32($chunk, $crc32); $actual_length += length($chunk); $search_window = substr($search_window, -$window_size) if (length($search_window) > 2 * $window_size); last if $is_last; } $buffer = ''; # discard any padding bits my $stored_crc32 = bits2int_lsb($in_fh, 32, \$buffer); my $actual_crc32 = $crc32; say STDERR ''; if ($stored_crc32 != $actual_crc32) { print STDERR "[!] The CRC32 does not match: $actual_crc32 (actual) != $stored_crc32 (stored)\n"; } else { print STDERR ":: CRC32 value: $actual_crc32\n"; } my $stored_length = bits2int_lsb($in_fh, 32, \$buffer); if ($stored_length != $actual_length) { print STDERR "[!] The length does not match: $actual_length (actual) != $stored_length (stored)\n"; } else { print STDERR ":: Total length: $actual_length\n"; } if (eof($in_fh)) { print STDERR "\n:: Reached the end of the file.\n"; } else { print STDERR "\n:: There is something else in the container! Trying to recurse!\n\n"; __SUB__->($in_fh, $out_fh, 1); } } if (-t STDIN) { my $input = $ARGV[0] // die "usage: $0 [input] [output.gz]\n"; my $output = $ARGV[1] // ($input =~ s/\.gz\z//ir); open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; extract($fh, $output, defined($ARGV[1])); } else { extract(\*STDIN, \*STDOUT, 1); } ================================================ FILE: Compression/gzip_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 May 2024 # https://github.com/trizen # A valid Gzip file compressor/decompressor, generating DEFLATE blocks of type 0, 1 or 2, whichever is smaller. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(all min max); use Getopt::Std qw(getopts); use constant { FORMAT => 'gz', CHUNK_SIZE => (1 << 16) - 1, # increased for better LZ matching }; local $Compression::Util::LZ_MIN_LEN = 3; # minimum match length in LZ parsing (DEFLATE supports 3) local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::LZ_MAX_CHAIN_LEN = 128; # more thorough match search my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables(); my @DISTANCE_INDICES; foreach my $i (0 .. $#$DISTANCE_SYMBOLS) { my $min = $DISTANCE_SYMBOLS->[$i][0]; my $max = ($i < $#$DISTANCE_SYMBOLS) ? $DISTANCE_SYMBOLS->[$i + 1][0] - 1 : $Compression::Util::LZ_MAX_DIST; foreach my $d ($min .. $max) { $DISTANCE_INDICES[$d] = $i; } } sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } ################# # GZIP COMPRESSOR ################# sub code_length_encoding ($dict) { my @lengths; foreach my $symbol (0 .. max(keys %$dict) // 0) { if (exists($dict->{$symbol})) { push @lengths, length($dict->{$symbol}); } else { push @lengths, 0; } } my $size = scalar(@lengths); my $rl = run_length(\@lengths); my $offset_bits = ''; my @CL_symbols; foreach my $pair (@$rl) { my ($v, $run) = @$pair; while ($v == 0 and $run >= 3) { if ($run >= 11) { push @CL_symbols, 18; my $extra = min($run - 11, 127); $offset_bits .= int2bits_lsb($extra, 7); $run -= 11 + $extra; } if ($run >= 3 and $run < 11) { push @CL_symbols, 17; my $extra = min($run - 3, 7); $offset_bits .= int2bits_lsb($extra, 3); $run -= 3 + $extra; } } if ($v == 0) { push(@CL_symbols, (0) x $run) if ($run > 0); next; } push @CL_symbols, $v; $run -= 1; while ($run >= 3) { push @CL_symbols, 16; my $extra = min($run - 3, 3); $offset_bits .= int2bits_lsb($extra, 2); $run -= 3 + $extra; } push(@CL_symbols, ($v) x $run) if ($run > 0); } return (\@CL_symbols, $size, $offset_bits); } sub cl_encoded_bitstring ($cl_dict, $cl_symbols, $offset_bits) { my $bitstring = ''; foreach my $cl_symbol (@$cl_symbols) { $bitstring .= $cl_dict->{$cl_symbol}; if ($cl_symbol == 16) { $bitstring .= substr($offset_bits, 0, 2, ''); } elsif ($cl_symbol == 17) { $bitstring .= substr($offset_bits, 0, 3, ''); } elsif ($cl_symbol == 18) { $bitstring .= substr($offset_bits, 0, 7, ''); } } return $bitstring; } sub create_cl_dictionary (@cl_symbols) { my @keys; my $freq = frequencies(\@cl_symbols); while (1) { my ($cl_dict) = huffman_from_freq($freq); # The CL codes must have at most 7 bits return $cl_dict if all { length($_) <= 7 } values %$cl_dict; if (scalar(@keys) == 0) { @keys = sort { $freq->{$b} <=> $freq->{$a} } keys %$freq; } # Scale down the frequencies and try again foreach my $k (@keys) { if ($freq->{$k} > 1) { $freq->{$k} >>= 1; } else { last; } } } } sub block_type_2 ($literals, $distances, $lengths) { my @CL_order = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); my @parts; push @parts, '01'; my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $k (0 .. $#$literals) { if ($lengths->[$k] == 0) { push @len_symbols, $literals->[$k]; next; } my $len = $lengths->[$k]; my $dist = $distances->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @len_symbols, [$len_idx + 256 - 1, $bits]; $offset_bits .= int2bits_lsb($len - $min, $bits) if ($bits > 0); } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @dist_symbols, [$dist_idx - 1, $bits]; $offset_bits .= int2bits_lsb($dist - $min, $bits) if ($bits > 0); } } push @len_symbols, 256; # end-of-block marker my ($dict) = huffman_from_symbols([map { ref($_) eq 'ARRAY' ? $_->[0] : $_ } @len_symbols]); my ($dist_dict) = huffman_from_symbols([map { $_->[0] } @dist_symbols]); my ($LL_code_lengths, $LL_cl_len, $LL_offset_bits) = code_length_encoding($dict); my ($distance_code_lengths, $distance_cl_len, $distance_offset_bits) = code_length_encoding($dist_dict); my $cl_dict = create_cl_dictionary(@$LL_code_lengths, @$distance_code_lengths); my @CL_code_lenghts; foreach my $symbol (0 .. 18) { if (exists($cl_dict->{$symbol})) { push @CL_code_lenghts, length($cl_dict->{$symbol}); } else { push @CL_code_lenghts, 0; } } # Put the CL codes in the required order @CL_code_lenghts = @CL_code_lenghts[@CL_order]; while (scalar(@CL_code_lenghts) > 4 and $CL_code_lenghts[-1] == 0) { pop @CL_code_lenghts; } my $CL_code_lengths_bitstring = join('', map { int2bits_lsb($_, 3) } @CL_code_lenghts); my $LL_code_lengths_bitstring = cl_encoded_bitstring($cl_dict, $LL_code_lengths, $LL_offset_bits); my $distance_code_lengths_bitstring = cl_encoded_bitstring($cl_dict, $distance_code_lengths, $distance_offset_bits); # (5 bits) HLIT = (number of LL code entries present) - 257 my $HLIT = $LL_cl_len - 257; # (5 bits) HDIST = (number of distance code entries present) - 1 my $HDIST = $distance_cl_len - 1; # (4 bits) HCLEN = (number of CL code entries present) - 4 my $HCLEN = scalar(@CL_code_lenghts) - 4; push @parts, int2bits_lsb($HLIT, 5); push @parts, int2bits_lsb($HDIST, 5); push @parts, int2bits_lsb($HCLEN, 4); push @parts, $CL_code_lengths_bitstring; push @parts, $LL_code_lengths_bitstring; push @parts, $distance_code_lengths_bitstring; foreach my $symbol (@len_symbols) { if (ref($symbol) eq 'ARRAY') { my ($len, $len_offset) = @$symbol; push @parts, $dict->{$len}; push @parts, substr($offset_bits, 0, $len_offset, '') if ($len_offset > 0); my ($dist, $dist_offset) = @{shift(@dist_symbols)}; push @parts, $dist_dict->{$dist}; push @parts, substr($offset_bits, 0, $dist_offset, '') if ($dist_offset > 0); } else { push @parts, $dict->{$symbol}; } } my $bitstring = join('', @parts); return $bitstring; } sub block_type_1 ($literals, $distances, $lengths) { state $dict; state $dist_dict; if (!defined($dict)) { my @code_lengths = (0) x 288; foreach my $i (0 .. 143) { $code_lengths[$i] = 8; } foreach my $i (144 .. 255) { $code_lengths[$i] = 9; } foreach my $i (256 .. 279) { $code_lengths[$i] = 7; } foreach my $i (280 .. 287) { $code_lengths[$i] = 8; } ($dict) = huffman_from_code_lengths(\@code_lengths); ($dist_dict) = huffman_from_code_lengths([(5) x 32]); } my @parts; push @parts, '10'; foreach my $k (0 .. $#$literals) { if ($lengths->[$k] == 0) { push @parts, $dict->{$literals->[$k]}; next; } my $len = $lengths->[$k]; my $dist = $distances->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @parts, $dict->{$len_idx + 256 - 1}; push @parts, int2bits_lsb($len - $min, $bits) if ($bits > 0); } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @parts, $dist_dict->{$dist_idx - 1}; push @parts, int2bits_lsb($dist - $min, $bits) if ($bits > 0); } } push @parts, $dict->{256}; # end-of-block symbol my $bitstring = join('', @parts); return $bitstring; } sub block_type_0($chunk) { my $chunk_len = length($chunk); my $len = int2bits_lsb($chunk_len, 16); my $nlen = int2bits_lsb((~$chunk_len) & 0xffff, 16); $len . $nlen; } sub my_gzip_compress ($in_fh, $out_fh) { print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $crc32 = 0; my $bitstring = ''; if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . '0000000'; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { $crc32 = crc32($chunk, $crc32); $total_length += length($chunk); my ($literals, $distances, $lengths) = lzss_encode($chunk); $bitstring .= eof($in_fh) ? '1' : '0'; my $bt0_size = (length($chunk) + 5) * 8; # type 0 cost in bits my $bt1_bitstring = block_type_1($literals, $distances, $lengths); if ($bt0_size <= length($bt1_bitstring)) { # Block type 0 is cheapest — skip computing type 2 say STDERR ":: Using block type: 0"; $bitstring .= '00'; print $out_fh pack('b*', $bitstring); # pads to a byte print $out_fh pack('b*', block_type_0($chunk)); print $out_fh $chunk; $bitstring = ''; next; } my $bt2_bitstring = block_type_2($literals, $distances, $lengths); # When block type 2 is larger than block type 1, then we may have very small data if (length($bt2_bitstring) > length($bt1_bitstring)) { say STDERR ":: Using block type: 1"; $bitstring .= $bt1_bitstring; } else { say STDERR ":: Using block type: 2"; $bitstring .= $bt2_bitstring; } print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh pack('b*', int2bits_lsb($crc32, 32)); print $out_fh pack('b*', int2bits_lsb($total_length, 32)); return 1; } ################### # GZIP DECOMPRESSOR ################### sub extract_block_type_0 ($in_fh, $buffer) { my $len = bits2int_lsb($in_fh, 16, $buffer); my $nlen = bits2int_lsb($in_fh, 16, $buffer); my $expected_nlen = (~$len) & 0xffff; if ($expected_nlen != $nlen) { die "[!] The ~length value is not correct: $nlen (actual) != $expected_nlen (expected)\n"; } else { print STDERR ":: Chunk length: $len\n"; } read($in_fh, (my $chunk), $len); return $chunk; } sub decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window) { my $data = ''; my $code = ''; my $max_ll_code_len = max(map { length($_) } keys %$rev_dict); my $max_dist_code_len = max(map { length($_) } keys %$dist_rev_dict); while (1) { $code .= read_bit_lsb($in_fh, $buffer); if (length($code) > $max_ll_code_len) { die "[!] Something went wrong: length of LL code `$code` is > $max_ll_code_len.\n"; } if (exists($rev_dict->{$code})) { my $symbol = $rev_dict->{$code}; if ($symbol <= 255) { $data .= chr($symbol); $$search_window .= chr($symbol); } elsif ($symbol == 256) { # end-of-block marker $code = ''; last; } else { # LZSS decoding my ($length, $LL_bits) = @{$LENGTH_SYMBOLS->[$symbol - 256 + 1]}; $length += bits2int_lsb($in_fh, $LL_bits, $buffer) if ($LL_bits > 0); my $dist_code = ''; while (1) { $dist_code .= read_bit_lsb($in_fh, $buffer); if (length($dist_code) > $max_dist_code_len) { die "[!] Something went wrong: length of distance code `$dist_code` is > $max_dist_code_len.\n"; } if (exists($dist_rev_dict->{$dist_code})) { last; } } my ($dist, $dist_bits) = @{$DISTANCE_SYMBOLS->[$dist_rev_dict->{$dist_code} + 1]}; $dist += bits2int_lsb($in_fh, $dist_bits, $buffer) if ($dist_bits > 0); if ($dist == 1) { $$search_window .= substr($$search_window, -1) x $length; } elsif ($dist >= $length) { # non-overlapping matches $$search_window .= substr($$search_window, length($$search_window) - $dist, $length); } else { # overlapping matches my $sw_len = length($$search_window); foreach my $i (1 .. $length) { $$search_window .= substr($$search_window, $sw_len - $dist, 1); $sw_len++; } } $data .= substr($$search_window, -$length); } $code = ''; } } if ($code ne '') { die "[!] Something went wrong: code `$code` is not empty!\n"; } return $data; } sub extract_block_type_1 ($in_fh, $buffer, $search_window) { state $rev_dict; state $dist_rev_dict; if (!defined($rev_dict)) { my @code_lengths = (0) x 288; foreach my $i (0 .. 143) { $code_lengths[$i] = 8; } foreach my $i (144 .. 255) { $code_lengths[$i] = 9; } foreach my $i (256 .. 279) { $code_lengths[$i] = 7; } foreach my $i (280 .. 287) { $code_lengths[$i] = 8; } (undef, $rev_dict) = huffman_from_code_lengths(\@code_lengths); (undef, $dist_rev_dict) = huffman_from_code_lengths([(5) x 32]); } decode_huffman($in_fh, $buffer, $rev_dict, $dist_rev_dict, $search_window); } sub decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $size) { my @lengths; my $code = ''; while (1) { $code .= read_bit_lsb($in_fh, $buffer); if (length($code) > 7) { die "[!] Something went wrong: length of CL code `$code` is > 7.\n"; } if (exists($CL_rev_dict->{$code})) { my $CL_symbol = $CL_rev_dict->{$code}; if ($CL_symbol <= 15) { push @lengths, $CL_symbol; } elsif ($CL_symbol == 16) { push @lengths, ($lengths[-1]) x (3 + bits2int_lsb($in_fh, 2, $buffer)); } elsif ($CL_symbol == 17) { push @lengths, (0) x (3 + bits2int_lsb($in_fh, 3, $buffer)); } elsif ($CL_symbol == 18) { push @lengths, (0) x (11 + bits2int_lsb($in_fh, 7, $buffer)); } else { die "Unknown CL symbol: $CL_symbol\n"; } $code = ''; last if (scalar(@lengths) >= $size); } } if (scalar(@lengths) != $size) { die "Something went wrong: size $size (expected) != ", scalar(@lengths); } if ($code ne '') { die "Something went wrong: code `$code` is not empty!"; } return @lengths; } sub extract_block_type_2 ($in_fh, $buffer, $search_window) { # (5 bits) HLIT = (number of LL code entries present) - 257 my $HLIT = bits2int_lsb($in_fh, 5, $buffer) + 257; # (5 bits) HDIST = (number of distance code entries present) - 1 my $HDIST = bits2int_lsb($in_fh, 5, $buffer) + 1; # (4 bits) HCLEN = (number of CL code entries present) - 4 my $HCLEN = bits2int_lsb($in_fh, 4, $buffer) + 4; say STDERR ":: Number of LL codes: $HLIT"; say STDERR ":: Number of dist codes: $HDIST"; say STDERR ":: Number of CL codes: $HCLEN"; my @CL_code_lenghts = (0) x 19; my @CL_order = (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15); foreach my $i (0 .. $HCLEN - 1) { $CL_code_lenghts[$CL_order[$i]] = bits2int_lsb($in_fh, 3, $buffer); } say STDERR ":: CL code lengths: @CL_code_lenghts"; my (undef, $CL_rev_dict) = huffman_from_code_lengths(\@CL_code_lenghts); my @LL_CL_lengths = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HLIT); my @dist_CL_lengths = decode_CL_lengths($in_fh, $buffer, $CL_rev_dict, $HDIST); my (undef, $LL_rev_dict) = huffman_from_code_lengths(\@LL_CL_lengths); my (undef, $dist_rev_dict) = huffman_from_code_lengths(\@dist_CL_lengths); decode_huffman($in_fh, $buffer, $LL_rev_dict, $dist_rev_dict, $search_window); } sub my_gzip_decompress ($in_fh, $out_fh) { my $MAGIC = (getc($in_fh) // die "error") . (getc($in_fh) // die "error"); if ($MAGIC ne pack('C*', 0x1f, 0x8b)) { die "Not a valid Gzip container!\n"; } my $CM = getc($in_fh) // die "error"; # 0x08 = DEFLATE my $FLAGS = ord(getc($in_fh) // die "error"); # flags my $MTIME = join('', map { getc($in_fh) // die "error" } 1 .. 4); # modification time my $XFLAGS = getc($in_fh) // die "error"; # extra flags my $OS = getc($in_fh) // die "error"; # 0x03 = Unix if ($CM ne chr(0x08)) { die "Only DEFLATE compression method is supported (0x08)! Got: 0x", sprintf('%02x', ord($CM)); } # Reference: # https://web.archive.org/web/20240221024029/https://forensics.wiki/gzip/ my $has_filename = 0; my $has_comment = 0; my $has_header_checksum = 0; my $has_extra_fields = 0; if ($FLAGS & 0x08) { $has_filename = 1; } if ($FLAGS & 0x10) { $has_comment = 1; } if ($FLAGS & 0x02) { $has_header_checksum = 1; } if ($FLAGS & 0x04) { $has_extra_fields = 1; } if ($has_extra_fields) { my $size = bytes2int_lsb($in_fh, 2); read($in_fh, (my $extra_field_data), $size) // die "can't read extra field data: $!"; say STDERR ":: Extra field data: $extra_field_data"; } if ($has_filename) { my $filename = read_null_terminated($in_fh); # filename say STDERR ":: Filename: $filename"; } if ($has_comment) { my $comment = read_null_terminated($in_fh); # comment say STDERR ":: Comment: $comment"; } if ($has_header_checksum) { my $header_checksum = bytes2int_lsb($in_fh, 2); say STDERR ":: Header checksum: $header_checksum"; } my $crc32 = 0; my $actual_length = 0; my $buffer = ''; my $search_window = ''; my $window_size = $Compression::Util::LZ_MAX_DIST; while (1) { my $is_last = read_bit_lsb($in_fh, \$buffer); my $block_type = bits2int_lsb($in_fh, 2, \$buffer); my $chunk = ''; if ($block_type == 0) { say STDERR "\n:: Extracting block of type 0"; $buffer = ''; # pad to a byte $chunk = extract_block_type_0($in_fh, \$buffer); $search_window .= $chunk; } elsif ($block_type == 1) { say STDERR "\n:: Extracting block of type 1"; $chunk = extract_block_type_1($in_fh, \$buffer, \$search_window); } elsif ($block_type == 2) { say STDERR "\n:: Extracting block of type 2"; $chunk = extract_block_type_2($in_fh, \$buffer, \$search_window); } else { die "[!] Unknown block of type: $block_type"; } print $out_fh $chunk; $crc32 = crc32($chunk, $crc32); $actual_length += length($chunk); $search_window = substr($search_window, -$window_size) if (length($search_window) > 2 * $window_size); last if $is_last; } $buffer = ''; # discard any padding bits my $stored_crc32 = bits2int_lsb($in_fh, 32, \$buffer); my $actual_crc32 = $crc32; say STDERR ''; if ($stored_crc32 != $actual_crc32) { print STDERR "[!] The CRC32 does not match: $actual_crc32 (actual) != $stored_crc32 (stored)\n"; } else { print STDERR ":: CRC32 value: $actual_crc32\n"; } my $stored_length = bits2int_lsb($in_fh, 32, \$buffer); if ($stored_length != $actual_length) { print STDERR "[!] The length does not match: $actual_length (actual) != $stored_length (stored)\n"; } else { print STDERR ":: Total length: $actual_length\n"; } if (eof($in_fh)) { print STDERR "\n:: Reached the end of the file.\n"; } else { print STDERR "\n:: There is something else in the container! Trying to recurse!\n\n"; __SUB__->($in_fh, $out_fh); } } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_gzip_decompress($in_fh, $out_fh) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_gzip_compress($in_fh, $out_fh) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } main(); exit(0); ================================================ FILE: Compression/gzip_store.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2024 # https://github.com/trizen # Create a valid Gzip container, with uncompressed data. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Compression::Util qw(crc32); use File::Basename qw(basename); use constant { CHUNK_SIZE => 0xffff, # 2^16 - 1 }; my $MAGIC = pack('C*', 0x1f, 0x8b); # magic MIME type my $CM = chr(0x08); # 0x08 = DEFLATE my $FLAGS = chr(0x00); # flags my $MTIME = pack('C*', (0x00) x 4); # modification time my $XFLAGS = chr(0x00); # extra flags my $OS = chr(0x03); # 0x03 = Unix my $input = $ARGV[0] // die "usage: $0 [input] [output.gz]\n"; my $output = $ARGV[1] // (basename($input) . '.gz'); sub int2bits ($value, $size = 32) { scalar reverse sprintf("%0*b", $size, $value); } open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh $MAGIC, $CM, $FLAGS, $MTIME, $XFLAGS, $OS; my $total_length = 0; my $block_type = '00'; # 00 = store; 10 = LZSS + Fixed codes; 01 = LZSS + Dynamic codes my $crc32 = 0; while (read($in_fh, (my $chunk), CHUNK_SIZE)) { my $chunk_len = length($chunk); my $len = int2bits($chunk_len, 16); my $nlen = int2bits((~$chunk_len) & 0xffff, 16); my $is_last = eof($in_fh) ? '1' : '0'; my $block_header = pack('b*', $is_last . $block_type . ('0' x 5) . $len . $nlen); print $out_fh $block_header; print $out_fh $chunk; $crc32 = crc32($chunk, $crc32); $total_length += $chunk_len; } print $out_fh pack('b*', int2bits($crc32, 32)); print $out_fh pack('b*', int2bits($total_length, 32)); close $in_fh; close $out_fh; ================================================ FILE: Compression/hfm_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 01 December 2022 # Edit: 28 April 2023 # https://github.com/trizen # Compress/decompress files using Huffman coding. # Huffman coding algorithm from: # https://rosettacode.org/wiki/Huffman_coding#Perl # See also: # https://en.wikipedia.org/wiki/Huffman_coding use 5.036; use List::Util qw(min max); use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'HFM', VERSION => '0.03', FORMAT => 'hfm', }; use constant { CHUNK_SIZE => 1 << 15, SIGNATURE => uc(FORMAT) . chr(3), }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr; # very fast } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub compress ($input, $output) { # Open the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; # Open the output file and write the archive signature open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; print $out_fh SIGNATURE; # Read and encode while (read($fh, (my $chunk), CHUNK_SIZE)) { create_huffman_entry([unpack('C*', $chunk)], $out_fh); } return 1; } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub decode_huffman_entry ($fh, $out_fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); foreach my $k (keys %$rev_dict) { $rev_dict->{$k} = chr($rev_dict->{$k}); } my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { print $out_fh huffman_decode(read_bits($fh, $enc_len), $rev_dict); return 1; } return 0; } sub decompress ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; # Decode while (!eof($fh)) { decode_huffman_entry($fh, $out_fh) || last; } return 1; } main(); exit(0); ================================================ FILE: Compression/lz4_compressor.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 23 August 2024 # https://github.com/trizen # A simple LZ4 compressor. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md # See also: # https://github.com/trizen/Compression-Util use 5.036; use Compression::Util qw(:all); use constant {CHUNK_SIZE => 1 << 17}; local $| = 1; binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); my $s = "abcabcabc\n"; my $fh; if (-t STDIN) { open $fh, "<:raw", \$s; } else { $fh = \*STDIN; } my $compressed = ''; $compressed .= int2bytes_lsb(0x184D2204, 4); # LZ4 magic number my $fd = ''; # frame description $fd .= chr(0b01_10_00_00); # flags (FLG) $fd .= chr(0b0_111_0000); # block description (BD) $compressed .= $fd; # Header Checksum if (eval { require Digest::xxHash; 1 }) { $compressed .= chr((Digest::xxHash::xxhash32($fd, 0) >> 8) & 0xFF); } else { $compressed .= chr(115); } while (!eof($fh)) { read($fh, (my $chunk), CHUNK_SIZE); my ($literals, $distances, $lengths) = do { local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = ~0; # maximum match length local $Compression::Util::LZ_MAX_DIST = (1 << 16) - 1; # maximum match distance local $Compression::Util::LZ_MAX_CHAIN_LEN = 32; # higher value = better compression lzss_encode(substr($chunk, 0, -5)); }; # The last 5 bytes of each block must be literals # https://github.com/lz4/lz4/issues/1495 push @$literals, unpack('C*', substr($chunk, -5)); my $literals_end = $#{$literals}; my $block = ''; for (my $i = 0 ; $i <= $literals_end ; ++$i) { my @uncompressed; while ($i <= $literals_end and defined($literals->[$i])) { push @uncompressed, $literals->[$i]; ++$i; } my $literals_string = pack('C*', @uncompressed); my $literals_length = scalar(@uncompressed); my $match_len = $lengths->[$i] ? ($lengths->[$i] - 4) : 0; my $len_byte = 0; $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4; $len_byte |= ($match_len >= 15 ? 15 : $match_len); $literals_length -= 15; $match_len -= 15; $block .= chr($len_byte); while ($literals_length >= 0) { $block .= ($literals_length >= 255 ? "\xff" : chr($literals_length)); $literals_length -= 255; } $block .= $literals_string; my $dist = $distances->[$i] // last; $block .= pack('b*', scalar reverse sprintf('%016b', $dist)); while ($match_len >= 0) { $block .= ($match_len >= 255 ? "\xff" : chr($match_len)); $match_len -= 255; } } if ($block ne '') { $compressed .= int2bytes_lsb(length($block), 4); $compressed .= $block; } print $compressed; $compressed = ''; } print int2bytes_lsb(0x00000000, 4); # EndMark ================================================ FILE: Compression/lz4_decompressor.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 09 May 2024 # Edit: 08 July 2024 # https://github.com/trizen # A simple LZ4 decompressor. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; local $| = 1; binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); sub bytes2int_lsb ($fh, $n) { my $bytes = ''; $bytes .= getc($fh) for (1 .. $n); oct('0b' . reverse unpack('b*', $bytes)); } my $s = ''; $s .= "\4\"M\30d@\xA7\16\0\0\x80Hello, World!\n\0\0\0\0\xE8C\xD0\x9E"; # uncompressed $s .= "\4\"M\30d@\xA7\27\0\0\0\xE5Hello, World! \16\0Prld!\n\0\0\0\0\x9FL\"T"; # compressed my $fh; if (-t STDIN) { open $fh, "<:raw", \$s; } else { $fh = \*STDIN; } while (!eof($fh)) { bytes2int_lsb($fh, 4) == 0x184D2204 or die "Not an LZ4 file\n"; my $FLG = ord(getc($fh)); my $BD = ord(getc($fh)); my $version = $FLG & 0b11_00_00_00; my $B_indep = $FLG & 0b00_10_00_00; my $B_checksum = $FLG & 0b00_01_00_00; my $C_size = $FLG & 0b00_00_10_00; my $C_checksum = $FLG & 0b00_00_01_00; my $DictID = $FLG & 0b00_00_00_01; my $Block_MaxSize = $BD & 0b0_111_0000; say STDERR "Maximum block size: $Block_MaxSize"; if ($version != 0b01_00_00_00) { die "Error: Invalid version number"; } if ($C_size) { my $content_size = bytes2int_lsb($fh, 8); say STDERR "Content size: ", $content_size; } if ($DictID) { my $dict_id = bytes2int_lsb($fh, 4); say STDERR "Dictionary ID: ", $dict_id; } my $header_checksum = ord(getc($fh)); my $decoded = ''; while (!eof($fh)) { my $block_size = bytes2int_lsb($fh, 4); if ($block_size == 0x00000000) { # signifies an EndMark say STDERR "Block size == 0"; last; } say STDERR "Block size: $block_size"; if ($block_size >> 31) { say STDERR "Highest bit set: ", $block_size; $block_size &= ((1 << 31) - 1); say STDERR "Block size: ", $block_size; my $uncompressed = ''; read($fh, $uncompressed, $block_size); $decoded .= $uncompressed; } else { my $compressed = ''; read($fh, $compressed, $block_size); while ($compressed ne '') { my $len_byte = ord(substr($compressed, 0, 1, '')); my $literals_length = $len_byte >> 4; my $match_len = $len_byte & 0b1111; #say STDERR "Literal: ", $literals_length; #say STDERR "Match len: ", $match_len; if ($literals_length == 15) { while (1) { my $byte_len = ord(substr($compressed, 0, 1, '')); $literals_length += $byte_len; last if $byte_len != 255; } } #say STDERR "Total literals length: ", $literals_length; my $literals = ''; if ($literals_length > 0) { $literals = substr($compressed, 0, $literals_length, ''); } if ($compressed eq '') { # end of block $decoded .= $literals; last; } my $offset = oct('0b' . reverse unpack('b16', substr($compressed, 0, 2, ''))); if ($offset == 0) { die "Corrupted block"; } # say STDERR "Offset: $offset"; if ($match_len == 15) { while (1) { my $byte_len = ord(substr($compressed, 0, 1, '')); $match_len += $byte_len; last if $byte_len != 255; } } $decoded .= $literals; $match_len += 4; # say STDERR "Total match len: $match_len\n"; if ($offset >= $match_len) { # non-overlapping matches $decoded .= substr($decoded, length($decoded) - $offset, $match_len); } elsif ($offset == 1) { $decoded .= substr($decoded, -1) x $match_len; } else { # overlapping matches foreach my $i (1 .. $match_len) { $decoded .= substr($decoded, length($decoded) - $offset, 1); } } } } if ($B_checksum) { my $content_checksum = bytes2int_lsb($fh, 4); say STDERR "Block checksum: $content_checksum"; } if ($B_indep) { # blocks are independent of each other print $decoded; $decoded = ''; } elsif (length($decoded) > 2**16) { # blocks are dependent print substr($decoded, 0, -(2**16), ''); } } if ($C_checksum) { my $content_checksum = bytes2int_lsb($fh, 4); say STDERR "Content checksum: $content_checksum"; } print $decoded; } ================================================ FILE: Compression/lz4_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 25 August 2024 # https://github.com/trizen # A valid LZ4 file compressor/decompressor. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use Getopt::Std qw(getopts); binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); use constant { FORMAT => 'lz4', CHUNK_SIZE => 1 << 17, }; sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub my_lz4_compress($fh, $out_fh) { my $compressed = ''; $compressed .= int2bytes_lsb(0x184D2204, 4); # LZ4 magic number my $fd = ''; # frame description $fd .= chr(0b01_10_00_00); # flags (FLG) $fd .= chr(0b0_111_0000); # block description (BD) $compressed .= $fd; # Header Checksum if (eval { require Digest::xxHash; 1 }) { $compressed .= chr((Digest::xxHash::xxhash32($fd, 0) >> 8) & 0xFF); } else { $compressed .= chr(115); } while (!eof($fh)) { read($fh, (my $chunk), CHUNK_SIZE); my ($literals, $distances, $lengths) = do { local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length local $Compression::Util::LZ_MAX_LEN = ~0; # maximum match length local $Compression::Util::LZ_MAX_DIST = (1 << 16) - 1; # maximum match distance local $Compression::Util::LZ_MAX_CHAIN_LEN = 32; # higher value = better compression lzss_encode(substr($chunk, 0, -5)); }; # The last 5 bytes of each block must be literals # https://github.com/lz4/lz4/issues/1495 push @$literals, unpack('C*', substr($chunk, -5)); my $literals_end = $#{$literals}; my $block = ''; for (my $i = 0 ; $i <= $literals_end ; ++$i) { my @uncompressed; while ($i <= $literals_end and defined($literals->[$i])) { push @uncompressed, $literals->[$i]; ++$i; } my $literals_string = pack('C*', @uncompressed); my $literals_length = scalar(@uncompressed); my $match_len = $lengths->[$i] ? ($lengths->[$i] - 4) : 0; my $len_byte = 0; $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4; $len_byte |= ($match_len >= 15 ? 15 : $match_len); $literals_length -= 15; $match_len -= 15; $block .= chr($len_byte); while ($literals_length >= 0) { $block .= ($literals_length >= 255 ? "\xff" : chr($literals_length)); $literals_length -= 255; } $block .= $literals_string; my $dist = $distances->[$i] // last; $block .= pack('b*', scalar reverse sprintf('%016b', $dist)); while ($match_len >= 0) { $block .= ($match_len >= 255 ? "\xff" : chr($match_len)); $match_len -= 255; } } if ($block ne '') { $compressed .= int2bytes_lsb(length($block), 4); $compressed .= $block; } print $out_fh $compressed; $compressed = ''; } print $out_fh int2bytes_lsb(0x00000000, 4); # EndMark return 1; } sub my_lz4_decompress($fh, $out_fh) { while (!eof($fh)) { bytes2int_lsb($fh, 4) == 0x184D2204 or die "Not an LZ4 file\n"; my $FLG = ord(getc($fh)); my $BD = ord(getc($fh)); my $version = $FLG & 0b11_00_00_00; my $B_indep = $FLG & 0b00_10_00_00; my $B_checksum = $FLG & 0b00_01_00_00; my $C_size = $FLG & 0b00_00_10_00; my $C_checksum = $FLG & 0b00_00_01_00; my $DictID = $FLG & 0b00_00_00_01; my $Block_MaxSize = $BD & 0b0_111_0000; say STDERR "Maximum block size: $Block_MaxSize"; if ($version != 0b01_00_00_00) { die "Error: Invalid version number"; } if ($C_size) { my $content_size = bytes2int_lsb($fh, 8); say STDERR "Content size: ", $content_size; } if ($DictID) { my $dict_id = bytes2int_lsb($fh, 4); say STDERR "Dictionary ID: ", $dict_id; } my $header_checksum = ord(getc($fh)); my $decoded = ''; while (!eof($fh)) { my $block_size = bytes2int_lsb($fh, 4); if ($block_size == 0x00000000) { # signifies an EndMark say STDERR "Block size == 0"; last; } say STDERR "Block size: $block_size"; if ($block_size >> 31) { say STDERR "Highest bit set: ", $block_size; $block_size &= ((1 << 31) - 1); say STDERR "Block size: ", $block_size; my $uncompressed = ''; read($fh, $uncompressed, $block_size); $decoded .= $uncompressed; } else { my $compressed = ''; read($fh, $compressed, $block_size); while ($compressed ne '') { my $len_byte = ord(substr($compressed, 0, 1, '')); my $literals_length = $len_byte >> 4; my $match_len = $len_byte & 0b1111; #say STDERR "Literal: ", $literals_length; #say STDERR "Match len: ", $match_len; if ($literals_length == 15) { while (1) { my $byte_len = ord(substr($compressed, 0, 1, '')); $literals_length += $byte_len; last if $byte_len != 255; } } #say STDERR "Total literals length: ", $literals_length; my $literals = ''; if ($literals_length > 0) { $literals = substr($compressed, 0, $literals_length, ''); } if ($compressed eq '') { # end of block $decoded .= $literals; last; } my $offset = oct('0b' . reverse unpack('b16', substr($compressed, 0, 2, ''))); if ($offset == 0) { die "Corrupted block"; } # say STDERR "Offset: $offset"; if ($match_len == 15) { while (1) { my $byte_len = ord(substr($compressed, 0, 1, '')); $match_len += $byte_len; last if $byte_len != 255; } } $decoded .= $literals; $match_len += 4; # say STDERR "Total match len: $match_len\n"; if ($offset >= $match_len) { # non-overlapping matches $decoded .= substr($decoded, length($decoded) - $offset, $match_len); } elsif ($offset == 1) { $decoded .= substr($decoded, -1) x $match_len; } else { # overlapping matches foreach my $i (1 .. $match_len) { $decoded .= substr($decoded, length($decoded) - $offset, 1); } } } } if ($B_checksum) { my $content_checksum = bytes2int_lsb($fh, 4); say STDERR "Block checksum: $content_checksum"; } if ($B_indep) { # blocks are independent of each other print $out_fh $decoded; $decoded = ''; } elsif (length($decoded) > 2**16) { # blocks are dependent print $out_fh substr($decoded, 0, -(2**16), ''); } } if ($C_checksum) { my $content_checksum = bytes2int_lsb($fh, 4); say STDERR "Content checksum: $content_checksum"; } print $out_fh $decoded; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_lz4_decompress($in_fh, $out_fh) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_lz4_compress($in_fh, $out_fh) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } main(); exit(0); ================================================ FILE: Compression/lz77_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # https://github.com/trizen # Compress/decompress files using LZ77 compression. use 5.020; use strict; use warnings; use experimental qw(signatures); use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'LZ77', VERSION => '0.02', FORMAT => 'lz77', CHUNK_SIZE => 1 << 16, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub compression ($str) { my @rep; my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = 0; my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = index($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push(@rep, $p, $n, $chars[$la + $n]); $la += $n + 1; $prefix .= $token; } pack('(SCa)*', @rep); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh compression($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $chunk = ''; while (read($fh, (my $str), 4 * CHUNK_SIZE)) { my @decoded = unpack('(SCa)*', $str); while (@decoded) { my ($s, $l, $c) = splice(@decoded, 0, 3); $chunk .= substr($chunk, $s, $l) . $c; if (length($chunk) >= CHUNK_SIZE) { print $out_fh $chunk; $chunk = ''; } } } print $out_fh $chunk; # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lza_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Arithmetic Coding (in fixed bits). # Reference: # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.020; use strict; use warnings; use experimental qw(signatures); use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZA', VERSION => '0.01', FORMAT => 'lza', CHUNK_SIZE => 1 << 16, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = 0; my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = index($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $p; push @$lengths, $n; push @$uncompressed, $chars[$la + $n]; $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $ret = ''; my $chunk = ''; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]); if (length($chunk) >= CHUNK_SIZE) { $ret .= $chunk; $chunk = ''; } } if ($chunk ne '') { $ret .= $chunk; } $ret; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my (@uncompressed, @indices, @lengths); # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); } @indices = unpack('C*', pack('S*', @indices)); @uncompressed = unpack('C*', join('', @uncompressed)); create_ac_entry(\@uncompressed, $out_fh); create_ac_entry(\@indices, $out_fh); create_ac_entry(\@lengths, $out_fh); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $uncompressed = decode_ac_entry($fh); my @indices = unpack('S*', pack('C*', @{decode_ac_entry($fh)})); my $lengths = decode_ac_entry($fh); print $out_fh lz77_decompression($uncompressed, \@indices, $lengths); # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzac_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 06 February 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Arithmetic Coding (in fixed bits). # Encoding the distances/indices using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max sum); use constant { PKGNAME => 'LZAC', VERSION => '0.02', FORMAT => 'lzac', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]); $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub encode_distances ($distances, $out_fh) { my @symbols; my $offset_bits = ''; foreach my $dist (@$distances) { my $i = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; push @symbols, $i; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } create_ac_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub decode_distances ($fh) { my $symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say(scalar(@uncompressed), ' -> ', $est_ratio); create_ac_entry(\@uncompressed, $out_fh); create_ac_entry(\@lengths, $out_fh); encode_distances(\@indices, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = decode_ac_entry($fh); my $lengths = decode_ac_entry($fh); my $indices = decode_distances($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzaz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 12 August 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Arithmetic Coding (with big-integers). # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max sum); use Math::GMPz; use constant { PKGNAME => 'LZAZ', VERSION => '0.01', FORMAT => 'lzaz', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]); $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub cumulative_freq ($freq) { my %cf; my $total = 0; foreach my $c (sort { $a <=> $b } keys %$freq) { $cf{$c} = $total; $total += $freq->{$c}; } return %cf; } sub ac_encode ($bytes_arr) { my @chars = @$bytes_arr; # The frequency characters my %freq; ++$freq{$_} for @chars; # Create the cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = Math::GMPz->new(scalar @chars); # Lower bound my $L = Math::GMPz->new(0); # Product of all frequencies my $pf = Math::GMPz->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { Math::GMPz::Rmpz_mul($L, $L, $base); Math::GMPz::Rmpz_addmul_ui($L, $pf, $cf{$c}); Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c}); } # Upper bound Math::GMPz::Rmpz_add($L, $L, $pf); # Compute the power for left shift my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1; # Set $enc to (U-1) divided by 2^pow Math::GMPz::Rmpz_sub_ui($L, $L, 1); Math::GMPz::Rmpz_div_2exp($L, $L, $pow); # Remove any divisibility by 2 if ($L > 0 and Math::GMPz::Rmpz_even_p($L)) { $pow += Math::GMPz::Rmpz_remove($L, $L, Math::GMPz->new(2)); } my $bin = Math::GMPz::Rmpz_get_str($L, 2); return ($bin, $pow, \%freq); } sub ac_decode ($bits, $pow2, $freq) { # Decode the bits into an integer my $enc = Math::GMPz->new($bits, 2); Math::GMPz::Rmpz_mul_2exp($enc, $enc, $pow2); my $base = sum(values %$freq) // 0; if ($base == 0) { return []; } elsif ($base == 1) { return [keys %$freq]; } # Create the cumulative frequency table my %cf = cumulative_freq($freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } my $div = Math::GMPz::Rmpz_init(); my @dec; # Decode the input number for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) { Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow); my $c = $dict{$div}; my $fv = $freq->{$c}; my $cv = $cf{$c}; Math::GMPz::Rmpz_submul_ui($enc, $pow, $cv); Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv); push @dec, $c; } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $pow, $freq) = ac_encode($bytes); my @freqs; my $max_symbol = max(keys %$freq) // 0; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, $pow; push @freqs, length($enc); print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my $pow2 = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my $bits = read_bits($fh, $bits_len); if ($bits_len > 0) { return ac_decode($bits, $pow2, \%freq); } return []; } sub encode_distances ($distances, $out_fh) { my @symbols; my $offset_bits = ''; foreach my $dist (@$distances) { my $i = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; push @symbols, $i; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } create_ac_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub decode_distances ($fh) { my $symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say(scalar(@uncompressed), ' -> ', $est_ratio); create_ac_entry(\@uncompressed, $out_fh); create_ac_entry(\@lengths, $out_fh); encode_distances(\@indices, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my $uncompressed = decode_ac_entry($fh); my $lengths = decode_ac_entry($fh); my $indices = decode_distances($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzb2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 May 2024 # Edit: 02 June 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'LZB2', VERSION => '0.01', FORMAT => 'lzb2', MIN_MATCH_LEN => 4, # minimum match length MAX_MATCH_LEN => ~0, # maximum match length MAX_MATCH_DIST => (1 << 16) - 1, # maximum match distance MAX_CHAIN_LEN => 48, # higher value = better compression CHUNK_SIZE => 1 << 18, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lzss_encode($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = MIN_MATCH_LEN; # minimum match length my $max_len = MAX_MATCH_LEN; # maximum match length my $max_dist = MAX_MATCH_DIST; # maximum match distance my $max_chain_len = MAX_CHAIN_LEN; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead})) { foreach my $p (@{$table{$lookahead}}) { last if ($la - $p > $max_dist); my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; } } my $matched = substr($str, $la, $best_n); foreach my $i (0 .. length($matched) - $min_len) { my $key = substr($matched, $i, $min_len); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } } if ($best_n == 1) { $table{$lookahead} = [$la]; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub compression($chunk, $out_fh) { my ($literals, $distances, $lengths) = lzss_encode($chunk); my $literals_end = $#{$literals}; for (my $i = 0 ; $i <= $literals_end ; ++$i) { my @uncompressed; while ($i <= $literals_end and defined($literals->[$i])) { push @uncompressed, $literals->[$i]; ++$i; } my $literals_string = pack('C*', @uncompressed); my $literals_length = scalar(@uncompressed); my $dist = $distances->[$i] // 0; my $match_len = $lengths->[$i] // 0; my $len_byte = 0; $len_byte |= ($literals_length >= 7 ? 7 : $literals_length) << 5; $len_byte |= ($match_len >= 31 ? 31 : $match_len); $literals_length -= 7; $match_len -= 31; print $out_fh chr($len_byte); while ($literals_length >= 0) { print $out_fh chr($literals_length >= 255 ? 255 : $literals_length); $literals_length -= 255; } print $out_fh $literals_string; while ($match_len >= 0) { print $out_fh chr($match_len >= 255 ? 255 : $match_len); $match_len -= 255; } if ($dist >= 1 << 16) { die "Too large distance: $dist"; } print $out_fh pack('B*', sprintf('%016b', $dist)); } } sub decompression($fh, $out_fh) { my $search_window = ''; while (!eof($fh)) { my $len_byte = ord(getc($fh)); my $literals_length = $len_byte >> 5; my $match_len = $len_byte & 0b11111; if ($literals_length == 7) { while (1) { my $byte_len = ord(getc($fh)); $literals_length += $byte_len; last if $byte_len != 255; } } my $literals = ''; if ($literals_length > 0) { read($fh, $literals, $literals_length); } if ($match_len == 31) { while (1) { my $byte_len = ord(getc($fh)); $match_len += $byte_len; last if $byte_len != 255; } } my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh))); $search_window .= $literals; if ($offset == 1) { $search_window .= substr($search_window, -1) x $match_len; } elsif ($offset >= $match_len) { # non-overlapping matches $search_window .= substr($search_window, length($search_window) - $offset, $match_len); } else { # overlapping matches foreach my $i (1 .. $match_len) { $search_window .= substr($search_window, length($search_window) - $offset, 1); } } print $out_fh substr($search_window, -($match_len + $literals_length)); $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzb_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'LZB', VERSION => '0.01', FORMAT => 'lzb', MIN_MATCH_LEN => 4, # minimum match length MAX_MATCH_LEN => ~0, # maximum match length MAX_MATCH_DIST => (1 << 16) - 1, # maximum match distance MAX_CHAIN_LEN => 48, # higher value = better compression CHUNK_SIZE => 1 << 18, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lzss_encode($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = MIN_MATCH_LEN; # minimum match length my $max_len = MAX_MATCH_LEN; # maximum match length my $max_dist = MAX_MATCH_DIST; # maximum match distance my $max_chain_len = MAX_CHAIN_LEN; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead})) { foreach my $p (@{$table{$lookahead}}) { last if ($la - $p > $max_dist); my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; } } my $matched = substr($str, $la, $best_n); foreach my $i (0 .. length($matched) - $min_len) { my $key = substr($matched, $i, $min_len); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } } if ($best_n == 1) { $table{$lookahead} = [$la]; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub compression($chunk, $out_fh) { my ($literals, $distances, $lengths) = lzss_encode($chunk); my $literals_end = $#{$literals}; for (my $i = 0 ; $i <= $literals_end ; ++$i) { my @uncompressed; while ($i <= $literals_end and defined($literals->[$i])) { push @uncompressed, $literals->[$i]; ++$i; } my $literals_string = pack('C*', @uncompressed); my $literals_length = scalar(@uncompressed); my $dist = $distances->[$i] // 0; my $match_len = $lengths->[$i] // 0; my $len_byte = 0; $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4; $len_byte |= ($match_len >= 15 ? 15 : $match_len); $literals_length -= 15; $match_len -= 15; print $out_fh chr($len_byte); while ($literals_length >= 0) { print $out_fh chr($literals_length >= 255 ? 255 : $literals_length); $literals_length -= 255; } print $out_fh $literals_string; while ($match_len >= 0) { print $out_fh chr($match_len >= 255 ? 255 : $match_len); $match_len -= 255; } if ($dist >= 1 << 16) { die "Too large distance: $dist"; } print $out_fh pack('B*', sprintf('%016b', $dist)); } } sub decompression($fh, $out_fh) { my $search_window = ''; while (!eof($fh)) { my $len_byte = ord(getc($fh)); my $literals_length = $len_byte >> 4; my $match_len = $len_byte & 0b1111; if ($literals_length == 15) { while (1) { my $byte_len = ord(getc($fh)); $literals_length += $byte_len; last if $byte_len != 255; } } my $literals = ''; if ($literals_length > 0) { read($fh, $literals, $literals_length); } if ($match_len == 15) { while (1) { my $byte_len = ord(getc($fh)); $match_len += $byte_len; last if $byte_len != 255; } } my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh))); $search_window .= $literals; if ($offset == 1) { $search_window .= substr($search_window, -1) x $match_len; } elsif ($offset >= $match_len) { # non-overlapping matches $search_window .= substr($search_window, length($search_window) - $offset, $match_len); } else { # overlapping matches foreach my $i (1 .. $match_len) { $search_window .= substr($search_window, length($search_window) - $offset, 1); } } print $out_fh substr($search_window, -($match_len + $literals_length)); $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbf2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 May 2024 # Edit: 02 June 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'LZBF2', VERSION => '0.01', FORMAT => 'lzbf2', MIN_MATCH_LEN => 5, # minimum match length MAX_MATCH_LEN => ~0, # maximum match length MAX_MATCH_DIST => (1 << 16) - 1, # maximum match distance CHUNK_SIZE => 1 << 18, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lzss_encode_fast($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = MIN_MATCH_LEN; # minimum match length my $max_len = MAX_MATCH_LEN; # maximum match length my $max_dist = MAX_MATCH_DIST; # maximum match distance my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead}) and $la - $table{$lookahead} <= $max_dist) { my $p = $table{$lookahead}; my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } $best_p = $p; $best_n = $n; } $table{$lookahead} = $la; if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub compression($chunk, $out_fh) { my ($literals, $distances, $lengths) = lzss_encode_fast($chunk); my $literals_end = $#{$literals}; for (my $i = 0 ; $i <= $literals_end ; ++$i) { my @uncompressed; while ($i <= $literals_end and defined($literals->[$i])) { push @uncompressed, $literals->[$i]; ++$i; } my $literals_string = pack('C*', @uncompressed); my $literals_length = scalar(@uncompressed); my $dist = $distances->[$i] // 0; my $match_len = $lengths->[$i] // 0; my $len_byte = 0; $len_byte |= ($literals_length >= 7 ? 7 : $literals_length) << 5; $len_byte |= ($match_len >= 31 ? 31 : $match_len); $literals_length -= 7; $match_len -= 31; print $out_fh chr($len_byte); while ($literals_length >= 0) { print $out_fh chr($literals_length >= 255 ? 255 : $literals_length); $literals_length -= 255; } print $out_fh $literals_string; while ($match_len >= 0) { print $out_fh chr($match_len >= 255 ? 255 : $match_len); $match_len -= 255; } if ($dist >= 1 << 16) { die "Too large distance: $dist"; } print $out_fh pack('B*', sprintf('%016b', $dist)); } } sub decompression($fh, $out_fh) { my $search_window = ''; while (!eof($fh)) { my $len_byte = ord(getc($fh)); my $literals_length = $len_byte >> 5; my $match_len = $len_byte & 0b11111; if ($literals_length == 7) { while (1) { my $byte_len = ord(getc($fh)); $literals_length += $byte_len; last if $byte_len != 255; } } my $literals = ''; if ($literals_length > 0) { read($fh, $literals, $literals_length); } if ($match_len == 31) { while (1) { my $byte_len = ord(getc($fh)); $match_len += $byte_len; last if $byte_len != 255; } } my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh))); $search_window .= $literals; if ($offset == 1) { $search_window .= substr($search_window, -1) x $match_len; } elsif ($offset >= $match_len) { # non-overlapping matches $search_window .= substr($search_window, length($search_window) - $offset, $match_len); } else { # overlapping matches foreach my $i (1 .. $match_len) { $search_window .= substr($search_window, length($search_window) - $offset, 1); } } print $out_fh substr($search_window, -($match_len + $literals_length)); $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbf_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables), using a byte-aligned encoding, similar to LZ4. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'LZBF', VERSION => '0.01', FORMAT => 'lzbf', MIN_MATCH_LEN => 5, # minimum match length MAX_MATCH_LEN => ~0, # maximum match length MAX_MATCH_DIST => (1 << 16) - 1, # maximum match distance CHUNK_SIZE => 1 << 18, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lzss_encode_fast($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = MIN_MATCH_LEN; # minimum match length my $max_len = MAX_MATCH_LEN; # maximum match length my $max_dist = MAX_MATCH_DIST; # maximum match distance my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead}) and $la - $table{$lookahead} <= $max_dist) { my $p = $table{$lookahead}; my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } $best_p = $p; $best_n = $n; } $table{$lookahead} = $la; if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub compression($chunk, $out_fh) { my ($literals, $distances, $lengths) = lzss_encode_fast($chunk); my $literals_end = $#{$literals}; for (my $i = 0 ; $i <= $literals_end ; ++$i) { my @uncompressed; while ($i <= $literals_end and defined($literals->[$i])) { push @uncompressed, $literals->[$i]; ++$i; } my $literals_string = pack('C*', @uncompressed); my $literals_length = scalar(@uncompressed); my $dist = $distances->[$i] // 0; my $match_len = $lengths->[$i] // 0; my $len_byte = 0; $len_byte |= ($literals_length >= 15 ? 15 : $literals_length) << 4; $len_byte |= ($match_len >= 15 ? 15 : $match_len); $literals_length -= 15; $match_len -= 15; print $out_fh chr($len_byte); while ($literals_length >= 0) { print $out_fh chr($literals_length >= 255 ? 255 : $literals_length); $literals_length -= 255; } print $out_fh $literals_string; while ($match_len >= 0) { print $out_fh chr($match_len >= 255 ? 255 : $match_len); $match_len -= 255; } if ($dist >= 1 << 16) { die "Too large distance: $dist"; } print $out_fh pack('B*', sprintf('%016b', $dist)); } } sub decompression($fh, $out_fh) { my $search_window = ''; while (!eof($fh)) { my $len_byte = ord(getc($fh)); my $literals_length = $len_byte >> 4; my $match_len = $len_byte & 0b1111; if ($literals_length == 15) { while (1) { my $byte_len = ord(getc($fh)); $literals_length += $byte_len; last if $byte_len != 255; } } my $literals = ''; if ($literals_length > 0) { read($fh, $literals, $literals_length); } if ($match_len == 15) { while (1) { my $byte_len = ord(getc($fh)); $match_len += $byte_len; last if $byte_len != 255; } } my $offset = oct('0b' . unpack('B*', getc($fh) . getc($fh))); $search_window .= $literals; if ($offset == 1) { $search_window .= substr($search_window, -1) x $match_len; } elsif ($offset >= $match_len) { # non-overlapping matches $search_window .= substr($search_window, length($search_window) - $offset, $match_len); } else { # overlapping matches foreach my $i (1 .. $match_len) { $search_window .= substr($search_window, length($search_window) - $offset, 1); } } print $out_fh substr($search_window, -($match_len + $literals_length)); $search_window = substr($search_window, -MAX_MATCH_DIST) if (length($search_window) > 2 * MAX_MATCH_DIST); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 May 2024 # Edit: 02 June 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables), inspired by LZ4, combined with Huffman coding. # References: # https://github.com/lz4/lz4/blob/dev/doc/lz4_Frame_format.md # https://github.com/lz4/lz4/blob/dev/doc/lz4_Block_format.md use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZBH', VERSION => '0.01', FORMAT => 'lzbh', MIN_MATCH_LEN => 4, # minimum match length MAX_MATCH_LEN => ~0, # maximum match length MAX_MATCH_DIST => (1 << 17) - 1, # maximum match distance MAX_CHAIN_LEN => 48, # higher value = better compression CHUNK_SIZE => 1 << 18, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > MAX_MATCH_DIST) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > MAX_MATCH_DIST); $DISTANCE_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub encode_distances ($distances, $out_fh) { my @symbols; my $offset_bits = ''; foreach my $dist (@$distances) { my $i = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; push @symbols, $i; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } create_huffman_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub decode_distances ($fh) { my $symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } sub lzss_encode($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = MIN_MATCH_LEN; # minimum match length my $max_len = MAX_MATCH_LEN; # maximum match length my $max_dist = MAX_MATCH_DIST; # maximum match distance my $max_chain_len = MAX_CHAIN_LEN; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead})) { foreach my $p (@{$table{$lookahead}}) { if ($la - $p > $max_dist) { last; } my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; } } my $matched = substr($str, $la, $best_n); foreach my $i (0 .. length($matched) - $min_len) { my $key = substr($matched, $i, $min_len); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } } if ($best_n == 1) { $table{$lookahead} = [$la]; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub lzbh_encode($chunk) { my ($literals, $distances, $lengths) = lzss_encode($chunk); my $literals_end = $#{$literals}; my (@symbols, @len_symbols, @match_symbols, @dist_symbols); for (my $i = 0 ; $i <= $literals_end ; ++$i) { my $j = $i; while ($i <= $literals_end and defined($literals->[$i])) { ++$i; } my $literals_length = $i - $j; my $match_len = $lengths->[$i] // 0; push @match_symbols, (($literals_length >= 7 ? 7 : $literals_length) << 5) | ($match_len >= 31 ? 31 : $match_len); $literals_length -= 7; $match_len -= 31; while ($literals_length >= 0) { push @len_symbols, ($literals_length >= 255 ? 255 : $literals_length); $literals_length -= 255; } push @symbols, @{$literals}[$j .. $i - 1]; while ($match_len >= 0) { push @match_symbols, ($match_len >= 255 ? 255 : $match_len); $match_len -= 255; } push @dist_symbols, $distances->[$i] // 0; } return (\@symbols, \@len_symbols, \@match_symbols, \@dist_symbols); } sub lzbh_decode($symbols, $len_symbols, $match_symbols, $dist_symbols) { my $data = ''; my $data_len = 0; my @symbols = @$symbols; my @len_symbols = @$len_symbols; my @match_symbols = @$match_symbols; my @dist_symbols = @$dist_symbols; while (@symbols) { my $len_byte = shift(@match_symbols); my $literals_length = $len_byte >> 5; my $match_len = $len_byte & 0b11111; if ($literals_length == 7) { while (1) { my $byte_len = shift(@len_symbols); $literals_length += $byte_len; last if $byte_len != 255; } } if ($literals_length > 0) { $data .= pack("C*", splice(@symbols, 0, $literals_length)); $data_len += $literals_length; } if ($match_len == 31) { while (1) { my $byte_len = shift(@match_symbols); $match_len += $byte_len; last if $byte_len != 255; } } my $dist = shift(@dist_symbols); if ($dist == 1) { $data .= substr($data, -1) x $match_len; } elsif ($dist >= $match_len) { $data .= substr($data, $data_len - $dist, $match_len); } else { foreach my $i (1 .. $match_len) { $data .= substr($data, $data_len + $i - $dist - 1, 1); } } $data_len += $match_len; } return $data; } sub compression($chunk, $out_fh) { my ($symbols, $len_symbols, $match_symbols, $dist_symbols) = lzbh_encode($chunk); create_huffman_entry($symbols, $out_fh); create_huffman_entry($len_symbols, $out_fh); create_huffman_entry($match_symbols, $out_fh); encode_distances($dist_symbols, $out_fh); } sub decompression($fh, $out_fh) { while (!eof($fh)) { my $symbols = decode_huffman_entry($fh); my $len_symbols = decode_huffman_entry($fh); my $match_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_distances($fh); print $out_fh lzbh_decode($symbols, $len_symbols, $match_symbols, $dist_symbols); } } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbw_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 September 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'LZBW', VERSION => '0.01', FORMAT => 'lzbw', CHUNK_SIZE => 1 << 16, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]); my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($fh) { my $ints = delta_decode($fh); my $half = scalar(@$ints) >> 1; my @counts; foreach my $i (0 .. ($half - 1)) { push @counts, [$ints->[$i], $ints->[$half + $i]]; } my $bits_len = 0; foreach my $pair (@counts) { my ($blen, $len) = @$pair; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @integers; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @integers, oct('0b' . $chunk); } } return \@integers; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths = ''; my $uncompressed = ''; my @sizes; my @indices_block; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes, 1); my $indices = encode_integers(\@indices_block); bz2_compression($uncompressed, $out_fh); bz2_compression($lengths, $out_fh); bz2_compression($indices, $out_fh); @sizes = (); @indices_block = (); open $uc_fh, '>:raw', \$uncompressed; open $len_fh, '>:raw', \$lengths; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say "Est. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; push @sizes, scalar(@uncompressed); print $uc_fh pack('C*', @uncompressed); print $len_fh pack('C*', @lengths); push @indices_block, @indices; if (length($uncompressed) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh, 1)}; my $indices = ''; my $lengths = ''; my $uncompressed = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; open my $idx_fh, '+>:raw', \$indices; bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh); # lengths bz2_decompression($fh, $idx_fh); # indices seek($idx_fh, 0, 0); my @indices = @{decode_integers($idx_fh)}; my @uncompressed = split(//, $uncompressed); my @lengths = unpack('C*', $lengths); while (@uncompressed) { my $size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $size); my @lengths_chunk = splice(@lengths, 0, $size); my @indices_chunk = splice(@indices, 0, $size); scalar(@uncompressed_chunk) == $size or die "decompression error"; scalar(@lengths_chunk) == $size or die "decompression error"; scalar(@indices_chunk) == $size or die "decompression error"; print $out_fh lz77_decompression(\@uncompressed_chunk, \@indices_chunk, \@lengths_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbwa_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 September 2023 # Edit: 23 February 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Arithmetic Coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'LZBWA', VERSION => '0.01', FORMAT => 'lzbwa', CHUNK_SIZE => 1 << 16, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]); my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($fh) { my $ints = delta_decode($fh); my $half = scalar(@$ints) >> 1; my @counts; foreach my $i (0 .. ($half - 1)) { push @counts, [$ints->[$i], $ints->[$half + $i]]; } my $bits_len = 0; foreach my $pair (@counts) { my ($blen, $len) = @$pair; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @integers; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @integers, oct('0b' . $chunk); } } return \@integers; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; say "Max symbol: $max_symbol\n"; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len\n"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_ac_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_ac_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths = ''; my $uncompressed = ''; my @sizes; my @indices_block; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes, 1); my $indices = encode_integers(\@indices_block); bz2_compression($uncompressed, $out_fh); bz2_compression($lengths, $out_fh); bz2_compression($indices, $out_fh); @sizes = (); @indices_block = (); open $uc_fh, '>:raw', \$uncompressed; open $len_fh, '>:raw', \$lengths; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say "Est. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; push @sizes, scalar(@uncompressed); print $uc_fh pack('C*', @uncompressed); print $len_fh pack('C*', @lengths); push @indices_block, @indices; if (length($uncompressed) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh, 1)}; my $indices = ''; my $lengths = ''; my $uncompressed = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; open my $idx_fh, '+>:raw', \$indices; bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh); # lengths bz2_decompression($fh, $idx_fh); # indices seek($idx_fh, 0, 0); my @indices = @{decode_integers($idx_fh)}; my @uncompressed = split(//, $uncompressed); my @lengths = unpack('C*', $lengths); while (@uncompressed) { my $size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $size); my @lengths_chunk = splice(@lengths, 0, $size); my @indices_chunk = splice(@indices, 0, $size); scalar(@uncompressed_chunk) == $size or die "decompression error"; scalar(@lengths_chunk) == $size or die "decompression error"; scalar(@indices_chunk) == $size or die "decompression error"; print $out_fh lz77_decompression(\@uncompressed_chunk, \@indices_chunk, \@lengths_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbwad_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 September 2023 # Edit: 07 March 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Burrows-Wheeler Transform (BWT) + Adaptive Arithmetic Coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'LZBWAD', VERSION => '0.01', FORMAT => 'lzbwad', CHUNK_SIZE => 1 << 16, # higher value = better compression LOOKAHEAD_LEN => 128, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); use constant INITIAL_FREQ => 1; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]); my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($fh) { my $ints = delta_decode($fh); my $half = scalar(@$ints) >> 1; my @counts; foreach my $i (0 .. ($half - 1)) { push @counts, [$ints->[$i], $ints->[$half + $i]]; } my $bits_len = 0; foreach my $pair (@counts) { my ($blen, $len) = @$pair; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @integers; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @integers, oct('0b' . $chunk); } } return \@integers; } sub create_cfreq ($freq_value, $max_symbol) { my $T = 0; my (@cf, @freq); foreach my $i (0 .. $max_symbol) { $freq[$i] = $freq_value; $cf[$i] = $T; $T += $freq_value; $cf[$i + 1] = $T; } return (\@freq, \@cf, $T); } sub increment_freq ($c, $max_symbol, $freq, $cf) { ++$freq->[$c]; my $T = $cf->[$c]; foreach my $i ($c .. $max_symbol) { $cf->[$i] = $T; $T += $freq->[$i]; $cf->[$i + 1] = $T; } return $T; } sub ac_encode ($bytes_arr) { my $enc = ''; my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1); my $max_symbol = max(@bytes) // 0; my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; $T = increment_freq($c, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, $max_symbol); } sub ac_decode ($fh, $max_symbol) { my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); while (1) { my $w = ($high + 1) - $low; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = 0; foreach my $j (0 .. $max_symbol) { if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) { $i = $j; last; } } last if ($i == $max_symbol); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; $T = increment_freq($i, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: ($high > ${\MAX})"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $max_symbol) = ac_encode($bytes); print $out_fh delta_encode([$max_symbol, length($enc)], 1); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)}; say "Encoded length: $enc_len"; if ($enc_len > 0) { my $bits = read_bits($fh, $enc_len); open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, $max_symbol); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_ac_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_ac_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths = ''; my $uncompressed = ''; my @sizes; my @indices_block; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes, 1); my $indices = encode_integers(\@indices_block); bz2_compression($uncompressed, $out_fh); bz2_compression($lengths, $out_fh); bz2_compression($indices, $out_fh); @sizes = (); @indices_block = (); open $uc_fh, '>:raw', \$uncompressed; open $len_fh, '>:raw', \$lengths; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say "Est. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; push @sizes, scalar(@uncompressed); print $uc_fh pack('C*', @uncompressed); print $len_fh pack('C*', @lengths); push @indices_block, @indices; if (length($uncompressed) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh, 1)}; my $indices = ''; my $lengths = ''; my $uncompressed = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; open my $idx_fh, '+>:raw', \$indices; bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh); # lengths bz2_decompression($fh, $idx_fh); # indices seek($idx_fh, 0, 0); my @indices = @{decode_integers($idx_fh)}; my @uncompressed = split(//, $uncompressed); my @lengths = unpack('C*', $lengths); while (@uncompressed) { my $size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $size); my @lengths_chunk = splice(@lengths, 0, $size); my @indices_chunk = splice(@indices, 0, $size); scalar(@uncompressed_chunk) == $size or die "decompression error"; scalar(@lengths_chunk) == $size or die "decompression error"; scalar(@indices_chunk) == $size or die "decompression error"; print $out_fh lz77_decompression(\@uncompressed_chunk, \@indices_chunk, \@lengths_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbwd_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 07 September 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'LZBWD', VERSION => '0.01', FORMAT => 'lzbwd', CHUNK_SIZE => 1 << 16, # higher value = better compression LOOKAHEAD_LEN => 128, MAX_INT => oct('0b' . ('1' x 32)), }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub encode_integers ($integers) { my @symbols; my $offset_bits = ''; foreach my $dist (@$integers) { foreach my $i (0 .. $#DISTANCE_SYMBOLS) { if ($DISTANCE_SYMBOLS[$i][0] > $dist) { push @symbols, $i - 1; if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) { $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]); } last; } } } return (pack('C*', @symbols), pack('B*', $offset_bits)); } sub decode_integers ($symbols, $fh) { my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths = ''; my $uncompressed = ''; my @sizes; my @indices_block; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes, 1); my ($symbols, $offset_bits) = encode_integers(\@indices_block); bz2_compression($uncompressed, $out_fh); bz2_compression($lengths, $out_fh); bz2_compression($symbols, $out_fh); bz2_compression($offset_bits, $out_fh); @sizes = (); @indices_block = (); open $uc_fh, '>:raw', \$uncompressed; open $len_fh, '>:raw', \$lengths; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say "Est. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; push @sizes, scalar(@uncompressed); print $uc_fh pack('C*', @uncompressed); print $len_fh pack('C*', @lengths); push @indices_block, @indices; if (length($uncompressed) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh, 1)}; my $lengths = ''; my $uncompressed = ''; my $symbols = ''; my $offset_bits = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; open my $sym_fh, '+>:raw', \$symbols; open my $offbits_fh, '+>:raw', \$offset_bits; bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh); # lengths bz2_decompression($fh, $sym_fh); # symbols bz2_decompression($fh, $offbits_fh); # offset bits seek($offbits_fh, 0, 0); my @indices = @{decode_integers([unpack('C*', $symbols)], $offbits_fh)}; my @uncompressed = split(//, $uncompressed); my @lengths = unpack('C*', $lengths); while (@uncompressed) { my $size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $size); my @lengths_chunk = splice(@lengths, 0, $size); my @indices_chunk = splice(@indices, 0, $size); scalar(@uncompressed_chunk) == $size or die "decompression error"; scalar(@lengths_chunk) == $size or die "decompression error"; scalar(@indices_chunk) == $size or die "decompression error"; print $out_fh lz77_decompression(\@uncompressed_chunk, \@indices_chunk, \@lengths_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzbwh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 07 September 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression + DEFLATE integers encoding + Burrows-Wheeler Transform (BWT) + Huffman coding. # References: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A # # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'LZBWH', VERSION => '0.01', FORMAT => 'lzbwh', CHUNK_SIZE => 1 << 16, # higher value = better compression LOOKAHEAD_LEN => 128, MAX_INT => oct('0b' . ('1' x 32)), }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub encode_integers ($integers) { my @symbols; my $offset_bits = ''; foreach my $dist (@$integers) { foreach my $i (0 .. $#DISTANCE_SYMBOLS) { if ($DISTANCE_SYMBOLS[$i][0] > $dist) { push @symbols, $i - 1; if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) { $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]); } last; } } } my $str = ''; open(my $out_fh, '>:raw', \$str); create_huffman_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); return $str; } sub decode_integers ($fh) { my $symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@$symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub bz2_compression ($chunk, $out_fh) { my $rle1 = rle4_encode([unpack('C*', $chunk)]); my ($bwt, $idx) = bwt_encode(pack('C*', @$rle1)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression ($fh, $out_fh) { my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $data = rle4_decode([unpack('C*', $rle4)]); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my $lengths = ''; my $uncompressed = ''; my @sizes; my @indices_block; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; my $create_bz2_block = sub { scalar(@sizes) > 0 or return; print $out_fh delta_encode(\@sizes, 1); my $indices = encode_integers(\@indices_block); bz2_compression($uncompressed, $out_fh); bz2_compression($lengths, $out_fh); bz2_compression($indices, $out_fh); @sizes = (); @indices_block = (); open $uc_fh, '>:raw', \$uncompressed; open $len_fh, '>:raw', \$lengths; }; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say "Est. ratio: ", $est_ratio, " (", scalar(@uncompressed), " uncompressed bytes)"; push @sizes, scalar(@uncompressed); print $uc_fh pack('C*', @uncompressed); print $len_fh pack('C*', @lengths); push @indices_block, @indices; if (length($uncompressed) >= CHUNK_SIZE) { $create_bz2_block->(); } } $create_bz2_block->(); close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @sizes = @{delta_decode($fh, 1)}; my $indices = ''; my $lengths = ''; my $uncompressed = ''; open my $uc_fh, '>:raw', \$uncompressed; open my $len_fh, '>:raw', \$lengths; open my $idx_fh, '+>:raw', \$indices; bz2_decompression($fh, $uc_fh); # uncompressed bz2_decompression($fh, $len_fh); # lengths bz2_decompression($fh, $idx_fh); # indices seek($idx_fh, 0, 0); my @indices = @{decode_integers($idx_fh)}; my @uncompressed = split(//, $uncompressed); my @lengths = unpack('C*', $lengths); while (@uncompressed) { my $size = shift(@sizes) // die "decompression error"; my @uncompressed_chunk = splice(@uncompressed, 0, $size); my @lengths_chunk = splice(@lengths, 0, $size); my @indices_chunk = splice(@indices, 0, $size); scalar(@uncompressed_chunk) == $size or die "decompression error"; scalar(@lengths_chunk) == $size or die "decompression error"; scalar(@indices_chunk) == $size or die "decompression error"; print $out_fh lz77_decompression(\@uncompressed_chunk, \@indices_chunk, \@lengths_chunk); } } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Huffman coding. use 5.020; use strict; use warnings; use experimental qw(signatures); use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZH', VERSION => '0.02', FORMAT => 'lzh', CHUNK_SIZE => 1 << 16, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = 0; my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = index($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $p; push @$lengths, $n; push @$uncompressed, $chars[$la + $n]; $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $ret = ''; my $chunk = ''; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $indices->[$i], $lengths->[$i]) . chr($uncompressed->[$i]); if (length($chunk) >= CHUNK_SIZE) { $ret .= $chunk; $chunk = ''; } } if ($chunk ne '') { $ret .= $chunk; } $ret; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; my (@uncompressed, @indices, @lengths); # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); } @indices = unpack('C*', pack('S*', @indices)); @uncompressed = unpack('C*', join('', @uncompressed)); create_huffman_entry(\@uncompressed, $out_fh); create_huffman_entry(\@indices, $out_fh); create_huffman_entry(\@lengths, $out_fh); # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my $uncompressed = decode_huffman_entry($fh); my @indices = unpack('S*', pack('C*', @{decode_huffman_entry($fh)})); my $lengths = decode_huffman_entry($fh); print $out_fh lz77_decompression($uncompressed, \@indices, $lengths); # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzhc_file_compression.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Created on: 21 May 2014 # Latest edit on: 26 April 2015 # Website: https://github.com/trizen # A new type of LZ compression + Huffman coding, featuring a very short decompression time. use 5.010; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'lzhc', VERSION => '0.02', FORMAT => 'lzhc', }; use constant { MIN => 4, BUFFER => 256, SIGNATURE => uc(FORMAT) . chr(2), }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub walk { my ($n, $s, $h) = @_; if (exists($n->{a})) { $h->{$n->{a}} = $s; return 1; } walk($n->{'0'}, $s . '0', $h); walk($n->{'1'}, $s . '1', $h); } sub mktree { my ($text) = @_; my %letters; ++$letters{$_} for (split(//, $text)); my @nodes; if ((@nodes = map { {a => $_, freq => $letters{$_}} } keys %letters) == 1) { return {$nodes[0]{a} => '0'}; } my %n; while ((@nodes = sort { $a->{freq} <=> $b->{freq} } @nodes) > 1) { %n = ('0' => {%{shift(@nodes)}}, '1' => {%{shift(@nodes)}}); $n{freq} = $n{'0'}{freq} + $n{'1'}{freq}; push @nodes, {%n}; } walk(\%n, '', $n{tree} = {}); return $n{tree}; } sub huffman_encode { my ($str, $dict) = @_; join('', map { $dict->{$_} // die("bad char $_") } split(//, $str)); } sub huffman_decode { my ($hash, $bytes) = @_; local $" = '|'; unpack('B*', $bytes) =~ s/(@{[sort {length($a) <=> length($b)} keys %{$hash}]})/$hash->{$1}/gr; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub compress { my ($input, $output) = @_; # Open the input file open my $fh, '<:raw', $input; # Open the output file and write the archive signature open my $out_fh, '>:raw', $output; print {$out_fh} SIGNATURE; while ((my $len = read($fh, (my $block), BUFFER)) > 0) { my %dict; my $max = int($len / 2); foreach my $i (reverse(MIN .. $max)) { foreach my $j (0 .. $len - $i * 2) { if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) { if (not exists $dict{$pos} or $i > $dict{$pos}[1]) { $dict{$pos} = [$j, $i]; } } } } my @pairs; my $uncompressed = ''; for (my $i = 0 ; $i < $len ; $i++) { if (exists $dict{$i}) { my ($key, $vlen) = @{$dict{$i}}; push @pairs, [$i, $key, $vlen]; $i += $vlen - 1; } else { $uncompressed .= substr($block, $i, 1); } } my $huffman_hash = mktree($uncompressed); my $huffman_enc = huffman_encode($uncompressed, $huffman_hash); my %huffman_dict; foreach my $k (keys %{$huffman_hash}) { push @{$huffman_dict{length($huffman_hash->{$k})}}, [$k, $huffman_hash->{$k}]; } { use bytes; my $binary_enc = pack('B*', $huffman_enc); my $encoding_len = length($binary_enc); printf("%3d -> %3d (%.2f%%)\n", $len, $encoding_len, ($len - $encoding_len) / $len * 100); print {$out_fh} # Length of the uncompressed text chr(length($uncompressed) - 1), # LZT pairs num chr($#pairs + 1), # LZT pairs encoded into bytes ( map { map { chr } @{$_} } @pairs ), # Huffman dictionary size chr(scalar(keys(%huffman_dict)) > 0 ? scalar(keys(%huffman_dict)) - 1 : 0), # Huffman dictionary into bytes ( join( '', map { chr($_) . chr($#{$huffman_dict{$_}} + 1) . join('', map { $_->[0] } @{$huffman_dict{$_}}) . pack('B*', join('', map { $_->[1] } @{$huffman_dict{$_}})) } sort { $a <=> $b } keys %huffman_dict ) ), # Huffman encoded bytes length chr($encoding_len - 1), # Huffman encoded bytes $binary_enc } # exit; } close $fh; close $out_fh; } sub decompress { my ($input, $output) = @_; # Open and validate the input file open my $fh, '<:raw', $input; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E archive!\n"; # Open the output file open my $out_fh, '>:raw', $output; while (read($fh, (my $len_byte), 1) > 0) { read($fh, (my $lzt_pairs), 1); # Create the LZT dictionary my %dict; for my $i (1 .. ord($lzt_pairs)) { read($fh, (my $at_byte), 1); read($fh, (my $from_byte), 1); read($fh, (my $size_byte), 1); $dict{ord($at_byte)} = [ord($from_byte), ord($size_byte)]; } read($fh, (my $huffman_pairs), 1); # Create the Huffman dictionary my %huffman_dict; for my $i (1 .. ord($huffman_pairs) + 1) { read($fh, (my $pattern_len), 1); read($fh, (my $pattern_num), 1); my $bits_num = ord($pattern_len) * ord($pattern_num); if ($bits_num % 8 != 0) { $bits_num += 8 - ($bits_num % 8); } read($fh, (my $chars), ord($pattern_num)); read($fh, (my $patterns), $bits_num / 8); my $bits = unpack('B*', $patterns); foreach my $char (split(//, $chars)) { $huffman_dict{substr($bits, 0, ord($pattern_len), '')} = $char; } } read($fh, (my $bytes_len), 1); read($fh, (my $bytes), ord($bytes_len) + 1); # Huffman decoding my $len = ord($len_byte) + 1; my $block = substr(huffman_decode(\%huffman_dict, $bytes), 0, $len); my $acc = 0; my $decompressed = ''; # LZT decoding for (my $i = 0 ; $i <= $len ; $i++) { if (exists($dict{$i + $acc})) { my $pos = $dict{$i + $acc}; $decompressed .= substr($decompressed, $pos->[0], $pos->[1]); $acc += $pos->[1]; $i--; } else { $decompressed .= substr($block, $i, 1); } } print {$out_fh} $decompressed; } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzhd_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 13 June 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression + Huffman coding. # Encoding the distances/indices using a DEFLATE-like approach. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZHD', VERSION => '0.02', FORMAT => 'lzhd', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); foreach my $k (keys %$rev_dict) { $rev_dict->{$k} = chr($rev_dict->{$k}); } my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return ''; } sub encode_distances ($distances, $out_fh) { my @symbols; my $offset_bits = ''; foreach my $dist (@$distances) { my $i = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; push @symbols, $i; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } create_huffman_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub decode_distances ($fh) { my @symbols = unpack('C*', decode_huffman_entry($fh)); my $bits_len = 0; foreach my $i (@symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say(scalar(@uncompressed), ' -> ', $est_ratio); create_huffman_entry(\@uncompressed, $out_fh); create_huffman_entry(\@lengths, $out_fh); encode_distances(\@indices, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @uncompressed = split(//, decode_huffman_entry($fh)); my @lengths = unpack('C*', decode_huffman_entry($fh)); my $indices = decode_distances($fh); print $out_fh lz77_decompression(\@uncompressed, $indices, \@lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzih_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 15 December 2022 # Edit: 13 June 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression + fixed-width integers encoding + Huffman coding. use 5.020; use strict; use warnings; use experimental qw(signatures); use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZIH', VERSION => '0.04', FORMAT => 'lzih', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(4); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n < 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @$indices, $la - $p; push @$lengths, $n; push @$uncompressed, ord($chars[$la + $n]); $la += $n + 1; $prefix .= $token; } return; } sub lz77_decompression ($uncompressed, $indices, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#{$uncompressed}) { $chunk .= substr($chunk, $offset - $indices->[$i], $lengths->[$i]) . $uncompressed->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]); my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($fh) { my $ints = delta_decode($fh); my $half = scalar(@$ints) >> 1; my @counts; foreach my $i (0 .. ($half - 1)) { push @counts, [$ints->[$i], $ints->[$half + $i]]; } my $bits_len = 0; foreach my $pair (@counts) { my ($blen, $len) = @$pair; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @integers; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @integers, oct('0b' . $chunk); } } return \@integers; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); foreach my $k (keys %$rev_dict) { $rev_dict->{$k} = chr($rev_dict->{$k}); } my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return ''; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (4 * scalar(@uncompressed)); say(scalar(@uncompressed), ' -> ', $est_ratio); create_huffman_entry(\@uncompressed, $out_fh); create_huffman_entry(\@lengths, $out_fh); print $out_fh encode_integers(\@indices); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my @uncompressed = split(//, decode_huffman_entry($fh)); my @lengths = unpack('C*', decode_huffman_entry($fh)); my $indices = decode_integers($fh); print $out_fh lz77_decompression(\@uncompressed, $indices, \@lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzsa_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 12 August 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant) + Arithmetic Coding (in fixed bits). # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max sum); use POSIX qw(ceil log2); use constant { PKGNAME => 'LZSA', VERSION => '0.02', FORMAT => 'lzsa', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage ($code) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive ($fh) { if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_ac_entry(\@len_symbols, $out_fh); create_ac_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_ac_entry($fh); my $dist_symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzsad_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 07 March 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant) + Adaptive Arithmetic Coding (in fixed bits). # Encoding the literals and the pointers using a DEFLATE-like approach. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max sum); use POSIX qw(ceil log2); use constant { PKGNAME => 'LZSAD', VERSION => '0.01', FORMAT => 'lzsad', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); use constant INITIAL_FREQ => 1; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq_value, $max_symbol) { my $T = 0; my (@cf, @freq); foreach my $i (0 .. $max_symbol) { $freq[$i] = $freq_value; $cf[$i] = $T; $T += $freq_value; $cf[$i + 1] = $T; } return (\@freq, \@cf, $T); } sub increment_freq ($c, $max_symbol, $freq, $cf) { ++$freq->[$c]; my $T = $cf->[$c]; foreach my $i ($c .. $max_symbol) { $cf->[$i] = $T; $T += $freq->[$i]; $cf->[$i + 1] = $T; } return $T; } sub ac_encode ($bytes_arr) { my $enc = ''; my @bytes = (@$bytes_arr, (max(@$bytes_arr) // 0) + 1); my $max_symbol = max(@bytes) // 0; my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; $T = increment_freq($c, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, $max_symbol); } sub ac_decode ($fh, $max_symbol) { my ($freq, $cf, $T) = create_cfreq(INITIAL_FREQ, $max_symbol); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); while (1) { my $w = ($high + 1) - $low; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = 0; foreach my $j (0 .. $max_symbol) { if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) { $i = $j; last; } } last if ($i == $max_symbol); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; $T = increment_freq($i, $max_symbol, $freq, $cf); if ($high > MAX) { die "high > MAX: ($high > ${\MAX})"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $max_symbol) = ac_encode($bytes); print $out_fh delta_encode([$max_symbol, length($enc)], 1); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my ($max_symbol, $enc_len) = @{delta_decode($fh, 1)}; say "Encoded length: $enc_len"; if ($enc_len > 0) { my $bits = read_bits($fh, $enc_len); open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, $max_symbol); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_ac_entry(\@len_symbols, $out_fh); create_ac_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_ac_entry($fh); my $dist_symbols = decode_ac_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzsbw_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 18 March 2024 # https://github.com/trizen # Compress/decompress files using LZSS + Bzip2. # Encoding the literals and the pointers using a DEFLATE-like approach. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use POSIX qw(ceil log2); use constant { PKGNAME => 'LZSBW', VERSION => '0.01', FORMAT => 'lzsbw', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort_symbolic ($s) { # O(n) space (slowish) my @cyclic = @$s; my $len = scalar(@cyclic); my $rle = 1; foreach my $i (1 .. $len - 1) { if ($cyclic[$i] != $cyclic[$i - 1]) { $rle = 0; last; } } $rle && return [0 .. $len - 1]; [ sort { my ($i, $j) = ($a, $b); while ($cyclic[$i] == $cyclic[$j]) { $i %= $len if (++$i >= $len); $j %= $len if (++$j >= $len); } $cyclic[$i] <=> $cyclic[$j]; } 0 .. $len - 1 ]; } sub bwt_encode_symbolic ($s) { my $bwt = bwt_sort_symbolic($s); my @ret = map { $s->[$_ - 1] } @$bwt; my $idx = 0; foreach my $i (@$bwt) { $i || last; ++$idx; } return (\@ret, $idx); } sub bwt_decode_symbolic ($bwt, $idx) { # fast inversion my @tail = @$bwt; my @head = sort { $a <=> $b } @tail; my @indices; foreach my $i (0 .. $#tail) { push @{$indices[$tail[$i]]}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices[$v]}); } my @dec; my $i = $idx; for (1 .. scalar(@head)) { push @dec, $head[$i]; $i = $table[$i]; } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet_symbolic ($alphabet) { return delta_encode([@$alphabet]); } sub decode_alphabet_symbolic ($fh) { return [@{delta_decode($fh)}]; } sub bz2_compression_symbolic ($symbols, $out_fh) { my ($bwt, $idx) = bwt_encode_symbolic($symbols); say "BWT index = $idx"; my @bytes = @$bwt; my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet_symbolic(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub bz2_decompression_symbolic ($fh) { my $idx = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); my $alphabet = decode_alphabet_symbolic($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet); my $data = bwt_decode_symbolic($bwt, $idx); return $data; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } bz2_compression_symbolic(\@len_symbols, $out_fh); bz2_compression_symbolic(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = bz2_decompression_symbolic($fh); my $dist_symbols = bz2_decompression_symbolic($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzss2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 20 March 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # This version is memory-friendly, supporting arbitrary large chunk sizes. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use POSIX qw(ceil log2); use constant { PKGNAME => 'LZSS2', VERSION => '0.01', FORMAT => 'lzss2', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub find_distance_index ($dist, $distance_symbols) { foreach my $i (0 .. $#{$distance_symbols}) { if ($distance_symbols->[$i][0] > $dist) { return $i - 1; } } } sub make_deflate_symbols ($size) { # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > $size) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } return (\@DISTANCE_SYMBOLS, \@LENGTH_INDICES, \@LENGTH_SYMBOLS); } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols(length($str)); my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS->[0][0]; my $max_len = $LENGTH_SYMBOLS->[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $dist = undef; my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $distance_index = find_distance_index($la - $p, $DISTANCE_SYMBOLS); $dist = $DISTANCE_SYMBOLS->[$distance_index]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES->[$n - 1]; my $len = $LENGTH_SYMBOLS->[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES->[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) { my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS); my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } print $out_fh pack('N', $size); create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS->[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS->[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; deflate_encode(length($chunk), \@uncompressed, \@indices, \@lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzss_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use POSIX qw(ceil log2); use constant { PKGNAME => 'LZSS', VERSION => '0.01', FORMAT => 'lzss', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my (@uncompressed, @indices, @lengths); lz77_compression($chunk, \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($uncompressed, $indices, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($uncompressed, $indices, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzssf_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 02 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables -- fast version) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # This version is memory-friendly, supporting arbitrary large chunk sizes. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZSSF', VERSION => '0.01', FORMAT => 'lzssf', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub find_distance_index ($dist, $distance_symbols) { foreach my $i (0 .. $#{$distance_symbols}) { if ($distance_symbols->[$i][0] > $dist) { return $i - 1; } } } sub make_deflate_symbols ($size) { # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > $size) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } return (\@DISTANCE_SYMBOLS, \@LENGTH_INDICES, \@LENGTH_SYMBOLS); } sub lz77_compression($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = 4; # minimum match length my $max_len = 258; # maximum match length my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead})) { my $p = $table{$lookahead}; my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } $best_p = $p; $best_n = $n; $table{$lookahead} = $la; } else { $table{$lookahead} = $la; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub lz77_decompression ($literals, $distances, $lengths) { my $data = ''; my $data_len = 0; foreach my $i (0 .. $#$lengths) { if ($lengths->[$i] == 0) { $data .= chr($literals->[$i]); ++$data_len; next; } my $length = $lengths->[$i]; my $dist = $distances->[$i]; if ($dist >= $length) { $data .= substr($data, $data_len - $dist, $length); } elsif ($dist == 1) { $data .= substr($data, -1) x $length; } else { foreach my $i (1 .. $length) { $data .= substr($data, $data_len + $i - $dist - 1, 1); } } $data_len += $length; } return $data; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) { my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $k (0 .. $#{$literals}) { if ($lengths->[$k] == 0) { push @len_symbols, $literals->[$k]; next; } my $len = $lengths->[$k]; my $dist = $distances->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS); my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } print $out_fh pack('N', $size); create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS->[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS->[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; my $k = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($literals, $distances, $lengths) = lz77_compression($chunk); my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances)); say scalar(@$literals), ' -> ', $est_ratio; deflate_encode(length($chunk), $literals, $distances, $lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($literals, $distances, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($literals, $distances, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzsst2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 04 July 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables and lazy matching) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # This version is memory-friendly, supporting arbitrary large chunk sizes. # References: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ # # DEFLATE Compressed Data Format Specification version 1.3 # https://datatracker.ietf.org/doc/html/rfc1951 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZSST2', VERSION => '0.01', FORMAT => 'lzsst2', CHUNK_SIZE => 1 << 19, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub find_distance_index ($dist, $distance_symbols) { my ($lo, $hi) = (0, $#{$distance_symbols}); while ($lo < $hi) { my $mid = ($lo + $hi + 1) >> 1; if ($distance_symbols->[$mid][0] <= $dist) { $lo = $mid; } else { $hi = $mid - 1; } } return $lo; } sub make_deflate_symbols ($size) { # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > $size) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } return (\@DISTANCE_SYMBOLS, \@LENGTH_INDICES, \@LENGTH_SYMBOLS); } sub find_match ($str_ref, $la, $min_len, $max_len, $end, $table, $symbols) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($$str_ref, $la, $min_len); if (exists($table->{$lookahead})) { foreach my $p (@{$table->{$lookahead}}) { my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols->[$la + $n - 1] == $symbols->[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; last if ($best_n > $max_len); # can't do better } } } return ($best_n, $best_p); } sub lz77_compression($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = 4; # minimum match length my $max_len = 258; # maximum match length my $max_chain_len = 48; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $lookahead1 = substr($str, $la, $min_len); my $lookahead2 = substr($str, $la + 1, $min_len); my ($n1, $p1) = (1, $la); my ($n2, $p2) = (1, $la + 1); if (exists($table{$lookahead1})) { ($n1, $p1) = find_match(\$str, $la, $min_len, $max_len, $end, \%table, \@symbols); } if ($n1 > 1 and exists($table{$lookahead2})) { ($n2, $p2) = find_match(\$str, $la + 1, $min_len, $max_len, $end, \%table, \@symbols); } my $best_n = $n1; my $best_p = $p1; my $lookahead = $lookahead1; # When a longer match is found at position la+1, # emit a literal followed by the longer match. # https://datatracker.ietf.org/doc/html/rfc1951#section-4 if ($n2 > $n1 and $p1 < $p2) { push @lengths, (0); push @distances, (0); push @literals, $symbols[$la]; $la += 1; $best_n = $n2; $best_p = $p2; $lookahead = $lookahead2; } my $matched = substr($str, $la, $best_n); foreach my $i (0 .. length($matched) - $min_len) { my $key = substr($matched, $i, $min_len); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } if ($best_n == 1) { $table{$lookahead} = [$la]; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub lz77_decompression ($literals, $distances, $lengths) { my $data = ''; my $data_len = 0; foreach my $i (0 .. $#$lengths) { if ($lengths->[$i] == 0) { $data .= chr($literals->[$i]); ++$data_len; next; } my $length = $lengths->[$i]; my $dist = $distances->[$i]; if ($dist >= $length) { # non-overlapping matches $data .= substr($data, $data_len - $dist, $length); } elsif ($dist == 1) { # run-length of last character $data .= substr($data, -1) x $length; } else { # overlapping matches my $pattern = substr($data, $data_len - $dist, $dist); my $full_reps = int(($length + $dist - 1) / $dist) + 1; $data .= substr($pattern x $full_reps, 0, $length); } $data_len += $length; } return $data; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # Heap helpers sub _heap_push ($heap, $item) { push @$heap, $item; my $i = $#$heap; while ($i > 0) { my $p = ($i - 1) >> 1; last if $heap->[$p][1] <= $heap->[$i][1]; @{$heap}[$p, $i] = @{$heap}[$i, $p]; $i = $p; } } sub _heap_pop ($heap) { return pop @$heap if @$heap == 1; my $min = $heap->[0]; $heap->[0] = pop @$heap; my ($i, $n) = (0, scalar @$heap); while (1) { my ($l, $r, $s) = ($i * 2 + 1, $i * 2 + 2, $i); $s = $l if $l < $n && $heap->[$l][1] < $heap->[$s][1]; $s = $r if $r < $n && $heap->[$r][1] < $heap->[$s][1]; last if $s == $i; @{$heap}[$i, $s] = @{$heap}[$s, $i]; $i = $s; } return $min; } sub mktree_from_freq ($freq) { my @heap; _heap_push(\@heap, [$_, $freq->{$_}]) for sort { $a <=> $b } keys %$freq; while (@heap > 1) { my $x = _heap_pop(\@heap); my $y = _heap_pop(\@heap); _heap_push(\@heap, [[$x, $y], $x->[1] + $y->[1]]); } walk($heap[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) { my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $k (0 .. $#{$literals}) { if ($lengths->[$k] == 0) { push @len_symbols, $literals->[$k]; next; } my $len = $lengths->[$k]; my $dist = $distances->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS); my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } print $out_fh pack('N', $size); create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS->[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS->[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($literals, $distances, $lengths) = lz77_compression($chunk); my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances)); say scalar(@$literals), ' -> ', $est_ratio; deflate_encode(length($chunk), $literals, $distances, $lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($literals, $distances, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($literals, $distances, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzsst_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 02 May 2024 # https://github.com/trizen # Compress/decompress files using LZ77 compression (LZSS variant with hash tables) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # This version is memory-friendly, supporting arbitrary large chunk sizes. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use constant { PKGNAME => 'LZSST', VERSION => '0.01', FORMAT => 'lzsst', CHUNK_SIZE => 1 << 19, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub find_distance_index ($dist, $distance_symbols) { foreach my $i (0 .. $#{$distance_symbols}) { if ($distance_symbols->[$i][0] > $dist) { return $i - 1; } } } sub make_deflate_symbols ($size) { # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > $size) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (4 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } return (\@DISTANCE_SYMBOLS, \@LENGTH_INDICES, \@LENGTH_SYMBOLS); } sub lz77_compression($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = 4; # minimum match length my $max_len = 258; # maximum match length my $max_chain_len = 48; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead})) { foreach my $p (@{$table{$lookahead}}) { my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; } } my $matched = substr($str, $la, $best_n); foreach my $i (0 .. length($matched) - $min_len) { my $key = substr($matched, $i, $min_len); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } } if ($best_n == 1) { $table{$lookahead} = [$la]; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub lz77_decompression ($literals, $distances, $lengths) { my $data = ''; my $data_len = 0; foreach my $i (0 .. $#$lengths) { if ($lengths->[$i] == 0) { $data .= chr($literals->[$i]); ++$data_len; next; } my $length = $lengths->[$i]; my $dist = $distances->[$i]; if ($dist >= $length) { # non-overlapping matches $data .= substr($data, $data_len - $dist, $length); } elsif ($dist == 1) { # run-length of last character $data .= substr($data, -1) x $length; } else { # overlapping matches foreach my $i (1 .. $length) { $data .= substr($data, $data_len + $i - $dist - 1, 1); } } $data_len += $length; } return $data; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($size, $literals, $distances, $lengths, $out_fh) { my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $k (0 .. $#{$literals}) { if ($lengths->[$k] == 0) { push @len_symbols, $literals->[$k]; next; } my $len = $lengths->[$k]; my $dist = $distances->[$k]; { my $len_idx = $LENGTH_INDICES->[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS->[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = find_distance_index($dist, $DISTANCE_SYMBOLS); my ($min, $bits) = @{$DISTANCE_SYMBOLS->[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } print $out_fh pack('N', $size); create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $size = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my ($DISTANCE_SYMBOLS, $LENGTH_INDICES, $LENGTH_SYMBOLS) = make_deflate_symbols($size); my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS->[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS->[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS->[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS->[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS->[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS->[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { my ($literals, $distances, $lengths) = lz77_compression($chunk); my $est_ratio = length($chunk) / (scalar(@$literals) + scalar(@$lengths) + 2 * scalar(@$distances)); say scalar(@$literals), ' -> ', $est_ratio; deflate_encode(length($chunk), $literals, $distances, $lengths, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { my ($literals, $distances, $lengths) = deflate_decode($fh); print $out_fh lz77_decompression($literals, $distances, $lengths); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzt2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Created on: 21 May 2014 # Latest edit on: 28 May 2014 # Website: https://github.com/trizen # A new type of LZ compression, featuring a very short decompression time. use 5.010; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'lzt2', VERSION => '0.01', FORMAT => 'lzt2', }; use constant { MIN => 9, BUFFER => 2**16, SIGNATURE => uc(FORMAT) . chr(1), }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub compress { my ($input, $output) = @_; # Open the input file open my $fh, '<:raw', $input; # Open the output file and write the archive signature open my $out_fh, '>:raw', $output; print {$out_fh} SIGNATURE; while ((my $len = read($fh, (my $block), BUFFER)) > 0) { my %dict; foreach my $i (reverse(MIN .. 255)) { for (my $lim = $len - $i * 2, my $j = 0 ; $j <= $lim ; $j++) { if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) { if (not exists $dict{$pos} or $i > $dict{$pos}[1]) { $dict{$pos} = [$j, $i]; } } else { $j += int($i / MIN) - 1; } } } my @pairs; my $last_pos = 0; my $uncompressed = ''; for (my $i = 0 ; $i < $len ; $i++, $last_pos++) { if (exists $dict{$i}) { my ($key, $vlen) = @{$dict{$i}}; push @pairs, [$last_pos, $key, $vlen]; $i += $vlen - 1; $last_pos = 0; } else { $uncompressed .= substr($block, $i, 1); } } my $uncomp_len = length($uncompressed); printf("%3d -> %3d (%.2f%%)\n", $len, $uncomp_len, ($len - $uncomp_len) / $len * 100); print {$out_fh} pack('S', $uncomp_len - 1), pack('S', scalar @pairs), (map { pack('SSC', @{$_}) } @pairs), $uncompressed; } close $fh; close $out_fh; } sub decompress { my ($input, $output) = @_; # Open and validate the input file open my $fh, '<:raw', $input; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E archive!\n"; # Open the output file open my $out_fh, '>:raw', $output; while (read($fh, (my $len_byte), 2) > 0) { read($fh, (my $groups_byte), 2); my @dict; for my $i (1 .. unpack('S', $groups_byte)) { read($fh, (my $positions), 5); push @dict, [unpack('SSC', $positions)]; } my $len = unpack('S', $len_byte) + 1; read($fh, (my $block), $len); my $last_pos = 0; my $decompressed = ''; for (my $i = 0 ; $i <= $len ; $i++) { if (@dict and ($i - $last_pos == $dict[0][0])) { $decompressed .= substr($decompressed, $dict[0][1], $dict[0][2]); $last_pos = --$i; shift @dict; } else { $decompressed .= substr($block, $i, 1); } } print {$out_fh} $decompressed; } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzt_file_compression.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Created on: 21 May 2014 # Latest edit on: 28 May 2014 # Website: https://github.com/trizen # A new type of LZ compression, featuring a very short decompression time. use 5.010; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'lzt', VERSION => '0.01', FORMAT => 'lzt', }; use constant { MIN => 4, BUFFER => 256, SIGNATURE => uc(FORMAT) . chr(1), }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub compress { my ($input, $output) = @_; # Open the input file open my $fh, '<:raw', $input; # Open the output file and write the archive signature open my $out_fh, '>:raw', $output; print {$out_fh} SIGNATURE; while ((my $len = read($fh, (my $block), BUFFER)) > 0) { my %dict; foreach my $i (reverse(MIN .. int($len / 2))) { foreach my $j (0 .. $len - $i * 2) { if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) { if (not exists $dict{$pos} or $i > $dict{$pos}[1]) { $dict{$pos} = [$j, $i]; } } } } my @pairs; my $last_pos = 0; my $uncompressed = ''; for (my $i = 0 ; $i < $len ; $i++, $last_pos++) { if (exists $dict{$i}) { my ($key, $vlen) = @{$dict{$i}}; push @pairs, [$last_pos, $key, $vlen]; $i += $vlen - 1; $last_pos = 0; } else { $uncompressed .= substr($block, $i, 1); } } my $uncomp_len = length($uncompressed); printf("%3d -> %3d (%.2f%%)\n", $len, $uncomp_len, ($len - $uncomp_len) / $len * 100); print {$out_fh} chr($uncomp_len - 1), chr(scalar @pairs), ( map { map { chr } @{$_} } @pairs ), $uncompressed; } close $fh; close $out_fh; } sub decompress { my ($input, $output) = @_; # Open and validate the input file open my $fh, '<:raw', $input; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E archive!\n"; # Open the output file open my $out_fh, '>:raw', $output; while (read($fh, (my $len_byte), 1) > 0) { read($fh, (my $groups_byte), 1); my @dict; for my $i (1 .. ord($groups_byte)) { read($fh, (my $at_byte), 1); read($fh, (my $from_byte), 1); read($fh, (my $size_byte), 1); push @dict, [ord($at_byte), ord($from_byte), ord($size_byte)]; } my $len = ord($len_byte) + 1; read($fh, (my $block), $len); my $last_pos = 0; my $decompressed = ''; for (my $i = 0 ; $i <= $len ; $i++) { if (@dict and ($i - $last_pos == $dict[0][0])) { $decompressed .= substr($decompressed, $dict[0][1], $dict[0][2]); $last_pos = --$i; shift @dict; } else { $decompressed .= substr($block, $i, 1); } } print {$out_fh} $decompressed; } close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/lzw_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 08 December 2022 # Edit: 15 June 2023 # https://github.com/trizen # Compress/decompress files using LZW compression. # See also: # https://en.wikipedia.org/wiki/Lempel%E2%80%93Ziv%E2%80%93Welch use 5.020; use strict; use warnings; use experimental qw(signatures); use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { PKGNAME => 'LZW', VERSION => '0.03', FORMAT => 'lzw', CHUNK_SIZE => 1 << 17, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(3); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } # Compress a string to a list of output symbols sub compress ($uncompressed) { # Build the dictionary my $dict_size = 256; my %dictionary; foreach my $i (0 .. $dict_size - 1) { $dictionary{chr($i)} = $i; } my $w = ''; my @result; foreach my $c (split(//, $uncompressed)) { my $wc = $w . $c; if (exists $dictionary{$wc}) { $w = $wc; } else { push @result, $dictionary{$w}; # Add wc to the dictionary $dictionary{$wc} = $dict_size++; $w = $c; } } # Output the code for w if ($w ne '') { push @result, $dictionary{$w}; } return \@result; } # Decompress a list of output ks to a string sub decompress ($compressed) { # Build the dictionary my $dict_size = 256; my @dictionary = map { chr($_) } 0 .. $dict_size - 1; my $w = $dictionary[$compressed->[0]]; my $result = $w; foreach my $j (1 .. $#{$compressed}) { my $k = $compressed->[$j]; my $entry = ($k < $dict_size) ? $dictionary[$k] : ($k == $dict_size) ? ($w . substr($w, 0, 1)) : die "Bad compressed k: $k"; $result .= $entry; # Add w+entry[0] to the dictionary push @dictionary, $w . substr($entry, 0, 1); ++$dict_size; $w = $entry; } return \$result; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub elias_encoding ($integers) { my $bitstring = ''; foreach my $k (scalar(@$integers), @$integers) { if ($k == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', $k); my $l = length($t) + 1; my $L = sprintf('%b', $l); $bitstring .= ('1' x (length($L) - 1)) . '0' . substr($L, 1) . substr($t, 1); } } pack('B*', $bitstring); } sub elias_decoding ($fh) { my @ints; my $len = 0; my $buffer = ''; for (my $k = 0 ; $k <= $len ; ++$k) { my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); if ($bl > 0) { my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)) - 1; my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @ints, $int; } else { push @ints, 0; } if ($k == 0) { $len = pop(@ints); } } return \@ints; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; say "Bit sizes: ", join(' ', map { $_->[0] } @counts); say "Lengths : ", join(' ', map { $_->[1] } @counts); say ''; my $compressed = elias_encoding([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]); my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($fh) { my $ints = elias_decoding($fh); my $half = scalar(@$ints) >> 1; my @counts; foreach my $i (0 .. ($half - 1)) { push @counts, [$ints->[$i], $ints->[$half + $i]]; } my $bits_len = 0; foreach my $pair (@counts) { my ($blen, $len) = @$pair; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @integers; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @integers, oct('0b' . $chunk); } } return \@integers; } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh encode_integers(compress($chunk)); } # Close the output file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh ${decompress(decode_integers($fh))}; } # Close the output file close $out_fh; } main(); exit(0); ================================================ FILE: Compression/mbwr_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Move-to-Front Transform (MTF) + Burrows-Wheeler Transform (BWT) + Run-length encoding (RLE) + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'MBWR', VERSION => '0.01', FORMAT => 'mbwr', CHUNK_SIZE => 1 << 17, LOOKAHEAD_LEN => 128, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $len = length($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub compression ($chunk, $out_fh) { my $rle4 = do { my @bytes = unpack('C*', $chunk); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); print $out_fh $alphabet_enc; my $mtf = mtf_encode(\@bytes, [@alphabet]); rle4_encode($mtf); }; my ($bwt, $idx) = bwt_encode(pack('C*', @$rle4)); say "BWT index = $idx"; my @bytes = unpack('C*', $bwt); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle = rle_encode($mtf); print $out_fh pack('N', $idx); print $out_fh $alphabet_enc; create_huffman_entry($rle, $out_fh); } sub decompression ($fh, $out_fh) { my $alphabet2 = decode_alphabet($fh); my $idx = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet1 = decode_alphabet($fh); say "BWT index = $idx"; say "Alphabet size: ", scalar(@$alphabet1); my $rle = decode_huffman_entry($fh); my $mtf = rle_decode($rle); my $bwt = mtf_decode($mtf, $alphabet1); my $rle4 = bwt_decode(pack('C*', @$bwt), $idx); my $mtf2 = rle4_decode([unpack('C*', $rle4)]); my $data = mtf_decode($mtf2, $alphabet2); print $out_fh pack('C*', @$data); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/mra_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 29 February 2024 # https://github.com/trizen # Compress/decompress files using Move-to-Front Transform + Run-length encoding + Arithmetic Coding. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'MRA', VERSION => '0.01', FORMAT => 'mra', CHUNK_SIZE => 1 << 17, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(3); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; say "Max symbol: $max_symbol\n"; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len\n"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub compression ($chunk, $out_fh) { my $bytes = [unpack('C*', $chunk)]; my @alphabet = sort { $a <=> $b } uniq(@$bytes); my $alphabet_enc = encode_alphabet(\@alphabet); $bytes = mtf_encode($bytes, [@alphabet]); $bytes = rle_encode($bytes); $bytes = rle4_encode($bytes); print $out_fh $alphabet_enc; create_ac_entry($bytes, $out_fh); } sub decompression ($fh, $out_fh) { my $alphabet = decode_alphabet($fh); say "Alphabet size: ", scalar(@$alphabet); my $bytes = decode_ac_entry($fh); $bytes = rle4_decode($bytes); $bytes = rle_decode($bytes); $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @$bytes); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/mrh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 15 August 2023 # https://github.com/trizen # Compress/decompress files using Move-to-Front Transform + Run-length encoding + Huffman coding. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'MRH', VERSION => '0.03', FORMAT => 'mrh', CHUNK_SIZE => 1 << 16, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(3); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol: $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 254 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub rle_encode ($bytes) { # RLE2 my @rle; my $end = $#{$bytes}; for (my $i = 0 ; $i <= $end ; ++$i) { my $run = 0; while ($i <= $end and $bytes->[$i] == 0) { ++$run; ++$i; } if ($run >= 1) { my $t = sprintf('%b', $run + 1); push @rle, split(//, substr($t, 1)); } if ($i <= $end) { push @rle, $bytes->[$i] + 1; } } return \@rle; } sub rle_decode ($rle) { # RLE2 my @dec; my $end = $#{$rle}; for (my $i = 0 ; $i <= $end ; ++$i) { my $k = $rle->[$i]; if ($k == 0 or $k == 1) { my $run = 1; while (($i <= $end) and ($k == 0 or $k == 1)) { ($run <<= 1) |= $k; $k = $rle->[++$i]; } push @dec, (0) x ($run - 1); } if ($i <= $end) { push @dec, $k - 1; } } return \@dec; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh) // die "error"))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub compression ($chunk, $out_fh) { my $bytes = [unpack('C*', $chunk)]; my @alphabet = sort { $a <=> $b } uniq(@$bytes); my $alphabet_enc = encode_alphabet(\@alphabet); $bytes = mtf_encode($bytes, [@alphabet]); $bytes = rle_encode($bytes); $bytes = rle4_encode($bytes); print $out_fh $alphabet_enc; create_huffman_entry($bytes, $out_fh); } sub decompression ($fh, $out_fh) { my $alphabet = decode_alphabet($fh); say "Alphabet size: ", scalar(@$alphabet); my $bytes = decode_huffman_entry($fh); $bytes = rle4_decode($bytes); $bytes = rle_decode($bytes); $bytes = mtf_decode($bytes, [@$alphabet]); print $out_fh pack('C*', @$bytes); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/mrlz_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 June 2023 # Edit: 19 March 2024 # https://github.com/trizen # Compress/decompress files using Move to Front transform (MTF) + RLE4 + LZ77 compression (LZSS variant) + Huffman coding. # Encoding the literals and the pointers using a DEFLATE-like approach. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use POSIX qw(ceil log2); use constant { PKGNAME => 'MRLZ', VERSION => '0.01', FORMAT => 'mrlz', CHUNK_SIZE => 1 << 16, # higher value = better compression }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); # [distance value, offset bits] my @DISTANCE_SYMBOLS = map { [$_, 0] } (0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > CHUNK_SIZE) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } # [length, offset bits] my @LENGTH_SYMBOLS = ((map { [$_, 0] } (3 .. 10))); { my $delta = 1; until ($LENGTH_SYMBOLS[-1][0] > 163) { push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1] + 1]; $delta *= 2; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; push @LENGTH_SYMBOLS, [$LENGTH_SYMBOLS[-1][0] + $delta, $LENGTH_SYMBOLS[-1][1]]; } push @LENGTH_SYMBOLS, [258, 0]; } my @DISTANCE_INDICES; foreach my $i (0 .. $#DISTANCE_SYMBOLS) { my ($min, $bits) = @{$DISTANCE_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { last if ($k > CHUNK_SIZE); $DISTANCE_INDICES[$k] = $i; } } my @LENGTH_INDICES; foreach my $i (0 .. $#LENGTH_SYMBOLS) { my ($min, $bits) = @{$LENGTH_SYMBOLS[$i]}; foreach my $k ($min .. $min + (1 << $bits) - 1) { $LENGTH_INDICES[$k] = $i; } } sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub lz77_compression ($str, $uncompressed, $indices, $lengths) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = $LENGTH_SYMBOLS[0][0]; my $max_len = $LENGTH_SYMBOLS[-1][0]; my %literal_freq; my %distance_freq; my $literal_count = 0; my $distance_count = 0; while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } my $enc_bits_len = 0; my $literal_bits_len = 0; if ($n > $min_len) { my $dist = $DISTANCE_SYMBOLS[$DISTANCE_INDICES[$la - $p]]; $enc_bits_len += $dist->[1] + ceil(log2((1 + $distance_count) / (1 + ($distance_freq{$dist->[0]} // 0)))); my $len_idx = $LENGTH_INDICES[$n - 1]; my $len = $LENGTH_SYMBOLS[$len_idx]; $enc_bits_len += $len->[1] + ceil(log2((1 + $literal_count) / (1 + ($literal_freq{$len_idx + 256} // 0)))); my %freq; foreach my $c (unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1])) { ++$freq{$c}; $literal_bits_len += ceil(log2(($n + $literal_count) / ($freq{$c} + ($literal_freq{$c} // 0)))); } } if ($n > $min_len and $enc_bits_len < $literal_bits_len) { push @$lengths, $n - 1; push @$indices, $la - $p; push @$uncompressed, undef; my $dist_idx = $DISTANCE_INDICES[$la - $p]; my $dist = $DISTANCE_SYMBOLS[$dist_idx]; ++$distance_count; ++$distance_freq{$dist->[0]}; ++$literal_count; ++$literal_freq{$LENGTH_INDICES[$n - 1] + 256}; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = unpack('C*', substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @$uncompressed, @bytes; push @$lengths, (0) x scalar(@bytes); push @$indices, (0) x scalar(@bytes); ++$literal_freq{$_} for @bytes; $literal_count += $n; $la += $n; $prefix .= $token; } } return; } sub lz77_decompression ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= chr($literals->[$i]); $offset += 1; } } return $chunk; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub deflate_encode ($literals, $distances, $lengths, $out_fh) { my @len_symbols; my @dist_symbols; my $offset_bits = ''; foreach my $j (0 .. $#{$literals}) { if ($lengths->[$j] == 0) { push @len_symbols, $literals->[$j]; next; } my $len = $lengths->[$j]; my $dist = $distances->[$j]; { my $len_idx = $LENGTH_INDICES[$len]; my ($min, $bits) = @{$LENGTH_SYMBOLS[$len_idx]}; push @len_symbols, $len_idx + 256; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $len - $min); } } { my $dist_idx = $DISTANCE_INDICES[$dist]; my ($min, $bits) = @{$DISTANCE_SYMBOLS[$dist_idx]}; push @dist_symbols, $dist_idx; if ($bits > 0) { $offset_bits .= sprintf('%0*b', $bits, $dist - $min); } } } create_huffman_entry(\@len_symbols, $out_fh); create_huffman_entry(\@dist_symbols, $out_fh); print $out_fh pack('B*', $offset_bits); } sub deflate_decode ($fh) { my $len_symbols = decode_huffman_entry($fh); my $dist_symbols = decode_huffman_entry($fh); my $bits_len = 0; foreach my $i (@$dist_symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } foreach my $i (@$len_symbols) { if ($i >= 256) { $bits_len += $LENGTH_SYMBOLS[$i - 256][1]; } } my $bits = read_bits($fh, $bits_len); my @literals; my @lengths; my @distances; my $j = 0; foreach my $i (@$len_symbols) { if ($i >= 256) { my $dist = $dist_symbols->[$j++]; push @literals, undef; push @lengths, $LENGTH_SYMBOLS[$i - 256][0] + oct('0b' . substr($bits, 0, $LENGTH_SYMBOLS[$i - 256][1], '')); push @distances, $DISTANCE_SYMBOLS[$dist][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$dist][1], '')); } else { push @literals, $i; push @lengths, 0; push @distances, 0; } } return (\@literals, \@distances, \@lengths); } sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@$alphabet, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@$alphabet, $p, 1)); } return \@S; } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } if ($enc == 0) { $populated <<= 1; } else { ($populated <<= 1) |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($run < 255 and $i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub compression ($chunk, $out_fh) { my @bytes = unpack('C*', $chunk); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $mtf = mtf_encode(\@bytes, [@alphabet]); my $rle4 = rle4_encode($mtf); my (@uncompressed, @indices, @lengths); lz77_compression(pack('C*', @$rle4), \@uncompressed, \@indices, \@lengths); my $est_ratio = length($chunk) / (scalar(@uncompressed) + scalar(@lengths) + 2 * scalar(@indices)); say scalar(@uncompressed), ' -> ', $est_ratio; print $out_fh $alphabet_enc; deflate_encode(\@uncompressed, \@indices, \@lengths, $out_fh); } sub decompression ($fh, $out_fh) { my $alphabet = decode_alphabet($fh); say "Alphabet size: ", scalar(@$alphabet); my ($uncompressed, $indices, $lengths) = deflate_decode($fh); my @rle4 = unpack('C*', lz77_decompression($uncompressed, $indices, $lengths)); my $mtf = rle4_decode(\@rle4); my $bytes = mtf_decode($mtf, $alphabet); print $out_fh pack('C*', @$bytes); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/ppmh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 August 2023 # https://github.com/trizen # Compress/decompress files using Prediction by partial-matching (PPM) + Huffman coding. # Reference: # Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods # https://youtube.com/watch?v=YKv-w8bXi9c use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'PPMH', VERSION => '0.01', FORMAT => 'ppmh', CHUNK_SIZE => 1 << 16, ESCAPE_SYMBOL => 256, # escape symbol CONTEXTS_NUM => 4, # maximum number of contexts INITIAL_CONTEXT => 1, # start in this context VERBOSE => 0, # verbose/debug mode PPM_MODE => chr(0), VLR_MODE => chr(1), HUFFMAN_MODE => chr(2), }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub encode_alphabet ($alphabet) { my %table; @table{@$alphabet} = (); my $populated = 0; my @marked; for (my $i = 0 ; $i <= 255 ; $i += 32) { my $enc = 0; foreach my $j (0 .. 31) { if (exists($table{$i + $j})) { $enc |= 1 << $j; } } $populated <<= 1; if ($enc != 0) { $populated |= 1; push @marked, $enc; } } my $delta = delta_encode([@marked], 1); say "Uniq symbs : ", scalar(@$alphabet); say "Max symbol : ", max(@$alphabet); say "Populated : ", sprintf('%08b', $populated); say "Marked : @marked"; say "Delta len : ", length($delta); my $encoded = ''; $encoded .= chr($populated); $encoded .= $delta; return $encoded; } sub decode_alphabet ($fh) { my @populated = split(//, sprintf('%08b', ord(getc($fh)))); my $marked = delta_decode($fh, 1); my @alphabet; for (my $i = 0 ; $i <= 255 ; $i += 32) { if (shift(@populated)) { my $m = shift(@$marked); foreach my $j (0 .. 31) { if ($m & 1) { push @alphabet, $i + $j; } $m >>= 1; } } } return \@alphabet; } sub freq ($arr) { my %freq; ++$freq{$_} for @$arr; return \%freq; } sub ppm_encode ($symbols, $alphabet) { my @enc; my @prev; my $s = join(' ', @prev); my @ctx = ({$s => {freq => freq($alphabet)}},); foreach my $i (1 .. CONTEXTS_NUM) { push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}}; } foreach my $c (@ctx) { $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[0]; } my $prev_ctx = INITIAL_CONTEXT; foreach my $symbol (@$symbols) { foreach my $k (reverse(0 .. $prev_ctx)) { $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]); if (!exists($ctx[$k]{$s})) { $ctx[$k]{$s}{freq} = freq([ESCAPE_SYMBOL]); } if (exists($ctx[$k]{$s}{freq}{$symbol})) { if ($k != 0) { $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0]; ++$ctx[$k]{$s}{freq}{$symbol}; } say STDERR "Encoding $symbol with context=$k using $ctx[$k]{$s}{tree}{$symbol} and prefix ($s)" if VERBOSE; push @enc, $ctx[$k]{$s}{tree}{$symbol}; ++$prev_ctx if ($prev_ctx < $#ctx); push @prev, $symbol; shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM); last; } --$prev_ctx; $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0]; push @enc, $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}; say STDERR "Escaping from context = $k with $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}" if VERBOSE; $ctx[$k]{$s}{freq}{$symbol} = 1; } } return join('', @enc); } sub ppm_decode ($enc, $alphabet) { my @out; my @prev; my $prefix = ''; my $s = join(' ', @prev); my @ctx = ({$s => {freq => freq($alphabet)}},); foreach my $i (1 .. CONTEXTS_NUM) { push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}},; } foreach my $c (@ctx) { $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[1]; } my $prev_ctx = my $context = INITIAL_CONTEXT; my @key = @prev; foreach my $bit (split(//, $enc)) { $prefix .= $bit; if (!exists($ctx[$context]{$s})) { $ctx[$context]{$s}{freq} = freq([ESCAPE_SYMBOL]); $ctx[$context]{$s}{tree} = (mktree_from_freq($ctx[$context]{$s}{freq}))[1]; } if (exists($ctx[$context]{$s}{tree}{$prefix})) { my $symbol = $ctx[$context]{$s}{tree}{$prefix}; if ($symbol == ESCAPE_SYMBOL) { --$context; shift(@key) if (scalar(@key) >= $context); $s = join(' ', @key); } else { push @out, $symbol; foreach my $k (max($context, 1) .. $prev_ctx) { my $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]); $ctx[$k]{$s}{freq} //= freq([ESCAPE_SYMBOL]); ++$ctx[$k]{$s}{freq}{$symbol}; $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[1]; } ++$context if ($context < $#ctx); $prev_ctx = $context; push @prev, $symbol; shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM); @key = @prev[max($#prev - $context + 2, 0) .. $#prev]; $s = join(' ', @key); } $prefix = ''; } } return \@out; } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub binary_vrl_encoding ($str) { my @bits = split(//, $str); my $bitstring = $bits[0]; foreach my $rle (@{run_length(\@bits)}) { my ($c, $v) = @$rle; if ($v == 1) { $bitstring .= '0'; } else { my $t = sprintf('%b', $v - 1); $bitstring .= join('', '1' x length($t), '0', substr($t, 1)); } } return $bitstring; } sub binary_vrl_decoding ($bitstring) { open my $fh, '<:raw', \$bitstring; my $decoded = ''; my $bit = getc($fh) // die "error"; while (!eof($fh)) { $decoded .= $bit; my $bl = 0; while ((getc($fh) // die "error") == 1) { ++$bl; } if ($bl > 0) { $decoded .= $bit x oct('0b1' . join('', map { getc($fh) // die "error" } 1 .. $bl - 1)); } $bit = ($bit eq '1' ? '0' : '1'); } return $decoded; } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; say "Max symbol : $max_symbol\n"; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len\n"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub compression ($chunk, $out_fh) { my @bytes = unpack('C*', $chunk); my @alphabet = sort { $a <=> $b } uniq(@bytes); my $alphabet_enc = encode_alphabet(\@alphabet); my $enc = ppm_encode(\@bytes, \@alphabet); printf("Before VRL : %s (saving %.2f%%)\n", length($enc), (length($chunk) - length($enc) / 8) / length($chunk) * 100); my $vrl_enc = binary_vrl_encoding($enc); printf("After VRL : %s (saving %.2f%%)\n\n", length($vrl_enc), (length($chunk) - length($vrl_enc) / 8) / length($chunk) * 100); my $mode = PPM_MODE; if (length($vrl_enc) < length($enc)) { $mode = VLR_MODE; $enc = $vrl_enc; } else { $mode = PPM_MODE; } if (length($enc) / 8 > length($chunk)) { $mode = HUFFMAN_MODE; } print $out_fh $mode; if ($mode eq HUFFMAN_MODE) { create_huffman_entry(\@bytes, $out_fh); } else { print $out_fh pack('N', length($enc)); print $out_fh $alphabet_enc; print $out_fh pack('B*', $enc); } } sub decompression ($fh, $out_fh) { my $mode = getc($fh) // die "decompression error"; if ($mode eq HUFFMAN_MODE) { say "Decoding Huffman entry..."; print $out_fh pack('C*', @{decode_huffman_entry($fh)}); return 1; } my $enc_len = unpack('N', join('', map { getc($fh) // return undef } 1 .. 4)); my $alphabet = decode_alphabet($fh); say "Length = $enc_len"; say "Alphabet size: ", scalar(@$alphabet); my $bitstring = read_bits($fh, $enc_len); if ($mode eq VLR_MODE) { say "Decoding VRL..."; $bitstring = binary_vrl_decoding($bitstring); } say ''; print $out_fh pack('C*', @{ppm_decode($bitstring, $alphabet)}); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/qof_file_compression.pl ================================================ #!/usr/bin/perl # A general purpose lossless compressor, based on ideas from the QOI compressor. # See also: # https://qoiformat.org/ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(max); use Getopt::Std qw(getopts); binmode(STDIN, ":raw"); binmode(STDOUT, ":raw"); use constant { PKGNAME => 'QOF', FORMAT => 'qof', VERSION => '0.01', CHUNK_SIZE => 1 << 14, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub qof_encoder ($string) { use constant { QOI_OP_RGB => 0b1111_1110, QOI_OP_DIFF => 0b01_000_000, QOI_OP_RUN => 0b11_000_000, QOI_OP_LUMA => 0b10_000_000, }; my $run = 0; my $px = 0; my $prev_px = -1; my @bytes; my @table = (0) x 64; my @chars = unpack('C*', $string); while (@chars) { $px = shift(@chars); if ($px == $prev_px) { if (++$run == 62) { push @bytes, QOI_OP_RUN | ($run - 1); $run = 0; } } else { if ($run > 0) { push @bytes, (QOI_OP_RUN | ($run - 1)); $run = 0; } my $hash = $px % 64; my $index_px = $table[$hash]; if ($px == $index_px) { push @bytes, $hash; } else { $table[$hash] = $px; my $diff = $px - $prev_px; if ($diff > -33 and $diff < 32) { push(@bytes, QOI_OP_DIFF | ($diff + 32)); } else { push(@bytes, QOI_OP_RGB, $px); } } } $prev_px = $px; } if ($run > 0) { push(@bytes, QOI_OP_RUN | ($run - 1)); } create_huffman_entry(\@bytes); } sub qof_decoder ($fh) { use constant { QOI_OP_RGB => 0b1111_1110, QOI_OP_DIFF => 0b01_000_000, QOI_OP_RUN => 0b11_000_000, QOI_OP_LUMA => 0b10_000_000, QOI_OP_INDEX => 0b00_000_000, }; my $run = 0; my $px = -1; my @bytes; my @table = ((0) x 64); my $index = 0; my @symbols = @{decode_huffman_entry($fh)}; while (1) { if ($run > 0) { --$run; } else { my $byte = $symbols[$index++] // last; if ($byte == QOI_OP_RGB) { # OP RGB $px = $symbols[$index++]; } elsif (($byte >> 6) == (QOI_OP_INDEX >> 6)) { # OP INDEX $px = $table[$byte]; } elsif (($byte >> 6) == (QOI_OP_DIFF >> 6)) { # OP DIFF $px += ($byte & 0b00_111_111) - 32; } elsif (($byte >> 6) == (QOI_OP_RUN >> 6)) { # OP RUN $run = ($byte & 0b00_111_111); } $table[$px % 64] = $px; } push @bytes, $px; } return pack('C*', @bytes); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { print $out_fh qof_encoder($chunk); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { print $out_fh qof_decoder($fh); } # Close the file close $fh; close $out_fh; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } main(); exit(0); ================================================ FILE: Compression/rans_file_compression.pl ================================================ #!/usr/bin/perl # File compression with rANS encoding, using big integers. # Reference: # ‎Stanford EE274: Data Compression I 2023 I Lecture 7 - ANS # https://youtube.com/watch?v=5Hp4bnvSjng use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max); use Math::GMPz; use constant { PKGNAME => 'rANS', VERSION => '0.01', FORMAT => 'rans', }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub valid_archive ($fh) { if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub cumulative_freq ($freq) { my %cf; my $total = Math::GMPz->new(0); foreach my $c (sort keys %{$freq}) { $cf{$c} = $total; $total += $freq->{$c}; } return %cf; } sub rans_base_enc($freq, $cumul, $M, $x_prev, $s, $block_id, $x) { Math::GMPz::Rmpz_div_ui($block_id, $x_prev, $freq->{$s}); my $r = Math::GMPz::Rmpz_mod_ui($x, $x_prev, $freq->{$s}); my $slot = $cumul->{$s} + $r; Math::GMPz::Rmpz_mul_ui($x, $block_id, $M); Math::GMPz::Rmpz_add_ui($x, $x, $slot); return $x; } sub encode($input, $freq, $cumul, $M) { my $x = Math::GMPz::Rmpz_init_set_ui(0); my $block_id = Math::GMPz::Rmpz_init(); my $next_x = Math::GMPz::Rmpz_init(); foreach my $s (@$input) { $x = rans_base_enc($freq, $cumul, $M, $x, $s, $block_id, $next_x); } return $x; } sub rans_base_dec($alphabet, $freq, $cumul, $M, $x, $block_id, $slot, $x_prev) { Math::GMPz::Rmpz_tdiv_qr_ui($block_id, $slot, $x, $M); my ($left, $right, $mid, $cmp) = (0, $#{$alphabet}); while (1) { $mid = ($left + $right) >> 1; $cmp = ($cumul->{$alphabet->[$mid]} <=> $slot) || last; if ($cmp < 0) { $left = $mid + 1; $left > $right and last; } else { $right = $mid - 1; if ($left > $right) { $mid -= 1; last; } } } my $s = $alphabet->[$mid]; Math::GMPz::Rmpz_mul_ui($x_prev, $block_id, $freq->{$s}); Math::GMPz::Rmpz_add($x_prev, $x_prev, $slot); Math::GMPz::Rmpz_sub_ui($x_prev, $x_prev, $cumul->{$s}); return ($s, $x_prev); } sub decode($x, $alphabet, $freq, $cumul, $M) { my @dec; my $s = undef; my $block_id = Math::GMPz::Rmpz_init(); my $slot = Math::GMPz::Rmpz_init(); my $x_prev = Math::GMPz::Rmpz_init(); for (1 .. $M) { ($s, $x) = rans_base_dec($alphabet, $freq, $cumul, $M, $x, $block_id, $slot, $x_prev); push @dec, $s; } return [reverse @dec]; } sub compress ($input, $output) { # Open the input file open my $fh, '<:raw', $input; # Open the output file and write the archive signature open my $out_fh, '>:raw', $output; print {$out_fh} SIGNATURE; my $str = do { local $/; scalar(<$fh>); }; close $fh; my (%freq, %cumul); my @symbols = unpack('C*', $str); ++$freq{$_} for @symbols; my @alphabet = sort { $a <=> $b } keys %freq; my $t = 0; foreach my $s (@alphabet) { $cumul{$s} = $t; $t += $freq{$s}; } my $M = $t; my $enc = encode(\@symbols, \%freq, \%cumul, $M); my $bin = Math::GMPz::Rmpz_get_str($enc, 2); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq{$k} // 0; } print {$out_fh} delta_encode(\@freqs); print {$out_fh} pack('N', length($bin)); print {$out_fh} pack('B*', $bin); close $out_fh; } sub decompress ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E archive!\n"; my @freqs = @{delta_decode($fh)}; my $bits_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); # Create the frequency table my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i] > 0) { $freq{$i} = $freqs[$i]; } } # Decode the bits into an integer my $enc = Math::GMPz->new(read_bits($fh, $bits_len), 2); # Open the output file open my $out_fh, '>:raw', $output; my @alphabet = sort { $a <=> $b } keys %freq; my $t = 0; my %cumul; foreach my $s (@alphabet) { $cumul{$s} = $t; $t += $freq{$s}; } my $M = $t; my $symbols = decode($enc, \@alphabet, \%freq, \%cumul, $M); print $out_fh pack('C*', @$symbols); close $out_fh; } main(); exit(0); ================================================ FILE: Compression/rlac_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 August 2023 # Edit: 06 February 2024 # https://github.com/trizen # Compress/decompress files using Run-length encoding + Arithmetic Coding (in fixed bits). # References: # Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits # https://youtube.com/watch?v=EqKbT3QdtOI # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq sum); use constant { PKGNAME => 'RLAC', VERSION => '0.02', FORMAT => 'rlac', CHUNK_SIZE => 1 << 16, }; # Arithmetic Coding settings use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); # Container signature use constant SIGNATURE => uc(FORMAT) . chr(2); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub ac_encode ($bytes_arr) { my $enc = ''; my $EOF_SYMBOL = (max(@$bytes_arr) // 0) + 1; my @bytes = (@$bytes_arr, $EOF_SYMBOL); my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub ac_decode ($fh, $freq) { my ($cf, $T) = create_cfreq($freq); my @dec; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); push @dec, $i; $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return \@dec; } sub create_ac_entry ($bytes, $out_fh) { my ($enc, $freq) = ac_encode($bytes); my $max_symbol = max(keys %$freq) // 0; say "Max symbol: $max_symbol"; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq->{$k} // 0; } push @freqs, length($enc) >> 3; print $out_fh delta_encode(\@freqs); print $out_fh pack("B*", $enc); } sub decode_ac_entry ($fh) { my @freqs = @{delta_decode($fh)}; my $bits_len = pop(@freqs); my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } say "Encoded length: $bits_len"; my $bits = read_bits($fh, $bits_len << 3); if ($bits_len > 0) { open my $bits_fh, '<:raw', \$bits; return ac_decode($bits_fh, \%freq); } return []; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub compression ($chunk, $out_fh) { my $bytes = [unpack('C*', $chunk)]; $bytes = rle4_encode($bytes); create_ac_entry($bytes, $out_fh); } sub decompression ($fh, $out_fh) { my $bytes = decode_ac_entry($fh); $bytes = rle4_decode($bytes); print $out_fh pack('C*', @$bytes); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/rlh_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 August 2023 # https://github.com/trizen # Compress/decompress files using Run-length encoding + Huffman coding. use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(max uniq); use constant { PKGNAME => 'RLH', VERSION => '0.01', FORMAT => 'rlh', CHUNK_SIZE => 1 << 15, }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh, $double = 0) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; [split(' ', $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1} /gr)]; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my @symbols = sort { $a <=> $b } keys(%freq); print $out_fh delta_encode([@symbols]); print $out_fh delta_encode([map { $freq{$_} } @symbols], 1); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my $symbols = delta_decode($fh); my $freqs = delta_decode($fh, 1); my %freq; foreach my $i (0 .. $#{$symbols}) { $freq{$symbols->[$i]} = $freqs->[$i]; } my (undef, $rev_dict) = mktree_from_freq(\%freq); my $enc_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); say "Encoded length: $enc_len"; if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return []; } sub rle4_encode ($bytes) { # RLE1 my @rle; my $end = $#{$bytes}; my $prev = -1; my $run = 0; for (my $i = 0 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @rle, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { $run = 0; $i += 1; while ($i <= $end and $bytes->[$i] == $prev) { ++$run; ++$i; } push @rle, $run; $run = 1; if ($i <= $end) { $prev = $bytes->[$i]; push @rle, $bytes->[$i]; } } } return \@rle; } sub rle4_decode ($bytes) { # RLE1 my @dec = $bytes->[0]; my $end = $#{$bytes}; my $prev = $bytes->[0]; my $run = 1; for (my $i = 1 ; $i <= $end ; ++$i) { if ($bytes->[$i] == $prev) { ++$run; } else { $run = 1; } push @dec, $bytes->[$i]; $prev = $bytes->[$i]; if ($run >= 4) { if (++$i <= $end) { $run = $bytes->[$i]; push @dec, (($prev) x $run); } $run = 0; } } return \@dec; } sub compression ($chunk, $out_fh) { my $bytes = [unpack('C*', $chunk)]; $bytes = rle4_encode($bytes); create_huffman_entry($bytes, $out_fh); } sub decompression ($fh, $out_fh) { my $bytes = decode_huffman_entry($fh); $bytes = rle4_decode($bytes); print $out_fh pack('C*', @$bytes); } # Compress file sub compress_file ($input, $output) { open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; my $header = SIGNATURE; # Open the output file for writing open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for write: $!"; # Print the header print $out_fh $header; # Compress data while (read($fh, (my $chunk), CHUNK_SIZE)) { compression($chunk, $out_fh); } # Close the file close $out_fh; } # Decompress file sub decompress_file ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E v${\VERSION} archive!\n"; # Open the output file open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; while (!eof($fh)) { decompression($fh, $out_fh); } # Close the file close $fh; close $out_fh; } main(); exit(0); ================================================ FILE: Compression/tac_file_compression.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 01 May 2015 # Website: https://github.com/trizen # ## The arithmetic coding algorithm. # # See: https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix use 5.010; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Basename qw(basename); use Math::BigInt (try => 'GMP'); use constant { PKGNAME => 'TAC Compressor', VERSION => '0.02', FORMAT => 'tac', }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(1); sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub cumulative_freq { my ($freq) = @_; my %cf; my $total = Math::BigInt->new(0); foreach my $c (sort keys %{$freq}) { $cf{$c} = $total; $total += $freq->{$c}; } return %cf; } sub compress { my ($input, $output) = @_; use bytes; # Open the input file open my $fh, '<:raw', $input; # Open the output file and write the archive signature open my $out_fh, '>:raw', $output; print {$out_fh} SIGNATURE; my $str = do { local $/; scalar(<$fh>); }; close $fh; my @chars = split(//, $str); # The frequency characters my %freq; $freq{$_}++ for @chars; # Create the cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = Math::BigInt->new(scalar @chars); # Lower bound my $L = Math::BigInt->new(0); # Product of all frequencies my $pf = Math::BigInt->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { $L->bmuladd($base, $cf{$c} * $pf); $pf->bmul($freq{$c}); } # Upper bound my $U = $L + $pf; my $pow = $pf->copy->blog(2); my $enc = ($U - 1)->bdiv(Math::BigInt->new(2)->bpow($pow)); # Remove any divisibility by 2 while ($enc > 0 and $enc % 2 == 0) { $pow->binc; $enc->brsft(1); } my $bin = substr($enc->as_bin, 2); my $encoded = pack('L', $pow); # the power value $encoded .= chr(scalar(keys %freq) - 1); # number of unique chars $encoded .= chr(length($bin) % 8); # padding while (my ($k, $v) = each %freq) { $encoded .= $k . pack('S', $v); # char => freq } print {$out_fh} $encoded, pack('B*', $bin); close $out_fh; } sub decompress { my ($input, $output) = @_; use bytes; # Open and validate the input file open my $fh, '<:raw', $input; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E archive!\n"; my $content = do { local $/; <$fh> }; close $fh; my ($pow, $uniq, $padd) = unpack('LCC', $content); substr($content, 0, length(pack('LCC', 0, 0, 0)), ''); # Create the frequency table (char => freq) my %freq; foreach my $i (0 .. $uniq) { my ($char, $f) = unpack('aS', $content); $freq{$char} = $f; substr($content, 0, length(pack('aS', 0, 0)), ''); } # Decode the bits into an integer my $enc = Math::BigInt->new('0b' . unpack('B*', $content)); # Remove the trailing bits (if any) if ($padd != 0) { $enc >>= (8 - $padd); } $pow = Math::BigInt->new($pow); $enc->blsft($pow); my $base = Math::BigInt->new(0); $base += $_ for values %freq; # Create the cumulative frequency table my %cf = cumulative_freq(\%freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } # Open the output file open my $out_fh, '>:raw', $output; # Decode the input number for (my $pow = $base**($base - 1) ; $pow > 0 ; $pow /= $base) { my $div = $enc / $pow; my $c = $dict{$div}; my $fv = $freq{$c}; my $cv = $cf{$c}; $enc = ($enc - $pow * $cv) / $fv; print {$out_fh} $c; } close $out_fh; } main(); exit(0); ================================================ FILE: Compression/tacc_file_compression.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 11 February 2016 # Edit: 14 July 2023 # https://github.com/trizen # Arithmetic coding compressor for small files. # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix use 5.020; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Basename qw(basename); use List::Util qw(sum max); use experimental qw(signatures); use Math::GMPz; use constant { PKGNAME => 'TAC Compressor', VERSION => '0.05', FORMAT => 'tacc', }; # Container signature use constant SIGNATURE => uc(FORMAT) . chr(5); sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code); } sub version { printf("%s %s\n", PKGNAME, VERSION); exit; } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub valid_archive ($fh) { if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub cumulative_freq ($freq) { my %cf; my $total = Math::GMPz->new(0); foreach my $c (sort keys %{$freq}) { $cf{$c} = $total; $total += $freq->{$c}; } return %cf; } sub compress ($input, $output) { # Open the input file open my $fh, '<:raw', $input; # Open the output file and write the archive signature open my $out_fh, '>:raw', $output; print {$out_fh} SIGNATURE; my $str = do { local $/; scalar(<$fh>); }; close $fh; my @chars = split(//, $str); # The frequency characters my %freq; $freq{$_}++ for @chars; # Create the cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = Math::GMPz->new(scalar @chars); # Lower bound my $L = Math::GMPz->new(0); # Product of all frequencies my $pf = Math::GMPz->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { Math::GMPz::Rmpz_mul($L, $L, $base); Math::GMPz::Rmpz_addmul($L, $pf, $cf{$c}); Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c}); } # Upper bound my $U = $L + $pf; # Compute the power for left shift my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1; # Set $enc to (U-1) divided by 2^pow my $enc = ($U - 1) >> $pow; # Remove any divisibility by 2 if ($enc > 0 and Math::GMPz::Rmpz_even_p($enc)) { $pow += Math::GMPz::Rmpz_remove($enc, $enc, Math::GMPz->new(2)); } my $bin = Math::GMPz::Rmpz_get_str($enc, 2); my $max_symbol = max(map { ord($_) } keys %freq) // 0; my @freqs; foreach my $k (0 .. $max_symbol) { push @freqs, $freq{chr($k)} // 0; } push @freqs, $pow; print {$out_fh} delta_encode(\@freqs); print {$out_fh} pack('N', length($bin)); print {$out_fh} pack('B*', $bin); close $out_fh; } sub decompress ($input, $output) { # Open and validate the input file open my $fh, '<:raw', $input; valid_archive($fh) || die "$0: file `$input' is not a \U${\FORMAT}\E archive!\n"; my @freqs = @{delta_decode($fh)}; my $pow2 = pop(@freqs); my $bits_len = unpack('N', join('', map { getc($fh) // die "error" } 1 .. 4)); # Create the frequency table my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i] > 0) { $freq{chr($i)} = $freqs[$i]; } } # Decode the bits into an integer my $enc = Math::GMPz->new(read_bits($fh, $bits_len), 2); $enc <<= $pow2; my $base = sum(values %freq) // 0; # Create the cumulative frequency table my %cf = cumulative_freq(\%freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } # Open the output file open my $out_fh, '>:raw', $output; if ($base == 0) { close $out_fh; return; } elsif ($base == 1) { print {$out_fh} keys %freq; close $out_fh; return; } my $div = Math::GMPz::Rmpz_init(); # Decode the input number for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) { Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow); my $c = $dict{$div}; my $fv = $freq{$c}; my $cv = $cf{$c}; Math::GMPz::Rmpz_submul($enc, $pow, $cv); Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv); print {$out_fh} $c; } close $out_fh; } main(); exit(0); ================================================ FILE: Compression/test_compressors.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 19 March 2024 # https://github.com/trizen use 5.036; use File::Temp qw(tempdir tempfile); use File::Compare qw(compare); use File::Basename qw(basename); use File::Spec::Functions qw(catfile); use List::Util qw(min); use Time::HiRes qw(gettimeofday tv_interval); my %ignored_methods = ( 'tac_file_compression.pl' => 1, # slow 'tacc_file_compression.pl' => 1, # slow 'rans_file_compression.pl' => 1, # slow 'tzip_file_compression.pl' => 1, # poor compression / slow 'tzip2_file_compression.pl' => 1, # poor compression / slow 'lzt_file_compression.pl' => 1, # poor compression 'lzhc_file_compression.pl' => 1, # very poor compression 'lzt2_file_compression.pl' => 1, # slow 'bbwr_file_compression.pl' => 1, # slow 'ppmh_file_compression.pl' => 1, # slow ); my $input_file = shift(@ARGV) // die "usage: perl $0 [input file] [regex]\n"; my $regex = shift(@ARGV) // ''; if (not -f $input_file) { die "Error for input file <<$input_file>>: $!\n"; } my $compressed_dir = tempdir(CLEANUP => 1); my $decompressed_dir = tempdir(CLEANUP => 1); my @stats = ({format => 'orig', filename => basename($input_file), compression_time => 0, decompression_time => 0, size => -s $input_file}); sub commify ($n) { scalar reverse(reverse($n) =~ s/(\d{3})(?=\d)/$1,/gr); } foreach my $file (glob("*_file_compression.pl")) { next if $ignored_methods{$file}; $file =~ /$regex/o or next; say "\n:: Testing: $file"; my ($format) = $file =~ /^([^_]+)/; my $basename = basename($input_file) . '.' . $format; my $compressed_file = catfile($compressed_dir, $basename); my $compression_t0 = [gettimeofday]; system($^X, $file, '-i', $input_file, '-o', $compressed_file); my $compression_dt = tv_interval($compression_t0); $? == 0 or die "compression error for: $file"; my (undef, $decompressed_file) = tempfile(DIR => $decompressed_dir); my $decompression_t0 = [gettimeofday]; system($^X, $file, '-r', '-e', '-i', $compressed_file, '-o', $decompressed_file); my $decompression_dt = tv_interval($decompression_t0); $? == 0 or die "decompression error for: $file"; if (compare($decompressed_file, $input_file) != 0) { die "Decompressed file does not match the input file for: $file"; } push @stats, { format => $format, filename => $basename, compression_time => $compression_dt, decompression_time => $decompression_dt, size => -s $compressed_file, }; } say ''; printf("%8s %6s %6s %6s %s\n", "SIZE", "RATIO", "COMPRE", "DECOMP", "FILENAME"); foreach my $entry (sort { $a->{size} <=> $b->{size} } @stats) { printf("%8s %6.3f %6.3f %6.3f %s\n", commify($entry->{size}), (-s $input_file) / $entry->{size}, $entry->{compression_time}, $entry->{decompression_time}, $entry->{filename}); } say ''; my $top = min(20, scalar(@stats) - 1); say "Top $top fastest compression methods: ", join(', ', map { $_->{format} } (sort { $a->{compression_time} <=> $b->{compression_time} } grep { $_->{compression_time} > 0 } @stats)[0 .. $top - 1]); say "Top $top fastest decompression methods: ", join(', ', map { $_->{format} } (sort { $a->{decompression_time} <=> $b->{decompression_time} } grep { $_->{decompression_time} > 0 } @stats)[0 .. $top - 1]); say ''; say "Top $top slowest compression methods: ", join(', ', map { $_->{format} } (sort { $b->{compression_time} <=> $a->{compression_time} } grep { $_->{compression_time} > 0 } @stats)[0 .. $top - 1]); say "Top $top slowest decompression methods: ", join(', ', map { $_->{format} } (sort { $b->{decompression_time} <=> $a->{decompression_time} } grep { $_->{decompression_time} > 0 } @stats)[0 .. $top - 1]); __END__ SIZE RATIO COMPRE DECOMP FILENAME 2,356 6.088 0.148 0.144 perl.bwad 2,359 6.081 0.187 0.192 perl.bwlzad2 2,379 6.029 0.210 0.193 perl.bwlzad 2,413 5.944 0.053 0.037 perl.bwac 2,414 5.942 0.056 0.051 perl.bwaz 2,418 5.932 0.083 0.067 perl.bwlza2 2,426 5.913 0.090 0.065 perl.bwlza 2,426 5.913 0.076 0.050 perl.bwt 2,443 5.871 0.079 0.061 perl.bwlz 2,591 5.536 0.136 0.043 perl.bwrm 2,626 5.462 0.134 0.046 perl.bwrl2 2,653 5.407 0.153 0.073 perl.bwrlz 2,695 5.322 0.179 0.180 perl.lzsad 2,751 5.214 0.141 0.052 perl.bwrla 2,760 5.197 0.135 0.049 perl.bwrl 2,819 5.088 0.079 0.069 perl.lzsa 2,831 5.067 0.077 0.041 perl.bwt2 2,835 5.060 0.104 0.065 perl.bwlz2 2,836 5.058 0.057 0.042 perl.lzss 2,865 5.007 0.086 0.048 perl.lzsbw 2,868 5.001 0.043 0.041 perl.lzaz 2,870 4.998 0.042 0.035 perl.lzac 2,877 4.986 0.070 0.059 perl.bwlzss 2,878 4.984 0.037 0.030 perl.lzhd 2,905 4.938 0.169 0.077 perl.bwrlz2 2,980 4.813 0.057 0.028 perl.bww 3,003 4.777 0.051 0.042 perl.mra 3,005 4.773 0.055 0.046 perl.bwlzhd 3,014 4.759 0.135 0.126 perl.lzbwad 3,025 4.742 0.065 0.046 perl.mrh 3,027 4.739 0.028 0.023 perl.lzw 3,028 4.737 0.075 0.040 perl.lzbwd 3,030 4.734 0.069 0.050 perl.mrlz 3,072 4.669 0.063 0.037 perl.lzbwh 3,146 4.559 0.075 0.042 perl.mbwr 3,176 4.516 0.062 0.040 perl.lzbwa 3,186 4.502 0.057 0.036 perl.lzbw 3,214 4.463 0.036 0.031 perl.lzih 3,230 4.441 0.022 0.029 perl.rlh 3,321 4.319 0.053 0.042 perl.lza 3,335 4.301 0.047 0.035 perl.lzh 3,504 4.094 0.032 0.037 perl.rlac 4,052 3.540 0.030 0.034 perl.hfm 4,193 3.421 0.038 0.020 perl.lz77 14,344 1.000 0.000 0.000 perl Top 20 fastest compression methods: rlh, lzw, hfm, rlac, lzih, lzhd, lz77, lzac, lzaz, lzh, mra, lza, bwac, bwlzhd, bwaz, lzss, lzbw, bww, lzbwa, lzbwh Top 20 fastest decompression methods: lz77, lzw, bww, rlh, lzhd, lzih, hfm, lzh, lzac, lzbw, lzbwh, bwac, rlac, lzbwa, lzbwd, bwt2, lzaz, lza, mbwr, mra Top 20 slowest compression methods: bwlzad, bwlzad2, lzsad, bwrlz2, bwrlz, bwad, bwrla, bwrm, bwrl, lzbwad, bwrl2, bwlz2, bwlza, lzsbw, bwlza2, lzsa, bwlz, bwt2, bwt, mbwr Top 20 slowest decompression methods: bwlzad, bwlzad2, lzsad, bwad, lzbwad, bwrlz2, bwrlz, lzsa, bwlza2, bwlza, bwlz2, bwlz, bwlzss, bwrla, bwaz, bwt, mrlz, bwrl, lzsbw, bwrl2 ================================================ FILE: Compression/tzip2_file_compression.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 12 August 2013 # Website: https://trizenx.blogspot.com # ## A very simple file compressor. # # Best usage of this script is to compress files which # contains not so many different bytes (for example, DNA-sequences) use 5.010; use strict; use autodie; use warnings; use List::Util qw(min); use Getopt::Std qw(getopts); use File::Basename qw(basename); our $DEBUG = 0; use constant { CHUNK_SIZE => 1024, # in bytes SIGNATURE => 'TZP2' . chr(1), FORMAT => 'tzp2', }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub _make_map { my ($int) = @_; my @groups = ([], [], []); for my $i (1 .. 3) { foreach my $j (0 .. length($int) - $i) { $i > 1 && substr($int, $j, 1) == 0 && next; (my $num = substr($int, $j, $i)) > 255 && next; $groups[$i - 1][$j] = $num; } } my @map = [[]]; for (my $j = 0 ; $j <= $#{$groups[0]} ; $j++) { for (my $i = $j ; $i <= $#{$groups[0]} ; $i++) { if (defined($groups[2][$i])) { push @{$map[$j][$j]}, $groups[2][$i]; $i += 2; } elsif (defined($groups[1][$i])) { push @{$map[$j][$j]}, $groups[1][$i]; $i += 1; } else { push @{$map[$j][$j]}, $groups[0][$i]; } } } return \@map; } sub int2bytes { my ($int) = @_; my $data = _make_map($int); my @nums; foreach my $arr (@{$data}) { for my $i (0 .. $#{$arr}) { if (ref($arr->[$i]) eq 'ARRAY') { my $head = _make_map(substr($int, 0, $i)); push @nums, [@{$head->[0][0]}, @{$arr->[$i]}]; } } } my $min = min(map { $#{$_} } @nums); my @bytes = do { my %seen; grep { !$seen{join(' ', @{$_})}++ } grep { $#{$_} == $min } @nums; }; return \@bytes; } sub next_power_of_two { my ($number) = @_; return 2 if $number <= 1; ## If the number is a power of ## two, then return it as it is. unless ($number & ($number - 1)) { return $number; } ## Return the next power of two return 2 << (log($number) / log(2)); } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub open_file { my ($mode, $file) = @_; open(my $fh, $mode, $file); return $fh; } sub uniq_bytes { my ($fh) = @_; my %table; while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) { @table{split //, $chunk} = (); } seek($fh, 0, 0); return [keys %table]; } sub info { my (%info) = @_; print STDERR <<"EOT"; input : $info{input} output : $info{output} filesize : $info{filesize} bits num : $info{bits_num} bytes num : $info{bytes_num} compressing : $info{compress} EOT } sub compress_file { my ($input, $output) = @_; my $fh = open_file('<:raw', $input); my $out_fh = open_file('>:raw', $output); my $filesize = -s $input; my $uniq_bytes = uniq_bytes($fh); my $bytes_num = scalar @{$uniq_bytes}; my $bits_num = log(next_power_of_two($bytes_num)) / log(2); $DEBUG && info( bytes_num => $bytes_num, bits_num => $bits_num, input => $input, output => $output, filesize => $filesize, compress => 'true', ); my %table; my $bits_map = ''; foreach my $i (0 .. $#{$uniq_bytes}) { $bits_map .= ($table{$uniq_bytes->[$i]} = sprintf("%0${bits_num}b", $i)); } my $size_bytes = ${int2bytes($filesize)}[0]; print {$out_fh} SIGNATURE, chr($#{$size_bytes} + 1), join('', map { chr } @{$size_bytes}), chr($bits_num), chr($bytes_num - 1), join('', @{$uniq_bytes}), pack('B*', $bits_map); while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) { print {$out_fh} scalar pack "B*", join('', @table{split //, $chunk}); } return 1; } sub decompress_file { my ($input, $output) = @_; my $fh = open_file('<:raw', $input); my $out_fh = open_file('>:raw', $output); valid_archive($fh) || die "$0: file `$input' is not a TZP archive!\n"; my $fsize_len = do { read($fh, (my $byte), 1); ord $byte }; my $filesize = do { read($fh, (my $bytes), $fsize_len); join('', unpack('C*', $bytes)); }; my $bits_num = do { read($fh, (my $byte), 1); ord $byte }; my $bytes_num = do { read($fh, (my $byte), 1); 1 + ord $byte }; $DEBUG && info( bytes_num => $bytes_num, bits_num => $bits_num, input => $input, output => $output, filesize => $filesize, compress => 'false', ); my $bytes = do { read($fh, (my $bytes), $bytes_num); [split(//, $bytes)] }; my $bits_len = $bits_num * $bytes_num; if ((my $mod = $bits_len % 8) != 0) { $bits_len += 8 - $mod; } my $bits = do { read($fh, my ($bytes), $bits_len / 8); unpack 'B*', $bytes }; my %table; foreach my $byte (@{$bytes}) { $table{substr($bits, 0, $bits_num, '')} = $byte; } my $byte_counter = 0; my $prev_bits = ''; while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) { my $bits = $prev_bits . unpack('B*', $chunk); my $bits_len = 8 * $size + length($prev_bits); my $left = $bits_len % $bits_num; $prev_bits = $left == 0 ? q{} : substr($bits, $bits_len - $left, $bits_len, ''); if (($byte_counter += int($bits_len / $bits_num)) > $filesize) { $bits_len -= ($byte_counter - $filesize); } print {$out_fh} join('', @{table}{unpack("(a$bits_num)" . int($bits_len / $bits_num), $bits)}); } return 1; } main(); exit(0); ================================================ FILE: Compression/tzip_file_compression.pl ================================================ #!/usr/bin/perl # Author: Șuteu "Trizen" Daniel # License: GPLv3 # Date: 12 August 2013 # Website: https://trizenx.blogspot.com # ## A very simple file compressor. # # Best usage of this script is to compress files which # contains not so many different bytes (for example, DNA-sequences) use 5.010; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Basename qw(basename); our $DEBUG = 0; use constant { CHUNK_SIZE => 2 * 1024**2, # 2 MB SIGNATURE => 'TZP' . chr(1), FORMAT => 'tzp', }; sub usage { my ($code) = @_; print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -v : version number -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } decompress_file($input, $output) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; compress_file($input, $output) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } sub next_power_of_two { my ($number) = @_; ## If the number is a power of ## two, then return it as it is. unless ($number & ($number - 1)) { return $number; } ## Return the next power of two return 2 << (log($number) / log(2)); } sub valid_archive { my ($fh) = @_; if (read($fh, (my $sig), length(SIGNATURE), 0) == length(SIGNATURE)) { $sig eq SIGNATURE || return; } return 1; } sub open_file { my ($mode, $file) = @_; open(my $fh, $mode, $file); return $fh; } sub uniq_bytes { my ($fh) = @_; my %table; while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) { @table{split //, $chunk} = (); } seek($fh, 0, 0); return [keys %table]; } sub info { my (%info) = @_; print STDERR <<"EOT"; input : $info{input} output : $info{output} filesize : $info{filesize} bits num : $info{bits_num} bytes num : $info{bytes_num} compressing : $info{compress} EOT } sub compress_file { my ($input, $output) = @_; my $fh = open_file('<:raw', $input); my $out_fh = open_file('>:raw', $output); my $filesize = -s $input; my $uniq_bytes = uniq_bytes($fh); my $bytes_num = scalar @{$uniq_bytes}; my $bits_num = log(next_power_of_two($bytes_num)) / log(2); $DEBUG && info( bytes_num => $bytes_num, bits_num => $bits_num, input => $input, output => $output, filesize => $filesize, compress => 'true', ); my %table; my $bits_map = ''; foreach my $i (0 .. $#{$uniq_bytes}) { $bits_map .= ($table{$uniq_bytes->[$i]} = sprintf("%0${bits_num}b", $i)); } print {$out_fh} SIGNATURE, chr(int(length($filesize) / 2 + 0.5)), join('', map { chr } unpack '(A2)*', $filesize), chr($bits_num), chr($bytes_num - 1), join('', @{$uniq_bytes}), pack('B*', $bits_map); while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) { print {$out_fh} scalar pack "B*", join('', @table{split //, $chunk}); } return 1; } sub decompress_file { my ($input, $output) = @_; my $fh = open_file('<:raw', $input); my $out_fh = open_file('>:raw', $output); valid_archive($fh) || die "$0: file `$input' is not a TZP archive!\n"; my $fsize_len = do { read($fh, (my $byte), 1); ord $byte }; my $filesize = do { read($fh, (my $bytes), $fsize_len); my @bytes = unpack('C*', $bytes); foreach my $i (0 .. $#bytes - 1) { length($bytes[$i]) != 2 && do { $bytes[$i] = sprintf('%02d', $bytes[$i]) } } join('', @bytes); }; my $bits_num = do { read($fh, (my $byte), 1); ord $byte }; my $bytes_num = do { read($fh, (my $byte), 1); 1 + ord $byte }; $DEBUG && info( bytes_num => $bytes_num, bits_num => $bits_num, input => $input, output => $output, filesize => $filesize, compress => 'false', ); my $bytes = do { read($fh, (my $bytes), $bytes_num); [split(//, $bytes)] }; my $bits_len = $bits_num * $bytes_num; if ((my $mod = $bits_len % 8) != 0) { $bits_len += 8 - $mod; } my $bits = do { read($fh, my ($bytes), $bits_len / 8); unpack 'B*', $bytes }; my %table; foreach my $byte (@{$bytes}) { $table{substr($bits, 0, $bits_num, '')} = $byte; } my $bit_counter = 0; my $prev_bits = ''; while (my $size = read($fh, (my $chunk), CHUNK_SIZE)) { $bit_counter += $size * 8; my $bits = $prev_bits . unpack "B*", $chunk; my $bits_len = ($size * 8 + length($prev_bits)); if ($bit_counter / $bits_num - $filesize == 1) { chop($bits), $bits_len-- for (1 .. $bits_num); } elsif ($bits_num < 8 && $bit_counter % $bits_num != 0 && eof($fh)) { chop($bits), $bits_len-- for (1 .. $bit_counter % $bits_num); } my $sequence = ''; foreach (1 .. $bits_len / $bits_num) { $sequence .= $table{substr($bits, 0, $bits_num, '')}; } print {$out_fh} $sequence; $prev_bits = $bits; } return 1; } main(); exit(0); ================================================ FILE: Compression/unzip.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 20 November 2024 # https://github.com/trizen # Basic implementation of a ZIP file extractor. # Reference: # https://pkware.cachefly.net/webdocs/casestudies/APPNOTE.TXT use 5.036; use Compression::Util qw(:all); use File::Path qw(make_path); use File::Spec::Functions qw(catfile catdir); use File::Basename qw(dirname); local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = 32768; # maximum allowed back-reference distance in LZ parsing my $output_directory = 'OUTPUT'; if (not -d $output_directory) { make_path($output_directory); } sub extract_file($fh) { my $version_needed = bytes2int_lsb($fh, 2); my $general_purpose_bit_flag = bytes2int_lsb($fh, 2); my $compression_method = bytes2int_lsb($fh, 2); my $last_mod_file_time = bytes2int_lsb($fh, 2); my $last_mod_file_date = bytes2int_lsb($fh, 2); my $crc32 = bytes2int_lsb($fh, 4); my $compressed_size = bytes2int_lsb($fh, 4); my $uncompressed_size = bytes2int_lsb($fh, 4); my $file_name_length = bytes2int_lsb($fh, 2); my $extra_field_length = bytes2int_lsb($fh, 2); my $skip_crc32 = 0; if ($general_purpose_bit_flag & 0b1000) { $skip_crc32 = 1; $crc32 == 0 or warn "[WARNING] Bit 3 is set, therefore CRC-32 must be set to zero (got: $crc32)\n"; $compressed_size == 0 or warn "[WARNING] Bit 3 is set, thefore compressed size must be set to zero (got: $compressed_size)\n"; $uncompressed_size == 0 or warn "[WARNING] Bit 3 is set, therefore uncompressed size must be set to zero (got: $uncompressed_size)\n"; } read($fh, (my $file_name), $file_name_length); read($fh, (my $extra_field), $extra_field_length); if ($general_purpose_bit_flag & 0x01) { die "Encrypted file are currently not supported!\n"; } say STDERR ":: Extracting: $file_name ($uncompressed_size bytes)"; # It's a directory if ($uncompressed_size == 0 and substr($file_name, -1) eq '/') { my $dir = catdir($output_directory, $file_name); make_path($dir) if not -d $dir; return 1; } my $out_filename = catfile($output_directory, $file_name); my $out_dir = dirname($out_filename); make_path($out_dir) if not -d $out_dir; open my $out_fh, '>:raw', $out_filename or die "Can't create file <<$out_filename>>: $!\n"; my $actual_crc32 = 0; my $buffer = ''; my $search_window = ''; my $actual_uncompressed_size = 0; if ($compression_method == 8) { # DEFLATE method while (1) { my $is_last = read_bit_lsb($fh, \$buffer); my $chunk = deflate_extract_next_block($fh, \$buffer, \$search_window); $actual_crc32 = crc32($chunk, $actual_crc32); $actual_uncompressed_size += length($chunk); print $out_fh $chunk; last if $is_last; } } elsif ($compression_method == 0) { # uncompressed (stored) # TODO: do not read the entire content at once (read in small chunks) read($fh, (my $chunk), $uncompressed_size); $actual_crc32 = crc32($chunk); $actual_uncompressed_size += length($chunk); print $out_fh $chunk; } else { die "Unsupported compression method: $compression_method\n"; } if (not $skip_crc32 and $crc32 != $actual_crc32) { die "CRC32 error: $crc32 (stored) != $actual_crc32 (actual)\n"; } if ($general_purpose_bit_flag & 0b100) { # TODO die "Data descriptor is currently not supported!\n"; } if ($skip_crc32) { my $header_signature = bytes2int_lsb($fh, 4); if ($header_signature == 0x8074b50) { my $stored_crc32 = bytes2int_lsb($fh, 4); my $compressed_size = bytes2int_lsb($fh, 4); my $uncompressed_size = bytes2int_lsb($fh, 4); if ($stored_crc32 != $actual_crc32) { die "CRC32 error: $stored_crc32 (stored) != $actual_crc32 (actual)\n"; } if ($uncompressed_size != $actual_uncompressed_size) { die "Uncompressed size error: $uncompressed_size (stored) != $actual_uncompressed_size (actual)\n"; } } else { die "Unknown signature: $header_signature\n"; } } close $out_fh; return $actual_crc32; } sub extract_central_directory($fh) { # TODO my $version_made_by = bytes2int_lsb($fh, 2); my $version_needed_to_extract = bytes2int_lsb($fh, 2); my $general_purpose_bit_flag = bytes2int_lsb($fh, 2); my $compression_method = bytes2int_lsb($fh, 2); my $last_mod_file_time = bytes2int_lsb($fh, 2); my $last_mod_file_date = bytes2int_lsb($fh, 2); my $crc_32 = bytes2int_lsb($fh, 4); my $compressed_size = bytes2int_lsb($fh, 4); my $uncompressed_size = bytes2int_lsb($fh, 4); my $file_name_length = bytes2int_lsb($fh, 2); my $extra_field_length = bytes2int_lsb($fh, 2); my $file_comment_length = bytes2int_lsb($fh, 2); my $disk_number_start = bytes2int_lsb($fh, 2); my $internal_file_attributes = bytes2int_lsb($fh, 2); my $external_file_attributes = bytes2int_lsb($fh, 4); my $relative_offset_of_local_header = bytes2int_lsb($fh, 4); read($fh, (my $file_name), $file_name_length); read($fh, (my $extra_field), $extra_field_length); read($fh, (my $file_comment), $file_comment_length); } sub extract_end_of_file ($fh) { # TODO my $number_of_this_disk = bytes2int_lsb($fh, 2); my $number_of_the_disk_central_dir = bytes2int_lsb($fh, 2); my $start_of_central_dir = bytes2int_lsb($fh, 2); my $total_number_of_entries = bytes2int_lsb($fh, 2); my $size_of_the_central_directory = bytes2int_lsb($fh, 4); my $offset = bytes2int_lsb($fh, 4); my $ZIP_file_comment_length = bytes2int_lsb($fh, 2); read($fh, (my $ZIP_file_comment), $ZIP_file_comment_length); } sub unzip($file) { open my $fh, '<:raw', $file or die "Can't open file <<$file>> for reading: $!"; while (!eof($fh)) { my $header_signature = bytes2int_lsb($fh, 4); if ($header_signature == 0x04034b50) { extract_file($fh); } elsif ($header_signature == 0x02014b50) { extract_central_directory($fh); } elsif ($header_signature == 0x05054b50) { # TODO die "Digital signature is currently not supported!\n"; } elsif ($header_signature == 0x06064b50) { # TODO die "ZIP64 is currently not supported!\n"; } elsif ($header_signature == 0x08064b50) { # TODO die "Extra data record is currently not supported!\n"; } elsif ($header_signature == 0x06054b50) { extract_end_of_file($fh); } else { die "Unknown header signature: $header_signature\n"; } } } foreach my $input_file (@ARGV) { unzip($input_file); } ================================================ FILE: Compression/zip.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 03 February 2025 # Edit: 04 February 2025 # https://github.com/trizen # Basic implementation of a ZIP archiver. (WIP) # Reference: # https://pkware.cachefly.net/webdocs/casestudies/APPNOTE.TXT use 5.036; use Compression::Util qw(:all); use File::Path qw(make_path); use File::Spec::Functions qw(catfile catdir); use File::Basename qw(dirname); use File::Find qw(find); use constant { FORMAT => 'zip', CHUNK_SIZE => (1 << 15) - 1, }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = 32768; # maximum allowed back-reference distance in LZ parsing binmode(STDOUT, ':raw'); binmode(STDIN, ':raw'); my $OFFSET = 0; sub zip_directory ($dir) { if (substr($dir, 0, -1) ne '/') { $dir .= '/'; } print STDOUT int2bytes_lsb(0x04034b50, 4); # header signature print STDOUT int2bytes_lsb(20, 2); # version needed print STDOUT int2bytes_lsb(0, 2); # general purpose bit print STDOUT int2bytes_lsb(0, 2); # compression method (8 = DEFLATE) print STDOUT int2bytes_lsb(0, 2); # last mod file time print STDOUT int2bytes_lsb(0, 2); # last mod file date print STDOUT int2bytes_lsb(0, 4); # CRC32 print STDOUT int2bytes_lsb(0, 4); # compressed size print STDOUT int2bytes_lsb(0, 4); # uncompressed size print STDOUT int2bytes_lsb(length($dir), 2); # filename length print STDOUT int2bytes_lsb(0, 2); # extra field length print STDOUT $dir; my $info = { crc32 => 0, name => $dir, compressed_size => 0, uncompressed_size => 0, compression_method => 0, offset => $OFFSET, }; $OFFSET += 4 * 4 + 2 * 7 + length($dir); return $info; } sub zip_file ($file) { if (-d $file) { return zip_directory($file); } print STDOUT int2bytes_lsb(0x04034b50, 4); # header signature print STDOUT int2bytes_lsb(20, 2); # version needed print STDOUT int2bytes_lsb(0b1000, 2); # general purpose bit print STDOUT int2bytes_lsb(8, 2); # compression method (8 = DEFLATE) print STDOUT int2bytes_lsb(0, 2); # last mod file time print STDOUT int2bytes_lsb(0, 2); # last mod file date print STDOUT int2bytes_lsb(0, 4); # CRC32 print STDOUT int2bytes_lsb(0, 4); # compressed size print STDOUT int2bytes_lsb(0, 4); # uncompressed size print STDOUT int2bytes_lsb(length($file), 2); # filename length print STDOUT int2bytes_lsb(0, 2); # extra field length print STDOUT $file; # filename my $crc32 = 0; my $uncompressed_size = 0; my $compressed_size = 0; my $bitstring = ''; open my $in_fh, '<:raw', $file; if (eof($in_fh)) { # empty file $bitstring = '1' . '10' . '0000000'; } while (read($in_fh, (my $chunk), CHUNK_SIZE)) { $crc32 = crc32($chunk, $crc32); $uncompressed_size += length($chunk); my ($literals, $distances, $lengths) = lzss_encode($chunk); $bitstring .= eof($in_fh) ? '1' : '0'; my $bt1_bitstring = deflate_create_block_type_1($literals, $distances, $lengths); # When block type 1 is larger than the input, then we have random uncompressible data: use block type 0 if ((length($bt1_bitstring) >> 3) > length($chunk) + 5) { say STDERR ":: Using block type: 0"; $bitstring .= '00'; my $comp = pack('b*', $bitstring); # pads to a byte $comp .= pack('b*', deflate_create_block_type_0_header($chunk)); $comp .= $chunk; $compressed_size .= length($comp); print STDOUT $comp; $bitstring = ''; next; } my $bt2_bitstring = deflate_create_block_type_2($literals, $distances, $lengths); # When block type 2 is larger than block type 1, then we may have very small data if (length($bt2_bitstring) > length($bt1_bitstring)) { say STDERR ":: Using block type: 1"; $bitstring .= $bt1_bitstring; } else { say STDERR ":: Using block type: 2"; $bitstring .= $bt2_bitstring; } my $comp = pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); $compressed_size += length($comp); print STDOUT $comp; } if ($bitstring ne '') { my $comp = pack('b*', $bitstring); $compressed_size += length($comp); print STDOUT $comp; } print STDOUT int2bytes_lsb(0x8074b50, 4); print STDOUT int2bytes_lsb($crc32, 4); print STDOUT int2bytes_lsb($compressed_size, 4); print STDOUT int2bytes_lsb($uncompressed_size, 4); my $info = { compression_method => 8, crc32 => $crc32, name => $file, compressed_size => $compressed_size, uncompressed_size => $uncompressed_size, offset => $OFFSET, }; $OFFSET += 4 * 8 + 2 * 7 + length($file) + $compressed_size; return $info; } sub central_directory($entry) { # FIXME: the offset of the local header is incorrect print STDOUT int2bytes_lsb(0x02014b50, 4); # header signature print STDOUT int2bytes_lsb(831, 2); # version made by print STDOUT int2bytes_lsb(20, 2); # version needed to extract print STDOUT int2bytes_lsb(0, 2); # general purpose bit print STDOUT int2bytes_lsb($entry->{compression_method}, 2); # compression method print STDOUT int2bytes_lsb(0, 2); # last mod file time print STDOUT int2bytes_lsb(0, 2); # last mod file date print STDOUT int2bytes_lsb($entry->{crc32}, 4); # crc32 print STDOUT int2bytes_lsb($entry->{compressed_size}, 4); # compressed size print STDOUT int2bytes_lsb($entry->{uncompressed_size}, 4); # uncompressed size print STDOUT int2bytes_lsb(length($entry->{name}), 2); # file name length print STDOUT int2bytes_lsb(0, 2); # extra field length print STDOUT int2bytes_lsb(0, 2); # file comment length print STDOUT int2bytes_lsb(0, 2); # disk number start print STDOUT int2bytes_lsb(0, 2); # internal file attributes print STDOUT int2bytes_lsb(0, 4); # external file attributes print STDOUT int2bytes_lsb($entry->{offset}, 4); # relative offset of local header (TODO) print STDOUT $entry->{name}; } sub end_of_zip_file (@entries) { print STDOUT int2bytes_lsb(0x06054b50, 4); # header signature print STDOUT int2bytes_lsb(0, 2); # number of this disk print STDOUT int2bytes_lsb(0, 2); # number of the disk central dir print STDOUT int2bytes_lsb(0, 2); # start of central dir print STDOUT int2bytes_lsb(scalar(@entries), 2); # total number of entries print STDOUT int2bytes_lsb(0, 4); # size of the central directory print STDOUT int2bytes_lsb(0, 4); # offset print STDOUT int2bytes_lsb(0, 2); # zip file comment length } my @entries; sub zip ($file) { find( { no_chdir => 1, wanted => sub { push @entries, zip_file($_); } }, $file ); } zip($ARGV[0]); #~ foreach my $entry(@entries) { #~ central_directory($entry); #~ } #~ end_of_zip_file(@entries); ================================================ FILE: Compression/zlib_compressor.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 05 November 2024 # https://github.com/trizen # Basic implementation of the ZLIB Compressed Data Format. # Reference: # https://datatracker.ietf.org/doc/html/rfc1950 # Usage: # perl zlib_compressor.pl < input_file.txt | zlib-flate -uncompress use 5.036; use Compression::Util qw(:all); local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::VERBOSE = 1; binmode(STDIN, ':raw'); binmode(STDOUT, ':raw'); sub zlib_compress ($in_fh, $out_fh) { my $CMF = (7 << 4) | 8; my $FLG = 2 << 6; while (($CMF * 256 + $FLG) % 31 != 0) { ++$FLG; } state $CHUNK_SIZE = (1 << 15) - 1; my $bitstring = ''; my $adler32 = 1; print $out_fh chr($CMF); print $out_fh chr($FLG); while (read($in_fh, (my $chunk), $CHUNK_SIZE)) { my ($literals, $distances, $lengths) = lzss_encode($chunk); $adler32 = adler32($chunk, $adler32); $bitstring .= eof($in_fh) ? '1' : '0'; $bitstring .= deflate_create_block_type_2($literals, $distances, $lengths); print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh int2bytes($adler32, 4); } zlib_compress(\*STDIN, \*STDOUT); ================================================ FILE: Compression/zlib_decompressor.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 06 November 2024 # https://github.com/trizen # Basic decompressor for the ZLIB Compressed Data Format. # Reference: # https://datatracker.ietf.org/doc/html/rfc1950 # Usage: # zlib-flate -compress=9 < /usr/bin/fdf | perl zlib_decompressor.pl use 5.036; use Compression::Util qw(:all); local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::VERBOSE = 1; binmode(STDIN, ':raw'); binmode(STDOUT, ':raw'); sub zlib_decompress ($in_fh, $out_fh) { my $adler32 = 1; my $CMF = ord(getc($in_fh)); my $FLG = ord(getc($in_fh)); if (($CMF * 256 + $FLG) % 31 != 0) { die "Invalid header checksum!\n"; } my $CINFO = $CMF >> 4; if ($CINFO > 7) { die "Values of CINFO above 7 are not supported!\n"; } my $method = $CMF & 0b1111; if ($method != 8) { die "Only method 8 (DEFLATE) is supported!\n"; } my $buffer = ''; my $search_window = ''; while (1) { my $is_last = read_bit_lsb($in_fh, \$buffer); my $chunk = deflate_extract_next_block($in_fh, \$buffer, \$search_window); print $out_fh $chunk; $adler32 = adler32($chunk, $adler32); last if $is_last; } my $stored_adler32 = bytes2int($in_fh, 4); if ($adler32 != $stored_adler32) { die "Adler32 checksum does not match: $adler32 (actual) != $stored_adler32 (stored)\n"; } if (eof($in_fh)) { print STDERR "\n:: Reached the end of the file.\n"; } else { print STDERR "\n:: There is something else in the container! Trying to recurse!\n\n"; __SUB__->($in_fh, $out_fh); } } zlib_decompress(\*STDIN, \*STDOUT); ================================================ FILE: Compression/zlib_file_compression.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 May 2024 # Edit: 06 November 2024 # https://github.com/trizen # A valid Gzip file compressor/decompressor, generating DEFLATE blocks of type 0, 1 or 2, whichever is smaller. # Reference: # Data Compression (Summer 2023) - Lecture 11 - DEFLATE (gzip) # https://youtube.com/watch?v=SJPvNi4HrWQ use 5.036; use File::Basename qw(basename); use Compression::Util qw(:all); use List::Util qw(all min max); use Getopt::Std qw(getopts); use constant { FORMAT => 'zlib', CHUNK_SIZE => (1 << 15) - 1, }; local $Compression::Util::LZ_MIN_LEN = 4; # minimum match length in LZ parsing local $Compression::Util::LZ_MAX_LEN = 258; # maximum match length in LZ parsing local $Compression::Util::LZ_MAX_DIST = (1 << 15) - 1; # maximum allowed back-reference distance in LZ parsing local $Compression::Util::LZ_MAX_CHAIN_LEN = 64; # how many recent positions to remember in LZ parsing local $Compression::Util::VERBOSE = 1; my ($DISTANCE_SYMBOLS, $LENGTH_SYMBOLS, $LENGTH_INDICES) = make_deflate_tables(); sub usage ($code = 0) { print <<"EOH"; usage: $0 [options] [input file] [output file] options: -e : extract -i : input filename -o : output filename -r : rewrite output -h : this message examples: $0 document.txt $0 document.txt archive.${\FORMAT} $0 archive.${\FORMAT} document.txt $0 -e -i archive.${\FORMAT} -o document.txt EOH exit($code // 0); } ################# # GZIP COMPRESSOR ################# sub my_zlib_compress ($in_fh, $out_fh) { my $CMF = (7 << 4) | 8; my $FLG = 2 << 6; while (($CMF * 256 + $FLG) % 31 != 0) { ++$FLG; } my $bitstring = ''; my $adler32 = 1; print $out_fh chr($CMF); print $out_fh chr($FLG); while (read($in_fh, (my $chunk), CHUNK_SIZE)) { my ($literals, $distances, $lengths) = lzss_encode($chunk); $adler32 = adler32($chunk, $adler32); $bitstring .= eof($in_fh) ? '1' : '0'; $bitstring .= deflate_create_block_type_2($literals, $distances, $lengths); print $out_fh pack('b*', substr($bitstring, 0, length($bitstring) - (length($bitstring) % 8), '')); } if ($bitstring ne '') { print $out_fh pack('b*', $bitstring); } print $out_fh int2bytes($adler32, 4); } ################### # GZIP DECOMPRESSOR ################### sub my_zlib_decompress ($in_fh, $out_fh) { my $adler32 = 1; my $CMF = ord(getc($in_fh)); my $FLG = ord(getc($in_fh)); if (($CMF * 256 + $FLG) % 31 != 0) { die "Invalid header checksum!\n"; } my $CINFO = $CMF >> 4; if ($CINFO > 7) { die "Values of CINFO above 7 are not supported!\n"; } my $method = $CMF & 0b1111; if ($method != 8) { die "Only method 8 (DEFLATE) is supported!\n"; } my $buffer = ''; my $search_window = ''; while (1) { my $is_last = read_bit_lsb($in_fh, \$buffer); my $chunk = deflate_extract_next_block($in_fh, \$buffer, \$search_window); print $out_fh $chunk; $adler32 = adler32($chunk, $adler32); last if $is_last; } my $stored_adler32 = bytes2int($in_fh, 4); if ($adler32 != $stored_adler32) { die "Adler32 checksum does not match: $adler32 (actual) != $stored_adler32 (stored)\n"; } if (eof($in_fh)) { print STDERR "\n:: Reached the end of the file.\n"; } else { print STDERR "\n:: There is something else in the container! Trying to recurse!\n\n"; __SUB__->($in_fh, $out_fh); } } sub main { my %opt; getopts('ei:o:vhr', \%opt); $opt{h} && usage(0); $opt{v} && version(); my ($input, $output) = @ARGV; $input //= $opt{i} // usage(2); $output //= $opt{o}; my $ext = qr{\.${\FORMAT}\z}io; if ($opt{e} || $input =~ $ext) { if (not defined $output) { ($output = basename($input)) =~ s{$ext}{} || die "$0: no output file specified!\n"; } if (not $opt{r} and -e $output) { print "'$output' already exists! -- Replace? [y/N] "; =~ /^y/i || exit 17; } open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_zlib_decompress($in_fh, $out_fh) || die "$0: error: decompression failed!\n"; } elsif ($input !~ $ext || (defined($output) && $output =~ $ext)) { $output //= basename($input) . '.' . FORMAT; open my $in_fh, '<:raw', $input or die "Can't open file <<$input>> for reading: $!"; open my $out_fh, '>:raw', $output or die "Can't open file <<$output>> for writing: $!"; my_zlib_compress($in_fh, $out_fh) || die "$0: error: compression failed!\n"; } else { warn "$0: don't know what to do...\n"; usage(1); } } main(); exit(0); ================================================ FILE: Converters/another_notes_to_markdown.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 27 April 2024 # https://github.com/trizen # Convert JSON data from the Android app "Another notes" to Markdown format. # See also: # https://github.com/maltaisn/another-notes-app use 5.036; use JSON qw(from_json); use File::Slurper qw(read_text); binmode(STDOUT, ':utf8'); binmode(STDERR, ':utf8'); my $json_file = $ARGV[0] // die "usage: $0 [input.json]\n"; my $json = read_text($json_file); my $notes = from_json($json)->{notes} // die "Invalid input file"; sub markdown_escape($str) { $str =~ s/([-*_`\\()\[\]#])/\\$1/gr; } foreach my $key (1 .. 1e6) { if (exists $notes->{$key}) { my $note = $notes->{$key}; my $title = markdown_escape($note->{title}); my $content = markdown_escape(unpack('A*', $note->{content})); if ($title !~ /\S/) { $title = '...'; } say "# $title\n"; if ($note->{type} == 0) { say(($content =~ s/\R/\n\n/gr), "\n"); } elsif ($note->{type} == 1) { my $meta = from_json($note->{metadata}); my @list = split(/\R/, $content); my $checked = $meta->{checked}; foreach my $i (0 .. $#list) { say "- [", ($checked->[$i] ? 'x' : ' '), "] $list[$i]\n"; } } else { warn "Unknown note type: $note->{type}\n"; } } } ================================================ FILE: Converters/another_notes_to_material_notes.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 27 April 2024 # Edit: 28 September 2024 # https://github.com/trizen # Convert JSON data from the Android app "Another notes" to "Material Notes". # See also: # https://github.com/maltaisn/another-notes-app # https://github.com/maelchiotti/LocalMaterialNotes use 5.036; use JSON qw(to_json from_json); use File::Slurper qw(read_text); binmode(STDOUT, ':utf8'); binmode(STDERR, ':utf8'); my $json_file = $ARGV[0] // die "usage: $0 [input.json]\n"; my $json = read_text($json_file); my $notes = from_json($json)->{notes} // die "Invalid input file"; my %new_notes = ( encrypted => JSON::false, notes => [], version => "1.6.0", ); foreach my $key (1 .. 1e6) { if (exists $notes->{$key}) { my $note = $notes->{$key}; my $title = $note->{title}; my $content = $note->{content}; my %new_note = ( title => $title // '', pinned => JSON::false, deleted => JSON::false, created_time => ($note->{added} =~ s{Z\z}{}r), edited_time => ($note->{modified} =~ s{Z\z}{}r), ); if ($note->{type} == 0) { # text $new_note{content} = to_json([{insert => $content}]); } elsif ($note->{type} == 1) { # checklist my $meta = from_json($note->{metadata}); my @list = split(/\R/, $content); my $checked = $meta->{checked}; my @new_checklist; foreach my $i (0 .. $#list) { push @new_checklist, {insert => $list[$i]}; push @new_checklist, { attributes => { block => "cl", checked => $checked->[$i] ? JSON::true : JSON::false, }, insert => "\n", }; } $new_note{content} = to_json(\@new_checklist); } else { warn "Unknown note type: $note->{type}\n"; } push @{$new_notes{notes}}, \%new_note; } } say to_json(\%new_notes); ================================================ FILE: Converters/any_to_3gp.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10 June 2013 # https://github.com/trizen # ## Convert any media file to the 3gp mobile format. # # Requires ffmpeg compiled with '--enable-libopencore_amrnb' use 5.010; use strict; use warnings; use Getopt::Std qw(getopts); use File::Path qw(make_path); use File::Spec::Functions qw(catfile); my %opt; getopts('f:o:i:h', \%opt); if ($opt{h} or not defined $opt{f}) { print <<"USAGE"; usage: $0 [options] options: -f format : convert only this video formats (can be a regex) -i input dir : convert videos from this directory (default: '.') -o output dir : where to put the converted videos (default: '.') example: perl $0 -f 'mp4|webm' -i Videos/ -o 3GP_Videos/ USAGE exit !$opt{h}; } my $output_dir = $opt{o} // '.'; my $input_dir = $opt{i} // '.'; my $input_format = eval { qr{\.\K(?:$opt{f})\z}i } // die "$0: Invalid regex: $@"; if (not -d $output_dir) { make_path($output_dir) or die "$0: Can't create path '$output_dir': $!\n"; } opendir(my $dir_h, $input_dir) or die "$0: Can't open dir '$input_dir': $!\n"; while (defined(my $file = readdir $dir_h)) { (my $output_file = $file) =~ s{$input_format}{3gp} or next; -f -s (my $input_file = catfile($input_dir, $file)) or next; system qw(ffmpeg -i), $input_file, qw( -acodec amr_nb -ar 8000 -ac 1 -ab 32 -vcodec h263 -s qcif -r 15 ), catfile($output_dir, $output_file); if ($? != 0) { die "$0: ffmpeg exited with a non-zero code!\n"; } } closedir($dir_h); ================================================ FILE: Converters/ass2srt.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 01 February 2022 # https://github.com/trizen # Convert ASS/SSA subtitles to SRT. # See also: # http://www.tcax.org/docs/ass-specs.htm # http://matroska.sourceforge.net/technical/specs/subtitles/ssa.html use 5.020; use strict; use warnings; use experimental qw(signatures); binmode(STDOUT, ':utf8'); binmode(STDERR, ':utf8'); sub parse_ASS_subtitle ($file) { open my $fh, '<:crlf:utf8', $file or die "Can't open file <<$file>> for reading: $!"; my %sections; my $section = ''; while (my $line = <$fh>) { if ($line =~ m{^\[(.*?)\]\s*\z}) { $section = $1; } else { push @{$sections{$section}}, $line; } } close $fh; my $events = $sections{"Events"} // die "No <> section found."; my $format = shift(@$events); my @fields; if ($format =~ m{^Format: (.+)}) { @fields = split(/\s*,\s*/, $1); } else { die "Can't find the <> line"; } my @dialogues; foreach my $event (@$events) { if ($event =~ /^Dialogue: (.+)/) { my @values = split(/\s*,\s*/, $1, scalar(@fields)); my %dialogue; @dialogue{@fields} = @values; push @dialogues, \%dialogue; } else { warn "Ignoring line: $event"; } } return @dialogues; } sub ASS_time_to_sec ($time) { my ($hours, $min, $sec, $milisec) = split(/[:.]/, $time, 4); ($hours * 3600 + $min * 60 + $sec + $milisec / 10**length($milisec)); } sub sec_to_SRT_time ($sec) { $sec = sprintf('%.3f', $sec); sprintf('%02d:%02d:%02d,%03d', int($sec / 3600) % 24, int($sec / 60) % 60, $sec % 60, substr($sec, -3)); } sub reformat_text ($text) { $text =~ s{\{\\i0\}}{}g; $text =~ s{\{\\b0\}}{}g; $text =~ s{\{\\i\d+\}}{}g; $text =~ s{\{\\b\d+\}}{}g; # Strip unknown style codes $text =~ s{\{\\\w.*?\}}{}g; # Replace \N and \n with a newline $text =~ s{\\N}{\n}g; $text =~ s{\\n}{\n}g; # Replace \h with a horizontal space $text =~ s{\\h}{ }g; $text; } sub reformat_time ($time) { sec_to_SRT_time(ASS_time_to_sec($time)); } sub ASS2SRT ($file) { my @dialogues = parse_ASS_subtitle($file); my $count = 1; my @srt_data; foreach my $entry (@dialogues) { my $srt_entry = join("\n", $count++, join(' --> ', reformat_time($entry->{Start}), reformat_time($entry->{End})), reformat_text($entry->{Text}), ); push @srt_data, $srt_entry; } join("\n\n", @srt_data) . "\n\n"; } sub usage ($exit_code = 0) { print <<"EOT"; usage: $^X $0 [input.ass] [output.srt] EOT exit($exit_code); } my $input_file = shift(@ARGV) // usage(2); my $srt_data = ASS2SRT($input_file); my $output_file = shift(@ARGV); if (defined($output_file)) { open my $fh, '>:utf8', $output_file or die "Can't open file <<$output_file>> for writing: $!"; print $fh $srt_data; close $fh; } else { print $srt_data; } ================================================ FILE: Converters/code2pdf.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 30 July 2022 # https://github.com/trizen # Code to PDF converter, with syntax highlighting, given a summary file. # Using the following tools: # md2html -- for converting Markdown to HTML (provided by md4c) # markdown2pdf.pl -- for converting Markdown to PDF (with syntax highlighting) use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; use HTML::TreeBuilder 5 ('-weak'); use Encode qw(decode_utf8 encode_utf8); use Getopt::Long qw(GetOptions); use URI::Escape qw(uri_unescape); use Digest::MD5 qw(md5_hex); my $md2html = "md2html"; # path to the `md2html` tool my $markdown2pdf = "markdown2pdf.pl"; # path to the `markdown2pdf.pl` script my $style = 'github'; my $title = 'Document'; my $lang = 'perl'; my $page_size = 'A3'; my $mathjax = 0; # true to use MathJax sub usage { my ($exit_code) = @_; $exit_code //= 0; print <<"EOT"; usage: $0 [options] [SUMMARY.md] [output.pdf] options: --style=s : style theme for `highlight` (default: $style) --title=s : title of the PDF file (default: $title) --lang=s : language code used for highlighting (default: $lang) --size=s : set paper size to: A4, Letter, etc. (default: $page_size) --mathjax! : enable support for Tex expressions (default: $mathjax) EOT exit($exit_code); } GetOptions( "style=s" => \$style, "title=s" => \$title, "lang=s" => \$lang, "size=s" => \$page_size, "mathjax!" => \$mathjax, "h|help" => sub { usage(0) }, ) or die("Error in command line arguments\n"); my $input_markdown_file = $ARGV[0] // usage(2); my $output_pdf_file = $ARGV[1] // "OUTPUT.pdf"; say ":: Converting <<$input_markdown_file>> to HTML..."; my $html = `\Q$md2html\E \Q$input_markdown_file\E`; if ($? != 0) { die "`$md2html` failed with code: $?"; } my $tree = HTML::TreeBuilder->new(); $tree->parse($html); $tree->eof(); #my @nodes = $tree->guts(); my @nodes = $tree->disembowel(); my %language_codes = ( # Source: # https://support.codebasehq.com/articles/tips-tricks/syntax-highlighting-in-markdown Cucumber => ['.feature'], abap => ['.abap'], ada => ['.adb', '.ads', '.ada'], ahk => ['.ahk', '.ahkl'], apacheconf => ['.htaccess', 'apache.conf', 'apache2.conf'], applescript => ['.applescript'], as => ['.as'], as3 => ['.as'], asy => ['.asy'], bash => ['.sh', '.ksh', '.bash', '.ebuild', '.eclass'], bat => ['.bat', '.cmd'], befunge => ['.befunge'], blitzmax => ['.bmx'], boo => ['.boo'], brainfuck => ['.bf', '.b'], c => ['.c', '.h'], cfm => ['.cfm', '.cfml', '.cfc'], cheetah => ['.tmpl', '.spt'], cl => ['.cl', '.lisp', '.el'], clojure => ['.clj', '.cljs'], cmake => ['.cmake', 'CMakeLists.txt'], coffeescript => ['.coffee'], console => ['.sh-session'], control => ['control'], cpp => ['.cpp', '.hpp', '.c++', '.h++', '.cc', '.hh', '.cxx', '.hxx', '.pde'], csharp => ['.cs'], css => ['.css'], cython => ['.pyx', '.pxd', '.pxi'], d => ['.d', '.di'], delphi => ['.pas'], diff => ['.diff', '.patch'], dpatch => ['.dpatch', '.darcspatch'], duel => ['.duel', '.jbst'], dylan => ['.dylan', '.dyl'], erb => ['.erb'], erl => ['.erl-sh'], erlang => ['.erl', '.hrl'], evoque => ['.evoque'], factor => ['.factor'], felix => ['.flx', '.flxh'], fortran => ['.f', '.f90'], gas => ['.s', '.S'], genshi => ['.kid'], glsl => ['.vert', '.frag', '.geo'], gnuplot => ['.plot', '.plt'], go => ['.go'], groff => ['.1', '.2', '.3', '.4', '.5', '.6', '.7', '.man'], haml => ['.haml'], haskell => ['.hs'], html => ['.html', '.htm', '.xhtml', '.xslt'], hx => ['.hx'], hybris => ['.hy', '.hyb'], ini => ['.ini', '.cfg'], io => ['.io'], ioke => ['.ik'], irc => ['.weechatlog'], jade => ['.jade'], java => ['.java'], js => ['.js'], jsp => ['.jsp'], lhs => ['.lhs'], llvm => ['.ll'], logtalk => ['.lgt'], lua => ['.lua', '.wlua'], make => ['.mak', 'Makefile', 'makefile', 'Makefile.', 'GNUmakefile'], mako => ['.mao'], maql => ['.maql'], mason => ['.mhtml', '.mc', '.mi', 'autohandler', 'dhandler'], markdown => ['.md'], modelica => ['.mo'], modula2 => ['.def', '.mod'], moocode => ['.moo'], mupad => ['.mu'], mxml => ['.mxml'], myghty => ['.myt', 'autodelegate'], nasm => ['.asm', '.ASM'], newspeak => ['.ns2'], objdump => ['.objdump'], objectivec => ['.m'], objectivej => ['.j'], ocaml => ['.ml', '.mli', '.mll', '.mly'], ooc => ['.ooc'], perl => ['.pl', '.PL', '.perl', '.PERL', '.pm', '.pod', '.POD', '.t', '.cgi', '.fcgi'], php => ['.php', '.php3', '.php4', '.php5'], postscript => ['.ps', '.eps'], pot => ['.pot', '.po'], pov => ['.pov', '.inc'], prolog => ['.prolog', '.pro'], properties => ['.properties'], protobuf => ['.proto'], py3tb => ['.py3tb'], pytb => ['.pytb'], python => ['.py', '.pyw', '.sc', 'SConstruct', 'SConscript', '.tac'], ruby => ['.rb', '.rbw', 'Rakefile', '.rake', '.gemspec', '.rbx', '.duby'], rconsole => ['.Rout'], rebol => ['.r', '.r3'], redcode => ['.cw'], rhtml => ['.rhtml'], rst => ['.rst', '.rest'], sass => ['.sass'], scala => ['.scala'], scaml => ['.scaml'], scheme => ['.scm'], scss => ['.scss'], smalltalk => ['.st'], smarty => ['.tpl'], sourceslist => ['sources.list'], splus => ['.S', '.R'], sql => ['.sql'], sqlite3 => ['.sqlite3-console'], squidconf => ['squid.conf'], ssp => ['.ssp'], tcl => ['.tcl'], tcsh => ['.tcsh', '.csh'], tex => ['.tex', '.aux', '.toc'], text => ['.txt'], v => ['.v', '.sv'], vala => ['.vala', '.vapi'], vbnet => ['.vb', '.bas'], velocity => ['.vm', '.fhtml'], vim => ['.vim', '.vimrc'], xml => ['.xml', '.xsl', '.rss', '.xslt', '.xsd', '.wsdl'], xquery => ['.xqy', '.xquery'], xslt => ['.xsl', '.xslt'], yaml => ['.yaml', '.yml'], julia => ['.jl'], ); sub determine_language_code { my ($file) = @_; my @found_codes; foreach my $lang_code (keys %language_codes) { foreach my $ext (@{$language_codes{$lang_code}}) { if (substr($file, -length($ext)) eq $ext) { push @found_codes, $lang_code; } } } if (scalar(@found_codes) == 1) { return $found_codes[0]; } if (scalar(@found_codes) > 1) { warn ":: Ambiguous file extension for <<$file>>: it could be (@found_codes)\n"; @found_codes = sort @found_codes; # be deterministic return $found_codes[0]; } return $lang; } say ":: Reading Markdown files..."; my $markdown_content = ''; sub expand_ul { my ($ul, $depth) = @_; foreach my $t (@{$ul->content}) { if ($t->tag eq 'li') { foreach my $x (@{$t->content}) { if (!ref($x)) { $markdown_content .= ("#" x $depth) . ' ' . $x . "\n\n"; next; } if ($x->tag eq 'ul') { expand_ul($x, $depth + 1); } else { if ($x->tag eq 'a') { my $href = $x->attr('href'); my $file = decode_utf8(uri_unescape($href)); if (not -e $file) { warn ":: File <<$file>> does not exist. Skipping...\n"; next; } if (-d $file) { $markdown_content .= ("#" x $depth) . ' ' . $x->content->[0] . "\n\n"; next; } if (not -T $file) { warn ":: Ignoring binary file <<$file>>...\n"; next; } if (open(my $fh, '<:utf8', $file)) { my $lang_code = determine_language_code($file); $markdown_content .= ("#" x $depth) . ' ' . $x->content->[0] . "\n\n"; $markdown_content .= "```$lang_code\n"; $markdown_content .= do { local $/; <$fh>; }; if (substr($markdown_content, -1) ne "\n") { $markdown_content .= "\n"; } $markdown_content .= "```\n\n"; } else { warn ":: Cannot open file <<$file>> for reading: $!\n"; } } } } } } } foreach my $entry (@nodes) { if ($entry->tag eq 'ul') { expand_ul($entry, 1); } } my $markdown_file = "$output_pdf_file.md"; open my $fh, '>:utf8', $markdown_file or die "Can't open file <<$markdown_file>> for writing: $!"; print $fh $markdown_content; close $fh; say ":: Converting Markdown to PDF..."; system($markdown2pdf, ($mathjax ? "--mathjax" : ()), "--style", $style, "--title", $title, "--size", $page_size, $markdown_file, $output_pdf_file); unlink($markdown_file); if ($? != 0) { die "`$markdown2pdf` failed with code: $?"; } ================================================ FILE: Converters/euler2pdf.pl ================================================ #!/usr/bin/perl use 5.010; use strict; use warnings; use PDF::API2 qw(); use Text::Unidecode qw(unidecode); use HTML::Entities qw(decode_entities); use File::Spec::Functions qw(catfile tmpdir); my $main_url = 'https://projecteuler.net/problem=%d'; my $p_beg = 1; my $p_end = 679; my $update_p_nums = 1; # true to retrieve the current number of problems if ($update_p_nums) { require LWP::UserAgent; my $lwp = LWP::UserAgent->new(env_proxy => 1, agent => 'Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/46.0.2490.80 Safari/537.36',); my $resp = $lwp->get('https://projecteuler.net/archives'); if ($resp->is_success) { my $content = $resp->decoded_content; if ($content =~ /The problems archives table shows problems (\d+) to (\d+)/) { $p_beg = $1; $p_end = $2; say "Successfully updated the number of problems ($p_beg to $p_end)"; } else { warn "Can't get the new number of problems. Using the default ones..."; } } } my $page = 1; my $pdf = PDF::API2->new; my $ms_delay = 3500; # wait some milliseconds for JavaScript to finish my $outlines = $pdf->outline; my $cache_dir = tmpdir(); my $outline_file = catfile($cache_dir, "outline_$$.txt"); sub end { $pdf->preferences(-outlines => 1, -onecolumn => 1); $pdf->save('Project Euler.pdf'); } local $SIG{INT} = \&end; for my $i ($p_beg .. $p_end) { printf("[%3d of %3d] Processing...\n", $i, $p_end); my $url = sprintf($main_url, $i); my $pdf_data = `wkhtmltopdf \\ --dump-outline \Q$outline_file\E \\ --quiet \\ --use-xserver \\ --enable-javascript \\ --enable-smart-shrinking \\ --images \\ --enable-forms \\ --enable-plugins \\ --enable-external-links \\ --load-error-handling ignore \\ --javascript-delay $ms_delay \\ --cache-dir \Q$cache_dir\E \\ \Q$url\E \\ /dev/stdout`; if (defined $pdf_data) { my $pdf_obj = PDF::API2->from_string($pdf_data); my $outline = $outlines->outline; if (open my $fh, '<:utf8', $outline_file) { while (<$fh>) { if (/^\h*title("$i. $title"); last; } } } my $start = $page; for my $i (1 .. $pdf_obj->page_count) { $pdf->import_page($pdf_obj, $i, $page); ++$page; } $outline->destination($pdf->open_page($start)); } } end(); ================================================ FILE: Converters/from_hex.pl ================================================ #!/usr/bin/perl # Convert HEX to binary. use 5.020; use strict; use warnings; use Getopt::Long qw(GetOptions); my $low_nybble = 0; GetOptions("l|low!" => \$low_nybble) or die "Error in arguments"; my $hex_str = ''; while (<>) { # Make sure the line starts with an hexadecimal if (/^[[:xdigit:]]/) { # Collect all hexadecimal strings from the line while (/([[:xdigit:]]+)/g) { $hex_str .= $1; } } } binmode(STDOUT, ':raw'); print pack(($low_nybble ? "h*" : "H*"), $hex_str); ================================================ FILE: Converters/gdbm_to_berkeley.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 03 April 2023 # https://github.com/trizen # Convert a GDBM database to a Berkeley database. use 5.036; use DB_File; use GDBM_File; scalar(@ARGV) == 2 or die "usage: $0 [input.dbm] [output.dbm]"; my $input_file = $ARGV[0]; my $output_file = $ARGV[1]; if (not -f $input_file) { die "Input file <<$input_file>> does not exist!\n"; } if (-e $output_file) { die "Output file <<$output_file>> already exists!\n"; } tie(my %input, 'GDBM_File', $input_file, &GDBM_READER, 0555) or die "Can't access database <<$input_file>>: $!"; tie(my %output, 'DB_File', $output_file, O_CREAT | O_RDWR, 0666, $DB_HASH) or die "Can't create database <<$output_file>>: $!"; while (my ($key, $value) = each %input) { $output{$key} = $value; } untie(%input); untie(%output); ================================================ FILE: Converters/gitbook2pdf.pl ================================================ #~ #!/usr/bin/perl # Author: Trizen # Date: 30 July 2022 # https://github.com/trizen # Gitbook to PDF converter, with syntax highlighting. # Uses the following tools: # md2html -- for converting Markdown to HTML (provided by md4c) # markdown2pdf.pl -- for converting Markdown to PDF (with syntax highlighting) use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; use HTML::TreeBuilder 5 ('-weak'); use Encode qw(decode_utf8 encode_utf8); use Getopt::Long qw(GetOptions); use URI::Escape qw(uri_unescape); use Digest::MD5 qw(md5_hex); my $md2html = "md2html"; # path to the `md2html` tool my $markdown2pdf = "markdown2pdf.pl"; # path to the `markdown2pdf.pl` script my $style = 'github'; my $title = 'Document'; my $page_size = "A3"; my $mathjax = 0; # true to use MathJax sub usage { my ($exit_code) = @_; $exit_code //= 0; print <<"EOT"; usage: $0 [options] [SUMMARY.md] [output.pdf] options: --style=s : style theme for `highlight` (default: $style) --title=s : title of the PDF file (default: $title) --size=s : set paper size to: A4, Letter, etc. (default: $page_size) --mathjax! : enable support for Tex expressions (default: $mathjax) EOT exit($exit_code); } GetOptions( "style=s" => \$style, "title=s" => \$title, "size=s" => \$page_size, "mathjax!" => \$mathjax, "h|help" => sub { usage(0) }, ) or die("Error in command line arguments\n"); my $input_markdown_file = $ARGV[0] // usage(2); my $output_pdf_file = $ARGV[1] // "OUTPUT.pdf"; say ":: Converting <<$input_markdown_file>> to HTML..."; my $html = `\Q$md2html\E \Q$input_markdown_file\E`; if ($? != 0) { die "`$md2html` failed with code: $?"; } my $tree = HTML::TreeBuilder->new(); $tree->parse($html); $tree->eof(); #my @nodes = $tree->guts(); my @nodes = $tree->disembowel(); say ":: Reading Markdown files..."; my $markdown_content = ''; sub expand_ul { my ($ul, $depth) = @_; foreach my $t (@{$ul->content}) { if ($t->tag eq 'li') { foreach my $x (@{$t->content}) { if (!ref($x)) { next; } if ($x->tag eq 'ul') { expand_ul($x, $depth + 1); } else { if ($x->tag eq 'a') { my $href = $x->attr('href'); my $file = decode_utf8(uri_unescape($href)); if (not -e $file) { warn ":: File <<$file>> does not exist. Skipping...\n"; next; } if (open my $fh, '<:utf8', $file) { local $/; $markdown_content .= <$fh>; $markdown_content .= "\n\n"; } else { warn ":: Cannot open file <<$file>> for reading: $!\n"; } } } } } } } foreach my $entry (@nodes) { if ($entry->tag eq 'ul') { expand_ul($entry, 1); } } my $markdown_file = "$output_pdf_file.md"; $markdown_content =~ s{^####+ Output:$}{**Output:**}gm; $markdown_content =~ s{ \[(\d+)\]:\s*(https?://.+) \s*\R\s* \#\s*\[(.+?)\]\[\1\] }{ my $t = 'a'.md5_hex(encode_utf8($2)); "[". $t ."]: $2\n\n# [$3][$t]"; }gex; open my $fh, '>:utf8', $markdown_file or die "Can't open file <<$markdown_file>> for writing: $!"; print $fh $markdown_content; close $fh; say ":: Converting Markdown to PDF..."; system($markdown2pdf, ($mathjax ? "--mathjax" : ()), "--style", $style, "--title", $title, "--size", $page_size, $markdown_file, $output_pdf_file); unlink($markdown_file); if ($? != 0) { die "`$markdown2pdf` failed with code: $?"; } ================================================ FILE: Converters/gz2xz.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 08 May 2024 # https://github.com/trizen # Convert Gzip files to XZ. use 5.036; use IO::Compress::Xz qw(); use IO::Uncompress::Gunzip qw(); use Getopt::Long qw(GetOptions); use constant { CHUNK_SIZE => 1 << 16, # how many bytes to read per chunk }; sub gz2xz ($in_fh, $out_fh) { while ($in_fh->read(my $chunk, CHUNK_SIZE)) { $out_fh->print($chunk); } $in_fh->eof or return; $in_fh->close or return; $out_fh->close; } my $keep_original = 0; my $overwrite = 0; sub usage ($exit_code) { print <<"EOT"; usage: $0 [options] [.gz files] options: -k --keep! : keep the original Gzip files (default: $keep_original) -f --force! : overwrite existing files (default: $overwrite) -h --help : print this message and exit example: # Convert a bunch of Gzip files to XZ format $0 *.gz EOT exit($exit_code); } GetOptions( 'k|keep!' => \$keep_original, 'f|force!' => \$overwrite, 'h|help' => sub { usage(0) }, ) or usage(1); @ARGV || usage(2); foreach my $gz_file (@ARGV) { if (not -f $gz_file) { warn ":: Not a file: <<$gz_file>>. Skipping...\n"; next; } say "\n:: Processing: $gz_file"; my $xz_file = $gz_file; if ( $xz_file =~ s{\.tgz\z}{.txz}i or $xz_file =~ s{\.gz\z}{.xz}i) { ## ok } else { $xz_file .= '.xz'; } if (-e $xz_file) { if (not $overwrite) { say "-> File <<$xz_file>> already exists. Skipping..."; next; } } my $in_fh = IO::Uncompress::Gunzip->new($gz_file) or do { warn "[!] Probably not a Gzip file ($IO::Uncompress::Gunzip::GunzipError). Skipping...\n"; next; }; my $out_fh = IO::Compress::Xz->new($xz_file) or die "[!] Failed to initialize the compressor: $IO::Compress::Xz::XzError\n"; gz2xz($in_fh, $out_fh) || do { warn "[!] Something went wrong! Skipping...\n"; unlink($xz_file); next; }; my $old_size = -s $gz_file; my $new_size = -s $xz_file; say "-> $old_size vs. $new_size"; if (not $keep_original) { say "-> Removing the original Gzip file: $gz_file"; unlink($gz_file) or warn "[!] Can't remove file <<$gz_file>>: $!\n"; } } ================================================ FILE: Converters/html2pdf.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 16 April 2023 # https://github.com/trizen # HTML|URL to PDF converter, with JavaScript support. # Using the following tool: # wkhtmltopdf -- for converting HTML to PDF use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; use Getopt::Long qw(GetOptions); my $title = undef; my $js = 0; my $js_delay = 1000; my $page_size = 'A3'; sub usage { my ($exit_code) = @_; $exit_code //= 0; print <<"EOT"; usage: $0 [options] [input.html | URL] [output.pdf] options: --js : allow web pages to run JavaScript (default: $js) --js-delay=i : wait some milliseconds for JavaScript to finish (default: $js_delay) --title=s : title of the PDF file --size=s : set paper size to: A4, Letter, etc. (default: $page_size) EOT exit($exit_code); } GetOptions( "title=s" => \$title, "size=s" => \$page_size, 'js|javascript!' => \$js, 'js-delay=i' => \$js_delay, "h|help" => sub { usage(0) }, ) or die("Error in command line arguments\n"); my $input_html_file = $ARGV[0] // usage(2); my $output_pdf_file = $ARGV[1] // "output.pdf"; say ":: Converting HTML to PDF..."; system( qw(wkhtmltopdf --quiet --enable-smart-shrinking --images --enable-external-links --enable-internal-links --keep-relative-links --enable-local-file-access --load-error-handling ignore), "--page-size", $page_size, (defined($title) ? ('--title', $title) : ()), ($js ? ( '--enable-javascript', '--javascript-delay', $js_delay ) : ('--disable-javascript')), $input_html_file, $output_pdf_file, ); if ($? != 0) { die "`wkhtmltopdf` failed with code: $?"; } say ":: Done!" ================================================ FILE: Converters/html2pdf_chromium.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 16 April 2023 # https://github.com/trizen # HTML|URL to PDF converter, with JavaScript support. # Using the following tool: # chromium -- for converting HTML to PDF use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; use Getopt::Long qw(GetOptions); my $js_delay = 10000; sub usage { my ($exit_code) = @_; $exit_code //= 0; print <<"EOT"; usage: $0 [options] [input.html | URL] [output.pdf] options: --js-delay=i : wait some milliseconds for JavaScript to finish (default: $js_delay) EOT exit($exit_code); } GetOptions('js-delay=i' => \$js_delay, "h|help" => sub { usage(0) },) or die("Error in command line arguments\n"); my $input_html_file = $ARGV[0] // usage(2); my $output_pdf_file = $ARGV[1] // "output.pdf"; say ":: Converting HTML to PDF..."; # Reference: # https://peter.sh/experiments/chromium-command-line-switches/ system( qw( chromium --headless --disable-gpu --no-pdf-header-footer --disable-pdf-tagging --enable-local-file-accesses --run-all-compositor-stages-before-draw ), "--virtual-time-budget=$js_delay", "--print-to-pdf=$output_pdf_file", $input_html_file, ); if ($? != 0) { die "`chromium` failed with code: $?"; } say ":: Done!" ================================================ FILE: Converters/html2text.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 08 January 2022 # https://github.com/trizen # Convert HTML to text (UTF-8), given either an HTML file, or an URL. # Dependencies: # perl-html-tree # perl-html-formatter # perl-libwww (optional: when given URLs) # perl-lwp-protocol-https (optional: when given https:// URLs) # See also: # https://github.com/grobian/html2text use 5.020; use strict; use warnings; use experimental qw(signatures); use HTML::TreeBuilder 5 qw(-weak); use HTML::FormatText qw(); use Getopt::Long qw(GetOptions); binmode(STDIN, ':utf8'); binmode(STDOUT, ':utf8'); sub extract_html ($source) { if ($source =~ m{^https?://}) { require LWP::UserAgent; require HTTP::Message; my $lwp = LWP::UserAgent->new( env_proxy => 1, timeout => 15, agent => "Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Firefox/91.0", cookie_jar => {}, ssl_opts => {verify_hostname => 0}, ); state $accepted_encodings = HTTP::Message::decodable(); $lwp->default_header('Accept-Encoding' => $accepted_encodings); my $resp = $lwp->get($source); $resp->is_success or return; my $html = $resp->decoded_content; return $html; } if (ref($source) eq 'GLOB') { my $html = do { local $/; <$source>; }; return $html; } my $html = do { open my $fh, '<:utf8', $source or die "Can't open file <<$source>> for reading: $!"; local $/; <$fh>; }; return $html; } sub html2text ($html, $formatter) { my $tree = HTML::TreeBuilder->new(); $tree->parse($html); $tree->eof(); $tree->elementify(); # just for safety my $text = $formatter->format($tree); return $text; } my $left_margin = 0; my $right_margin = 80; sub help ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [URL or HTML file] -lm --left=i : the column of the left margin. (default: $left_margin) -rm --right=i : the column of the right margin. (default: $right_margin) EOT exit($exit_code); } GetOptions( "lm|left=i" => \$left_margin, "rm|right=i" => \$right_margin, "h|help" => sub { help(0) } ) or do { warn("Error in command line arguments\n"); help(1); }; my $stdin_on_tty = -t STDIN; if (not $stdin_on_tty) { # assume input provided via STDIN ## ok } else { @ARGV || do { warn "\nerror: no URL or HTML file provided!\n\n"; help(2); }; } my $formatter = HTML::FormatText->new(leftmargin => $left_margin, rightmargin => $right_margin,); my $html = extract_html($stdin_on_tty ? $ARGV[0] : \*STDIN); $html // die "error: unable to extract HTML content"; my $text = html2text($html, $formatter); $text // die "error: unable to extract text"; print $text; ================================================ FILE: Converters/json2csv.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 08 March 2016 # License: GPLV3 # Website: https://github.com/trizen # Converts a stream of newline separated json data to csv format. # See also: https://github.com/jehiah/json2csv use 5.010; use strict; use warnings; use Text::CSV qw(); use JSON qw(from_json); use Getopt::Std qw(getopts); use Encode qw(decode_utf8); use Text::ParseWords qw(quotewords); use open IO => ':encoding(UTF-8)', ':std'; @ARGV = map { decode_utf8($_) } @ARGV; my %opt; getopts('k:i:o:p:d:', \%opt); my $in = \*ARGV; my $out = \*STDOUT; if (defined($opt{i})) { open $in, '<', $opt{i} or die "Can't open file `$opt{i}' for reading: $!"; } if (defined($opt{o})) { open $out, '>', $opt{o} or die "Can't open file `$opt{o}' for writing: $!"; } sub usage { my ($code) = @_; print <<"EOT"; usage: $0 [options] [< input.json] [> output.csv] options: -k fields.0,and,nested.fields,to,output -i /path/to/input.json (optional; default is stdin) -o /path/to/output.csv (optional; default is stdout) -d delimiter separator for csv (default: ",") -p print csv header row example: $0 -k user.name,list.0,remote_ip -i input.json -o output.csv EOT exit($code); } $opt{k} // usage(1); sub unescape { my ($str) = @_; my %esc = ( a => "\a", t => "\t", r => "\r", n => "\n", e => "\e", b => "\b", f => "\f", ); $str =~ s{(?new( { eol => "\n", sep_char => defined($opt{d}) ? unescape($opt{d}) : ",", } ) or die "Cannot use CSV: " . Text::CSV->error_diag(); sub extract { my ($json, $fields) = @_; my @row; foreach my $field (@{$fields}) { my $ref = $json; foreach my $key (@{$field}) { if ( ref($ref) eq 'ARRAY' and $key =~ /^[-+]?[0-9]+\z/ and exists($ref->[$key])) { $ref = $ref->[$key]; } elsif (ref($ref) eq 'HASH' and exists($ref->{$key})) { $ref = $ref->{$key}; } else { local $" = ' -> '; warn "[!] Field `$key' (from `@{$field}') does not exists in JSON.\n"; $ref = undef; last; } } push @row, $ref; } \@row; } while (defined(my $line = <$in>)) { my $data = extract(from_json($line), \@fields); $csv->print($out, $data); } ================================================ FILE: Converters/markdown2pdf.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 29 July 2022 # Edit: 05 January 2024 # https://github.com/trizen # Markdown to PDF converter, with syntax highlighting. # Using the following tools: # md2html -- for converting Markdown to HTML (provided by md4c) # highlight -- for syntax highlighting # wkhtmltopdf -- for converting HTML to PDF use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; use HTML::TreeBuilder 5 ('-weak'); use HTML::Entities qw(encode_entities); use IPC::Run3 qw(run3); use File::Temp qw(tempfile); use Encode qw(decode_utf8 encode_utf8); use Getopt::Long qw(GetOptions); my $md2html = "md2html"; # path to the `md2html` tool my $syntax_lang = 'text'; my $style = 'github'; my $title = 'Document'; my $page_size = 'A3'; my $mathjax = 0; # true to use MathJax.js my $js_delay = 3000; # in ms my $keep_html = 0; sub usage { my ($exit_code) = @_; $exit_code //= 0; print <<"EOT"; usage: $0 [options] [input.md] [output.pdf] options: --style=s : style theme for `highlight` (default: $style) --title=s : title of the PDF file (default: $title) --size=s : set paper size to: A4, Letter, etc. (default: $page_size) --lang=s : default syntax highlighting language (default: $syntax_lang) --mathjax! : enable support for Tex expressions (default: $mathjax) --js-delay=i : JavaScript delay in ms (with --mathjax) (default: $js_delay) --html! : keep the intermediary HTML file (default: $keep_html) EOT exit($exit_code); } GetOptions( "lang=s" => \$syntax_lang, "style=s" => \$style, "title=s" => \$title, "size=s" => \$page_size, "mathjax!" => \$mathjax, "js-delay=i" => \$js_delay, "html!" => \$keep_html, "h|help" => sub { usage(0) }, ) or die("Error in command line arguments\n"); my $input_markdown_file = $ARGV[0] // usage(2); my $output_pdf_file = $ARGV[1] // ($input_markdown_file . ".pdf"); say ":: Converting Markdown to HTML..."; my $html = `\Q$md2html\E --github \Q$input_markdown_file\E`; if ($? != 0) { die "`$md2html` failed with code: $?"; } my $tree = HTML::TreeBuilder->new(); $tree->parse($html); $tree->eof(); #my @nodes = $tree->guts(); my @nodes = $tree->disembowel(); my @highlight = qw(highlight --fragment -t 4 --no-trailing-nl -O html --encoding utf-8); my ($in_fh, $tmp_in_file) = tempfile(); my ($out_fh, $tmp_out_file) = tempfile(); my $html_content = ''; say ":: Syntax highlighting..."; foreach my $entry (@nodes) { ref($entry) || next; my $code = $entry->as_HTML(undef, undef, {}); if ($entry->tag eq 'pre') { my $t = $entry->content->[0]; if ($t->tag eq 'code') { my $lang = $syntax_lang; my $class = $t->attr('class'); if (defined($class) and $class =~ /^language-(.+)/) { $lang = $1; } if ($lang eq 'text' or $lang eq 'none' or $lang eq '') { # no need to highlight plaintext $html_content .= $code; next; } my $content = $t->content() // next; if (ref($content) ne 'ARRAY') { warn ":: Unexpected entry: <<$content>>\n"; next; } my $str = join(' ', @{$content}); print $in_fh encode_utf8($str); seek($in_fh, 0, 0); run3([@highlight, '--syntax', $lang, '--style', $style], $in_fh, $out_fh); if ($? != 0) { die ":: Can't execute the `highlight` command!"; } $code = "
    " . do {
                seek($out_fh, 0, 0);
                local $/;
                decode_utf8(<$out_fh>);
              }
              . "
    "; seek($in_fh, 0, 0); seek($out_fh, 0, 0); truncate($in_fh, 0); truncate($out_fh, 0); } } $html_content .= $code; } $title = encode_entities(decode_utf8($title)); my $final_html = <<"HTML"; $title HTML if ($mathjax) { # Reference: https://stackoverflow.com/questions/34347818/using-mathjax-on-a-github-page say ":: Adding MathJax support..."; $final_html .= <<'HTML'; HTML } my $css = `highlight --print-style -O html --style \Q$style\E --stdout`; $final_html .= <<'HTML'; HTML $final_html .= <<'HTML'; HTML $final_html .= $html_content; $final_html .= <<'HTML'; HTML my $tmp_html_file = $output_pdf_file . '.html'; do { open my $fh, '>:utf8', $tmp_html_file or die "Can't create file <<$tmp_html_file>>: $!"; print $fh $final_html; close $fh; }; say ":: Converting HTML to PDF..."; system( qw(wkhtmltopdf --quiet --enable-smart-shrinking --images --enable-external-links --enable-local-file-access --load-error-handling ignore), "--page-size", $page_size, ( $mathjax ? ('--enable-javascript', '--javascript-delay', $js_delay) : () ), $tmp_html_file, $output_pdf_file, ); unlink($tmp_in_file, $tmp_out_file); unlink($tmp_html_file) if not $keep_html; if ($? != 0) { die "`wkhtmltopdf` failed with code: $?"; } say ":: Done!" __DATA__ /* theme "github.css" from md2pdf */ @font-face { font-family: octicons-anchor; 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'); } .markdown-body { -ms-text-size-adjust: 100%; -webkit-text-size-adjust: 100%; color: #333; overflow: hidden; font-family: "Helvetica Neue", Helvetica, "Segoe UI", Arial, freesans, sans-serif; font-size: 16px; line-height: 1.6; word-wrap: break-word; /*padding: 3.17cm 2.54cm 2.54cm 2.54cm;*/ padding: 0; } .markdown-body a { background: transparent; } .markdown-body a:active, .markdown-body a:hover { outline: 0; } .markdown-body strong { font-weight: bold; } .markdown-body h1 { font-size: 2em; margin: 0.67em 0; } .markdown-body img { border: 0; } .markdown-body hr { -moz-box-sizing: content-box; box-sizing: content-box; height: 0; } .markdown-body pre { overflow: auto; } .markdown-body code, .markdown-body kbd, .markdown-body pre { font-family: monospace, monospace; font-size: 1em; } .markdown-body input { color: inherit; font: inherit; margin: 0; } .markdown-body html input[disabled] { cursor: default; } .markdown-body input { line-height: normal; } .markdown-body input[type="checkbox"] { -moz-box-sizing: border-box; box-sizing: border-box; padding: 0; } .markdown-body table { border-collapse: collapse; border-spacing: 0; } .markdown-body td, .markdown-body th { padding: 0; } .markdown-body * { -moz-box-sizing: border-box; box-sizing: border-box; } .markdown-body input { font: 13px/1.4 Helvetica, arial, freesans, clean, sans-serif, "Segoe UI Emoji", "Segoe UI Symbol"; } .markdown-body a { color: #4183c4; text-decoration: none; } .markdown-body a:hover, .markdown-body a:active { text-decoration: underline; } .markdown-body hr { height: 0; margin: 15px 0; overflow: hidden; background: transparent; border: 0; border-bottom: 1px solid #ddd; } .markdown-body hr:before { display: table; content: ""; } .markdown-body hr:after { display: table; clear: both; content: ""; } .markdown-body h1, .markdown-body h2, .markdown-body h3, .markdown-body h4, .markdown-body h5, .markdown-body h6 { margin-top: 15px; margin-bottom: 15px; line-height: 1.1; } .markdown-body h1 { font-size: 30px; } .markdown-body h2 { font-size: 21px; } .markdown-body h3 { font-size: 16px; } .markdown-body h4 { font-size: 14px; } .markdown-body h5 { font-size: 12px; } .markdown-body h6 { font-size: 11px; } .markdown-body blockquote { margin: 0; } .markdown-body ul, .markdown-body ol { padding: 0; margin-top: 0; margin-bottom: 0; } .markdown-body ol ol, .markdown-body ul ol { list-style-type: lower-roman; } .markdown-body ul ul ol, .markdown-body ul ol ol, .markdown-body ol ul ol, .markdown-body ol ol ol { list-style-type: lower-alpha; } .markdown-body dd { margin-left: 0; } .markdown-body code { font-family: Consolas, "Liberation Mono", Menlo, Courier, monospace; font-size: 12px; } .markdown-body pre { margin-top: 0; margin-bottom: 0; font: 12px Consolas, "Liberation Mono", Menlo, Courier, monospace; } .markdown-body .octicon { font: normal normal 16px octicons-anchor; line-height: 1; display: inline-block; text-decoration: none; -webkit-font-smoothing: antialiased; -moz-osx-font-smoothing: grayscale; -webkit-user-select: none; -moz-user-select: none; -ms-user-select: none; user-select: none; } .markdown-body .octicon-link:before { content: '\f05c'; } .markdown-body>*:first-child { margin-top: 0 !important; } .markdown-body>*:last-child { margin-bottom: 0 !important; } .markdown-body .anchor { position: absolute; top: 0; left: 0; display: block; padding-right: 6px; padding-left: 30px; margin-left: -30px; } .markdown-body .anchor:focus { outline: none; } .markdown-body h1, .markdown-body h2, .markdown-body h3, .markdown-body h4, .markdown-body h5, .markdown-body h6 { position: relative; margin-top: 1em; margin-bottom: 16px; font-weight: bold; line-height: 1.4; } .markdown-body h1 .octicon-link, .markdown-body h2 .octicon-link, .markdown-body h3 .octicon-link, .markdown-body h4 .octicon-link, .markdown-body h5 .octicon-link, .markdown-body h6 .octicon-link { display: none; color: #000; vertical-align: middle; } .markdown-body h1:hover .anchor, .markdown-body h2:hover .anchor, .markdown-body h3:hover .anchor, .markdown-body h4:hover .anchor, .markdown-body h5:hover .anchor, .markdown-body h6:hover .anchor { padding-left: 8px; margin-left: -30px; text-decoration: none; } .markdown-body h1:hover .anchor .octicon-link, .markdown-body h2:hover .anchor .octicon-link, .markdown-body h3:hover .anchor .octicon-link, .markdown-body h4:hover .anchor .octicon-link, .markdown-body h5:hover .anchor .octicon-link, .markdown-body h6:hover .anchor .octicon-link { display: inline-block; } .markdown-body h1 { padding-bottom: 0.3em; font-size: 2.25em; line-height: 1.2; border-bottom: 1px solid #eee; } .markdown-body h1 .anchor { line-height: 1; } .markdown-body h2 { padding-bottom: 0.3em; font-size: 1.75em; line-height: 1.225; border-bottom: 1px solid #eee; } .markdown-body h2 .anchor { line-height: 1; } .markdown-body h3 { font-size: 1.5em; line-height: 1.43; } .markdown-body h3 .anchor { line-height: 1.2; } .markdown-body h4 { font-size: 1.25em; } .markdown-body h4 .anchor { line-height: 1.2; } .markdown-body h5 { font-size: 1em; } .markdown-body h5 .anchor { line-height: 1.1; } .markdown-body h6 { font-size: 1em; color: #777; } .markdown-body h6 .anchor { line-height: 1.1; } .markdown-body p, .markdown-body blockquote, .markdown-body ul, .markdown-body ol, .markdown-body dl, .markdown-body table, .markdown-body pre { margin-top: 0; margin-bottom: 16px; } .markdown-body hr { height: 4px; padding: 0; margin: 16px 0; background-color: #e7e7e7; border: 0 none; } .markdown-body ul, .markdown-body ol { padding-left: 2em; } .markdown-body ul ul, .markdown-body ul ol, .markdown-body ol ol, .markdown-body ol ul { margin-top: 0; margin-bottom: 0; } .markdown-body li>p { margin-top: 16px; } .markdown-body dl { padding: 0; } .markdown-body dl dt { padding: 0; margin-top: 16px; font-size: 1em; font-style: italic; font-weight: bold; } .markdown-body dl dd { padding: 0 16px; margin-bottom: 16px; } .markdown-body blockquote { padding: 0 15px; color: #777; border-left: 4px solid #ddd; } .markdown-body blockquote>:first-child { margin-top: 0; } .markdown-body blockquote>:last-child { margin-bottom: 0; } .markdown-body table { display: block; width: 100%; overflow: auto; word-break: normal; word-break: keep-all; } .markdown-body table th { font-weight: bold; } .markdown-body table th, .markdown-body table td { padding: 6px 13px; border: 1px solid #ddd; } .markdown-body table tr { background-color: #fff; border-top: 1px solid #ccc; } .markdown-body table tr:nth-child(2n) { background-color: #f8f8f8; } .markdown-body img { max-width: 100%; -moz-box-sizing: border-box; box-sizing: border-box; } .markdown-body code { padding: 0; padding-top: 0.2em; padding-bottom: 0.2em; margin: 0; font-size: 85%; background-color: rgba(0,0,0,0.04); border-radius: 3px; } .markdown-body code:before, .markdown-body code:after { letter-spacing: -0.2em; content: "\00a0"; } .markdown-body pre>code { padding: 0; margin: 0; font-size: 100%; word-break: normal; white-space: pre; background: transparent; border: 0; } .markdown-body .highlight { margin-bottom: 16px; } .markdown-body .highlight pre, .markdown-body pre { padding: 16px; overflow: auto; font-size: 85%; line-height: 1.45; background-color: #f7f7f7; border-radius: 3px; } .markdown-body .highlight pre { margin-bottom: 0; word-break: normal; } .markdown-body pre { word-wrap: normal; } .markdown-body pre code { display: inline; max-width: initial; padding: 0; margin: 0; overflow: initial; line-height: inherit; word-wrap: normal; background-color: transparent; border: 0; } .markdown-body pre code:before, .markdown-body pre code:after { content: normal; } .markdown-body kbd { display: inline-block; padding: 3px 5px; font-size: 11px; line-height: 10px; color: #555; vertical-align: middle; background-color: #fcfcfc; border: solid 1px #ccc; border-bottom-color: #bbb; border-radius: 3px; box-shadow: inset 0 -1px 0 #bbb; } .markdown-body .pl-c { color: #969896; } .markdown-body .pl-c1, .markdown-body .pl-mdh, .markdown-body .pl-mm, .markdown-body .pl-mp, .markdown-body .pl-mr, .markdown-body .pl-s1 .pl-v, .markdown-body .pl-s3, .markdown-body .pl-sc, .markdown-body .pl-sv { color: #0086b3; } .markdown-body .pl-e, .markdown-body .pl-en { color: #795da3; } .markdown-body .pl-s1 .pl-s2, .markdown-body .pl-smi, .markdown-body .pl-smp, .markdown-body .pl-stj, .markdown-body .pl-vo, .markdown-body .pl-vpf { color: #333; } .markdown-body .pl-ent { color: #63a35c; } .markdown-body .pl-k, .markdown-body .pl-s, .markdown-body .pl-st { color: #a71d5d; } .markdown-body .pl-pds, .markdown-body .pl-s1, .markdown-body .pl-s1 .pl-pse .pl-s2, .markdown-body .pl-sr, .markdown-body .pl-sr .pl-cce, .markdown-body .pl-sr .pl-sra, .markdown-body .pl-sr .pl-sre, .markdown-body .pl-src { color: #df5000; } .markdown-body .pl-mo, .markdown-body .pl-v { color: #1d3e81; } .markdown-body .pl-id { color: #b52a1d; } .markdown-body .pl-ii { background-color: #b52a1d; color: #f8f8f8; } .markdown-body .pl-sr .pl-cce { color: #63a35c; font-weight: bold; } .markdown-body .pl-ml { color: #693a17; } .markdown-body .pl-mh, .markdown-body .pl-mh .pl-en, .markdown-body .pl-ms { color: #1d3e81; font-weight: bold; } .markdown-body .pl-mq { color: #008080; } .markdown-body .pl-mi { color: #333; font-style: italic; } .markdown-body .pl-mb { color: #333; font-weight: bold; } .markdown-body .pl-md, .markdown-body .pl-mdhf { background-color: #ffecec; color: #bd2c00; } .markdown-body .pl-mdht, .markdown-body .pl-mi1 { background-color: #eaffea; color: #55a532; } .markdown-body .pl-mdr { color: #795da3; font-weight: bold; } .markdown-body kbd { display: inline-block; padding: 3px 5px; font: 11px Consolas, "Liberation Mono", Menlo, Courier, monospace; line-height: 10px; color: #555; vertical-align: middle; background-color: #fcfcfc; border: solid 1px #ccc; border-bottom-color: #bbb; border-radius: 3px; box-shadow: inset 0 -1px 0 #bbb; } .markdown-body .task-list-item { list-style-type: none; } .markdown-body .task-list-item+.task-list-item { margin-top: 3px; } .markdown-body .task-list-item input { float: left; margin: 0.3em 0 0.25em -1.6em; vertical-align: middle; } .markdown-body :checked+.radio-label { z-index: 1; position: relative; border-color: #4183c4; } .footnotes { font-size: 12px; } .nobreak { page-break-inside: avoid; } ================================================ FILE: Converters/markdown2pdf_chromium.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 29 July 2022 # Edit: 05 January 2024 # https://github.com/trizen # Markdown to PDF converter, with syntax highlighting. # Using the following tools: # md2html -- for converting Markdown to HTML (provided by md4c) # highlight -- for syntax highlighting # chromium -- for converting HTML to PDF use 5.010; use strict; use warnings; use open IO => ':utf8', ':std'; use HTML::TreeBuilder 5 ('-weak'); use HTML::Entities qw(encode_entities); use IPC::Run3 qw(run3); use File::Temp qw(tempfile); use Encode qw(decode_utf8 encode_utf8); use Getopt::Long qw(GetOptions); my $md2html = "md2html"; # path to the `md2html` tool my $syntax_lang = 'text'; my $style = 'github'; my $title = 'Document'; my $page_size = 'A4'; # TODO: this is currently unimplemented my $mathjax = 0; # true to use MathJax.js sub usage { my ($exit_code) = @_; $exit_code //= 0; print <<"EOT"; usage: $0 [options] [input.md] [output.pdf] options: --style=s : style theme for `highlight` (default: $style) --title=s : title of the PDF file (default: $title) --size=s : set paper size to: A4, Letter, etc. (default: $page_size) --lang=s : default syntax highlighting language (default: $syntax_lang) --mathjax! : enable support for Tex expressions (default: $mathjax) EOT exit($exit_code); } GetOptions( "lang=s" => \$syntax_lang, "style=s" => \$style, "title=s" => \$title, "size=s" => \$page_size, "mathjax!" => \$mathjax, "h|help" => sub { usage(0) }, ) or die("Error in command line arguments\n"); my $input_markdown_file = $ARGV[0] // usage(2); my $output_pdf_file = $ARGV[1] // ($input_markdown_file . ".pdf"); say ":: Converting Markdown to HTML..."; my $html = `\Q$md2html\E --github \Q$input_markdown_file\E`; if ($? != 0) { die "`$md2html` failed with code: $?"; } my $tree = HTML::TreeBuilder->new(); $tree->parse($html); $tree->eof(); #my @nodes = $tree->guts(); my @nodes = $tree->disembowel(); my @highlight = qw(highlight --fragment -t 4 --no-trailing-nl -O html --encoding utf-8); my ($in_fh, $tmp_in_file) = tempfile(); my ($out_fh, $tmp_out_file) = tempfile(); my $html_content = ''; say ":: Syntax highlighting..."; foreach my $entry (@nodes) { ref($entry) || next; my $code = $entry->as_HTML(undef, undef, {}); if ($entry->tag eq 'pre') { my $t = $entry->content->[0]; if ($t->tag eq 'code') { my $lang = $syntax_lang; my $class = $t->attr('class'); if (defined($class) and $class =~ /^language-(.+)/) { $lang = $1; } if ($lang eq 'text' or $lang eq 'none' or $lang eq '') { # no need to highlight plaintext $html_content .= $code; next; } my $content = $t->content() // next; if (ref($content) ne 'ARRAY') { warn ":: Unexpected entry: <<$content>>\n"; next; } my $str = join(' ', @{$content}); print $in_fh encode_utf8($str); seek($in_fh, 0, 0); run3([@highlight, '--syntax', $lang, '--style', $style], $in_fh, $out_fh); if ($? != 0) { die ":: Can't execute the `highlight` command!"; } $code = "
    " . do {
                seek($out_fh, 0, 0);
                local $/;
                decode_utf8(<$out_fh>);
              }
              . "
    "; seek($in_fh, 0, 0); seek($out_fh, 0, 0); truncate($in_fh, 0); truncate($out_fh, 0); } } $html_content .= $code; } $title = encode_entities(decode_utf8($title)); my $final_html = <<"HTML"; $title HTML if ($mathjax) { # Reference: https://stackoverflow.com/questions/34347818/using-mathjax-on-a-github-page say ":: Adding MathJax support..."; $final_html .= <<'HTML'; HTML } my $css = `highlight --print-style -O html --style \Q$style\E --stdout`; $final_html .= <<'HTML'; HTML $final_html .= <<'HTML'; HTML $final_html .= $html_content; $final_html .= <<'HTML'; HTML my $tmp_html_file = $output_pdf_file . '.html'; do { open my $fh, '>:utf8', $tmp_html_file or die "Can't create file <<$tmp_html_file>>: $!"; print $fh $final_html; close $fh; }; say ":: Converting HTML to PDF..."; # Reference: # https://peter.sh/experiments/chromium-command-line-switches/ system( qw(chromium --headless --disable-gpu --no-pdf-header-footer --disable-pdf-tagging --enable-local-file-accesses --run-all-compositor-stages-before-draw --virtual-time-budget=10000 ), "--print-to-pdf=$output_pdf_file", $tmp_html_file, ); unlink($tmp_in_file, $tmp_out_file, $tmp_html_file); if ($? != 0) { die "`chromium` failed with code: $?"; } say ":: Done!" __DATA__ /* theme "github.css" from md2pdf */ @font-face { font-family: octicons-anchor; 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'); } .markdown-body { -ms-text-size-adjust: 100%; -webkit-text-size-adjust: 100%; color: #333; overflow: hidden; font-family: "Helvetica Neue", Helvetica, "Segoe UI", Arial, freesans, sans-serif; font-size: 16px; line-height: 1.6; word-wrap: break-word; /*padding: 3.17cm 2.54cm 2.54cm 2.54cm;*/ padding: 0; } .markdown-body a { background: transparent; } .markdown-body a:active, .markdown-body a:hover { outline: 0; } .markdown-body strong { font-weight: bold; } .markdown-body h1 { font-size: 2em; margin: 0.67em 0; } .markdown-body img { border: 0; } .markdown-body hr { -moz-box-sizing: content-box; box-sizing: content-box; height: 0; } .markdown-body pre { overflow: auto; } .markdown-body code, .markdown-body kbd, .markdown-body pre { font-family: monospace, monospace; font-size: 1em; } .markdown-body input { color: inherit; font: inherit; margin: 0; } .markdown-body html input[disabled] { cursor: default; } .markdown-body input { line-height: normal; } .markdown-body input[type="checkbox"] { -moz-box-sizing: border-box; box-sizing: border-box; padding: 0; } .markdown-body table { border-collapse: collapse; border-spacing: 0; } .markdown-body td, .markdown-body th { padding: 0; } .markdown-body * { -moz-box-sizing: border-box; box-sizing: border-box; } .markdown-body input { font: 13px/1.4 Helvetica, arial, freesans, clean, sans-serif, "Segoe UI Emoji", "Segoe UI Symbol"; } .markdown-body a { color: #4183c4; text-decoration: none; } .markdown-body a:hover, .markdown-body a:active { text-decoration: underline; } .markdown-body hr { height: 0; margin: 15px 0; overflow: hidden; background: transparent; border: 0; border-bottom: 1px solid #ddd; } .markdown-body hr:before { display: table; content: ""; } .markdown-body hr:after { display: table; clear: both; content: ""; } .markdown-body h1, .markdown-body h2, .markdown-body h3, .markdown-body h4, .markdown-body h5, .markdown-body h6 { margin-top: 15px; margin-bottom: 15px; line-height: 1.1; } .markdown-body h1 { font-size: 30px; } .markdown-body h2 { font-size: 21px; } .markdown-body h3 { font-size: 16px; } .markdown-body h4 { font-size: 14px; } .markdown-body h5 { font-size: 12px; } .markdown-body h6 { font-size: 11px; } .markdown-body blockquote { margin: 0; } .markdown-body ul, .markdown-body ol { padding: 0; margin-top: 0; margin-bottom: 0; } .markdown-body ol ol, .markdown-body ul ol { list-style-type: lower-roman; } .markdown-body ul ul ol, .markdown-body ul ol ol, .markdown-body ol ul ol, .markdown-body ol ol ol { list-style-type: lower-alpha; } .markdown-body dd { margin-left: 0; } .markdown-body code { font-family: Consolas, "Liberation Mono", Menlo, Courier, monospace; font-size: 12px; } .markdown-body pre { margin-top: 0; margin-bottom: 0; font: 12px Consolas, "Liberation Mono", Menlo, Courier, monospace; } .markdown-body .octicon { font: normal normal 16px octicons-anchor; line-height: 1; display: inline-block; text-decoration: none; -webkit-font-smoothing: antialiased; -moz-osx-font-smoothing: grayscale; -webkit-user-select: none; -moz-user-select: none; -ms-user-select: none; user-select: none; } .markdown-body .octicon-link:before { content: '\f05c'; } .markdown-body>*:first-child { margin-top: 0 !important; } .markdown-body>*:last-child { margin-bottom: 0 !important; } .markdown-body .anchor { position: absolute; top: 0; left: 0; display: block; padding-right: 6px; padding-left: 30px; margin-left: -30px; } .markdown-body .anchor:focus { outline: none; } .markdown-body h1, .markdown-body h2, .markdown-body h3, .markdown-body h4, .markdown-body h5, .markdown-body h6 { position: relative; margin-top: 1em; margin-bottom: 16px; font-weight: bold; line-height: 1.4; } .markdown-body h1 .octicon-link, .markdown-body h2 .octicon-link, .markdown-body h3 .octicon-link, .markdown-body h4 .octicon-link, .markdown-body h5 .octicon-link, .markdown-body h6 .octicon-link { display: none; color: #000; vertical-align: middle; } .markdown-body h1:hover .anchor, .markdown-body h2:hover .anchor, .markdown-body h3:hover .anchor, .markdown-body h4:hover .anchor, .markdown-body h5:hover .anchor, .markdown-body h6:hover .anchor { padding-left: 8px; margin-left: -30px; text-decoration: none; } .markdown-body h1:hover .anchor .octicon-link, .markdown-body h2:hover .anchor .octicon-link, .markdown-body h3:hover .anchor .octicon-link, .markdown-body h4:hover .anchor .octicon-link, .markdown-body h5:hover .anchor .octicon-link, .markdown-body h6:hover .anchor .octicon-link { display: inline-block; } .markdown-body h1 { padding-bottom: 0.3em; font-size: 2.25em; line-height: 1.2; border-bottom: 1px solid #eee; } .markdown-body h1 .anchor { line-height: 1; } .markdown-body h2 { padding-bottom: 0.3em; font-size: 1.75em; line-height: 1.225; border-bottom: 1px solid #eee; } .markdown-body h2 .anchor { line-height: 1; } .markdown-body h3 { font-size: 1.5em; line-height: 1.43; } .markdown-body h3 .anchor { line-height: 1.2; } .markdown-body h4 { font-size: 1.25em; } .markdown-body h4 .anchor { line-height: 1.2; } .markdown-body h5 { font-size: 1em; } .markdown-body h5 .anchor { line-height: 1.1; } .markdown-body h6 { font-size: 1em; color: #777; } .markdown-body h6 .anchor { line-height: 1.1; } .markdown-body p, .markdown-body blockquote, .markdown-body ul, .markdown-body ol, .markdown-body dl, .markdown-body table, .markdown-body pre { margin-top: 0; margin-bottom: 16px; } .markdown-body hr { height: 4px; padding: 0; margin: 16px 0; background-color: #e7e7e7; border: 0 none; } .markdown-body ul, .markdown-body ol { padding-left: 2em; } .markdown-body ul ul, .markdown-body ul ol, .markdown-body ol ol, .markdown-body ol ul { margin-top: 0; margin-bottom: 0; } .markdown-body li>p { margin-top: 16px; } .markdown-body dl { padding: 0; } .markdown-body dl dt { padding: 0; margin-top: 16px; font-size: 1em; font-style: italic; font-weight: bold; } .markdown-body dl dd { padding: 0 16px; margin-bottom: 16px; } .markdown-body blockquote { padding: 0 15px; color: #777; border-left: 4px solid #ddd; } .markdown-body blockquote>:first-child { margin-top: 0; } .markdown-body blockquote>:last-child { margin-bottom: 0; } .markdown-body table { display: block; width: 100%; overflow: auto; word-break: normal; word-break: keep-all; } .markdown-body table th { font-weight: bold; } .markdown-body table th, .markdown-body table td { padding: 6px 13px; border: 1px solid #ddd; } .markdown-body table tr { background-color: #fff; border-top: 1px solid #ccc; } .markdown-body table tr:nth-child(2n) { background-color: #f8f8f8; } .markdown-body img { max-width: 100%; -moz-box-sizing: border-box; box-sizing: border-box; } .markdown-body code { padding: 0; padding-top: 0.2em; padding-bottom: 0.2em; margin: 0; font-size: 85%; background-color: rgba(0,0,0,0.04); border-radius: 3px; } .markdown-body code:before, .markdown-body code:after { letter-spacing: -0.2em; content: "\00a0"; } .markdown-body pre>code { padding: 0; margin: 0; font-size: 100%; word-break: normal; white-space: pre; background: transparent; border: 0; } .markdown-body .highlight { margin-bottom: 16px; } .markdown-body .highlight pre, .markdown-body pre { padding: 16px; overflow: auto; font-size: 85%; line-height: 1.45; background-color: #f7f7f7; border-radius: 3px; } .markdown-body .highlight pre { margin-bottom: 0; word-break: normal; } .markdown-body pre { word-wrap: normal; } .markdown-body pre code { display: inline; max-width: initial; padding: 0; margin: 0; overflow: initial; line-height: inherit; word-wrap: normal; background-color: transparent; border: 0; } .markdown-body pre code:before, .markdown-body pre code:after { content: normal; } .markdown-body kbd { display: inline-block; padding: 3px 5px; font-size: 11px; line-height: 10px; color: #555; vertical-align: middle; background-color: #fcfcfc; border: solid 1px #ccc; border-bottom-color: #bbb; border-radius: 3px; box-shadow: inset 0 -1px 0 #bbb; } .markdown-body .pl-c { color: #969896; } .markdown-body .pl-c1, .markdown-body .pl-mdh, .markdown-body .pl-mm, .markdown-body .pl-mp, .markdown-body .pl-mr, .markdown-body .pl-s1 .pl-v, .markdown-body .pl-s3, .markdown-body .pl-sc, .markdown-body .pl-sv { color: #0086b3; } .markdown-body .pl-e, .markdown-body .pl-en { color: #795da3; } .markdown-body .pl-s1 .pl-s2, .markdown-body .pl-smi, .markdown-body .pl-smp, .markdown-body .pl-stj, .markdown-body .pl-vo, .markdown-body .pl-vpf { color: #333; } .markdown-body .pl-ent { color: #63a35c; } .markdown-body .pl-k, .markdown-body .pl-s, .markdown-body .pl-st { color: #a71d5d; } .markdown-body .pl-pds, .markdown-body .pl-s1, .markdown-body .pl-s1 .pl-pse .pl-s2, .markdown-body .pl-sr, .markdown-body .pl-sr .pl-cce, .markdown-body .pl-sr .pl-sra, .markdown-body .pl-sr .pl-sre, .markdown-body .pl-src { color: #df5000; } .markdown-body .pl-mo, .markdown-body .pl-v { color: #1d3e81; } .markdown-body .pl-id { color: #b52a1d; } .markdown-body .pl-ii { background-color: #b52a1d; color: #f8f8f8; } .markdown-body .pl-sr .pl-cce { color: #63a35c; font-weight: bold; } .markdown-body .pl-ml { color: #693a17; } .markdown-body .pl-mh, .markdown-body .pl-mh .pl-en, .markdown-body .pl-ms { color: #1d3e81; font-weight: bold; } .markdown-body .pl-mq { color: #008080; } .markdown-body .pl-mi { color: #333; font-style: italic; } .markdown-body .pl-mb { color: #333; font-weight: bold; } .markdown-body .pl-md, .markdown-body .pl-mdhf { background-color: #ffecec; color: #bd2c00; } .markdown-body .pl-mdht, .markdown-body .pl-mi1 { background-color: #eaffea; color: #55a532; } .markdown-body .pl-mdr { color: #795da3; font-weight: bold; } .markdown-body kbd { display: inline-block; padding: 3px 5px; font: 11px Consolas, "Liberation Mono", Menlo, Courier, monospace; line-height: 10px; color: #555; vertical-align: middle; background-color: #fcfcfc; border: solid 1px #ccc; border-bottom-color: #bbb; border-radius: 3px; box-shadow: inset 0 -1px 0 #bbb; } .markdown-body .task-list-item { list-style-type: none; } .markdown-body .task-list-item+.task-list-item { margin-top: 3px; } .markdown-body .task-list-item input { float: left; margin: 0.3em 0 0.25em -1.6em; vertical-align: middle; } .markdown-body :checked+.radio-label { z-index: 1; position: relative; border-color: #4183c4; } .footnotes { font-size: 12px; } .nobreak { page-break-inside: avoid; } ================================================ FILE: Converters/markdown2text.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 19 November 2023 # https://github.com/trizen # Convert Markdown to text (UTF-8). # # Using the following tool: # md2html -- for converting Markdown to HTML (provided by md4c) use 5.020; use strict; use warnings; use experimental qw(signatures); use HTML::TreeBuilder 5 qw(-weak); use HTML::FormatText qw(); use Getopt::Long qw(GetOptions); use File::Temp qw(tempfile); use Encode qw(encode_utf8 decode_utf8); binmode(STDIN, ':utf8'); binmode(STDOUT, ':utf8'); my $md2html = "md2html"; # path to the `md2html` tool sub read_input ($source) { if (ref($source) eq 'GLOB') { my $content = do { local $/; <$source>; }; return $content; } my $content = do { open my $fh, '<:utf8', $source or die "Can't open file <<$source>> for reading: $!"; local $/; <$fh>; }; return $content; } sub html2text ($html, $formatter) { my $tree = HTML::TreeBuilder->new(); $tree->parse($html); $tree->eof(); $tree->elementify(); # just for safety my $text = $formatter->format($tree); return $text; } my $left_margin = 0; my $right_margin = 80; sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.md] -lm --left=i : the column of the left margin. (default: $left_margin) -rm --right=i : the column of the right margin. (default: $right_margin) EOT exit($exit_code); } GetOptions( "lm|left=i" => \$left_margin, "rm|right=i" => \$right_margin, "h|help" => sub { usage(0) }, ) or do { warn("Error in command line arguments\n"); usage(1); }; my $stdin_on_tty = -t STDIN; if (not $stdin_on_tty) { # assume input provided via STDIN ## ok } else { @ARGV || do { warn "\nerror: no input file provided!\n\n"; usage(2); }; } my $formatter = HTML::FormatText->new(leftmargin => $left_margin, rightmargin => $right_margin,); my $markdown = read_input($stdin_on_tty ? $ARGV[0] : \*STDIN); $markdown // die "error: unable to read Markdown content"; my ($md_fh, $md_file) = tempfile(); print $md_fh encode_utf8($markdown); close $md_fh; my $html = decode_utf8(scalar `\Q$md2html\E --github \Q$md_file\E`); unlink($md_file); my $text = html2text($html, $formatter); $text // die "error: unable to extract text"; print $text; ================================================ FILE: Converters/notepadfree_to_txt.pl ================================================ #!/usr/bin/perl # Convert Android Notepad Free backup notes to text files. use utf8; use 5.014; use autodie; use warnings; use JSON qw(from_json); use File::Slurper qw(read_text write_text); use File::Spec::Functions qw(catfile updir); use File::Compare qw(); my $output_dir = 'Text files'; my $meta_json = from_json(read_text('notes_meta_data.json')); if (not -d $output_dir) { mkdir($output_dir); } OUTER: foreach my $note (@{$meta_json->{notes}}) { my $title = $note->{title}; my $file = $note->{file}; my $lastEditDate = $note->{lastEditDate}; $title =~ s{/}{÷}g; # replace '/' with '÷' my $input_file = catfile(updir, $file); my $content = read_text($input_file); my $output_file = catfile($output_dir, $title . '.txt'); for (my $k = 1 ; (-f $output_file) ; ++$k) { if (File::Compare::compare($input_file, $output_file) == 0) { say "File `$output_file` already exists... Skipping..."; next OUTER; # files are equal } else { $output_file = catfile($output_dir, $title . '_' . $k . '.txt'); } } say "Creating: `$output_file`..."; write_text($output_file, $content); utime($lastEditDate, $lastEditDate, $output_file); } ================================================ FILE: Converters/pod2pdf.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 16 April 2023 # https://github.com/trizen # POD to PDF converter, with syntax highlighting. # Using the following tools: # pod2markdown -- for converting POD to Markdown (part of Pod::Markdown) # markdown2pdf.pl -- for converting Markdown to PDF use 5.010; use strict; use warnings; use Getopt::Long qw(GetOptions); use File::Temp qw(tempfile); my $markdown2pdf = "markdown2pdf.pl"; # path to the `markdown2pdf.pl` script my $pod2markdown = "pod2markdown"; # path to the `pod2markdown` script my $lang = 'perl'; my $style = 'github'; my $title = 'Document'; my $page_size = 'A3'; my $mathjax = 0; # true to use MathJax sub usage { my ($exit_code) = @_; $exit_code //= 0; print <<"EOT"; usage: $0 [options] [input.pod] [output.pdf] options: --lang=s : default syntax highlighting language (default: $lang) --style=s : style theme for `highlight` (default: $style) --title=s : title of the PDF file (default: $title) --size=s : set paper size to: A4, Letter, etc. (default: $page_size) --mathjax! : enable support for Tex expressions (default: $mathjax) EOT exit($exit_code); } GetOptions( "lang=s" => \$lang, "title=s" => \$title, "size=s" => \$page_size, "mathjax!" => \$mathjax, "h|help" => sub { usage(0) }, ) or die("Error in command line arguments\n"); my $input_pod_file = $ARGV[0] // usage(2); my $output_pdf_file = $ARGV[1] // "output.pdf"; say ":: Converting POD to Markdown..."; my $md = `\Q$pod2markdown\E \Q$input_pod_file\E`; if (!defined($md)) { die "Failed to convert POD to Markdown...\n"; } my ($md_fh, $md_file) = tempfile(); print $md_fh $md; close $md_fh; say ":: Converting Markdown to PDF..."; system($markdown2pdf, ($mathjax ? "--mathjax" : ()), "--lang", $lang, "--style", $style, "--title", $title, "--size", $page_size, $md_file, $output_pdf_file); if ($? != 0) { die "Failed to convert Markdown to PDF...\n"; } unlink($md_file); ================================================ FILE: Converters/pod2text.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 19 November 2023 # https://github.com/trizen # Convert POD to text (UTF-8). # Using the following tools: # pod2markdown -- for converting POD to Markdown (part of Pod::Markdown) # md2hml -- for converting Markdown to HTML (provided by md4c) use 5.020; use strict; use warnings; use experimental qw(signatures); use HTML::TreeBuilder 5 qw(-weak); use HTML::FormatText qw(); use Getopt::Long qw(GetOptions); use File::Temp qw(tempfile); use Encode qw(encode_utf8 decode_utf8); binmode(STDIN, ':utf8'); binmode(STDOUT, ':utf8'); my $pod2markdown = "pod2markdown"; # path to the `pod2markdown` script my $md2html = "md2html"; # path to the `md2html` tool sub read_input ($source) { if (ref($source) eq 'GLOB') { my $content = do { local $/; <$source>; }; return $content; } my $content = do { open my $fh, '<:utf8', $source or die "Can't open file <<$source>> for reading: $!"; local $/; <$fh>; }; return $content; } sub html2text ($html, $formatter) { my $tree = HTML::TreeBuilder->new(); $tree->parse($html); $tree->eof(); $tree->elementify(); # just for safety my $text = $formatter->format($tree); return $text; } my $left_margin = 0; my $right_margin = 80; sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.pod] -lm --left=i : the column of the left margin. (default: $left_margin) -rm --right=i : the column of the right margin. (default: $right_margin) EOT exit($exit_code); } GetOptions( "lm|left=i" => \$left_margin, "rm|right=i" => \$right_margin, "h|help" => sub { usage(0) }, ) or do { warn("Error in command line arguments\n"); usage(1); }; my $stdin_on_tty = -t STDIN; if (not $stdin_on_tty) { # assume input provided via STDIN ## ok } else { @ARGV || do { warn "\nerror: no input file provided!\n\n"; usage(2); }; } my $formatter = HTML::FormatText->new(leftmargin => $left_margin, rightmargin => $right_margin,); my $pod = read_input($stdin_on_tty ? $ARGV[0] : \*STDIN); my ($pod_fh, $pod_file) = tempfile(); print $pod_fh encode_utf8($pod); close $pod_fh; my $md = `\Q$pod2markdown\E \Q$pod_file\E`; unlink($pod_file); if (!defined($md)) { die "Failed to convert POD to Markdown...\n"; } my ($md_fh, $md_file) = tempfile(); print $md_fh $md; close $md_fh; my $html = decode_utf8(scalar `\Q$md2html\E --github \Q$md_file\E`); unlink($md_file); my $text = html2text($html, $formatter); $text // die "error: unable to extract text"; print $text; ================================================ FILE: Converters/recompress.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 04 June 2024 # https://github.com/trizen # Recompress gzip, zip, bzip2, zstd, xz, lzma, lzip, lzf or lzop to another format. use 5.036; use Getopt::Long qw(GetOptions); use IO::Uncompress::AnyUncompress qw(); use constant { CHUNK_SIZE => 1 << 16, # how many bytes to read per chunk }; my %compressors = ( 'gzip' => { class => 'IO::Compress::Gzip', format => 'gz', }, 'bzip2' => { class => 'IO::Compress::Bzip2', format => 'bz2', }, 'lzf' => { class => 'IO::Compress::Lzf', format => 'lzf', }, #~ 'lzip' => { # buggy #~ class => 'IO::Compress::Lzip', #~ format => 'lz', #~ }, #~ 'lzma' => { # buggy #~ class => 'IO::Compress::Lzma', #~ format => 'lzma', #~ }, 'lzop' => { class => 'IO::Compress::Lzop', format => 'lzop', }, 'xz' => { class => 'IO::Compress::Xz', format => 'xz', }, 'zstd' => { class => 'IO::Compress::Zstd', format => 'zst', }, 'zip' => { class => 'IO::Compress::Zip', format => 'zip', }, ); my $compression_method = 'none'; my $keep_original = 0; my $overwrite = 0; sub usage ($exit_code) { local $" = ", "; print <<"EOT"; usage: $0 [options] [.gz files] options: -c --compress=s : select compression method valid: @{[sort keys %compressors]} -k --keep! : keep the original files (default: $keep_original) -f --force! : overwrite existing files (default: $overwrite) -h --help : print this message and exit example: # Convert a bunch of Gzip files to XZ format $0 -c=xz *.gz EOT exit($exit_code); } GetOptions( 'c|compress=s' => \$compression_method, 'k|keep!' => \$keep_original, 'f|force!' => \$overwrite, 'h|help' => sub { usage(0) }, ) or usage(1); @ARGV || usage(2); my $compression = $compressors{$compression_method} // do { warn "[!] Please select a valid compression method with `-c` option!\n"; warn "[!] Valid values: ", join(', ', sort keys(%compressors)), "\n"; exit(1); }; foreach my $file (@ARGV) { if (not -f $file) { warn ":: Not a file: <<$file>>. Skipping...\n"; next; } say "\n:: Processing: $file"; my $new_file = $file; my $new_format = $compression->{format}; if ( $new_file =~ s{\.t\w+\z}{.t$new_format}i or $new_file =~ s{\.\w+\z}{.$new_format}i) { ## ok } else { $new_file .= ".$new_format"; } if (-e $new_file) { if (not $overwrite) { say "-> File <<$new_file>> already exists. Skipping..."; next; } } my $in_fh = IO::Uncompress::AnyUncompress->new($file) or do { warn "[!] Probably not a valid compressed file ($IO::Uncompress::AnyUncompress::AnyUncompressError). Skipping...\n"; next; }; require(($compression->{class} =~ s{::}{/}rg) . '.pm'); my $out_fh = $compression->{class}->new($new_file) or die "[!] Failed to initialize the compressor class: $compression->{class}: $!\n"; while (read($in_fh, (my $chunk), CHUNK_SIZE)) { $out_fh->write($chunk); } ($in_fh->eof and $in_fh->close and $out_fh->close) || do { warn "[!] Something went wrong! Skipping...\n"; unlink($new_file); next; }; my $old_size = -s $file; my $new_size = -s $new_file; say "-> $old_size vs. $new_size"; if (not $keep_original) { say "-> Removing the original file: $file"; unlink($file) or warn "[!] Can't remove file <<$file>>: $!\n"; } } ================================================ FILE: Converters/unicode2ascii.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 29 April 2012 # Edit: 12 March 2023 # https://github.com/trizen # Substitute Unicode characters with ASCII characters in a stream input. use 5.010; use strict; use warnings; use Encode qw(decode_utf8); use Text::Unidecode qw(unidecode); while (defined(my $line = <>)) { print unidecode(decode_utf8($line)); } ================================================ FILE: Converters/vnt2txt_simple.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 08 May 2013 # https://github.com/trizen # Convert a .vnt file to a plain text file and set the right modification time. use strict; use warnings; use Date::Parse; use File::Slurper qw(read_text write_text); my $source = shift() // die "usage: $0 [vnt file]\n"; read_text($source) =~ /^BODY.*?:(.*?)\R^DCREATED:(\S+)\R^LAST-MODIFIED:(\S+)/ms; write_text((my $tfile = join('-', unpack("A4A2A2", $2)) . '.' . join(".", unpack("x9A2A2A2", $2)) . '.txt'), $1); utime time(), str2time($3), $tfile, $source; ================================================ FILE: Converters/xml2hash.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 27 December 2013 # Edit: 01 January 2018 # License: GPLv3 # https://github.com/trizen # A tiny pure-Perl XML parser. use utf8; use 5.010; use strict; use warnings; { my %entities = ( 'amp' => '&', 'quot' => '"', 'apos' => "'", 'gt' => '>', 'lt' => '<', ); state $ent_re = do { local $" = '|'; qr/&(@{[keys %entities]});/; }; sub _decode_entities { $_[0] =~ s/$ent_re/$entities{$1}/gor; } } sub xml2hash { my $xml = shift(@_) // ''; my $xml_ref = {}; $xml = "$xml"; my %args = ( attr => '-', text => '#text', empty => q{}, @_ ); my %ctags; my $ref = $xml_ref; state $inv_chars = q{!"#$@%&'()*+,/;\\<=>?\]\[^`{|}~}; state $valid_tag = qr{[^\-.\s0-9$inv_chars][^$inv_chars\s]*}; { if ( $xml =~ m{\G< \s* ($valid_tag) \s* ((?>$valid_tag\s*=\s*(?>".*?"|'.*?')|\s+)+)? \s* (/)?\s*> \s* }gcsxo ) { my ($tag, $attrs, $closed) = ($1, $2, $3); if (defined $attrs) { push @{$ctags{$tag}}, $ref; $ref = ref $ref eq 'HASH' ? ref $ref->{$tag} ? $ref->{$tag} : ( defined $ref->{$tag} ? ($ref->{$tag} = [$ref->{$tag}]) : ($ref->{$tag} //= []) ) : ref $ref eq 'ARRAY' ? ref $ref->[-1]{$tag} ? $ref->[-1]{$tag} : ( defined $ref->[-1]{$tag} ? ($ref->[-1]{$tag} = [$ref->[-1]{$tag}]) : ($ref->[-1]{$tag} //= []) ) : []; ++$#{$ref} if ref $ref eq 'ARRAY'; while ( $attrs =~ m{\G ($valid_tag) \s*=\s* (?> "(.*?)" | '(.*?)' ) \s* }gsxo ) { my ($key, $value) = ($1, $+); $key = join(q{}, $args{attr}, $key); if (ref $ref eq 'ARRAY') { $ref->[-1]{$key} = _decode_entities($value); } elsif (ref $ref eq 'HASH') { $ref->{$key} = $value; } } if (defined $closed) { $ref = pop @{$ctags{$tag}}; } if ($xml =~ m{\G<\s*/\s*\Q$tag\E\s*>\s*}gc) { $ref = pop @{$ctags{$tag}}; } elsif ($xml =~ m{\G([^<]+)(?=<)}gsc) { if (ref $ref eq 'ARRAY') { $ref->[-1]{$args{text}} .= _decode_entities($1); $ref = pop @{$ctags{$tag}}; } elsif (ref $ref eq 'HASH') { $ref->{$args{text}} .= $1; $ref = pop @{$ctags{$tag}}; } } } elsif (defined $closed) { if (ref $ref eq 'ARRAY') { if (exists $ref->[-1]{$tag}) { if (ref $ref->[-1]{$tag} ne 'ARRAY') { $ref->[-1]{$tag} = [$ref->[-1]{$tag}]; } push @{$ref->[-1]{$tag}}, $args{empty}; } else { $ref->[-1]{$tag} = $args{empty}; } } } else { if ($xml =~ /\G(?=<(?!!))/) { push @{$ctags{$tag}}, $ref; $ref = ref $ref eq 'HASH' ? ref $ref->{$tag} ? $ref->{$tag} : ( defined $ref->{$tag} ? ($ref->{$tag} = [$ref->{$tag}]) : ($ref->{$tag} //= []) ) : ref $ref eq 'ARRAY' ? ref $ref->[-1]{$tag} ? $ref->[-1]{$tag} : ( defined $ref->[-1]{$tag} ? ($ref->[-1]{$tag} = [$ref->[-1]{$tag}]) : ($ref->[-1]{$tag} //= []) ) : []; ++$#{$ref} if ref $ref eq 'ARRAY'; redo; } elsif ($xml =~ /\G\s*/gcs or $xml =~ /\G([^<]+)(?=<)/gsc) { my ($text) = $1; if ($xml =~ m{\G<\s*/\s*\Q$tag\E\s*>\s*}gc) { if (ref $ref eq 'ARRAY') { if (exists $ref->[-1]{$tag}) { if (ref $ref->[-1]{$tag} ne 'ARRAY') { $ref->[-1]{$tag} = [$ref->[-1]{$tag}]; } push @{$ref->[-1]{$tag}}, $text; } else { $ref->[-1]{$tag} .= _decode_entities($text); } } elsif (ref $ref eq 'HASH') { $ref->{$tag} .= $text; } } else { push @{$ctags{$tag}}, $ref; $ref = ref $ref eq 'HASH' ? ref $ref->{$tag} ? $ref->{$tag} : ( defined $ref->{$tag} ? ($ref->{$tag} = [$ref->{$tag}]) : ($ref->{$tag} //= []) ) : ref $ref eq 'ARRAY' ? ref $ref->[-1]{$tag} ? $ref->[-1]{$tag} : ( defined $ref->[-1]{$tag} ? ($ref->[-1]{$tag} = [$ref->[-1]{$tag}]) : ($ref->[-1]{$tag} //= []) ) : []; ++$#{$ref} if ref $ref eq 'ARRAY'; if (ref $ref eq 'ARRAY') { if (exists $ref->[-1]{$tag}) { if (ref $ref->[-1]{$tag} ne 'ARRAY') { $ref->[-1] = [$ref->[-1]{$tag}]; } push @{$ref->[-1]}, {$args{text} => $text}; } else { $ref->[-1]{$args{text}} .= $text; } } elsif (ref $ref eq 'HASH') { $ref->{$tag} .= $text; } } } } if ($xml =~ m{\G<\s*/\s*\Q$tag\E\s*>\s*}gc) { ## tag closed - ok } redo; } elsif ($xml =~ m{\G<\s*/\s*($valid_tag)\s*>\s*}gco) { if (exists $ctags{$1} and @{$ctags{$1}}) { $ref = pop @{$ctags{$1}}; } redo; } elsif ($xml =~ /\G\s*/gcs or $xml =~ m{\G([^<]+)(?=<)}gsc) { if (ref $ref eq 'ARRAY') { $ref->[-1]{$args{text}} .= $1; } elsif (ref $ref eq 'HASH') { $ref->{$args{text}} .= $1; } redo; } elsif ($xml =~ /\G<\?/gc) { $xml =~ /\G.*?\?>\s*/gcs or die "Invalid XML!"; redo; } elsif ($xml =~ /\G\s*/gcs or die "Comment not closed!"; redo; } elsif ($xml =~ /\G$valid_tag|\s+|".*?"|'.*?')*\[.*?\]>\s*/sgco or $xml =~ /\G.*?>\s*/sgc or die "DOCTYPE not closed!"; redo; } elsif ($xml =~ /\G\z/gc) { ## ok } elsif ($xml =~ /\G\s+/gc) { redo; } else { die "Syntax error near: --> ", [split(/\n/, substr($xml, pos($xml), 2**6))]->[0], " <--\n"; } } return $xml_ref; } # ## Usage: $hash = xml2hash($xml) # use Data::Dump qw(pp); pp xml2hash( do { local $/; } ); __DATA__ QWZ5671 39.95 Red Burgundy Red Burgundy RRX9856 42.50 Red Navy Burgundy Red Navy Burgundy Black Navy Black Burgundy Black ================================================ FILE: Converters/xpm_c_to_perl.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date : 21 February 2013 # https://github.com/trizen # XPM to Perl data. # for file in `find /usr/share/pixmaps/ -maxdepth 1`; do perl -X xpm_c_to_perl.pl $file > $(basename $file); done use strict; use Data::Dump qw(dump); $Data::Dump::INDENT = ''; sub parse_xpm_file { my ($file) = @_; open my $fh, '<', $file or die "Can't open file '$file': $!"; my @data; while (<$fh>) { if (/^"(.*?)",?\s*(\};\s*)?$/s) { push @data, $1; } else { #print STDERR $_; } } close $fh; my $dumped = dump \@data; # In list context returns the dumped data and the array itself. # In scalar context returns only the dumped data return wantarray ? ($dumped, \@data) : $dumped; } my $xpm_file = shift // die "usage: $0 [xpm_file]\n"; $xpm_file =~ /\.xpm\z/i or die "Not a XPM file: $xpm_file\n"; my $data = parse_xpm_file($xpm_file); print $data; ================================================ FILE: Converters/xz2gz.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 04 June 2024 # https://github.com/trizen # Convert XZ files to Gzip format. use 5.036; use IO::Compress::Gzip qw(); use IO::Uncompress::UnXz qw(); use Getopt::Long qw(GetOptions); use constant { CHUNK_SIZE => 1 << 16, # how many bytes to read per chunk }; sub xz2gz ($in_fh, $out_fh) { while ($in_fh->read(my $chunk, CHUNK_SIZE)) { $out_fh->print($chunk); } $in_fh->eof or return; $in_fh->close or return; $out_fh->close; } my $keep_original = 0; my $overwrite = 0; sub usage ($exit_code) { print <<"EOT"; usage: $0 [options] [.gz files] options: -k --keep! : keep the original XZ files (default: $keep_original) -f --force! : overwrite existing files (default: $overwrite) -h --help : print this message and exit example: # Convert a bunch of XZ files to Gzip format $0 *.xz EOT exit($exit_code); } GetOptions( 'k|keep!' => \$keep_original, 'f|force!' => \$overwrite, 'h|help' => sub { usage(0) }, ) or usage(1); @ARGV || usage(2); foreach my $xz_file (@ARGV) { if (not -f $xz_file) { warn ":: Not a file: <<$xz_file>>. Skipping...\n"; next; } say "\n:: Processing: $xz_file"; my $gz_file = $xz_file; if ( $gz_file =~ s{\.txz\z}{.tgz}i or $gz_file =~ s{\.xz\z}{.gz}i) { ## ok } else { $gz_file .= '.gz'; } if (-e $gz_file) { if (not $overwrite) { say "-> File <<$gz_file>> already exists. Skipping..."; next; } } my $in_fh = IO::Uncompress::UnXz->new($xz_file) or do { warn "[!] Probably not an XZ file ($IO::Uncompress::UnXz::UnXzError). Skipping...\n"; next; }; my $out_fh = IO::Compress::Gzip->new($gz_file) or die "[!] Failed to initialize the compressor: $IO::Compress::Gzip::GzipError\n"; xz2gz($in_fh, $out_fh) || do { warn "[!] Something went wrong! Skipping...\n"; unlink($gz_file); next; }; my $old_size = -s $xz_file; my $new_size = -s $gz_file; say "-> $old_size vs. $new_size"; if (not $keep_original) { say "-> Removing the original XZ file: $xz_file"; unlink($xz_file) or warn "[!] Can't remove file <<$xz_file>>: $!\n"; } } ================================================ FILE: Converters/zip2tar.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 April 2024 # https://github.com/trizen # Convert a ZIP archive to a TAR archive (with optional compression). # Limitation: the TAR file is created in-memory! use 5.036; use Archive::Tar; use Archive::Tar::Constant; use Archive::Zip qw(:ERROR_CODES :CONSTANTS); use Getopt::Long qw(GetOptions); use Encode qw(encode_utf8); sub zip2tar ($zip_file) { my $zip = Archive::Zip->new(); unless ($zip->read($zip_file) == AZ_OK) { warn "Probably not a ZIP file: <<$zip_file>>. Skipping...\n"; return undef; } my $tar = Archive::Tar->new; foreach my $member ($zip->members) { if (ref($member) eq 'Archive::Zip::DirectoryMember') { my $dirName = encode_utf8($member->fileName); $tar->add_data( $dirName, '', { name => $dirName, size => 0, mode => 0755, mtime => $member->lastModTime, type => Archive::Tar::Constant::DIR, } ); } elsif (ref($member) eq 'Archive::Zip::ZipFileMember') { if ($member->isEncrypted) { warn "[!] This archive is encrypted! Skipping...\n"; return undef; } my $fileName = encode_utf8($member->fileName); my $size = $member->uncompressedSize; $member->desiredCompressionMethod(COMPRESSION_STORED); $member->rewindData() == AZ_OK or die "error in rewindData()"; my ($bufferRef, $status) = $member->readChunk($size); die "error $status" if ($status != AZ_OK and $status != AZ_STREAM_END); $member->endRead(); my $read_size = length($$bufferRef); if ($size != $read_size) { die "Error reading member <<$fileName>>: ($size (expected) != $read_size (actual value))"; } $tar->add_data( $fileName, $$bufferRef, { name => $fileName, size => $size, mode => 0644, mtime => $member->lastModTime, type => Archive::Tar::Constant::FILE, } ); } else { die "Unknown member of type: ", ref($member); } } return $tar; } my $compression_method = 'none'; my $keep_original = 0; my $overwrite = 0; sub usage ($exit_code) { print <<"EOT"; usage: $0 [options] [zip files] options: -c --compress=s : compression method (default: $compression_method) valid: none, gz, bz2, xz -k --keep! : keep the original ZIP files (default: $keep_original) -f --force! : overwrite existing files (default: $overwrite) -h --help : print this message and exit example: # Convert a bunch of zip files to tar.gz $0 -c=gz *.zip EOT exit($exit_code); } GetOptions( 'c|compress=s' => \$compression_method, 'k|keep!' => \$keep_original, 'f|force!' => \$overwrite, 'h|help' => sub { usage(0) }, ) or usage(1); @ARGV || usage(2); my $tar_suffix = ''; my $compression_flag = undef; if ($compression_method eq 'none') { ## ok } elsif ($compression_method eq 'gz') { $tar_suffix .= '.gz'; $compression_flag = Archive::Tar::Constant::COMPRESS_GZIP; } elsif ($compression_method eq 'bz2') { $tar_suffix .= '.bz2'; $compression_flag = Archive::Tar::Constant::COMPRESS_BZIP; Archive::Tar->has_bzip2_support or die "Please install: IO::Compress::Bzip2\n"; } elsif ($compression_method eq 'xz') { $tar_suffix = '.xz'; $compression_flag = Archive::Tar::Constant::COMPRESS_XZ; Archive::Tar->has_xz_support or die "Please install: IO::Compress::Xz\n"; } else { die "Unknown compression method: <<$compression_method>>\n"; } foreach my $zip_file (@ARGV) { if (-f $zip_file) { say "\n:: Processing: $zip_file"; my $tar_file = ($zip_file =~ s{\.zip\z}{}ri) . '.tar' . $tar_suffix; if (-e $tar_file) { if (not $overwrite) { say "-> Tar file <<$tar_file>> already exists. Skipping..."; next; } } my $tar = zip2tar($zip_file) // next; say "-> Creating TAR file: $tar_file"; $tar->write($tar_file, (defined($compression_flag) ? $compression_flag : ())); my $old_size = -s $zip_file; my $new_size = -s $tar_file; say "-> $old_size vs. $new_size"; if (not $keep_original) { say "-> Removing the original ZIP file: $zip_file"; unlink($zip_file) or warn "[!] Can't remove file <<$zip_file>>: $!\n"; } } else { warn ":: Not a file: <<$zip_file>>. Skipping...\n"; } } ================================================ FILE: Converters/zip2tar_fast.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 April 2024 # https://github.com/trizen # Convert a ZIP archive to a TAR archive (with optional compression). # Using `zip2tarcat` from LittleUtils: # https://sourceforge.net/projects/littleutils/ # Converts and recompresses a ZIP file, without storing the entire archive in memory. use 5.036; use Getopt::Long qw(GetOptions); use constant { CHUNK_SIZE => 1 << 16, # how many bytes to read per chunk }; my $zip2tarcat_cmd = 'zip2tarcat'; # command to zip2tarcat sub zip2tar ($zip_file, $out_fh) { open(my $fh, '-|:raw', $zip2tarcat_cmd, $zip_file) or die "Cannot pipe into <<$zip2tarcat_cmd>>: $!"; while (read($fh, (my $chunk), CHUNK_SIZE)) { $out_fh->print($chunk); } $out_fh->close; close $fh; } my $compression_method = 'none'; my $keep_original = 0; my $overwrite = 0; sub usage ($exit_code) { print <<"EOT"; usage: $0 [options] [zip files] options: -c --compress=s : compression method (default: $compression_method) valid: none, xz, gz, bz2, lzo, lzip, zstd -k --keep! : keep the original ZIP files (default: $keep_original) -f --force! : overwrite existing files (default: $overwrite) -h --help : print this message and exit example: # Convert a bunch of zip files to tar.xz $0 -c=xz *.zip EOT exit($exit_code); } GetOptions( 'c|compress=s' => \$compression_method, 'k|keep!' => \$keep_original, 'f|force!' => \$overwrite, 'h|help' => sub { usage(0) }, ) or usage(1); @ARGV || usage(2); my $tar_suffix = ''; my $compression_class = undef; if ($compression_method eq 'none') { require IO::Handle; } elsif ($compression_method =~ /^(?:gz|gzip)\z/) { require IO::Compress::Gzip; $tar_suffix .= '.gz'; $compression_class = 'IO::Compress::Gzip'; } elsif ($compression_method =~ /^(?:bz2|bzip2)\z/) { require IO::Compress::Bzip2; $tar_suffix .= '.bz2'; $compression_class = 'IO::Compress::Bzip2'; } elsif ($compression_method =~ /^(?:xz)\z/) { require IO::Compress::Xz; $tar_suffix = '.xz'; $compression_class = 'IO::Compress::Xz'; } elsif ($compression_method =~ /^(?:lzo|lzop)\z/) { require IO::Compress::Lzop; $tar_suffix = '.lzo'; $compression_class = 'IO::Compress::Lzop'; } elsif ($compression_method =~ /^(?:lz|lzip)\z/) { require IO::Compress::Lzip; $tar_suffix = '.lz'; $compression_class = 'IO::Compress::Lzip'; } elsif ($compression_method =~ /^(?:zstandard|zstd?)\z/) { require IO::Compress::Zstd; $tar_suffix = '.zst'; $compression_class = 'IO::Compress::Zstd'; } else { die "Unknown compression method: <<$compression_method>>\n"; } foreach my $zip_file (@ARGV) { if (-f $zip_file) { say "\n:: Processing: $zip_file"; my $tar_file = ($zip_file =~ s{\.zip\z}{}ri) . '.tar' . $tar_suffix; if (-e $tar_file) { if (not $overwrite) { say "-> Tar file <<$tar_file>> already exists. Skipping..."; next; } } my $out_fh; if (defined($compression_class)) { $out_fh = $compression_class->new($tar_file) or do { warn "[!] Failed to initialize the compressor: $!. Skipping...\n"; next; }; } else { open $out_fh, '>:raw', $tar_file or do { warn "[!] Can't create tar file <<$tar_file>>: $!\n"; next; }; } zip2tar($zip_file, $out_fh) || do { warn "[!] Something went wrong! Skipping...\n"; unlink($tar_file); next; }; my $old_size = -s $zip_file; my $new_size = -s $tar_file; say "-> $old_size vs. $new_size"; if (not $keep_original) { say "-> Removing the original ZIP file: $zip_file"; unlink($zip_file) or warn "[!] Can't remove file <<$zip_file>>: $!\n"; } } else { warn ":: Not a file: <<$zip_file>>. Skipping...\n"; } } ================================================ FILE: Decoders/base64_decoding-tutorial.pl ================================================ #!/usr/bin/perl # How does base64 works? # This short tutorial explains the basics behind the base64 decoding # Written by Trizen under the GPL. # # See also: https://en.wikipedia.org/wiki/Uuencoding # https://en.wikipedia.org/wiki/Base64 my $base64 = 'SnVzdCBhbm90aGVyIFBlcmwgaGFja2VyLAo='; # base64 #--------------Removing non-base64 chars--------------# # Anything that *ISN'T* A-Z, a-z, 0-9 or [+/._=] will be removed $base64 =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars $base64 =~ s/=+$//; # remove padding (if any) #--------------Transliteration--------------# $base64 =~ tr{A-Za-z0-9+/}{ -_}; # convert to uuencoded format # same thing as: # $base64 =~ tr{ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/} # { !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_}; # so: A => ' ' # B => '!' # C => '"' # and so on... #--------------Decoding--------------# print unpack 'u', pack('C', 32 + int(length($1) * 3 / 4)) . $1 while $base64 =~ s/(.{60}|.+)//; # For short strings, this works just fine: # print unpack('u','M'. $base64); # unpack('u','...') unpacks this: # print unpack('u', ':2G5S="!A;F]T:&5R(%!E $offset ? $offset : $base64_length, $base64_length > $x ? $x : $base64_length, ''); $decoded .= chr(32 + int(length($block) * 3 / 4)) . $block; } return unpack('u', $decoded); } # May be memory expensive, but it's faster than base64_decode_2() # Coded by Trizen sub base64_decode_3 { my ($base64) = @_; $base64 =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars $base64 =~ s/=+$//; # remove padding $base64 =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format my $x = 84; # block size (default should be 60?) my $decoded; foreach my $block (unpack("(A$x)*", $base64)) { $decoded .= chr(32 + int(length($block) * 3 / 4)) . $block; } return unpack('u', $decoded); } # Faster still :) # Coded by Gisle Aas # https://metacpan.org/release/GAAS/MIME-Base64-Perl-1.00/source/lib/MIME/Base64/Perl.pm sub base64_decode_4 { my ($str) = @_; $str =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars $str =~ s/=+$//; # remove padding $str =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format my $uustr = ''; my ($i, $l); $l = length($str) - 60; for ($i = 0 ; $i <= $l ; $i += 60) { $uustr .= "M" . substr($str, $i, 60); } $str = substr($str, $i); # and any leftover chars if ($str ne "") { $uustr .= chr(32 + length($str) * 3 / 4) . $str; } return unpack("u", $uustr); } # FASTEST (written in C) sub base64_decode_5 { use MIME::Base64 qw(decode_base64); return decode_base64($_[0]); } __END__ # Some benchmarks my $base64_text = <<'BASE64'; QmFzZTY0IGVuY29kaW5nIGNhbiBiZSBoZWxwZnVsIHdoZW4gZmFpcmx5IGxlbmd0aHkgaWRlbnRp ZnlpbmcgaW5mb3JtYXRpb24gaXMgdXNlZCBpbiBhbiBIVFRQIGVudmlyb25tZW50LiBGb3IgZXhh bXBsZSwgYSBkYXRhYmFzZSBwZXJzaXN0ZW5jZSBmcmFtZXdvcmsgZm9yIEphdmEgb2JqZWN0cyBt aWdodCB1c2UgQmFzZTY0IGVuY29kaW5nIHRvIGVuY29kZSBhIHJlbGF0aXZlbHkgbGFyZ2UgdW5p cXVlIGlkIChnZW5lcmFsbHkgMTI4LWJpdCBVVUlEcykgaW50byBhIHN0cmluZyBmb3IgdXNlIGFz IGFuIEhUVFAgcGFyYW1ldGVyIGluIEhUVFAgZm9ybXMgb3IgSFRUUCBHRVQgVVJMcy4gQWxzbywg bWFueSBhcHBsaWNhdGlvbnMgbmVlZCB0byBlbmNvZGUgYmluYXJ5IGRhdGEgaW4gYSB3YXkgdGhh dCBpcyBjb252ZW5pZW50IGZvciBpbmNsdXNpb24gaW4gVVJMcywgaW5jbHVkaW5nIGluIGhpZGRl biB3ZWIgZm9ybSBmaWVsZHMsIGFuZCBCYXNlNjQgaXMgYSBjb252ZW5pZW50IGVuY29kaW5nIHRv IHJlbmRlciB0aGVtIGluIG5vdCBvbmx5IGEgY29tcGFjdCB3YXksIGJ1dCBpbiBhIHJlbGF0aXZl bHkgdW5yZWFkYWJsZSBvbmUgd2hlbiB0cnlpbmcgdG8gb2JzY3VyZSB0aGUgbmF0dXJlIG9mIGRh dGEgZnJvbSBhIGNhc3VhbCBodW1hbiBvYnNlcnZlci4K BASE64 use Benchmark qw(timethese cmpthese); my $results = timethese( 10000, { 'base64_decode_1' => sub { base64_decode_1($base64_text) }, 'base64_decode_2' => sub { base64_decode_2($base64_text) }, 'base64_decode_3' => sub { base64_decode_3($base64_text) }, 'base64_decode_4' => sub { base64_decode_4($base64_text) }, 'base64_decode_5' => sub { base64_decode_5($base64_text) }, } ); cmpthese($results); ================================================ FILE: Decoders/cnp_info.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 11 October 2012 # https://github.com/trizen # CNP info # See also: # https://ro.wikipedia.org/wiki/Cod_numeric_personal use 5.010; use strict; use warnings; sub usage { die "usage: $0 CNP\n"; } my @cnp = split //, shift // usage(); (@cnp != 13 || join(q{}, @cnp) =~ /[^0-9]/) && die "Invalid CNP!\n"; my @magic = qw(2 7 9 1 4 6 3 5 8 2 7 9); my %year_num = ( 1 => {era => 1900,}, 2 => {era => 1900,}, 3 => {era => 1800,}, 4 => {era => 1800,}, 5 => {era => 2000,}, 6 => {era => 2000,}, 7 => { era => 0, cet => "Străin rezident în România", }, 8 => { era => 0, cet => "Străin rezident în România", }, 9 => { era => 0, cet => "Persoană străină", } ); my %jud = ( '01' => 'Alba', '02' => 'Arad', '03' => 'Argeș', '04' => 'Bacău', '05' => 'Bihor', '06' => 'Bistrița-Năsăud', '07' => 'Botoșani', '08' => 'Brașov', '09' => 'Brăila', '10' => 'Buzău', '11' => 'Caraș-Severin', '12' => 'Cluj', '13' => 'Constanța', '14' => 'Covasna', '15' => 'Dâmbovița', '16' => 'Dolj', '17' => 'Galați', '18' => 'Gorj', '19' => 'Harghita', '20' => 'Hunedoara', '21' => 'Ialomița', '22' => 'Iași', '23' => 'Ilfov', '24' => 'Maramureș', '25' => 'Mehedinți', '26' => 'Mureș', '27' => 'Neamț', '28' => 'Olt', '29' => 'Prahova', '30' => 'Satu Mare', '31' => 'Sălaj', '32' => 'Sibiu', '33' => 'Suceava', '34' => 'Teleorman', '35' => 'Timiș', '36' => 'Tulcea', '37' => 'Vaslui', '38' => 'Vâlcea', '39' => 'Vrancea', '40' => 'București', '41' => 'București S.1', '42' => 'București S.2', '43' => 'București S.3', '44' => 'București S.4', '45' => 'București S.5', '46' => 'București S.6', '51' => 'Călărași', '52' => 'Giurgiu', ); my @months = qw( Ianuarie Februarie Martie Aprilie Mai Iunie Iulie August Septembrie Octombrie Noiembrie Decembrie ); my %days; @days{@months} = qw( 31 29 31 30 31 30 31 31 30 31 30 31 ); my $sum = 0; $sum += $magic[$_] * $cnp[$_] for 0 .. $#magic; my $cc = $sum % 11; $cc = 1 if $cc == 10; if ($cc != $cnp[-1]) { die "Cifra de control e incorectă!\n"; } my $hash_ref = $year_num{$cnp[0]}; my $year_num = "$cnp[1]$cnp[2]"; my $month_num = "$cnp[3]$cnp[4]"; my $day_num = "$cnp[5]$cnp[6]"; my $jud_num = "$cnp[7]$cnp[8]"; if ($month_num < 1 or $month_num > 12) { die "Luna de naștere e invalidă!\n"; } my $cur_day = [localtime]->[3]; my $cur_mon = [localtime]->[4] + 1; my $cur_year = [localtime]->[5]; my $nationality = "Română"; if ($hash_ref->{era} == 0) { $hash_ref->{era} = $year_num < $cur_year - 100 ? 2000 : 1900; $nationality = $hash_ref->{cet} // 'Necunoscută'; } my $birth_year = $hash_ref->{era} + $year_num; my $month_name = $months[$month_num - 1]; if ($day_num > $days{$month_name} or $day_num < 1) { die "Ziua de naștere e invalidă!\n"; } my $jud_name = $jud{$jud_num} // die "Codul județului e invalid!\n"; if ($month_num == 2 and $day_num == 29) { die "Anul $birth_year nu a fost un an bisect!\n" if not($birth_year % 400 == 0 or $birth_year % 4 == 0 and $birth_year % 100 != 0); } my $age = $cur_year + 1900 - $birth_year; if ($cur_mon < $month_num or ($month_num == $cur_mon and $day_num < $cur_day)) { --$age; } my $gender = $cnp[0] == 9 ? "Necunoscut" : ("Feminin", "Masculin")[$cnp[0] % 2]; printf <<"EOF", Data Nașterii: %s Cetațenie: %s Sexul: %s Vârsta: %s Județul: %s EOF "$day_num $month_name $birth_year", $nationality, $gender, $age, $jud_name; ================================================ FILE: Decoders/named_parameters.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 23 October 2015 # Website: https://github.com/trizen # Code-concept for implementing the "named-parameters" feature in programming languages. =for Sidef example: func test (x, y, z) { say (x, y, z); # prints: '123' } test(1,2,3); test(1, y: 2, z: 3); test(x: 1, y: 2, z: 3); test(y: 2, z: 3, x: 1); ... =cut use 5.010; use strict; use warnings; use List::Util qw(shuffle); sub test { my @args = @_; my @vars = (\my $x, \my $y, \my $z); my %table = ( x => 0, y => 1, z => 2, ); my @left; my %seen; foreach my $arg (@args) { if (ref($arg) eq 'ARRAY') { if (exists $table{$arg->[0]}) { ${$vars[$table{$arg->[0]}]} = $arg->[1]; undef $seen{$vars[$table{$arg->[0]}]}; } else { die "No such named argument: <<$arg->[0]>>"; } } else { push @left, $arg; } } foreach my $var (@vars) { next if exists $seen{$var}; if (@left) { ${$var} = shift @left; } } say "$x $y $z"; ($x == 1 and $y == 2 and $z == 3) or die "error!"; } test(1, ['y', 2], 3); test(1, 3, ['y', 2]); test(1, ['z', 3], 2); test(1, 2, ['z', 3]); test(1, 3, ['y', 2]); test(['y', 2], 1, 3); test(['x', 1], ['z', 3], ['y', 2]); test(shuffle(['x', 1], 3, ['y', 2])); test(shuffle(['x', 1], 2, ['z', 3])); test(shuffle(1, ['y', 2], ['z', 3])); test(shuffle(['z', 3], ['x', 1], ['y', 2])); test(shuffle(['z', 3], 1, ['y', 2])); ================================================ FILE: Digest/brute-force_resistant_hashing.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 21 December 2021 # https://github.com/trizen # A concept for a brute-force resistant hashing method. # It requires a deterministic hash function, which is used in computing a # non-deterministic brute-force resistant hash, based on the processor speed # of the computer, taking about 2 seconds to hash a password, and about 1.5 seconds # to verify if the hash of a password is correct, given the password and the hash. # The method can be made deterministic, by providing a fixed number of iterations. # Otherwise, the method automatically computes a safe number of iterations based on hardware speed. # See also: # https://en.wikipedia.org/wiki/Bcrypt # https://en.wikipedia.org/wiki/Argon2 use 5.020; use strict; use warnings; use Digest::SHA qw(sha512_hex); use experimental qw(signatures); sub bfr_hash ($password, $hash_function, $iterations = undef) { my $strength = 1; # delay time in seconds my $salt_hash = $hash_function->(''); my $pass_hash = $hash_function->($password); my $hash_password = sub { $salt_hash = $hash_function->($salt_hash); $pass_hash = $hash_function->($salt_hash . $pass_hash); #$pass_hash = $hash_function->($pass_hash . $salt_hash); }; if (defined $iterations) { for (1 .. $iterations) { $hash_password->(); } } else { $iterations = 0; eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm $strength; while (1) { $hash_password->(); ++$iterations; } alarm 0; }; say "[DEBUG] Iterations: $iterations"; return __SUB__->($password, $hash_function, $iterations); } my $check_hash = $hash_function->($pass_hash . $salt_hash); return join('$', $pass_hash, $salt_hash, $check_hash); } sub check_bfr_hash ($password, $bfr_hash, $hash_function) { my ($pass_hash, $salt_hash, $check_hash) = split(/\$/, $bfr_hash); $salt_hash // return 0; $pass_hash // return 0; $check_hash // return 0; if ($hash_function->($pass_hash . $salt_hash) ne $check_hash) { return 0; } my $iterations = 0; my $hash = $hash_function->(''); while (1) { $hash = $hash_function->($hash); ++$iterations; last if ($hash eq $salt_hash); } if (bfr_hash($password, $hash_function, $iterations) eq $bfr_hash) { return 1; } return 0; } my $password1 = 'foo'; my $password2 = 'bar'; my $hash1 = bfr_hash($password1, \&sha512_hex); my $hash2 = bfr_hash($password2, \&sha512_hex); say qq{bfr_hash("$password1", sha512) = $hash1}; say qq{bfr_hash("$password2", sha512) = $hash2}; say check_bfr_hash($password1, $hash1, \&sha512_hex); #=> 1 say check_bfr_hash($password2, $hash2, \&sha512_hex); #=> 1 say check_bfr_hash($password1, $hash2, \&sha512_hex); #=> 0 say check_bfr_hash($password2, $hash1, \&sha512_hex); #=> 0 __END__ bfr_hash("foo", sha512) = d0cd2ed4ef19e55ea8d69212417e21d5723e41a716f74fea2bbc7d8e114108d1a439c763b2673c2e79ccc684b7558d42956982d6396abd6bcd99aca30b516787$a65bff3e58823c51d7a4a44bcebc8f5c8ba148e3eea81fc017ecd20eb94b5892f2112e397a48e5185ab500051ec285a0a9d104a6eed4828d04cc0661c0ea1885$03061c61439174d1a4f8f3fa73e53ff9b9480f02afa270544aaeacfc6cc08db27742f2d3721edc13a4cefabb0accbf476ef6c9596932fc81816c018e8fd6ca6e bfr_hash("bar", sha512) = 3eefe86bfbc36d7099625a3b3ab741c373435ab873d841eccbf9db465637b0c7a7e612cbc65fda0a9333c2065d10cbcb8120a8271b932234849753f899c4c396$906e9a62689d2bc012ff83f777432a2b1235faeff01a582d1fb3eb6b5201f1bca4174a4a983b6951fb211936d2040468c2a695f7b74ad45dcb76789ef267b9a9$e5bc95297be88c0b8003c731a052968ed6c2c75fceea2844e2584fdd05ae97ffa1795dc7f73e6b9c9c7c91d294dc7f435d687221fbf945d6d590fce7f54fcf7d ================================================ FILE: Digest/crc32.pl ================================================ #!/usr/bin/perl # Simple implementation of the Cyclic Redundancy Check (CRC32). # Reference: # https://web.archive.org/web/20240718094514/https://rosettacode.org/wiki/CRC-32 use 5.036; sub create_table() { my @table; for my $i (0 .. 255) { my $k = $i; for (0 .. 7) { if ($k & 1) { $k >>= 1; $k ^= 0xedb88320; } else { $k >>= 1; } } push @table, $k; } return \@table; } sub crc32($str, $crc = 0) { state $crc_table = create_table(); $crc ^= 0xffffffff; foreach my $c (unpack("C*", $str)) { $crc = ($crc >> 8) ^ $crc_table->[($crc & 0xff) ^ $c]; } return ($crc ^ 0xffffffff); } say crc32 "The quick brown fox jumps over the lazy dog"; say crc32("over the lazy dog", crc32("The quick brown fox jumps ")); ================================================ FILE: Encoding/adaptive_huffman_coding.pl ================================================ #!/usr/bin/perl # Implementation of the Adaptive Huffman Coding. # See also: # https://rosettacode.org/wiki/huffman_coding use 5.036; use List::Util qw(uniq); # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub encode ($bytes, $alphabet) { my %freq; ++$freq{$_} for @$alphabet; my @enc; foreach my $byte (@$bytes) { my ($h, $rev_h) = mktree_from_freq(\%freq); ++$freq{$byte}; push @enc, $h->{$byte}; } return join('', @enc); } sub decode ($enc, $alphabet) { my @out; my $prefix = ''; my %freq; ++$freq{$_} for @$alphabet; my ($h, $rev_h) = mktree_from_freq(\%freq); foreach my $bit (split(//, $enc)) { $prefix .= $bit; if (exists $rev_h->{$prefix}) { push @out, $rev_h->{$prefix}; ++$freq{$rev_h->{$prefix}}; ($h, $rev_h) = mktree_from_freq(\%freq); $prefix = ''; } } return \@out; } my $text = "this is an example for huffman encoding"; my @bytes = unpack('C*', $text); my @alphabet = uniq(@bytes); my $enc = encode(\@bytes, \@alphabet); my $dec = decode($enc, \@alphabet); say $enc; say pack('C*', @$dec); __END__ 1010000100010111110101010101010001010011011000101100010010010111110001011011111000011100111101111100111010110111011100111100011011100010001101100010011100000100010110001010 this is an example for huffman encoding ================================================ FILE: Encoding/arithmetic_coding.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 01 May 2015 # https://github.com/trizen # The arithmetic coding algorithm, as_a_generalized_change_of_radix. # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix use 5.010; use strict; use warnings; use Math::BigInt (try => 'GMP'); sub asciibet { map { chr } 0 .. 255; } sub cumulative_freq { my ($freq) = @_; my %cf; my $total = Math::BigInt->new(0); foreach my $c (asciibet()) { if (exists $freq->{$c}) { $cf{$c} = $total; $total += $freq->{$c}; } } return %cf; } sub arithmethic_coding { my ($str, $radix) = @_; my @chars = split(//, $str); # The frequency characters my %freq; $freq{$_}++ for @chars; # The cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = scalar @chars; # Lower bound my $L = Math::BigInt->new(0); # Product of all frequencies my $pf = Math::BigInt->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { $L->bmuladd($base, $cf{$c} * $pf); $pf->bmul($freq{$c}); } # Upper bound my $U = $L + $pf; #~ say $L; #~ say $U; my $pow = Math::BigInt->new($pf)->blog($radix); my $enc = ($U - 1)->bdiv(Math::BigInt->new($radix)->bpow($pow)); return ($enc, $pow, \%freq); } sub arithmethic_decoding { my ($enc, $radix, $pow, $freq) = @_; # Multiply enc by 10^pow $enc *= $radix**$pow; my $base = Math::BigInt->new(0); $base += $_ for values %{$freq}; # Create the cumulative frequency table my %cf = cumulative_freq($freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } # Decode the input number my $decoded = ''; for (my $i = $base - 1 ; $i >= 0 ; $i--) { my $pow = $base**$i; my $div = ($enc / $pow); my $c = $dict{$div}; my $fv = $freq->{$c}; my $cv = $cf{$c}; my $rem = ($enc - $pow * $cv) / $fv; #~ say "$enc / $base^$i = $div ($c)"; #~ say "($enc - $base^$i * $cv) / $fv = $rem\n"; $enc = $rem; $decoded .= $c; } # Return the decoded output return $decoded; } # ## Run some tests # my $radix = 10; # can be any integer >= 2 foreach my $str ( qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT 吹吹打打), 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols ' . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, ' . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial ' . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.' ) { my ($enc, $pow, $freq) = arithmethic_coding($str, $radix); my $dec = arithmethic_decoding($enc, $radix, $pow, $freq); say "Encoded: $enc"; say "Decoded: $dec"; if ($str ne $dec) { die "\tHowever that is incorrect!"; } say "-" x 80; } ================================================ FILE: Encoding/arithmetic_coding_adaptive_contexts_in_fixed_bits.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 12 July 2023 # Edit: 06 February 2024 # https://github.com/trizen # The Arithmetic Coding algorithm (adaptive version), implemented using native integers. # References: # Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits # https://youtube.com/watch?v=EqKbT3QdtOI # # Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods # https://youtube.com/watch?v=YKv-w8bXi9c use 5.036; use constant { ESCAPE => 256, EOF => 257, }; use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); sub create_cfreq ($table) { my $T = 0; my (@cf, @freq); foreach my $pair (@$table) { my ($i, $v) = @$pair; $v ||= 1; # FIXME: make it work with v = 0 $freq[$i] = $v; $cf[$i] = $T; $T += $v; $cf[$i + 1] = $T; } return (\@freq, \@cf, $T); } sub create_contexts { my @C; foreach my $i (0 .. 1) { my ($freq, $cf, $T) = create_cfreq( [(map { [$_, 1 - $i] } 0 .. 255), ( ($i == 0) ? ([ESCAPE, 0], [EOF, 1]) : ([ESCAPE, 1], [EOF, 1]) ), ] ); push @C, { low => 0, high => MAX, freq => $freq, cf => $cf, T => $T, uf_count => 0, }; } return @C; } sub increment_freq ($c, $freq, $cf) { if ($c <= 255) { ++$freq->[$c]; } my $T = $cf->[$c]; foreach my $i ($c .. 257) { $cf->[$i] = $T; $T += $freq->[$i]; $cf->[$i + 1] = $T; } return $T; } sub encode ($string) { my $enc = ''; my $bytes = [unpack('C*', $string), EOF]; my @C = create_contexts(); if ($C[0]{T} > MAX) { die "Too few bits: $C[0]{T} > ", MAX; } my sub encode_symbol ($c, $context) { my $w = $C[$context]{high} - $C[$context]{low} + 1; $C[$context]{high} = ($C[$context]{low} + int(($w * $C[$context]{cf}[$c + 1]) / $C[$context]{T}) - 1) & MAX; $C[$context]{low} = ($C[$context]{low} + int(($w * $C[$context]{cf}[$c]) / $C[$context]{T})) & MAX; foreach my $context (1) { $C[$context]{T} = increment_freq($c, $C[$context]{freq}, $C[$context]{cf}); } if ($C[$context]{high} > MAX) { die "high > MAX: $C[$context]{high} > ${\MAX}"; } if ($C[$context]{low} >= $C[$context]{high}) { die "$C[$context]{low} >= $C[$context]{high}"; } while (1) { if (($C[$context]{high} >> (BITS - 1)) == ($C[$context]{low} >> (BITS - 1))) { my $bit = $C[$context]{high} >> (BITS - 1); $enc .= $bit; if ($C[$context]{uf_count} > 0) { $enc .= join('', 1 - $bit) x $C[$context]{uf_count}; $C[$context]{uf_count} = 0; } $C[$context]{low} <<= 1; ($C[$context]{high} <<= 1) |= 1; } elsif (((($C[$context]{low} >> (BITS - 2)) & 0x1) == 1) && ((($C[$context]{high} >> (BITS - 2)) & 0x1) == 0)) { ($C[$context]{high} <<= 1) |= (1 << (BITS - 1)); $C[$context]{high} |= 1; ($C[$context]{low} <<= 1) &= ((1 << (BITS - 1)) - 1); ++$C[$context]{uf_count}; } else { last; } $C[$context]{low} &= MAX; $C[$context]{high} &= MAX; } } foreach my $c (@$bytes) { if ($C[1]{freq}[$c] == 0) { encode_symbol(ESCAPE, 1); encode_symbol($c, 0); } else { encode_symbol($c, 1); } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return $enc; } sub decode ($bits) { open my $fh, '<:raw', \$bits; my @C = create_contexts(); my $dec = ''; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my $context = 1; while (1) { my $w = $C[$context]{high} - $C[$context]{low} + 1; my $ss = int((($C[$context]{T} * ($enc - $C[$context]{low} + 1)) - 1) / $w); my $i = undef; my $cf = $C[$context]{cf}; my $freq = $C[$context]{freq}; foreach my $j (0 .. 257) { $freq->[$j] > 0 or next; if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) { $i = $j; last; } } $i // die "decoding error"; last if ($i == EOF); if ($i <= 255) { $dec .= chr($i); } $C[$context]{high} = ($C[$context]{low} + int(($w * $C[$context]{cf}[$i + 1]) / $C[$context]{T}) - 1) & MAX; $C[$context]{low} = ($C[$context]{low} + int(($w * $C[$context]{cf}[$i]) / $C[$context]{T})) & MAX; foreach my $context (1) { $C[$context]{T} = increment_freq($i, $C[$context]{freq}, $C[$context]{cf}); } if ($C[$context]{high} > MAX) { die "high > MAX: ($C[$context]{high} > ${\MAX})"; } if ($C[$context]{low} >= $C[$context]{high}) { die "$C[$context]{low} >= $C[$context]{high}"; } while (1) { if (($C[$context]{high} >> (BITS - 1)) == ($C[$context]{low} >> (BITS - 1))) { ($C[$context]{high} <<= 1) |= 1; $C[$context]{low} <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($C[$context]{low} >> (BITS - 2)) & 0x1) == 1) && ((($C[$context]{high} >> (BITS - 2)) & 0x1) == 0)) { ($C[$context]{high} <<= 1) |= (1 << (BITS - 1)); $C[$context]{high} |= 1; ($C[$context]{low} <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $C[$context]{low} &= MAX; $C[$context]{high} &= MAX; $enc &= MAX; } if ($i == ESCAPE) { $context == 1 or die "error"; $context = 0; } elsif ($context == 0) { $context = 1; } } return $dec; } my $str = "ABRACADABRA AND A VERY SAD SALAD"; if (@ARGV) { if (-f $ARGV[0]) { $str = do { open my $fh, '<:raw', $ARGV[0]; local $/; <$fh>; }; } else { $str = $ARGV[0]; } } my ($enc) = encode($str); say $enc; say "Encoded bytes length: ", length($enc) / 8; my $dec = decode($enc); say $dec; $str eq $dec or die "Decoding error: ", length($str), ' <=> ', length($dec); __END__ 0100000011000001000010010011111111110001001000010100100101000010110101110111001000110110110010011001000111010101100010111110010111111101011110010010110000110100100101110011110101110111101000110000011100010111111100001010011011001011 Encoded bytes length: 29 ABRACADABRA AND A VERY SAD SALAD ================================================ FILE: Encoding/arithmetic_coding_adaptive_in_fixed_bits.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 12 July 2023 # Edit: 05 February 2024 # https://github.com/trizen # The Arithmetic Coding algorithm (adaptive version), implemented using native integers. # References: # Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits # https://youtube.com/watch?v=EqKbT3QdtOI # # Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods # https://youtube.com/watch?v=YKv-w8bXi9c # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use List::Util qw(max); use constant EOF_SYMBOL => 256; use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); sub create_cfreq ($freq_value) { my $T = 0; my (@cf, @freq); foreach my $i (0 .. EOF_SYMBOL) { $freq[$i] = $freq_value; $cf[$i] = $T; $T += $freq_value; $cf[$i + 1] = $T; } return (\@freq, \@cf, $T); } sub increment_freq ($c, $freq, $cf) { ++$freq->[$c]; my $T = $cf->[$c]; foreach my $i ($c .. EOF_SYMBOL) { $cf->[$i] = $T; $T += $freq->[$i]; $cf->[$i + 1] = $T; } return $T; } sub encode ($string) { my $enc = ''; my $bytes = [unpack('C*', $string), EOF_SYMBOL]; my ($freq, $cf, $T) = create_cfreq(1); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@$bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; $T = increment_freq($c, $freq, $cf); if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return $enc; } sub decode ($bits) { open my $fh, '<:raw', \$bits; my ($freq, $cf, $T) = create_cfreq(1); my $dec = ''; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = 0; foreach my $j (0 .. EOF_SYMBOL) { if ($cf->[$j] <= $ss and $ss < $cf->[$j + 1]) { $i = $j; last; } } last if ($i == EOF_SYMBOL); $dec .= chr($i); $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; $T = increment_freq($i, $freq, $cf); if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return $dec; } my $str = "ABRACADABRA AND A VERY SAD SALAD"; if (@ARGV) { if (-f $ARGV[0]) { $str = do { open my $fh, '<:raw', $ARGV[0]; local $/; <$fh>; }; } else { $str = $ARGV[0]; } } my ($enc) = encode($str); say $enc; say "Encoded bytes length: ", length($enc) / 8; my $dec = decode($enc); say $dec; $str eq $dec or die "Decoding error: ", length($str), ' <=> ', length($dec); __END__ 0100000100000001110010111101111100111011001101010100000111010101101011111111010100110100011111001010110010110110010001001100100111000101010111111101011110101001010110111111000111101000010110011000010100100111110010011111110111011111 Encoded bytes length: 29 ABRACADABRA AND A VERY SAD SALAD ================================================ FILE: Encoding/arithmetic_coding_anynum.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 01 May 2015 # https://github.com/trizen # The arithmetic coding algorithm, as_a_generalized_change_of_radix. # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix use 5.010; use strict; use warnings; use Math::AnyNum qw(ipow ilog idiv); sub asciibet { map { chr } 0 .. 255; } sub cumulative_freq { my ($freq) = @_; my %cf; my $total = Math::AnyNum->new(0); foreach my $c (asciibet()) { if (exists $freq->{$c}) { $cf{$c} = $total; $total += $freq->{$c}; } } return %cf; } sub arithmethic_coding { my ($str, $radix) = @_; my @chars = split(//, $str); # The frequency characters my %freq; $freq{$_}++ for @chars; # The cumulative frequency table my %cf = cumulative_freq(\%freq); # Base my $base = Math::AnyNum->new(scalar @chars); # Lower bound my $L = Math::AnyNum->new(0); # Product of all frequencies my $pf = Math::AnyNum->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { $L *= $base; $L += $cf{$c} * $pf; $pf *= $freq{$c}; } # Upper bound my $U = $L + $pf; #~ say $L; #~ say $U; my $pow = ilog($pf, $radix); my $enc = idiv($U - 1, ipow($radix, $pow)); return ($enc, $pow, \%freq); } sub arithmethic_decoding { my ($enc, $radix, $pow, $freq) = @_; # Multiply enc by 10^pow $enc *= ipow($radix, $pow); my $base = Math::AnyNum->new(0); $base += $_ for values %{$freq}; # Create the cumulative frequency table my %cf = cumulative_freq($freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } # Decode the input number my $decoded = ''; for (my $pow = ipow($base, $base - 1) ; $pow > 0 ; $pow = idiv($pow, $base)) { my $div = idiv($enc, $pow); my $c = $dict{$div}; my $fv = $freq->{$c}; my $cv = $cf{$c}; my $rem = idiv($enc - $pow * $cv, $fv); #~ say "$enc / $base^$pow = $div ($c)"; #~ say "($enc - $base^$pow * $cv) / $fv = $rem\n"; $enc = $rem; $decoded .= $c; } # Return the decoded output return $decoded; } # ## Run some tests # my $radix = 10; # can be any integer >= 2 foreach my $str ( qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT 吹吹打打), 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols ' . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, ' . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial ' . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.' ) { my ($enc, $pow, $freq) = arithmethic_coding($str, $radix); my $dec = arithmethic_decoding($enc, $radix, $pow, $freq); say "Encoded: $enc"; say "Decoded: $dec"; if ($str ne $dec) { die "\tHowever that is incorrect!"; } say "-" x 80; } open my $fh, '<', __FILE__; my $content = do { local $/; <$fh> }; my ($enc, $pow, $freq) = arithmethic_coding($content, $radix); my $dec = arithmethic_decoding($enc, $radix, $pow, $freq); if ($dec ne $content) { die "Failed to encode and decode the __FILE__ correctly."; } ================================================ FILE: Encoding/arithmetic_coding_in_fixed_bits.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 12 July 2023 # Edit: 05 February 2024 # https://github.com/trizen # The Arithmetic Coding algorithm, implemented using native integers. # References: # Data Compression (Summer 2023) - Lecture 15 - Infinite Precision in Finite Bits # https://youtube.com/watch?v=EqKbT3QdtOI # # Basic arithmetic coder in C++ # https://github.com/billbird/arith32 use 5.036; use List::Util qw(max); use constant BITS => 32; use constant MAX => oct('0b' . ('1' x BITS)); sub create_cfreq ($freq) { my @cf; my $T = 0; foreach my $i (sort { $a <=> $b } keys %$freq) { $freq->{$i} // next; $cf[$i] = $T; $T += $freq->{$i}; $cf[$i + 1] = $T; } return (\@cf, $T); } sub encode ($string) { my $enc = ''; my @bytes = unpack('C*', $string); my $EOF_SYMBOL = (max(@bytes) // 0) + 1; push @bytes, $EOF_SYMBOL; my %freq; ++$freq{$_} for @bytes; my ($cf, $T) = create_cfreq(\%freq); if ($T > MAX) { die "Too few bits: $T > ${\MAX}"; } my $low = 0; my $high = MAX; my $uf_count = 0; foreach my $c (@bytes) { my $w = $high - $low + 1; $high = ($low + int(($w * $cf->[$c + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$c]) / $T)) & MAX; if ($high > MAX) { die "high > MAX: $high > ${\MAX}"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { my $bit = $high >> (BITS - 1); $enc .= $bit; if ($uf_count > 0) { $enc .= join('', 1 - $bit) x $uf_count; $uf_count = 0; } $low <<= 1; ($high <<= 1) |= 1; } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); ++$uf_count; } else { last; } $low &= MAX; $high &= MAX; } } $enc .= '0'; $enc .= '1'; while (length($enc) % 8 != 0) { $enc .= '1'; } return ($enc, \%freq); } sub decode ($bits, $freq) { open my $fh, '<:raw', \$bits; my ($cf, $T) = create_cfreq($freq); my $dec = ''; my $low = 0; my $high = MAX; my $enc = oct('0b' . join '', map { getc($fh) // 1 } 1 .. BITS); my @table; foreach my $i (sort { $a <=> $b } keys %$freq) { foreach my $j ($cf->[$i] .. $cf->[$i + 1] - 1) { $table[$j] = $i; } } my $EOF_SYMBOL = max(keys %$freq) // 0; while (1) { my $w = $high - $low + 1; my $ss = int((($T * ($enc - $low + 1)) - 1) / $w); my $i = $table[$ss] // last; last if ($i == $EOF_SYMBOL); $dec .= chr($i); $high = ($low + int(($w * $cf->[$i + 1]) / $T) - 1) & MAX; $low = ($low + int(($w * $cf->[$i]) / $T)) & MAX; if ($high > MAX) { die "error"; } if ($low >= $high) { die "$low >= $high" } while (1) { if (($high >> (BITS - 1)) == ($low >> (BITS - 1))) { ($high <<= 1) |= 1; $low <<= 1; ($enc <<= 1) |= (getc($fh) // 1); } elsif (((($low >> (BITS - 2)) & 0x1) == 1) && ((($high >> (BITS - 2)) & 0x1) == 0)) { ($high <<= 1) |= (1 << (BITS - 1)); $high |= 1; ($low <<= 1) &= ((1 << (BITS - 1)) - 1); $enc = (($enc >> (BITS - 1)) << (BITS - 1)) | (($enc & ((1 << (BITS - 2)) - 1)) << 1) | (getc($fh) // 1); } else { last; } $low &= MAX; $high &= MAX; $enc &= MAX; } } return $dec; } my $str = "ABRACADABRA AND A VERY SAD SALAD"; if (@ARGV) { if (-f $ARGV[0]) { $str = do { open my $fh, '<:raw', $ARGV[0]; local $/; <$fh>; }; } else { $str = $ARGV[0]; } } my ($enc, $freq) = encode($str); say $enc; say "Encoded bytes length: ", length($enc) / 8; my $dec = decode($enc, $freq); say $dec; $str eq $dec or die "Decoding error: ", length($str), ' <=> ', length($dec); __END__ 0100110110111110100000000100000111110000110110011111000010110011011001000101100011011101001110000000010001111111 Encoded bytes length: 14 ABRACADABRA AND A VERY SAD SALAD ================================================ FILE: Encoding/arithmetic_coding_mpz.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 February 2016 # Edit: 31 July 2023 # https://github.com/trizen # Arithmetic coding, implemented using big integers. # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix use 5.036; use Math::GMPz; use List::Util qw(sum); sub cumulative_freq ($freq) { my %cf; my $total = 0; foreach my $c (sort { $a <=> $b } keys %$freq) { $cf{$c} = $total; $total += $freq->{$c}; } return %cf; } sub ac_encode ($bytes_arr) { my @chars = @$bytes_arr; # The frequency characters my %freq; ++$freq{$_} for @chars; # Create the cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = Math::GMPz->new(scalar @chars); # Lower bound my $L = Math::GMPz->new(0); # Product of all frequencies my $pf = Math::GMPz->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { Math::GMPz::Rmpz_mul($L, $L, $base); Math::GMPz::Rmpz_addmul_ui($L, $pf, $cf{$c}); Math::GMPz::Rmpz_mul_ui($pf, $pf, $freq{$c}); } # Upper bound my $U = $L + $pf; # Compute the power for left shift my $pow = Math::GMPz::Rmpz_sizeinbase($pf, 2) - 1; # Set $enc to (U-1) divided by 2^pow my $enc = ($U - 1) >> $pow; # Remove any divisibility by 2 if ($enc > 0 and Math::GMPz::Rmpz_even_p($enc)) { $pow += Math::GMPz::Rmpz_remove($enc, $enc, Math::GMPz->new(2)); } my $bin = Math::GMPz::Rmpz_get_str($enc, 2); return ($bin, $pow, \%freq); } sub ac_decode ($bits, $pow2, $freq) { # Decode the bits into an integer my $enc = Math::GMPz->new($bits, 2); $enc <<= $pow2; my $base = sum(values %$freq) // 0; if ($base == 0) { return []; } elsif ($base == 1) { return [keys %$freq]; } # Create the cumulative frequency table my %cf = cumulative_freq($freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } my $div = Math::GMPz::Rmpz_init(); my @dec; # Decode the input number for (my $pow = Math::GMPz->new($base)**($base - 1) ; Math::GMPz::Rmpz_sgn($pow) > 0 ; Math::GMPz::Rmpz_tdiv_q_ui($pow, $pow, $base)) { Math::GMPz::Rmpz_tdiv_q($div, $enc, $pow); my $c = $dict{$div}; my $fv = $freq->{$c}; my $cv = $cf{$c}; Math::GMPz::Rmpz_submul_ui($enc, $pow, $cv); Math::GMPz::Rmpz_tdiv_q_ui($enc, $enc, $fv); push @dec, $c; } return \@dec; } # ## Run some tests # foreach my $str ( '', 'a', 'this is a message for you to encode and to decode correctly!', join('', 'a' .. 'z', 0 .. 9, 'A' .. 'Z', 0 .. 9), qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT), 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols ' . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, ' . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial ' . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.' ) { my @bytes = unpack('C*', $str); my ($enc, $len, $freq) = ac_encode(\@bytes); my $dec_bytes = ac_decode($enc, $len, $freq); my $dec = pack('C*', @$dec_bytes); say "Encoded: $enc"; say "Decoded: $dec"; if ($str ne $dec) { die "\tHowever that is incorrect!"; } say "-" x 80; } ================================================ FILE: Encoding/ascii_encode_decode.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 July 2012 # https://github.com/trizen # A simple ASCII encoder-decoder. # What's special is that you can delete words from the encoded text, and still be able to decode it. # You can also insert or append encoded words to an encoded string and decode it later. use 5.010; use strict; use warnings; sub encode_decode ($$) { my ($encode, $text) = @_; my $i = 1; my $output = ''; LOOP_1: foreach my $c (map { ord } split //, $text) { foreach my $o ([32, 121]) { if ($c > $o->[0] && $c <= $o->[1]) { my $ord = $encode ? $c + ($i % 2 ? $i : -$i) : $c - ($i % 2 ? $i : -$i); if ($ord > $o->[1]) { $ord = $o->[0] + ($ord - $o->[1]); } elsif ($ord <= $o->[0]) { $ord = $o->[1] - ($o->[0] - $ord); } $output .= chr $ord; ++$i; next LOOP_1; } } $output .= chr($c); $i = 1; } return $output; } my $enc = encode_decode(1, "test"); my $dec = encode_decode(0, $enc); say "Enc: ", $enc; say "Dec: ", $dec; # Encoding my $encoded = encode_decode(1, "Just another ") . encode_decode(1, "Perl hacker,"); # Decoding my $decoded = encode_decode(0, $encoded); say $encoded; say $decoded; ================================================ FILE: Encoding/binary_arithmetic_coding.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 07 May 2015 # https://github.com/trizen # The binary arithmetic coding algorithm. # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding use 5.010; use strict; use warnings; use Math::BigInt (try => 'GMP'); use Math::BigRat (try => 'GMP'); sub asciibet { map { chr } 0 .. 255; } sub cumulative_freq { my ($freq, $sum) = @_; my %cf; my $total = 0; foreach my $c (asciibet()) { if (exists $freq->{$c}) { $cf{$c} = $total; $total += $freq->{$c}; } } return %cf; } sub mass_function { my ($freq, $sum) = @_; my %p; $p{$_} = Math::BigRat->new($freq->{$_}) / $sum for keys %{$freq}; return %p; } sub arithmethic_coding { my ($str) = @_; my @chars = split(//, $str); my %freq; $freq{$_}++ for @chars; my $len = @chars; my %p = mass_function(\%freq, $len); my %cf = cumulative_freq(\%p, $len); my $pf = Math::BigRat->new(1); my $L = Math::BigRat->new(0); foreach my $c (@chars) { $L->badd($pf * $cf{$c}); $pf->bmul($p{$c}); } my $U = $L + $pf; my $big_two = Math::BigInt->new(2); my $two_pow = Math::BigInt->new(1); my $n = Math::BigRat->new(0); my $bin = ''; for (my $i = Math::BigInt->new(1) ; ($n < $L || $n >= $U) ; $i->binc) { my $m = Math::BigRat->new(1)->bdiv($two_pow->bmul($big_two)); if ($n + $m < $U) { $n += $m; $bin .= '1'; } else { $bin .= '0'; } } return ($bin, $len, \%freq); } sub arithmethic_decoding { my ($enc, $len, $freq) = @_; my $two_pow = Math::BigInt->new(1); my $big_two = Math::BigInt->new(2); my $line = Math::BigRat->new(0); my @bin = split(//, $enc); foreach my $i (0 .. $#bin) { $line->badd(scalar Math::BigRat->new($bin[$i])->bdiv($two_pow->bmul($big_two))); } my %p = mass_function($freq, $len); my %cf = cumulative_freq(\%p, $len); my %df; foreach my $k (keys %p) { $df{$k} = $cf{$k} + $p{$k}; } my $L = 0; my $U = 1; my $decoded = ''; my @chars = sort { $p{$a} <=> $p{$b} or $a cmp $b } keys %p; my $i = 0; while (1) { foreach my $c (@chars) { my $w = $U - $L; my $low = $L + $w * $cf{$c}; my $high = $L + $w * $df{$c}; if ($low <= $line and $line < $high) { ($L, $U) = ($low, $high); $decoded .= $c; if (++$i == $len) { return $decoded; } } } } } # ## Run some tests # foreach my $str ( 'this is a message for you to encode and to decode correctly!', join('', 'a' .. 'z', 0 .. 9, 'A' .. 'Z', 0 .. 9), qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT), 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols ' . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, ' . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial ' . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.' ) { my ($enc, $len, $freq) = arithmethic_coding($str); my $dec = arithmethic_decoding($enc, $len, $freq); say "Encoded: $enc"; say "Decoded: $dec"; if ($str ne $dec) { die "\tHowever that is incorrect!"; } say "-" x 80; } ================================================ FILE: Encoding/binary_arithmetic_coding_anynum.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 07 May 2015 # https://github.com/trizen # The binary arithmetic coding algorithm. # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding use 5.010; use strict; use warnings; use Math::AnyNum; sub asciibet { map { chr } 0 .. 255; } sub cumulative_freq { my ($freq, $sum) = @_; my %cf; my $total = 0; foreach my $c (asciibet()) { if (exists $freq->{$c}) { $cf{$c} = $total; $total += $freq->{$c}; } } return %cf; } sub mass_function { my ($freq, $sum) = @_; my %p; $p{$_} = Math::AnyNum->new($freq->{$_}) / $sum for keys %{$freq}; return %p; } sub arithmethic_coding { my ($str) = @_; my @chars = split(//, $str); my %freq; $freq{$_}++ for @chars; my $len = @chars; my %p = mass_function(\%freq, $len); my %cf = cumulative_freq(\%p, $len); my $pf = Math::AnyNum->new(1); my $L = Math::AnyNum->new(0); for my $c (@chars) { $L += $pf * $cf{$c}; $pf *= $p{$c}; } my $U = $L + $pf; my $t = Math::AnyNum->new(1); my $n = Math::AnyNum->new(0); my $bin = ''; while ($n < $L || $n >= $U) { my $m = 1 / ($t <<= 1); if ($n + $m < $U) { $n += $m; $bin .= '1'; } else { $bin .= '0'; } } return ($bin, $len, \%freq); } sub arithmethic_decoding { my ($enc, $len, $freq) = @_; my $t = Math::AnyNum->new(1); my $line = Math::AnyNum->new(0); my @bin = split(//, $enc); foreach my $i (0 .. $#bin) { $line += $bin[$i] / ($t <<= 1); } my %p = mass_function($freq, $len); my %cf = cumulative_freq(\%p, $len); my %df; foreach my $k (keys %p) { $df{$k} = $cf{$k} + $p{$k}; } my $L = 0; my $U = 1; my $decoded = ''; my @chars = sort { $p{$a} <=> $p{$b} or $a cmp $b } keys %p; my $i = 0; while (1) { foreach my $c (@chars) { my $w = $U - $L; my $low = $L + $w * $cf{$c}; my $high = $L + $w * $df{$c}; if ($low <= $line and $line < $high) { ($L, $U) = ($low, $high); $decoded .= $c; if (++$i == $len) { return $decoded; } } } } } # ## Run some tests # foreach my $str ( 'this is a message for you to encode and to decode correctly!', join('', 'a' .. 'z', 0 .. 9, 'A' .. 'Z', 0 .. 9), qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT), 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols ' . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, ' . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial ' . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.' ) { my ($enc, $len, $freq) = arithmethic_coding($str); my $dec = arithmethic_decoding($enc, $len, $freq); say "Encoded: $enc"; say "Decoded: $dec"; if ($str ne $dec) { die "\tHowever that is incorrect!"; } say "-" x 80; } ================================================ FILE: Encoding/binary_variable_length_run_encoding.pl ================================================ #!/usr/bin/perl # Implementation of the Variable Length Run Encoding, for a binary string consisting of only 0s and 1s. # Reference: # Data Compression (Summer 2023) - Lecture 5 - Basic Techniques # https://youtube.com/watch?v=TdFWb8mL5Gk use 5.036; sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub binary_vrl_encoding ($str) { my @bits = split(//, $str); my $bitstring = $bits[0]; foreach my $rle (@{run_length(\@bits)}) { my ($c, $v) = @$rle; if ($v == 1) { $bitstring .= '0'; } else { my $t = sprintf('%b', $v - 1); $bitstring .= join('', '1' x length($t), '0', substr($t, 1)); } } return $bitstring; } sub binary_vrl_decoding ($bitstring) { open my $fh, '<:raw', \$bitstring; my $decoded = ''; my $bit = getc($fh); while (!eof($fh)) { $decoded .= $bit; my $bl = 0; while (getc($fh) == 1) { ++$bl; } if ($bl > 0) { $decoded .= $bit x oct('0b1' . join('', map { getc($fh) } 1 .. $bl - 1)); } $bit = ($bit eq '1' ? '0' : '1'); } return $decoded; } my $bitstring = "101000010000000010000000100000000001001100010000000000000010010100000000000000001"; my $enc = binary_vrl_encoding($bitstring); my $dec = binary_vrl_decoding($enc); say $enc; say $dec; $dec eq $bitstring or die "error"; __END__ 1000110101110110111010011110001010101100011110101010000111101110 101000010000000010000000100000000001001100010000000000000010010100000000000000001 ================================================ FILE: Encoding/binradix_arithmetic_coding.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 07 May 2015 # https://github.com/trizen # The arithmetic coding algorithm (radix+binary). # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix use 5.010; use strict; use warnings; use Math::BigInt (try => 'GMP'); use Math::BigRat (try => 'GMP'); sub asciibet { map { chr } 0 .. 255; } sub cumulative_freq { my ($freq) = @_; my %cf; my $total = Math::BigInt->new(0); foreach my $c (asciibet()) { if (exists $freq->{$c}) { $cf{$c} = $total; $total += $freq->{$c}; } } return %cf; } sub arithmethic_coding { my ($str) = @_; my @chars = split(//, $str); # The frequency characters my %freq; $freq{$_}++ for @chars; # The cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = scalar @chars; # Lower bound my $L = Math::BigInt->new(0); # Product of all frequencies my $pf = Math::BigInt->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols foreach my $c (@chars) { $L->bmuladd($base, $cf{$c} * $pf); $pf->bmul($freq{$c}); } # Upper bound my $U = $L + $pf; my $len = $L->length; $L = Math::BigRat->new("$L / " . Math::BigInt->new(10)->bpow($len)); $U = Math::BigRat->new("$U / " . Math::BigInt->new(10)->bpow($len)); my $big_two = Math::BigInt->new(2); my $two_pow = Math::BigInt->new(1); my $n = Math::BigRat->new(0); my $bin = ''; while ($n < $L || $n >= $U) { my $m = Math::BigRat->new(1)->bdiv($two_pow->bmul($big_two)); if ($n + $m < $U) { $n += $m; $bin .= '1'; } else { $bin .= '0'; } } #~ say $L; #~ say $U; return ($bin, $len, \%freq); } sub arithmethic_decoding { my ($enc, $pow, $freq) = @_; my $two_pow = Math::BigInt->new(1); my $big_two = Math::BigInt->new(2); my $line = Math::BigRat->new(0); my @bin = split(//, $enc); foreach my $i (0 .. $#bin) { $line->badd(scalar Math::BigRat->new($bin[$i])->bdiv($two_pow->bmul($big_two))); } $enc = $line->bmul(Math::BigInt->new(10)->bpow($pow))->as_int; my $base = Math::BigInt->new(0); $base += $_ for values %{$freq}; # Create the cumulative frequency table my %cf = cumulative_freq($freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } # Decode the input number my $decoded = ''; for (my $i = $base - 1 ; $i >= 0 ; $i--) { my $pow = $base**$i; my $div = ($enc / $pow); my $c = $dict{$div}; my $fv = $freq->{$c}; my $cv = $cf{$c}; my $rem = ($enc - $pow * $cv) / $fv; #~ say "$enc / $base^$i = $div ($c)"; #~ say "($enc - $base^$i * $cv) / $fv = $rem\n"; $enc = $rem; $decoded .= $c; } # Return the decoded output return $decoded; } # ## Run some tests # foreach my $str ( qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT), 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols ' . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, ' . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial ' . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.' ) { my ($enc, $pow, $freq) = arithmethic_coding($str); my $dec = arithmethic_decoding($enc, $pow, $freq); say "Encoded: $enc"; say "Decoded: $dec"; if ($str ne $dec) { die "\tHowever that is incorrect!"; } say "-" x 80; } ================================================ FILE: Encoding/binradix_arithmetic_coding_anynum.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 07 May 2015 # https://github.com/trizen # The arithmetic coding algorithm (radix+binary). # See also: # https://en.wikipedia.org/wiki/Arithmetic_coding#Arithmetic_coding_as_a_generalized_change_of_radix use 5.010; use strict; use warnings; use Math::AnyNum qw(ipow ipow10 idiv); sub cumulative_freq { my ($freq) = @_; my %cf; my $total = Math::AnyNum->new(0); foreach my $c (sort keys %$freq) { $cf{$c} = $total; $total += $freq->{$c}; } return %cf; } sub arithmethic_coding { my ($str) = @_; my @chars = split(//, $str); # The frequency characters my %freq; $freq{$_}++ for @chars; # The cumulative frequency table my %cf = cumulative_freq(\%freq); # Limit and base my $base = scalar @chars; # Lower bound my $L = Math::AnyNum->new(0); # Product of all frequencies my $pf = Math::AnyNum->new(1); # Each term is multiplied by the product of the # frequencies of all previously occurring symbols for my $c (@chars) { $L *= $base; $L += $cf{$c} * $pf; $pf *= $freq{$c}; } # Upper bound my $U = $L + $pf; my $len = $L->length; $L = Math::AnyNum->new("$L / " . ipow10($len)); $U = Math::AnyNum->new("$U / " . ipow10($len)); my $t = Math::AnyNum->new(1); my $n = Math::AnyNum->new(0); my $bin = ''; while ($n < $L || $n >= $U) { my $m = 1 / ($t <<= 1); if ($n + $m < $U) { $n += $m; $bin .= '1'; } else { $bin .= '0'; } } #~ say $L; #~ say $U; return ($bin, $len, \%freq); } sub arithmethic_decoding { my ($enc, $pow, $freq) = @_; my $t = Math::AnyNum->new(1); my $line = Math::AnyNum->new(0); my @bin = split(//, $enc); foreach my $i (0 .. $#bin) { $line += $bin[$i] / ($t <<= 1); } $enc = $line * ipow10($pow); my $base = Math::AnyNum->new(0); $base += $_ for values %{$freq}; # Create the cumulative frequency table my %cf = cumulative_freq($freq); # Create the dictionary my %dict; while (my ($k, $v) = each %cf) { $dict{$v} = $k; } # Fill the gaps in the dictionary my $lchar; foreach my $i (0 .. $base - 1) { if (exists $dict{$i}) { $lchar = $dict{$i}; } elsif (defined $lchar) { $dict{$i} = $lchar; } } # Decode the input number my $decoded = ''; for (my $i = $base - 1 ; $i >= 0 ; $i--) { my $pow = ipow($base, $i); my $div = idiv($enc, $pow); my $c = $dict{$div}; my $fv = $freq->{$c}; my $cv = $cf{$c}; my $rem = ($enc - $pow * $cv) / $fv; #~ say "$enc / $base^$i = $div ($c)"; #~ say "($enc - $base^$i * $cv) / $fv = $rem\n"; $enc = $rem; $decoded .= $c; } # Return the decoded output return $decoded; } # ## Run some tests # foreach my $str ( qw(DABDDB DABDDBBDDBA ABBDDD ABRACADABRA CoMpReSSeD Sidef Trizen google TOBEORNOTTOBEORTOBEORNOT), 'In a positional numeral system the radix, or base, is numerically equal to a number of different symbols ' . 'used to express the number. For example, in the decimal system the number of symbols is 10, namely 0, 1, 2, ' . '3, 4, 5, 6, 7, 8, and 9. The radix is used to express any finite integer in a presumed multiplier in polynomial ' . 'form. For example, the number 457 is actually 4×102 + 5×101 + 7×100, where base 10 is presumed but not shown explicitly.' ) { my ($enc, $pow, $freq) = arithmethic_coding($str); my $dec = arithmethic_decoding($enc, $pow, $freq); say "Encoded: $enc"; say "Decoded: $dec"; if ($str ne $dec) { die "\tHowever that is incorrect!"; } say "-" x 80; } ================================================ FILE: Encoding/burrows-wheeler_file_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 17 September 2023 # https://github.com/trizen # Apply the Burrows–Wheeler transform on a file. # https://rosettacode.org/wiki/Burrows–Wheeler_transform # References: # Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT) # https://youtube.com/watch?v=rQ7wwh4HRZM # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use Getopt::Std qw(getopts); use File::Basename qw(basename); use constant { LOOKAHEAD_LEN => 128, # lower values are usually faster }; sub bwt_sort ($s) { # O(n * LOOKAHEAD_LEN) space (fast) my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_sort($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion: O(n * log(n)) my @tail = split(//, $bwt); my @head = sort @tail; if ($idx > $#head) { die "Invalid bwt-index: $idx (must be <= $#head)\n"; } my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } getopts('dh', \my %opts); if ($opts{h} or !@ARGV) { die "usage: $0 [-d] [input file] [output file]\n"; } my $input_file = $ARGV[0]; my $output_file = $ARGV[1] // (basename($input_file) . ($opts{d} ? '.dec' : '.bw')); my $content = do { open my $fh, '<:raw', $input_file or die "Can't open file <<$input_file>> for reading: $!"; local $/; <$fh>; }; if ($opts{d}) { # decode mode my $idx = unpack('N', substr($content, 0, 4, '')); my $dec = bwt_decode($content, $idx); open my $out_fh, '>:raw', $output_file or die "Can't open file <<$output_file>> for writing: $!"; print $out_fh $dec; } else { my ($bwt, $idx) = bwt_encode($content); open my $out_fh, '>:raw', $output_file or die "Can't open file <<$output_file>> for writing: $!"; print $out_fh pack('N', $idx); print $out_fh $bwt; } ================================================ FILE: Encoding/burrows-wheeler_transform-n-char_generalization.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 23 February 2024 # https://github.com/trizen # Implementation of the Burrows–Wheeler transform, with fast inversion (n-character generalization). # https://rosettacode.org/wiki/Burrows–Wheeler_transform # References: # Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT) # https://youtube.com/watch?v=rQ7wwh4HRZM # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; sub bwt_cyclic ($s) { # O(n) space (slowish) my @cyclic = @$s; my $len = scalar(@cyclic); my $rle = 1; foreach my $i (1 .. $len - 1) { if ($cyclic[$i] ne $cyclic[$i - 1]) { $rle = 0; last; } } $rle && return [0 .. $len - 1]; [ sort { my ($i, $j) = ($a, $b); while ($cyclic[$i] eq $cyclic[$j]) { $i %= $len if (++$i >= $len); $j %= $len if (++$j >= $len); } $cyclic[$i] cmp $cyclic[$j]; } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_cyclic($s); my @ret = map { $s->[$_ - 1] } @$bwt; my $idx = 0; foreach my $i (@$bwt) { $i || last; ++$idx; } return (\@ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = @$bwt; my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } #<<< my @tests = ( "banana", "appellee", "dogwood", "TOBEORNOTTOBEORTOBEORNOT", "SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES", "PINEAPPLE", "","a","aa","aabb","aaaaaaaaaaaa","aaaaaaaaaaaab", "baaaaaaaaaaaa","aaaaaabaaaaaa","aaaaaaabaaaaa", ); #>>> foreach my $file (__FILE__, $^X) { push @tests, do { open my $fh, '<:raw', $file; local $/; <$fh>; }; } foreach my $str (@tests) { my ($enc, $idx) = bwt_encode([unpack('(a3)*', $str)]); my $dec = bwt_decode($enc, $idx); if (length($str) < 1024) { say "BWT($dec) = ([@$enc], $idx)"; } $dec eq $str or die "error: <<$dec>> != <<$str>>"; } __END__ BWT(banana) = ([ban ana], 1) BWT(appellee) = ([ee ell app], 0) BWT(dogwood) = ([woo d dog], 1) BWT(TOBEORNOTTOBEORTOBEORNOT) = ([TOB TOB TOB EOR EOR EOR NOT NOT], 6) BWT(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) BWT(PINEAPPLE) = ([PIN PLE EAP], 1) BWT() = ([], 0) BWT(a) = ([a], 0) BWT(aa) = ([aa], 0) BWT(aabb) = ([b aab], 0) BWT(aaaaaaaaaaaa) = ([aaa aaa aaa aaa], 0) BWT(aaaaaaaaaaaab) = ([b aaa aaa aaa aaa], 0) BWT(baaaaaaaaaaaa) = ([aaa aaa aaa baa a], 4) BWT(aaaaaabaaaaaa) = ([aaa baa a aaa aaa], 2) BWT(aaaaaaabaaaaa) = ([aaa aba a aaa aaa], 2) ================================================ FILE: Encoding/burrows-wheeler_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # https://github.com/trizen # Implementation of the Burrows–Wheeler transform, with fast inversion. # https://rosettacode.org/wiki/Burrows–Wheeler_transform # References: # Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT) # https://youtube.com/watch?v=rQ7wwh4HRZM # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; use constant { LOOKAHEAD_LEN => 512, # lower values are faster (on average) }; sub bwt_quadratic ($s) { # O(n^2) space (impractical) [map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [substr($s, $_) . substr($s, 0, $_), $_] } 0 .. length($s) - 1]; } sub bwt_simple ($s) { # O(n) space (very slow) [sort { (substr($s, $a) . substr($s, 0, $a)) cmp(substr($s, $b) . substr($s, 0, $b)) } 0 .. length($s) - 1]; } sub bwt_cyclic ($s) { # O(n) space (slow) my @cyclic = split(//, $s); my $len = scalar(@cyclic); my $rle = 1; foreach my $i (1 .. $len - 1) { if ($cyclic[$i] ne $cyclic[$i - 1]) { $rle = 0; last; } } $rle && return [0 .. $len - 1]; [ sort { my ($i, $j) = ($a, $b); while ($cyclic[$i] eq $cyclic[$j]) { $i %= $len if (++$i >= $len); $j %= $len if (++$j >= $len); } $cyclic[$i] cmp $cyclic[$j]; } 0 .. $len - 1 ]; } sub bwt_lookahead ($s) { # O(n) space (moderately fast) [ sort { my $t = substr($s, $a, LOOKAHEAD_LEN); my $u = substr($s, $b, LOOKAHEAD_LEN); if (length($t) < LOOKAHEAD_LEN) { $t .= substr($s, 0, ($a < LOOKAHEAD_LEN) ? $a : (LOOKAHEAD_LEN - length($t))); } if (length($u) < LOOKAHEAD_LEN) { $u .= substr($s, 0, ($b < LOOKAHEAD_LEN) ? $b : (LOOKAHEAD_LEN - length($u))); } ($t cmp $u) || ((substr($s, $a) . substr($s, 0, $a)) cmp(substr($s, $b) . substr($s, 0, $b))) } 0 .. length($s) - 1 ]; } sub bwt_balanced ($s) { # O(n * LOOKAHEAD_LEN) space (fast) #<<< [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || ((substr($s, $a->[1]) . substr($s, 0, $a->[1])) cmp (substr($s, $b->[1]) . substr($s, 0, $b->[1]))) } map { my $t = substr($s, $_, LOOKAHEAD_LEN); if (length($t) < LOOKAHEAD_LEN) { $t .= substr($s, 0, ($_ < LOOKAHEAD_LEN) ? $_ : (LOOKAHEAD_LEN - length($t))); } [$t, $_] } 0 .. length($s) - 1 ]; #>>> } sub bwt_balanced_double ($s) { # O(n * LOOKAHEAD_LEN) space (fast) #<<< my $len = length($s); my $double_s = $s . $s; # Pre-compute doubled string # Schwartzian transform with optimized sorting return [ map { $_->[1] } sort { ($a->[0] cmp $b->[0]) || (substr($double_s, $a->[1], $len) cmp substr($double_s, $b->[1], $len)) } map { my $pos = $_; my $end = $pos + LOOKAHEAD_LEN; # Handle wraparound efficiently my $t = ($end <= $len) ? substr($s, $pos, LOOKAHEAD_LEN) : substr($double_s, $pos, LOOKAHEAD_LEN); [$t, $pos] } 0 .. $len - 1 ]; #>>> } sub bwt_encode ($s) { #my $bwt = bwt_simple($s); #my $bwt = bwt_quadratic($s); #my $bwt = bwt_cyclic($s); #my $bwt = bwt_lookahead($s); #my $bwt = bwt_balanced($s); my $bwt = bwt_balanced_double($s); my $ret = ''; my $idx = 0; my $i = 0; foreach my $pos (@$bwt) { $ret .= substr($s, $pos - 1, 1); $idx = $i if !$pos; ++$i; } return ($ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = split(//, $bwt); my @head = sort @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my $dec = ''; my $i = $idx; for (1 .. scalar(@head)) { $dec .= $head[$i]; $i = $table[$i]; } return $dec; } #<<< my @tests = ( "banana", "appellee", "dogwood", "TOBEORNOTTOBEORTOBEORNOT", "SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES", "PINEAPPLE", "","a","aa","aabb","aaaaaaaaaaaa","aaaaaaaaaaaab", "baaaaaaaaaaaa","aaaaaabaaaaaa","aaaaaaabaaaaa", ); #>>> foreach my $file (__FILE__, $^X) { push @tests, do { open my $fh, '<:raw', $file; local $/; <$fh>; }; } foreach my $str (@tests) { my ($enc, $idx) = bwt_encode($str); my $dec = bwt_decode($enc, $idx); if (length($str) < 1024) { say "BWT($dec) = ($enc, $idx)"; } $dec eq $str or die "error: <<$dec>> != <<$str>>"; } __END__ BWT(banana) = (nnbaaa, 3) BWT(appellee) = (eelplepa, 0) BWT(dogwood) = (odoodwg, 1) BWT(TOBEORNOTTOBEORTOBEORNOT) = (OOOBBBRRTTTEEENNOOORTTOO, 20) BWT(SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES) = (TEXYDST.E.IXIXIXXSSMPPS.B..E.S.EUSFXDIIOIIIT, 29) BWT(PINEAPPLE) = (ENLPPIEPA, 6) ================================================ FILE: Encoding/burrows-wheeler_transform_symbolic.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # Edit: 18 March 2024 # https://github.com/trizen # Implementation of the Burrows–Wheeler transform, generalized to work over any array of numerical symbols. # References: # Data Compression (Summer 2023) - Lecture 12 - The Burrows-Wheeler Transform (BWT) # https://youtube.com/watch?v=rQ7wwh4HRZM # # Data Compression (Summer 2023) - Lecture 13 - BZip2 # https://youtube.com/watch?v=cvoZbBZ3M2A use 5.036; sub bwt_cyclic ($s) { # O(n) space (slowish) my @cyclic = @$s; my $len = scalar(@cyclic); my $rle = 1; foreach my $i (1 .. $len - 1) { if ($cyclic[$i] != $cyclic[$i - 1]) { $rle = 0; last; } } $rle && return [0 .. $len - 1]; [ sort { my ($i, $j) = ($a, $b); while ($cyclic[$i] == $cyclic[$j]) { $i %= $len if (++$i >= $len); $j %= $len if (++$j >= $len); } $cyclic[$i] <=> $cyclic[$j]; } 0 .. $len - 1 ]; } sub bwt_encode ($s) { my $bwt = bwt_cyclic($s); my @ret = map { $s->[$_ - 1] } @$bwt; my $idx = 0; foreach my $i (@$bwt) { $i || last; ++$idx; } return (\@ret, $idx); } sub bwt_decode ($bwt, $idx) { # fast inversion my @tail = @$bwt; my @head = sort { $a <=> $b } @tail; my %indices; foreach my $i (0 .. $#tail) { push @{$indices{$tail[$i]}}, $i; } my @table; foreach my $v (@head) { push @table, shift(@{$indices{$v}}); } my @dec; my $i = $idx; for (1 .. scalar(@head)) { push @dec, $head[$i]; $i = $table[$i]; } return \@dec; } #<<< my @tests = ( "banana", "appellee", "dogwood", "TOBEORNOTTOBEORTOBEORNOT", "SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES", "PINEAPPLE", "","a","aa","aabb","aaaaaaaaaaaa","aaaaaaaaaaaab", "baaaaaaaaaaaa","aaaaaabaaaaaa","aaaaaaabaaaaa", ); #>>> foreach my $file (__FILE__, $^X) { push @tests, do { open my $fh, '<:raw', $file; local $/; <$fh>; }; } foreach my $str (@tests) { my ($enc, $idx) = bwt_encode([unpack('C*', $str)]); my $dec = bwt_decode($enc, $idx); if (length($str) < 1024) { printf("BWT(%s) = (%s, %d)\n", pack('C*', @$dec), pack('C*', @$enc), $idx); } pack('C*', @$dec) eq $str or die sprintf("error: <<%s>> != <<%s>>", pack('C*', @$dec), $str); } __END__ BWT(banana) = (nnbaaa, 3) BWT(appellee) = (eelplepa, 0) BWT(dogwood) = (odoodwg, 1) BWT(TOBEORNOTTOBEORTOBEORNOT) = (OOOBBBRRTTTEEENNOOORTTOO, 20) BWT(SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES) = (TEXYDST.E.IXIXIXXSSMPPS.B..E.S.EUSFXDIIOIIIT, 29) BWT(PINEAPPLE) = (ENLPPIEPA, 6) BWT() = (, 0) BWT(a) = (a, 0) BWT(aa) = (aa, 0) BWT(aabb) = (baba, 0) BWT(aaaaaaaaaaaa) = (aaaaaaaaaaaa, 0) BWT(aaaaaaaaaaaab) = (baaaaaaaaaaaa, 0) BWT(baaaaaaaaaaaa) = (baaaaaaaaaaaa, 12) BWT(aaaaaabaaaaaa) = (baaaaaaaaaaaa, 6) BWT(aaaaaaabaaaaa) = (baaaaaaaaaaaa, 5) ================================================ FILE: Encoding/delta_encoding_with_double-elias_coding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # https://github.com/trizen # Implementation of the Delta encoding scheme, combined with Elias gamma encoding, optimized for very large deltas. # Reference: # Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction # https://youtube.com/watch?v=-3H_eDbWNEU use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($str) { open my $fh, '<:raw', \$str; my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } my @integers = map { int(rand($_)) } 1 .. 1000; my $str = delta_encode([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = delta_decode($str); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; { open my $fh, '<:raw', __FILE__; my $str = do { local $/; <$fh> }; my $encoded = delta_encode([unpack('C*', $str)]); my $decoded = delta_decode($encoded); $str eq pack('C*', @$decoded) or die "error"; } __END__ Encoded length: 1763 Rawdata length: 3615 ================================================ FILE: Encoding/delta_encoding_with_elias_coding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # https://github.com/trizen # Implementation of the Delta encoding scheme, combined with Elias gamma encoding, optimized for moderately large deltas. # Reference: # Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction # https://youtube.com/watch?v=-3H_eDbWNEU use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($str) { open my $fh, '<:raw', \$str; my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } my @integers = map { int(rand($_)) } 1 .. 1000; my $str = delta_encode([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = delta_decode($str); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; { open my $fh, '<:raw', __FILE__; my $str = do { local $/; <$fh> }; my $encoded = delta_encode([unpack('C*', $str)]); my $decoded = delta_decode($encoded); $str eq pack('C*', @$decoded) or die "error"; } __END__ Encoded length: 1882 Rawdata length: 3626 ================================================ FILE: Encoding/delta_encoding_with_unary_coding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 June 2023 # https://github.com/trizen # Implementation of the Delta encoding scheme, using unary coding. # Reference: # Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction # https://youtube.com/watch?v=-3H_eDbWNEU use 5.036; sub delta_encode ($bytes) { my @deltas; my $prev = 0; while (@$bytes) { my $curr = shift(@$bytes); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (abs($d) - 1)) . '0'; } } return $bitstring; } sub delta_decode ($bitstring) { my @bits = split(//, $bitstring); my @deltas; while (@bits) { my $bit = shift(@bits); if ($bit eq '0') { push @deltas, 0; } else { my $bit = shift(@bits); my $n = 1; ++$n while (shift(@bits) eq '1'); push @deltas, ($bit eq '1' ? $n : -$n); } } my @acc; my $prev = 0; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } my $str = "TOBEORNOTTOBEORTOBEORNOT"; my $encoded = delta_encode([unpack('C*', $str)]); my $decoded = delta_decode($encoded); say "Encoded: ", "$encoded"; say "Decoded: ", pack('C*', @$decoded); $str eq pack('C*', @$decoded) or die "error"; { open my $fh, '<:raw', __FILE__; my $str = do { local $/; <$fh> }; my $encoded = delta_encode([unpack('C*', $str)]); my $decoded = delta_decode($encoded); $str eq pack('C*', @$decoded) or die "error"; } __END__ Encoded: 111111111111111111111111111111111111111111111111111111111111111111111111111111111111101011110101111111111110111101111111111101111010111011011111100101111010111111111111011110111111111110111101110101111010111111111111011110111111111110111101011101101111110 Decoded: TOBEORNOTTOBEORTOBEORNOT ================================================ FILE: Encoding/delta_rle_elias_encoding.pl ================================================ #!/usr/bin/perl # Implementation of Delta + Run-length + Elias coding, for encoding arbitrary integers. # References: # Data Compression (Summer 2023) - Lecture 5 - Basic Techniques # https://youtube.com/watch?v=TdFWb8mL5Gk # # Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction # https://youtube.com/watch?v=-3H_eDbWNEU use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub DRE_encoding ($integers, $double = 0) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; my $rle = run_length(\@deltas); foreach my $cv (@$rle) { my ($c, $v) = @$cv; if ($c == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($c) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . (($c < 0) ? '0' : '1') . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($c)); $bitstring .= '1' . (($c < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } if ($v == 1) { $bitstring .= '0'; } else { my $t = sprintf('%b', $v); $bitstring .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } pack('B*', $bitstring); } sub DRE_decoding ($bitstring, $double = 0) { open my $fh, '<:raw', \$bitstring; my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer) // last; if ($bit eq '0') { push @deltas, 0; } elsif ($double) { my $bit = read_bit($fh, \$buffer); my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @deltas, ($bit eq '1' ? 1 : -1) * ($int - 1); } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } my $bl = 0; while (read_bit($fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { my $run = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)) - 1; $k += $run; push @deltas, ($deltas[-1]) x $run; } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } my $str = join('', 'a' x 13, 'b' x 14, 'c' x 10, 'd' x 3, 'e' x 1, 'f' x 1, 'g' x 4); my @bytes = unpack('C*', $str); my $enc = DRE_encoding(\@bytes); my $dec = pack('C*', @{DRE_decoding($enc)}); say unpack('B*', $enc); say $dec; $dec eq $str or die "error: $dec != $str"; do { my @integers = map { int(rand($_)) } 1 .. 1000; my $str = DRE_encoding([@integers], 1); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = DRE_decoding($str, 1); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; { open my $fh, '<:raw', __FILE__; my $str = do { local $/; <$fh> }; my $encoded = DRE_encoding([unpack('C*', $str)], 1); my $decoded = DRE_decoding($encoded, 1); $str eq pack('C*', @$decoded) or die "error"; } } __END__ Encoded length: 1879 Rawdata length: 3628 ================================================ FILE: Encoding/double-elias_gamma_encoding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 June 2023 # https://github.com/trizen # Implementation of the double-variant of the Elias gamma encoding scheme, optimized for large integers. # Reference: # COMP526 7-5 SS7.4 Run length encoding # https://youtube.com/watch?v=3jKLjmV1bL8 use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub elias_encoding ($integers) { my $bitstring = ''; foreach my $k (scalar(@$integers), @$integers) { if ($k == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', $k + 1); my $l = length($t); my $L = sprintf('%b', $l); $bitstring .= ('1' x (length($L) - 1)) . '0' . substr($L, 1) . substr($t, 1); } } pack('B*', $bitstring); } sub elias_decoding ($str) { open my $fh, '<:raw', \$str; my @ints; my $len = 0; my $buffer = ''; for (my $k = 0 ; $k <= $len ; ++$k) { my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); if ($bl > 0) { my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @ints, $int - 1; } else { push @ints, 0; } if ($k == 0) { $len = pop(@ints); } } return \@ints; } my @integers = map { int(rand($_)) } 1 .. 1000; my $str = elias_encoding([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = elias_decoding($str); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; __END__ Encoded length: 1631 Rawdata length: 3616 ================================================ FILE: Encoding/elias_gamma_encoding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 June 2023 # https://github.com/trizen # Implementation of the Elias gamma encoding scheme. # Reference: # COMP526 7-5 SS7.4 Run length encoding # https://youtube.com/watch?v=3jKLjmV1bL8 use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub elias_encoding ($integers) { my $bitstring = ''; foreach my $k (scalar(@$integers), @$integers) { my $t = sprintf('%b', $k + 1); $bitstring .= ('1' x (length($t) - 1)) . '0' . substr($t, 1); } pack('B*', $bitstring); } sub elias_decoding ($str) { open my $fh, '<:raw', \$str; my @ints; my $len = 0; my $buffer = ''; for (my $k = 0 ; $k <= $len ; ++$k) { my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); push @ints, oct('0b' . '1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)) - 1; if ($k == 0) { $len = pop(@ints); } } return \@ints; } my @integers = map { int(rand($_)) } 1 .. 1000; my $str = elias_encoding([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = elias_decoding($str); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; __END__ Encoded length: 1777 Rawdata length: 3594 ================================================ FILE: Encoding/eyes_dropper.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Created on: 01 July 2011 (00:01 AM) # Latest edit on: 24 December 2011 # Transforms a phrase in a Perl regex, using only punctuation characters. use strict; use warnings; use List::Util ('shuffle'); my $phrase; my @content; my %chars_table; my $quote = 0; my $compact = 0; my $exec_code = 0; my $eval_code = 0; my $brake_after = 8; my @symbols = shuffle(qw'^ + " * [ & | < ` / { > ; : ( ) ? - = } @ . ] $ _ % !', (',', '#')); foreach my $arg (@ARGV) { if (-f $arg) { open my $fh, '<', $arg or die $!; sysread $fh, $phrase, -s $arg; close $fh; next; } if (substr($arg, 0, 1) eq '-') { if ($arg =~ /^-+(?:h|help|usage|\?)$/) { usage(); } elsif ($arg =~ /^-+exec(?:ute)?$/) { $exec_code = 1; } elsif ($arg =~ /^-+e(?:val)?$/) { $eval_code = 1; } elsif ($arg =~ /^-+e(?:val)?2$/) { $eval_code = 2; } elsif ($arg =~ /^-+c(?:ompact)?$/) { $compact = 1; } elsif ($arg =~ /^-+q(?:uote(?:meta)?)?$/) { $quote = 1; } elsif ($arg =~ /^-+(\d+)$/) { $brake_after = $1; } } } unless (defined $phrase) { my @words = grep { substr($_, 0, 1) ne '-' } @ARGV; $phrase = @words ? join(' ', @words) : 'Just another Perl hacker,'; } sub usage { print " usage: $0 [...] \noptions: /my/file : encode text from a file -num : newline before N chars (ex: -10) -exec : execute code (unix only) -print : print text using single quotes (default) -eval : eval code using single quotes -eval2 : eval code using a code block -compact : compact code (not for files) -quote : quotemeta special characters\n\n"; exit; } my $char_to_quote = $quote ? qr/['\\{}]/ : qr/['\\]/; my $action; if ($exec_code) { $action = q[$x='/tmp/.x';open my $fh,">$x";system qq|perl $x| if print $fh]; } elsif ($eval_code) { $action = 'eval'; } else { $action = 'print'; } if ($compact) { $phrase =~ s/~/\\~/g; $phrase = "$action q~$phrase\n"; } elsif (defined $action and not $eval_code == 2) { push @content, qq[use re 'eval';'\n'=~('(?{'.]; $phrase = "$action <<'Q_M';\n$phrase\nQ_M\n"; } elsif (defined $action and $eval_code == 2) { push @content, q[''=~('(?{'.]; $phrase = "${action} {$phrase}"; } my %memoize; LOOP_1: foreach my $letter (split(//, $phrase, 0)) { if (exists $chars_table{$letter}) { next LOOP_1 if $chars_table{$letter} eq 'Not found!'; $compact ? push(@content, $chars_table{$letter}) : ( ref($chars_table{$letter}) eq 'ARRAY' ? push(@content, "('$chars_table{$letter}[0]'^'$chars_table{$letter}[1]').") : push(@content, $chars_table{$letter}) ); next LOOP_1; } foreach my $simb (@symbols) { foreach my $chr (@symbols) { next if exists $memoize{$simb . $chr}; next if exists $memoize{$chr . $simb}; ++$memoize{$simb . $chr}; ++$memoize{$chr . $simb}; $chars_table{$simb ^ $chr} = [$simb, $chr]; if (exists $chars_table{$letter}) { if ($compact) { push @content, [$simb, $chr]; next LOOP_1; } else { push @content, "('${simb}'^'${chr}')."; next LOOP_1; } } } } if (not $compact) { $letter = quotemeta $letter if $letter =~ /$char_to_quote/o; push @content, "('${letter}')."; $chars_table{$letter} = "('${letter}')."; } else { $chars_table{$letter} = 'Not found!'; } } if ($compact) { print q[''=~('(?{'.('], (map { $content[$_][0] } 0 .. $#content), q['^'], (map { $content[$_][1] } 0 .. $#content), q[').'~})');], "\n"; } else { for (my $i = $brake_after - 1 ; $i <= $#content ; $i += $brake_after) { splice @content, $i, 0, "\n"; } print @content, "'})');\n"; } ================================================ FILE: Encoding/fibonacci_coding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 19 March 2024 # https://github.com/trizen # Implementation of the Fibonacci coding method. # References: # Information Retrieval WS 17/18, Lecture 4: Compression, Codes, Entropy # https://youtube.com/watch?v=A_F94FV21Ek # # Fibonacci coding # https://en.wikipedia.org/wiki/Fibonacci_coding use 5.036; use List::Util qw(shuffle); sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub fibonacci_coding ($symbols) { my $bitstring = ''; foreach my $n (@$symbols) { my ($f1, $f2, $f3) = (0, 1, 1); my ($rn, $s, $k) = ($n, '', 2); for (; $f3 <= $rn ; ++$k) { ($f1, $f2, $f3) = ($f2, $f3, $f2 + $f3); } foreach my $i (1 .. $k - 2) { ($f3, $f2, $f1) = ($f2, $f1, $f2 - $f1); if ($f3 <= $rn) { $rn -= $f3; $s .= '1'; } else { $s .= '0'; } } $bitstring .= reverse($s) . '1'; } pack('B*', $bitstring); } sub bsearch_le ($left, $right, $callback) { my ($mid, $cmp); for (; ;) { $mid = int(($left + $right) / 2); $cmp = $callback->($mid) || return $mid; if ($cmp < 0) { $left = $mid + 1; $left > $right and last; } else { $right = $mid - 1; if ($left > $right) { $mid -= 1; last; } } } return $mid; } { my @FIB = (0, 1); sub find_fibonacci ($n) { if ($n == 1) { return (2, 0, 1, 1); } if ($n >= $FIB[-1]) { my ($f1, $f2) = ($FIB[-2], $FIB[-1]); while (1) { ($f1, $f2) = ($f2, $f1 + $f2); push @FIB, $f2; last if ($f2 >= $n); } } my $k = bsearch_le(0, $#FIB, sub ($k) { $FIB[$k] <=> $n }); return ($k, $FIB[$k - 1], $FIB[$k], $FIB[$k + 1]); } } sub fibonacci_coding_cached ($symbols) { my $bitstring = ''; foreach my $n (@$symbols) { my ($rn, $s) = ($n, ''); my ($k, $f1, $f2, $f3) = find_fibonacci($n); foreach my $i (1 .. $k - 1) { ($f3, $f2, $f1) = ($f2, $f1, $f2 - $f1); if ($f3 <= $rn) { $rn -= $f3; $s .= '1'; } else { $s .= '0'; } } $bitstring .= reverse($s) . '1'; } return pack('B*', $bitstring); } sub fibonacci_decoding ($str) { open my $fh, '<:raw', \$str; my @symbols; my $enc = ''; my $prev_bit = '0'; my $buffer = ''; while (1) { my $bit = read_bit($fh, \$buffer) // last; if ($bit eq '1' and $prev_bit eq '1') { my ($value, $f1, $f2) = (0, 1, 1); foreach my $bit (split //, $enc) { $value += $f2 if $bit; ($f1, $f2) = ($f2, $f1 + $f2); } push @symbols, $value; $enc = ''; $prev_bit = '0'; } else { $enc .= $bit; $prev_bit = $bit; } } return \@symbols; } my @integers = shuffle(grep { $_ > 0 } map { int(rand($_)) } 1 .. 1000); my $str = fibonacci_coding([@integers]); my $str2 = fibonacci_coding_cached([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = fibonacci_decoding($str); $str eq $str2 or die "Encoding error"; join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; __END__ Encoded length: 1428 Rawdata length: 3608 ================================================ FILE: Encoding/huffman_coding.pl ================================================ #!/usr/bin/perl # https://rosettacode.org/wiki/Huffman_coding#Perl use 5.020; use strict; use warnings; use experimental qw(signatures); # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0]; if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for (0, 1) } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree ($bytes) { my (%freq, @nodes); ++$freq{$_} for @$bytes; @nodes = map { [$_, $freq{$_}] } sort { $a <=> $b } keys %freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub encode ($bytes, $dict) { join('', map { $dict->{$_} // die("bad char $_") } @$bytes); } sub decode ($str, $dict) { my ($seg, @out) = (""); # append to current segment until it's in the dictionary foreach my $bit (split('', $str)) { $seg .= $bit; my $x = $dict->{$seg} // next; push @out, $x; $seg = ''; } die "bad code" if length($seg); return \@out; } my $txt = 'this is an example for huffman encoding'; my @bytes = unpack('C*', $txt); my ($h, $rev_h) = mktree(\@bytes); for (keys %$h) { printf("%3d: %s\n", $_, $h->{$_}) } my $enc = encode(\@bytes, $h); say $enc; my $dec = decode($enc, $rev_h); say pack('C*', @$dec); ================================================ FILE: Encoding/int2bytes.pl ================================================ #!/usr/bin/perl # Author: Șuteu "Trizen" Daniel # License: GPLv3 # Date: 18 August 2013 # https://trizenx.blogspot.com # Get all the shortest possible combinations of byte values for a large integer. use 5.010; use strict; use warnings; use List::Util qw(min); sub _make_map { my ($int) = @_; my @groups = ([], [], []); for my $i (1 .. 3) { foreach my $j (0 .. length($int) - $i) { $i > 1 && substr($int, $j, 1) == 0 && next; (my $num = substr($int, $j, $i)) > 255 && next; $groups[$i - 1][$j] = $num; } } my @map = [[]]; for (my $j = 0 ; $j <= $#{$groups[0]} ; $j++) { for (my $i = $j ; $i <= $#{$groups[0]} ; $i++) { if (defined($groups[2][$i])) { push @{$map[$j][$j]}, $groups[2][$i]; $i += 2; } elsif (defined($groups[1][$i])) { push @{$map[$j][$j]}, $groups[1][$i]; $i += 1; } else { push @{$map[$j][$j]}, $groups[0][$i]; } } } return \@map; } sub int2bytes { my ($int) = @_; my $data = _make_map($int); my @nums; foreach my $arr (@{$data}) { for my $i (0 .. $#{$arr}) { if (ref($arr->[$i]) eq 'ARRAY') { my $head = _make_map(substr($int, 0, $i)); push @nums, [@{$head->[0][0]}, @{$arr->[$i]}]; } } } my $min = min(map { $#{$_} } @nums); my @bytes = do { my %seen; grep { !$seen{join(' ', @{$_})}++ } grep { $#{$_} == $min } @nums; }; return \@bytes; } # ## MAIN # my $bigint = shift() // '8379776984727378713267797976'; my $array = int2bytes($bigint); foreach my $byte_seq (@{$array}) { say "@{$byte_seq}"; say map { chr } @{$byte_seq}; print "\n"; } ================================================ FILE: Encoding/integers_binary_encoding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 23 March 2023 # https://github.com/trizen # Encode and decode a random list of integers into a binary string, using increasing fixed-width segments. use 5.036; sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; my $compressed = chr(scalar @counts); foreach my $pair (@counts) { my ($blen, $len) = @$pair; $compressed .= chr($blen); $compressed .= pack('N', $len); } my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($str) { open my $fh, '<:raw', \$str; my $count_len = ord(getc($fh)); my @counts; my $bits_len = 0; for (1 .. $count_len) { my $blen = ord(getc($fh)); my $len = unpack('N', join('', map { getc($fh) } 1 .. 4)); push @counts, [$blen + 0, $len + 0]; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @chunks; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @chunks, oct('0b' . $chunk); } } return \@chunks; } my @integers = map { int(rand($_)) } 1 .. 1000; my $str = encode_integers([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = decode_integers($str); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; __END__ Encoded length: 1168 Rawdata length: 3625 ================================================ FILE: Encoding/integers_binary_encoding_with_delta_coding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 23 March 2023 # Edit: 13 June 2023 # https://github.com/trizen # Encode and decode a random list of integers into a binary string, using increasing fixed-width segments. use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } sub encode_integers ($integers) { my @counts; my $count = 0; my $bits_width = 1; my $bits_max_symbol = 1 << $bits_width; my $processed_len = 0; foreach my $k (@$integers) { while ($k >= $bits_max_symbol) { if ($count > 0) { push @counts, [$bits_width, $count]; $processed_len += $count; } $count = 0; $bits_max_symbol *= 2; $bits_width += 1; } ++$count; } push @counts, grep { $_->[1] > 0 } [$bits_width, scalar(@$integers) - $processed_len]; my $compressed = delta_encode([(map { $_->[0] } @counts), (map { $_->[1] } @counts)]); my $bits = ''; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $symbol (splice(@$integers, 0, $len)) { $bits .= sprintf("%0*b", $blen, $symbol); } } $compressed .= pack('B*', $bits); return $compressed; } sub decode_integers ($str) { open my $fh, '<:raw', \$str; my $ints = delta_decode($fh); my $half = scalar(@$ints) >> 1; my @counts; foreach my $i (0 .. ($half - 1)) { push @counts, [$ints->[$i], $ints->[$half + $i]]; } my $bits_len = 0; foreach my $pair (@counts) { my ($blen, $len) = @$pair; $bits_len += $blen * $len; } my $bits = read_bits($fh, $bits_len); my @integers; foreach my $pair (@counts) { my ($blen, $len) = @$pair; foreach my $chunk (unpack(sprintf('(a%d)*', $blen), substr($bits, 0, $blen * $len, ''))) { push @integers, oct('0b' . $chunk); } } return \@integers; } my @integers = map { int(rand($_)) } 1 .. 1000; my $str = encode_integers([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = decode_integers($str); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; __END__ Encoded length: 1133 Rawdata length: 3633 ================================================ FILE: Encoding/integers_binary_encoding_with_huffman_coding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 June 2023 # https://github.com/trizen # Encode and decode a random list of integers into a binary string, using a DEFLATE-like approach + Huffman coding. use 5.036; use List::Util qw(max shuffle); use constant {MAX_INT => 0b11111111111111111111111111111111}; # [distance value, offset bits] my @DISTANCE_SYMBOLS = (map { [$_, 0] } 0 .. 4); until ($DISTANCE_SYMBOLS[-1][0] > MAX_INT) { push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (4 / 3)), $DISTANCE_SYMBOLS[-1][1] + 1]; push @DISTANCE_SYMBOLS, [int($DISTANCE_SYMBOLS[-1][0] * (3 / 2)), $DISTANCE_SYMBOLS[-1][1]]; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub read_bits ($fh, $bits_len) { my $data = ''; read($fh, $data, $bits_len >> 3); $data = unpack('B*', $data); while (length($data) < $bits_len) { $data .= unpack('B*', getc($fh) // return undef); } if (length($data) > $bits_len) { $data = substr($data, 0, $bits_len); } return $data; } sub delta_encode ($integers) { my @deltas; my $prev = 0; unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($fh) { my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } return \@acc; } # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub huffman_encode ($bytes, $dict) { join('', @{$dict}{@$bytes}); } sub huffman_decode ($bits, $hash) { local $" = '|'; $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr; # very fast } sub create_huffman_entry ($bytes, $out_fh) { my %freq; ++$freq{$_} for @$bytes; my ($h, $rev_h) = mktree_from_freq(\%freq); my $enc = huffman_encode($bytes, $h); my $max_symbol = max(keys %freq) // 0; my @freqs; foreach my $i (0 .. $max_symbol) { push @freqs, $freq{$i} // 0; } print $out_fh delta_encode(\@freqs); print $out_fh pack("N", length($enc)); print $out_fh pack("B*", $enc); } sub decode_huffman_entry ($fh) { my @freqs = @{delta_decode($fh)}; my %freq; foreach my $i (0 .. $#freqs) { if ($freqs[$i]) { $freq{$i} = $freqs[$i]; } } my (undef, $rev_dict) = mktree_from_freq(\%freq); foreach my $k (keys %$rev_dict) { $rev_dict->{$k} = chr($rev_dict->{$k}); } my $enc_len = unpack('N', join('', map { getc($fh) } 1 .. 4)); if ($enc_len > 0) { return huffman_decode(read_bits($fh, $enc_len), $rev_dict); } return ''; } sub encode_integers_deflate_like ($integers) { my @symbols; my $offset_bits = ''; foreach my $dist (@$integers) { foreach my $i (0 .. $#DISTANCE_SYMBOLS) { if ($DISTANCE_SYMBOLS[$i][0] > $dist) { push @symbols, $i - 1; if ($DISTANCE_SYMBOLS[$i - 1][1] > 0) { $offset_bits .= sprintf('%0*b', $DISTANCE_SYMBOLS[$i - 1][1], $dist - $DISTANCE_SYMBOLS[$i - 1][0]); } last; } } } my $str = ''; open(my $out_fh, '>:raw', \$str); create_huffman_entry(\@symbols, $out_fh); print $out_fh pack('B*', $offset_bits); return $str; } sub decode_integers_deflate_like ($str) { open(my $fh, '<:raw', \$str); my @symbols = unpack('C*', decode_huffman_entry($fh)); my $bits_len = 0; foreach my $i (@symbols) { $bits_len += $DISTANCE_SYMBOLS[$i][1]; } my $bits = read_bits($fh, $bits_len); my @distances; foreach my $i (@symbols) { push @distances, $DISTANCE_SYMBOLS[$i][0] + oct('0b' . substr($bits, 0, $DISTANCE_SYMBOLS[$i][1], '')); } return \@distances; } my @integers = shuffle(map { int(rand($_)) } 1 .. 1000); my $str = encode_integers_deflate_like([@integers]); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = decode_integers_deflate_like($str); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; __END__ Encoded length: 1196 Rawdata length: 3590 ================================================ FILE: Encoding/jpeg_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 21 December 2023 # https://github.com/trizen # Apply the irreversible JPEG transform on arbitrary data. (lossy transform) use 5.020; use strict; use warnings; use GD qw(); use Getopt::Long qw(GetOptions); use experimental qw(signatures); GD::Image->trueColor(1); binmode(STDIN, ':raw'); binmode(STDOUT, ':raw'); sub encode_data ($data) { my @bytes = unpack("C*", $data); my $c = 1 + int(scalar(@bytes) / 3); my $width = int(sqrt($c)); my $height = int($c / $width) + 1; say STDERR ":: Image size: $width x $height"; my $image = GD::Image->new($width, $height) or die "Can't create image"; my $size = scalar(@bytes); OUTER: foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { if ($size > 0) { my $index = $image->colorResolve(shift(@bytes) // 0, shift(@bytes) // 0, shift(@bytes) // 0); $image->setPixel($x, $y, $index); $size -= 3; } else { last OUTER; } } } return $image; } sub decode_data ($img_data, $length) { my $image = GD::Image->new($img_data) or die "Can't read image: $!"; my ($width, $height) = $image->getBounds(); my $data = ''; my $size = 0; OUTER: foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $index = $image->getPixel($x, $y); if ($size < $length) { my ($red, $green, $blue) = $image->rgb($index); $data .= pack('C3', $red, $green, $blue); $size += 3; } else { last OUTER; } } } while (length($data) > $length) { chop $data; } return $data; } my $quality = 100; my $save_image = undef; sub help ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input] [output] options: -q --quality=i : quality level in range 0-100 (default: $quality) -s --save-image=s : save the JPEG image to a given filename example: perl $0 input.txt transformed.txt EOT exit($exit_code); } GetOptions( 's|save-image=s' => \$save_image, 'q|quality=i' => \$quality, "h|help" => sub { help(0) }, ) or die("Error in command line arguments\n"); my $data_file = shift(@ARGV) // help(2); my $output_file = shift(@ARGV); my $data = do { open my $fh, '<:raw', $data_file or die "Can't open file <<$data_file>> for reading: $!"; local $/; <$fh>; }; my $img = encode_data($data); my $jpeg = $img->jpeg($quality); if (defined($save_image)) { open my $fh, '>:raw', $save_image or die "Can't open file <<$save_image>> for writing: $!"; print $fh $jpeg; close $fh; } my $transformed = decode_data($jpeg, length($data)); if (length($transformed) != length($data)) { die sprintf("Failed: len(T) = %d != len(D) = %d\n", length($transformed), length($data)); } if (defined($output_file)) { open my $fh, '>:raw', $output_file or die "Can't open file <<$output_file>> for writing: $!"; print $fh $transformed; close $fh; } else { print $transformed; } ================================================ FILE: Encoding/length_encoder.pl ================================================ #!?usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 04 May 2015 # Website: https://github.com/trizen # A very basic length encoder use 5.010; use strict; use warnings; use Data::Dump qw(pp); # produce encode and decode dictionary from a tree sub walk { my ($node, $code, $h) = @_; my $c = $node->[0]; if (ref $c) { walk($c->[$_], $code . $_, $h) for 0, 1 } else { $h->{$c} = $code } $h; } # make a tree, and return resulting dictionaries sub mktree { my %freq = @_; my @nodes = map { [$_, $freq{$_}] } keys %freq; if (@nodes == 1) { return {$nodes[0][0] => '0'}; } do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub length_encoder { my ($str) = @_; my %table; my @chars = split(//, $str); my $lim = $#chars; my %t; for (my $i = 0 ; $i < $lim ; $i++) { for (my $j = $i + 1 ; $j <= $lim ; $j++) { last if $j + ($j - $i) + 1 > $lim; my $key = join('', @chars[$i .. $j]); if (join('', @chars[$j + 1 .. $j + ($j - $i) + 1]) eq $key) { if (not exists $t{$key}) { if (exists $t{substr($key, 0, -1)}) { last; } $t{$key} = length($key); } else { $t{$key}++; } } } } my ($dict) = keys(%t) ? mktree(%t) : {}; my @sorted_tokens = sort { length($dict->{$a}) <=> length($dict->{$b}) or $t{$b} <=> $t{$a} or $a cmp $b } keys %t; say "Weights: ", pp(\%t); say "Sorted: @sorted_tokens"; say "Bits: ", pp($dict); my $regex = do { my @tries = map { "(?\Q$_\E)(?(?:\Q$_\E)*+)" } @sorted_tokens; local $" = '|'; @sorted_tokens ? qr/^(?:@tries|(?.))/s : qr/^(?.)/s; }; my $enc = ''; while ($str =~ s/$regex//) { my $m = $+{token}; my $r = $+{rest}; if (defined $r) { $enc .= ("[$dict->{$m}x" . (1 + length($r) / length($m)) . "]"); } else { $enc .= $m; } } return $enc; } foreach my $str ( qw( ABABABAB ABABABABAAAAAAAAAAAAAFFFFFFFFFFFFFFFFFFFDDDDDDDDDDDDDDDDDDDDJKLABABVADSABABAB DABDDB DABDDBBDDBA ABBDDD ABRACADABRA TOBEORNOTTOBEORTOBEORNOT ) ) { say "Encoding: $str"; say "Encoded: ", length_encoder($str); say "-" x 80; } ================================================ FILE: Encoding/lz77_encoding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 02 May 2024 # https://github.com/trizen # Simple implementation of LZ77 encoding. use 5.036; sub lz77_encode ($str) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my (@literals, @distances, @lengths); while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= 255 and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } --$n; push @distances, $la - $p; push @lengths, $n; push @literals, $chars[$la + $n]; $la += $n + 1; $prefix .= $token; } return (\@literals, \@distances, \@lengths); } sub lz77_decode ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]) . $literals->[$i]; $offset += $lengths->[$i] + 1; } return $chunk; } my $string = "TOBEORNOTTOBEORTOBEORNOT"; my ($literals, $distances, $lengths) = lz77_encode($string); my $decoded = lz77_decode($literals, $distances, $lengths); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; foreach my $i (0 .. $#$literals) { say "$literals->[$i] -- [$distances->[$i], $lengths->[$i]]"; } foreach my $file (__FILE__, $^X) { # several tests my $string = do { open my $fh, '<:raw', $file or die "error for <<$file>>: $!"; local $/; <$fh>; }; my ($literals, $distances, $lengths) = lz77_encode($string); my $decoded = lz77_decode($literals, $distances, $lengths); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; } __END__ T -- [0, 0] O -- [0, 0] B -- [0, 0] E -- [0, 0] R -- [3, 1] N -- [0, 0] T -- [3, 1] T -- [9, 6] T -- [15, 7] ================================================ FILE: Encoding/lz77_encoding_symbolic.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 03 May 2024 # https://github.com/trizen # Symbolic implementation of LZ77 encoding, using an hash table. use 5.036; sub lz77_encode_symbolic ($symbols) { if (ref($symbols) eq '') { return __SUB__->(string2symbols($symbols)); } my $la = 0; my $end = $#$symbols; my $min_len = 4; # minimum match length my $max_len = 255; # maximum match length my $max_dist = (1 << 16) - 1; # maximum match distance my $max_chain_len = 16; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my @lookahead_symbols; if ($la + $min_len - 1 <= $end) { push @lookahead_symbols, @{$symbols}[$la .. $la + $min_len - 1]; } else { for (my $j = 0 ; ($j < $min_len and $la + $j <= $end) ; ++$j) { push @lookahead_symbols, $symbols->[$la + $j]; } } my $lookahead = join(' ', @lookahead_symbols); if (exists($table{$lookahead})) { foreach my $p (@{$table{$lookahead}}) { if ($la - $p > $max_dist) { last; } my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols->[$la + $n - 1] == $symbols->[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; } } my @matched = @{$symbols}[$la .. $la + $best_n - 1]; foreach my $i (0 .. scalar(@matched) - $min_len) { my $key = join(' ', @matched[$i .. $i + $min_len - 1]); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } } if ($best_n == 1) { $table{$lookahead} = [$la]; } --$best_n; if ($best_n >= $min_len) { push @lengths, $best_n; push @distances, $la - $best_p; push @literals, $symbols->[$la + $best_n]; $la += $best_n + 1; } else { my @bytes = @{$symbols}[$best_p .. $best_p + $best_n]; push @lengths, (0) x scalar(@bytes); push @distances, (0) x scalar(@bytes); push @literals, @bytes; $la += $best_n + 1; } } return (\@literals, \@distances, \@lengths); } sub lz77_decode_symbolic ($literals, $distances, $lengths) { my @data; my $data_len = 0; foreach my $i (0 .. $#$lengths) { if ($lengths->[$i] != 0) { my $length = $lengths->[$i]; my $dist = $distances->[$i]; foreach my $j (1 .. $length) { push @data, $data[$data_len + $j - $dist - 1]; } $data_len += $length; } push @data, $literals->[$i]; $data_len += 1; } return \@data; } my $string = "abbaabbaabaabaaaa"; my ($literals, $distances, $lengths) = lz77_encode_symbolic([unpack('C*', $string)]); my $decoded = lz77_decode_symbolic($literals, $distances, $lengths); $string eq pack('C*', @$decoded) or die "error: <<$string>> != <<@$decoded>>"; foreach my $i (0 .. $#$literals) { say "$literals->[$i] -- [$distances->[$i], $lengths->[$i]]"; } foreach my $file (__FILE__, $^X) { # several tests my $string = do { open my $fh, '<:raw', $file or die "error for <<$file>>: $!"; local $/; <$fh>; }; my ($literals, $distances, $lengths) = lz77_encode_symbolic([unpack('C*', $string)]); my $decoded = lz77_decode_symbolic($literals, $distances, $lengths); $string eq pack('C*', @$decoded) or die "error: <<$string>> != <<@$decoded>>"; } ================================================ FILE: Encoding/lzss_encoding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 03 May 2024 # https://github.com/trizen # Simple implementation of LZSS encoding. use 5.036; sub lzss_encode ($str) { my $la = 0; my $prefix = ''; my @chars = split(//, $str); my $end = $#chars; my $min_len = 3; my $max_len = 255; my (@literals, @distances, @lengths); while ($la <= $end) { my $n = 1; my $p = length($prefix); my $tmp; my $token = $chars[$la]; while ( $n <= $max_len and $la + $n <= $end and ($tmp = rindex($prefix, $token, $p)) >= 0) { $p = $tmp; $token .= $chars[$la + $n]; ++$n; } if ($n > $min_len) { push @lengths, $n - 1; push @distances, $la - $p; push @literals, undef; $la += $n - 1; $prefix .= substr($token, 0, -1); } else { my @bytes = split(//, substr($prefix, $p, $n - 1) . $chars[$la + $n - 1]); push @lengths, (0) x scalar(@bytes); push @distances, (0) x scalar(@bytes); push @literals, @bytes; $la += $n; $prefix .= $token; } } return (\@literals, \@distances, \@lengths); } sub lzss_decode ($literals, $distances, $lengths) { my $chunk = ''; my $offset = 0; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] != 0) { $chunk .= substr($chunk, $offset - $distances->[$i], $lengths->[$i]); $offset += $lengths->[$i]; } else { $chunk .= $literals->[$i]; $offset += 1; } } return $chunk; } my $string = "TOBEORNOTTOBEORTOBEORNOT"; my ($literals, $distances, $lengths) = lzss_encode($string); my $decoded = lzss_decode($literals, $distances, $lengths); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] == 0) { say $literals->[$i]; } else { say "[$distances->[$i], $lengths->[$i]]"; } } foreach my $file (__FILE__, $^X) { # several tests my $string = do { open my $fh, '<:raw', $file or die "error for <<$file>>: $!"; local $/; <$fh>; }; my ($literals, $distances, $lengths) = lzss_encode($string); my $decoded = lzss_decode($literals, $distances, $lengths); say "Ratio: ", scalar(@$literals) / scalar(grep { defined($_) } @$literals); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; } __END__ T O B E O R N O T [9, 6] [15, 8] T Ratio: 1.44887348353553 Ratio: 1.50565184626978 ================================================ FILE: Encoding/lzss_encoding_hash_table.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 02 May 2024 # https://github.com/trizen # Implementation of LZSS encoding, using an hash table. use 5.036; sub lzss_encode ($str) { my $la = 0; my @chars = split(//, $str); my $end = $#chars; my $min_len = 4; # minimum match length my $max_len = 255; # maximum match length my $max_dist = (1 << 16) - 1; # maximum match distance my $max_chain_len = 16; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead})) { foreach my $p (@{$table{$lookahead}}) { if ($la - $p > $max_dist) { last; } my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $chars[$la + $n - 1] eq $chars[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; } } my $matched = substr($str, $la, $best_n); foreach my $i (0 .. length($matched) - $min_len) { my $key = substr($matched, $i, $min_len); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } } if ($best_n == 1) { $table{$lookahead} = [$la]; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @chars[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub lzss_decode ($literals, $distances, $lengths) { my @data; my $data_len = 0; foreach my $i (0 .. $#$lengths) { if ($lengths->[$i] == 0) { push @data, $literals->[$i]; $data_len += 1; next; } my $length = $lengths->[$i]; my $dist = $distances->[$i]; foreach my $j (1 .. $length) { push @data, $data[$data_len + $j - $dist - 1]; } $data_len += $length; } return join('', @data); } my $string = "abbaabbaabaabaaaa"; my ($literals, $distances, $lengths) = lzss_encode($string); my $decoded = lzss_decode($literals, $distances, $lengths); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] == 0) { say $literals->[$i]; } else { say "[$distances->[$i], $lengths->[$i]]"; } } foreach my $file (__FILE__, $^X) { # several tests my $string = do { open my $fh, '<:raw', $file or die "error for <<$file>>: $!"; local $/; <$fh>; }; my ($literals, $distances, $lengths) = lzss_encode($string); my $decoded = lzss_decode($literals, $distances, $lengths); say "Ratio: ", scalar(@$literals) / scalar(grep { defined($_) } @$literals); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; } __END__ a b b a [4, 6] [3, 5] a a Ratio: 1.35733333333333 Ratio: 1.44651830581479 ================================================ FILE: Encoding/lzss_encoding_hash_table_fast.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 02 May 2024 # https://github.com/trizen # Implementation of LZSS encoding, using an hash table. # A non-optimal, but very fast approach. use 5.036; sub lzss_encode($str) { my $la = 0; my @symbols = unpack('C*', $str); my $end = $#symbols; my $min_len = 4; # minimum match length my $max_len = 255; # maximum match length my $max_dist = (1 << 16) - 1; # maximum match distance my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my $lookahead = substr($str, $la, $min_len); if (exists($table{$lookahead}) and $la - $table{$lookahead} <= $max_dist) { my $p = $table{$lookahead}; my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols[$la + $n - 1] == $symbols[$p + $n - 1]) { ++$n; } $best_p = $p; $best_n = $n; } $table{$lookahead} = $la; if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub lzss_decode ($literals, $distances, $lengths) { my @data; my $data_len = 0; foreach my $i (0 .. $#$lengths) { if ($lengths->[$i] == 0) { push @data, $literals->[$i]; $data_len += 1; next; } my $length = $lengths->[$i]; my $dist = $distances->[$i]; foreach my $j (1 .. $length) { push @data, $data[$data_len + $j - $dist - 1]; } $data_len += $length; } pack('C*', @data); } my $string = "abbaabbaabaabaaaa"; my ($literals, $distances, $lengths) = lzss_encode($string); my $decoded = lzss_decode($literals, $distances, $lengths); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] == 0) { say $literals->[$i]; } else { say "[$distances->[$i], $lengths->[$i]]"; } } foreach my $file (__FILE__, $^X) { # several tests my $string = do { open my $fh, '<:raw', $file or die "error for <<$file>>: $!"; local $/; <$fh>; }; my ($literals, $distances, $lengths) = lzss_encode($string); my $decoded = lzss_decode($literals, $distances, $lengths); say "Ratio: ", scalar(@$literals) / scalar(grep { defined($_) } @$literals); $string eq $decoded or die "error: <<$string>> != <<$decoded>>"; } __END__ 97 98 98 97 [4, 6] 97 97 98 97 97 97 97 Ratio: 1.36301369863014 Ratio: 1.46043165467626 ================================================ FILE: Encoding/lzss_encoding_symbolic.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 02 May 2024 # https://github.com/trizen # Symbolic implementation of LZSS encoding, using an hash table. use 5.036; sub lzss_encode_symbolic ($symbols) { my $la = 0; my $end = $#$symbols; my $min_len = 4; # minimum match length my $max_len = 255; # maximum match length my $max_dist = (1 << 16) - 1; # maximum match distance my $max_chain_len = 16; # how many recent positions to keep track of my (@literals, @distances, @lengths, %table); while ($la <= $end) { my $best_n = 1; my $best_p = $la; my @lookahead_symbols; if ($la + $min_len - 1 <= $end) { push @lookahead_symbols, @{$symbols}[$la .. $la + $min_len - 1]; } else { for (my $j = 0 ; ($j < $min_len and $la + $j <= $end) ; ++$j) { push @lookahead_symbols, $symbols->[$la + $j]; } } my $lookahead = join(' ', @lookahead_symbols); if (exists($table{$lookahead})) { foreach my $p (@{$table{$lookahead}}) { if ($la - $p > $max_dist) { last; } my $n = $min_len; while ($n <= $max_len and $la + $n <= $end and $symbols->[$la + $n - 1] == $symbols->[$p + $n - 1]) { ++$n; } if ($n > $best_n) { $best_p = $p; $best_n = $n; } } my @matched = @{$symbols}[$la .. $la + $best_n - 1]; foreach my $i (0 .. scalar(@matched) - $min_len) { my $key = join(' ', @matched[$i .. $i + $min_len - 1]); unshift @{$table{$key}}, $la + $i; if (scalar(@{$table{$key}}) > $max_chain_len) { pop @{$table{$key}}; } } } if ($best_n == 1) { $table{$lookahead} = [$la]; } if ($best_n > $min_len) { push @lengths, $best_n - 1; push @distances, $la - $best_p; push @literals, undef; $la += $best_n - 1; } else { push @lengths, (0) x $best_n; push @distances, (0) x $best_n; push @literals, @$symbols[$best_p .. $best_p + $best_n - 1]; $la += $best_n; } } return (\@literals, \@distances, \@lengths); } sub lzss_decode_symbolic ($literals, $distances, $lengths) { my @data; my $data_len = 0; foreach my $i (0 .. $#$lengths) { if ($lengths->[$i] == 0) { push @data, $literals->[$i]; $data_len += 1; next; } my $length = $lengths->[$i]; my $dist = $distances->[$i]; foreach my $j (1 .. $length) { push @data, $data[$data_len + $j - $dist - 1]; } $data_len += $length; } return \@data; } my $string = "abbaabbaabaabaaaa"; my ($literals, $distances, $lengths) = lzss_encode_symbolic([unpack('C*', $string)]); my $decoded = lzss_decode_symbolic($literals, $distances, $lengths); $string eq pack('C*', @$decoded) or die "error: <<$string>> != <<@$decoded>>"; foreach my $i (0 .. $#$literals) { if ($lengths->[$i] == 0) { say $literals->[$i]; } else { say "[$distances->[$i], $lengths->[$i]]"; } } foreach my $file (__FILE__, $^X) { # several tests my $string = do { open my $fh, '<:raw', $file or die "error for <<$file>>: $!"; local $/; <$fh>; }; my ($literals, $distances, $lengths) = lzss_encode_symbolic([unpack('C*', $string)]); my $decoded = lzss_decode_symbolic($literals, $distances, $lengths); say "Ratio: ", scalar(@$literals) / scalar(grep { defined($_) } @$literals); $string eq pack('C*', @$decoded) or die "error: <<$string>> != <<@$decoded>>"; } __END__ 97 98 98 97 [4, 6] [3, 5] 97 97 Ratio: 1.38851802403204 Ratio: 1.44651830581479 ================================================ FILE: Encoding/lzt-fast.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 April 2015 # Website: https://github.com/trizen # A very good and very fast compression algorithm. (concept only) use 5.010; use strict; use warnings; sub lzt_compress { my ($str) = @_; my $k = 0; # must be zero my $min = 4; # the minimum length of a substring my $max = 15; # the maximum length of a substring my $i = 0; # iterator (0 to length(str)-1) my $remember = 0; # remember mode my $memo = ''; # short-term memory my @dups; # array of duplicated substrings with positions my @cache; # cache of substrings my %dict; # dictionary of substrings foreach my $c (split(//, $str)) { if (not $remember and exists $dict{$c}) { $remember = 1; # activate the remember mode } $cache[$_] .= $c for ($k .. $i); # create the substrings # If remember mode is one, do some checks. if ($remember) { # Check to see if $memo + the current character exists in the dictionary if (exists $dict{$memo . $c}) { ## say "found in cache [$i]: $memo$c"; } # If it doesn't exists, then the $memo is the largest # duplicated substring in the dictionary at this point. else { $remember = 0; # turn-off remember mode if (length($memo) >= $min) { # check for the minimum length of the word push @dups, [$dict{$memo}, length($memo), $memo, $i - length($memo)]; } # $memo has been stored. Now, clear the memory. $memo = ''; } # Remember one more character $memo .= $c; } # Increment the iterator $i++; # Create the dictionary from the cache of substrings foreach my $item (@cache) { exists($dict{$item}) || ($dict{$item} = $i - length($item)); } # Update the minimum length ++$k if (($i - $k) >= $max); } return \@dups; } # ## Usage # my $str = @ARGV ? do { local $/; <> } : "TOBEORNOTTOBEORTOBEORNOT#"; say '[', join(', ', @{$_}), ']' for @{lzt_compress($str)}; ================================================ FILE: Encoding/lzw_encoding.pl ================================================ #!/usr/bin/perl use 5.020; use strict; use warnings; use constant DICT_SIZE => 256; use experimental qw(signatures); binmode(STDOUT, ':utf8'); sub create_dictionary() { my %dictionary; foreach my $i (0 .. DICT_SIZE - 1) { $dictionary{chr $i} = chr $i; } return %dictionary; } sub compress ($uncompressed) { my $dict_size = DICT_SIZE; my %dictionary = create_dictionary(); my $w = ''; my @compressed; foreach my $c (split(//, $uncompressed)) { my $wc = $w . $c; if (exists $dictionary{$wc}) { $w = $wc; } else { push @compressed, $dictionary{$w}; $dictionary{$wc} = chr($dict_size++); $w = $c; } } if ($w ne '') { push @compressed, $dictionary{$w}; } return @compressed; } sub decompress (@compressed) { my $dict_size = DICT_SIZE; my %dictionary = create_dictionary(); my $w = shift(@compressed); my $result = $w; foreach my $k (@compressed) { my $entry = do { if (exists $dictionary{$k}) { $dictionary{$k}; } elsif ($k eq chr($dict_size)) { $w . substr($w, 0, 1); } else { die "Invalid compression: $k"; } }; $result .= $entry; $dictionary{chr($dict_size++)} = $w . substr($entry, 0, 1); $w = $entry; } return $result; } my $orig = 'TOBEORNOTTOBEORTOBEORNOT'; my @compressed = compress($orig); my $enc = join('', @compressed); my $dec = decompress(@compressed); say "Encoded: $enc"; say "Decoded: $dec"; say '-' x 33; if ($dec ne $orig) { die "Decompression failed!"; } printf("Original size : %s\n", length($orig)); printf("Compressed size : %s\n", length($enc)); printf("Compression ratio : %.2f%%\n", (length($orig) - length($enc)) / length($orig) * 100); ================================================ FILE: Encoding/math_expr_encoder.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 14 April 2012 # https://github.com/trizen @ARGV = @ARGV ? (@ARGV) : ($0); foreach my $file (grep { -f } @ARGV) { open my $fh, '<', $file or next; my $s = ''; while (1) { my $i = ord(getc($fh) // last); while (1) { my $f = int rand $i; my $l = int rand $i * 2; if (($f | $l) == $i) { $s .= "$f|$l," => last } if (($f * $l) == $i) { $s .= "$f*$l," => last } if (($l >> $f) == $i) { $s .= "$l>>$f," => last } if (($f << $l) == $i) { $s .= "$f<<$l," => last } if (($l << $f) == $i) { $s .= "$l<<$f," => last } if (($f**$l) == $i) { $s .= "$f**$l," => last } if (($l**$f) == $i) { $s .= "$l**$f," => last } if (($f + $l) == $i) { $s .= "$f+$l," => last } if (($l - $f) == $i) { $s .= "$l-$f," => last } if (($f ^ $l) == $i) { $s .= "$f^$l," => last } } } close $fh; print <<"EOT"; print chr for $s; EOT } ================================================ FILE: Encoding/move-to-front_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 June 2023 # https://github.com/trizen # The Move to Front transform (MTF). # Reference: # COMP526 Unit 7-6 2020-03-24 Compression - Move-to-front transform # https://youtube.com/watch?v=Q2pinaj3i9Y use 5.036; sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@{$alphabet}, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@{$alphabet}, $p, 1)); } return \@S; } my $str = "INEFICIENCIES"; my $encoded = mtf_encode([unpack('C*', $str)], [ord('A') .. ord('Z')]); my $decoded = mtf_decode($encoded, [ord('A') .. ord('Z')]); say "Encoded: ", "@$encoded"; #=> Encoded: 8 13 6 7 3 6 1 3 4 3 3 3 18 say "Decoded: ", pack('C*', @$decoded); #=> Decoded: INEFICIENCIES $str eq pack('C*', @$decoded) or die "error"; { open my $fh, '<:raw', __FILE__; my $str = do { local $/; <$fh> }; my $encoded = mtf_encode([unpack('C*', $str)]); my $decoded = mtf_decode($encoded); $str eq pack('C*', @$decoded) or die "error"; } ================================================ FILE: Encoding/mtf-delta_encoding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 June 2023 # https://github.com/trizen # Implementation of the Move-to-Front transform, combined with Delta encoding. # References: # Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction # https://youtube.com/watch?v=-3H_eDbWNEU # # COMP526 Unit 7-6 2020-03-24 Compression - Move-to-front transform # https://youtube.com/watch?v=Q2pinaj3i9Y use 5.036; sub mtf_encode ($bytes, $alphabet = [0 .. 255]) { my @C; my @table; @table[@$alphabet] = (0 .. $#{$alphabet}); foreach my $c (@$bytes) { push @C, (my $index = $table[$c]); unshift(@$alphabet, splice(@{$alphabet}, $index, 1)); @table[@{$alphabet}[0 .. $index]] = (0 .. $index); } return \@C; } sub mtf_decode ($encoded, $alphabet = [0 .. 255]) { my @S; foreach my $p (@$encoded) { push @S, $alphabet->[$p]; unshift(@$alphabet, splice(@{$alphabet}, $p, 1)); } return \@S; } sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub delta_encode ($bytes) { # all bytes in the range [0, 255] my @deltas; my $prev = 0; my $integers = mtf_encode($bytes); unshift(@$integers, scalar(@$integers)); while (@$integers) { my $curr = shift(@$integers); push @deltas, $curr - $prev; $prev = $curr; } my $bitstring = ''; foreach my $d (@deltas) { if ($d == 0) { $bitstring .= '0'; } else { my $t = sprintf('%b', abs($d)); $bitstring .= '1' . (($d < 0) ? '0' : '1') . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } } pack('B*', $bitstring); } sub delta_decode ($str) { open my $fh, '<:raw', \$str; my @deltas; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer); if ($bit eq '0') { push @deltas, 0; } else { my $bit = read_bit($fh, \$buffer); my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @deltas, ($bit eq '1' ? $d : -$d); } if ($k == 0) { $len = pop(@deltas); } } my @acc; my $prev = $len; foreach my $d (@deltas) { $prev += $d; push @acc, $prev; } mtf_decode(\@acc); } my @bytes = do { open my $fh, '<:raw', $^X; local $/; unpack('C*', <$fh>); }; my $str = delta_encode([@bytes]); say "Encoded length: ", length($str); say "Rawdata length: ", length(pack('C*', @bytes)); my $decoded = delta_decode($str); join(' ', @bytes) eq join(' ', @$decoded) or die "Decoding error"; __END__ Encoded length: 5270 Rawdata length: 14168 ================================================ FILE: Encoding/png_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 21 December 2023 # https://github.com/trizen # Apply the reversible PNG transform on arbitrary data. # The transformation can be made irreversible by lossy # compressing the PNG file with a tool like "pngquant". use 5.020; use strict; use warnings; use GD qw(); use Getopt::Long qw(GetOptions); use experimental qw(signatures); GD::Image->trueColor(1); binmode(STDIN, ':raw'); binmode(STDOUT, ':raw'); sub encode_data ($data) { my @bytes = unpack("C*", $data); my $c = 1 + int(scalar(@bytes) / 3); my $width = int(sqrt($c)); my $height = int($c / $width) + 1; say STDERR ":: File size: ", scalar(@bytes); say STDERR ":: Image size: $width x $height"; my $image = GD::Image->new($width, $height) or die "Can't create image"; my $size = scalar(@bytes); OUTER: foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { if ($size > 0) { my $index = $image->colorResolve(shift(@bytes) // 0, shift(@bytes) // 0, shift(@bytes) // 0); $image->setPixel($x, $y, $index); $size -= 3; } else { last OUTER; } } } return $image; } sub decode_data ($img_data, $length) { my $image = GD::Image->new($img_data) or die "Can't read image: $!"; my ($width, $height) = $image->getBounds(); my $data = ''; my $size = 0; OUTER: foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $index = $image->getPixel($x, $y); if ($size < $length) { my ($red, $green, $blue) = $image->rgb($index); $data .= pack('C3', $red, $green, $blue); $size += 3; } else { last OUTER; } } } while (length($data) > $length) { chop $data; } return $data; } my $compression = 9; my $decode_size = undef; sub help ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input] [output] options: -d --decode=size : how many bytes to decode example: # Encode perl $0 input.txt encoded.png # Decode perl $0 -d=size encoded.png decoded.txt EOT exit($exit_code); } GetOptions('d|decode=s' => \$decode_size, "h|help" => sub { help(0) },) or die("Error in command line arguments\n"); my $data_file = shift(@ARGV) // help(2); my $output_file = shift(@ARGV); my $data = do { open my $fh, '<:raw', $data_file or die "Can't open file <<$data_file>> for reading: $!"; local $/; <$fh>; }; if (defined($decode_size)) { my $decoded = decode_data($data, $decode_size); if (length($decoded) != $decode_size) { warn sprintf("Incorrect size: len(T) = %d != len(D) = %d\n", length($decoded), length($data)); } if (defined($output_file)) { open my $fh, '>:raw', $output_file or die "Can't open file <<$output_file>> for writing: $!"; print $fh $decoded; close $fh; } else { print $decoded; } } else { my $img = encode_data($data); my $png = $img->png($compression); if (defined($output_file)) { open my $fh, '>:raw', $output_file or die "Can't open file <<$output_file>> for writing: $!"; print $fh $png; close $fh; } else { print $png; } } ================================================ FILE: Encoding/ppm_encoding.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 August 2023 # https://github.com/trizen # Implementation of a PPM (prediction by partial-matching) encoder, using Huffman Coding. # See also: # https://rosettacode.org/wiki/huffman_coding # Reference: # Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods # https://youtube.com/watch?v=YKv-w8bXi9c use 5.036; use List::Util qw(max uniq); use constant { ESCAPE_SYMBOL => 256, # escape symbol CONTEXTS_NUM => 4, # maximum number of contexts VERBOSE => 0, # verbose/debug mode }; # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub freq ($arr) { my %freq; ++$freq{$_} for @$arr; return \%freq; } sub encode ($symbols, $alphabet) { my @enc; my @prev; my $s = join(' ', @prev); my @ctx = ({$s => {freq => freq($alphabet)}},); foreach my $i (1 .. CONTEXTS_NUM) { push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}}; } foreach my $c (@ctx) { $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[0]; } foreach my $symbol (@$symbols) { foreach my $k (reverse(0 .. $#ctx)) { $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]); if (!exists($ctx[$k]{$s})) { $ctx[$k]{$s}{freq} = freq([ESCAPE_SYMBOL]); } if (exists($ctx[$k]{$s}{freq}{$symbol})) { if ($k != 0) { $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0]; ++$ctx[$k]{$s}{freq}{$symbol}; } say STDERR "Encoding $symbol with context=$k using $ctx[$k]{$s}{tree}{$symbol} and prefix ($s)" if VERBOSE; push @enc, $ctx[$k]{$s}{tree}{$symbol}; push @prev, $symbol; shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM); last; } $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0]; push @enc, $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}; say STDERR "Escaping from context = $k with $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}" if VERBOSE; $ctx[$k]{$s}{freq}{$symbol} = 1; } } return join('', @enc); } sub decode ($enc, $alphabet) { my @out; my @prev; my $prefix = ''; my $s = join(' ', @prev); my @ctx = ({$s => {freq => freq($alphabet)}},); foreach my $i (1 .. CONTEXTS_NUM) { push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}},; } foreach my $c (@ctx) { $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[1]; } my $context = CONTEXTS_NUM; my @key = @prev; foreach my $bit (split(//, $enc)) { $prefix .= $bit; if (!exists($ctx[$context]{$s})) { $ctx[$context]{$s}{freq} = freq([ESCAPE_SYMBOL]); $ctx[$context]{$s}{tree} = (mktree_from_freq($ctx[$context]{$s}{freq}))[1]; } if (exists($ctx[$context]{$s}{tree}{$prefix})) { my $symbol = $ctx[$context]{$s}{tree}{$prefix}; if ($symbol == ESCAPE_SYMBOL) { --$context; shift(@key) if (scalar(@key) >= $context); $s = join(' ', @key); } else { push @out, $symbol; foreach my $k (max($context, 1) .. CONTEXTS_NUM) { my $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]); $ctx[$k]{$s}{freq} //= freq([ESCAPE_SYMBOL]); ++$ctx[$k]{$s}{freq}{$symbol}; $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[1]; } $context = CONTEXTS_NUM; push @prev, $symbol; shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM); @key = @prev[max($#prev - $context + 2, 0) .. $#prev]; $s = join(' ', @key); } $prefix = ''; } } return \@out; } my $text = "A SAD DAD; A SAD SALSA"; ##my $text = "this is an example for huffman encoding"; my @bytes = unpack('C*', $text); my $enc = encode(\@bytes, [uniq(@bytes)]); my $dec = decode($enc, [uniq(@bytes)]); say $enc; say pack('C*', @$dec); printf("Saved: %.3f%%\n", ((@$dec - length($enc) / 8) / @$dec * 100)); pack('C*', @$dec) eq $text or die "Decoding failed!"; ================================================ FILE: Encoding/ppm_encoding_dynamic.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 August 2023 # https://github.com/trizen # Implementation of a PPM (prediction by partial-matching) encoder, using Huffman Coding. # This variant dynamically increments the context-length, based on the input data, in order to reduce the number of escape symbols being generated. # See also: # https://rosettacode.org/wiki/huffman_coding # Reference: # Data Compression (Summer 2023) - Lecture 16 - Adaptive Methods # https://youtube.com/watch?v=YKv-w8bXi9c use 5.036; use List::Util qw(max uniq); use constant { ESCAPE_SYMBOL => 256, # escape symbol CONTEXTS_NUM => 3, # maximum number of contexts INITIAL_CONTEXT => 1, # start in this context VERBOSE => 0, # verbose/debug mode }; # produce encode and decode dictionary from a tree sub walk ($node, $code, $h, $rev_h) { my $c = $node->[0] // return ($h, $rev_h); if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') } else { $h->{$c} = $code; $rev_h->{$code} = $c } return ($h, $rev_h); } # make a tree, and return resulting dictionaries sub mktree_from_freq ($freq) { my @nodes = map { [$_, $freq->{$_}] } sort { $a <=> $b } keys %$freq; do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice(@nodes, 0, 2); if (defined($x)) { if (defined($y)) { push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } else { push @nodes, [[$x], $x->[1]]; } } } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub freq ($arr) { my %freq; ++$freq{$_} for @$arr; return \%freq; } sub encode ($symbols, $alphabet) { my @enc; my @prev; my $s = join(' ', @prev); my @ctx = ({$s => {freq => freq($alphabet)}},); foreach my $i (1 .. CONTEXTS_NUM) { push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}}; } foreach my $c (@ctx) { $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[0]; } my $prev_ctx = INITIAL_CONTEXT; foreach my $symbol (@$symbols) { foreach my $k (reverse(0 .. $prev_ctx)) { $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]); if (!exists($ctx[$k]{$s})) { $ctx[$k]{$s}{freq} = freq([ESCAPE_SYMBOL]); } if (exists($ctx[$k]{$s}{freq}{$symbol})) { if ($k != 0) { $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0]; ++$ctx[$k]{$s}{freq}{$symbol}; } say STDERR "Encoding $symbol with context=$k using $ctx[$k]{$s}{tree}{$symbol} and prefix ($s)" if VERBOSE; push @enc, $ctx[$k]{$s}{tree}{$symbol}; ++$prev_ctx if ($prev_ctx < $#ctx); push @prev, $symbol; shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM); last; } --$prev_ctx; $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[0]; push @enc, $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}; say STDERR "Escaping from context = $k with $ctx[$k]{$s}{tree}{(ESCAPE_SYMBOL)}" if VERBOSE; $ctx[$k]{$s}{freq}{$symbol} = 1; } } return join('', @enc); } sub decode ($enc, $alphabet) { my @out; my @prev; my $prefix = ''; my $s = join(' ', @prev); my @ctx = ({$s => {freq => freq($alphabet)}},); foreach my $i (1 .. CONTEXTS_NUM) { push @ctx, {$s => {freq => freq([ESCAPE_SYMBOL])}},; } foreach my $c (@ctx) { $c->{$s}{tree} = (mktree_from_freq($c->{$s}{freq}))[1]; } my $prev_ctx = my $context = INITIAL_CONTEXT; my @key = @prev; foreach my $bit (split(//, $enc)) { $prefix .= $bit; if (!exists($ctx[$context]{$s})) { $ctx[$context]{$s}{freq} = freq([ESCAPE_SYMBOL]); $ctx[$context]{$s}{tree} = (mktree_from_freq($ctx[$context]{$s}{freq}))[1]; } if (exists($ctx[$context]{$s}{tree}{$prefix})) { my $symbol = $ctx[$context]{$s}{tree}{$prefix}; if ($symbol == ESCAPE_SYMBOL) { --$context; shift(@key) if (scalar(@key) >= $context); $s = join(' ', @key); } else { push @out, $symbol; foreach my $k (max($context, 1) .. $prev_ctx) { my $s = join(' ', @prev[max($#prev - $k + 2, 0) .. $#prev]); $ctx[$k]{$s}{freq} //= freq([ESCAPE_SYMBOL]); ++$ctx[$k]{$s}{freq}{$symbol}; $ctx[$k]{$s}{tree} = (mktree_from_freq($ctx[$k]{$s}{freq}))[1]; } ++$context if ($context < $#ctx); $prev_ctx = $context; push @prev, $symbol; shift(@prev) if (scalar(@prev) >= CONTEXTS_NUM); @key = @prev[max($#prev - $context + 2, 0) .. $#prev]; $s = join(' ', @key); } $prefix = ''; } } return \@out; } my $text = "A SAD DAD; A SAD SALSA"; ##my $text = "this is an example for huffman encoding"; my @bytes = unpack('C*', $text); my $enc = encode(\@bytes, [uniq(@bytes)]); my $dec = decode($enc, [uniq(@bytes)]); say $enc; say pack('C*', @$dec); printf("Saved: %.3f%%\n", ((@$dec - length($enc) / 8) / @$dec * 100)); pack('C*', @$dec) eq $text or die "Decoding failed!"; ================================================ FILE: Encoding/rANS_encoding.pl ================================================ #!/usr/bin/perl # Basic implementation of rANS encoding. # Reference: # ‎Stanford EE274: Data Compression I 2023 I Lecture 7 - ANS # https://youtube.com/watch?v=5Hp4bnvSjng use 5.036; package rANS { sub new { my ($class, $input) = @_; my %freq; my %cumul; ++$freq{$_} for @$input; my @alphabet = sort { $a <=> $b } keys %freq; my $t = 0; foreach my $s (@alphabet) { $cumul{$s} = $t; $t += $freq{$s}; } my $M = $t; bless { input => $input, M => $M, freq => \%freq, cumul => \%cumul, alphabet => \@alphabet, }, $class; } sub divint ($x, $y) { use integer; $x / $y; } sub divrem ($x, $y) { use integer; ($x / $y, $x % $y); } sub rans_base_enc($self, $x_prev, $s) { my $block_id = divint($x_prev, $self->{freq}{$s}); my $slot = $self->{cumul}{$s} + ($x_prev % $self->{freq}{$s}); my $x = ($block_id * $self->{M} + $slot); return $x; } sub encode($self) { my $x = 0; foreach my $s (@{$self->{input}}) { $x = $self->rans_base_enc($x, $s); } return $x; } sub rans_base_dec($self, $x) { my ($block_id, $slot) = divrem($x, $self->{M}); my $alphabet = $self->{alphabet}; my $cumul = $self->{cumul}; my ($left, $right, $mid, $cmp) = (0, $#{$alphabet}); while (1) { $mid = ($left + $right) >> 1; $cmp = ($cumul->{$alphabet->[$mid]} <=> $slot) || last; if ($cmp < 0) { $left = $mid + 1; $left > $right and last; } else { $right = $mid - 1; if ($left > $right) { $mid -= 1; last; } } } my $s = $alphabet->[$mid]; my $x_prev = ($block_id * $self->{freq}{$s} + $slot - $cumul->{$s}); return ($s, $x_prev); } sub decode($self, $x, $n) { my @dec; my $s = undef; for (1 .. $n) { ($s, $x) = $self->rans_base_dec($x); push @dec, $s; } return [reverse @dec]; } } my @seq = (1, 2, 1, 7, 8, 2, 2, 1, 3, 3, 1, 1, 1, 2); my $obj = rANS->new(\@seq); my $enc = $obj->encode; my $dec = $obj->decode($enc, scalar(@seq)); say $enc; say "@$dec"; join(' ', @seq) eq join(' ', @$dec) or die "error"; ================================================ FILE: Encoding/rANS_encoding_mpz.pl ================================================ #!/usr/bin/perl # Basic implementation of rANS encoding, using big integers. # Reference: # ‎Stanford EE274: Data Compression I 2023 I Lecture 7 - ANS # https://youtube.com/watch?v=5Hp4bnvSjng use 5.036; use Math::GMPz; package rANS { sub new { my ($class, $input) = @_; my %freq; my %cumul; ++$freq{$_} for @$input; my @alphabet = sort { $a <=> $b } keys %freq; my $t = 0; foreach my $s (@alphabet) { $cumul{$s} = $t; $t += $freq{$s}; } my $M = $t; bless { input => $input, M => $M, freq => \%freq, cumul => \%cumul, alphabet => \@alphabet, }, $class; } sub rans_base_enc($self, $x_prev, $s, $block_id, $x) { Math::GMPz::Rmpz_div_ui($block_id, $x_prev, $self->{freq}{$s}); my $r = Math::GMPz::Rmpz_mod_ui($x, $x_prev, $self->{freq}{$s}); my $slot = $self->{cumul}{$s} + $r; Math::GMPz::Rmpz_mul_ui($x, $block_id, $self->{M}); Math::GMPz::Rmpz_add_ui($x, $x, $slot); return $x; } sub encode($self) { my $x = Math::GMPz::Rmpz_init_set_ui(0); my $block_id = Math::GMPz::Rmpz_init(); my $next_x = Math::GMPz::Rmpz_init(); foreach my $s (@{$self->{input}}) { $x = $self->rans_base_enc($x, $s, $block_id, $next_x); } return $x; } sub rans_base_dec($self, $x, $block_id, $slot, $x_prev) { Math::GMPz::Rmpz_tdiv_qr_ui($block_id, $slot, $x, $self->{M}); my $alphabet = $self->{alphabet}; my $cumul = $self->{cumul}; my ($left, $right, $mid, $cmp) = (0, $#{$alphabet}); while (1) { $mid = ($left + $right) >> 1; $cmp = ($cumul->{$alphabet->[$mid]} <=> $slot) || last; if ($cmp < 0) { $left = $mid + 1; $left > $right and last; } else { $right = $mid - 1; if ($left > $right) { $mid -= 1; last; } } } my $s = $alphabet->[$mid]; Math::GMPz::Rmpz_mul_ui($x_prev, $block_id, $self->{freq}{$s}); Math::GMPz::Rmpz_add($x_prev, $x_prev, $slot); Math::GMPz::Rmpz_sub_ui($x_prev, $x_prev, $cumul->{$s}); return ($s, $x_prev); } sub decode($self, $x, $n) { my @dec; my $s = undef; my $block_id = Math::GMPz::Rmpz_init(); my $slot = Math::GMPz::Rmpz_init(); my $x_prev = Math::GMPz::Rmpz_init(); for (1 .. $n) { ($s, $x) = $self->rans_base_dec($x, $block_id, $slot, $x_prev); push @dec, $s; } return [reverse @dec]; } } my @seq = do { open my $fh, '<:raw', __FILE__; local $/; unpack('C*', <$fh>); }; my $obj = rANS->new(\@seq); my $enc = $obj->encode; my $dec = $obj->decode($enc, scalar(@seq)); say $enc; join(' ', @seq) eq join(' ', @$dec) or die "error"; ================================================ FILE: Encoding/run_length_with_elias_coding.pl ================================================ #!/usr/bin/perl # Implementation of Run-length + Elias coding, for encoding arbitrary non-negative integers. # References: # Data Compression (Summer 2023) - Lecture 5 - Basic Techniques # https://youtube.com/watch?v=TdFWb8mL5Gk # # Data Compression (Summer 2023) - Lecture 6 - Delta Compression and Prediction # https://youtube.com/watch?v=-3H_eDbWNEU use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub RLEE_encoding ($integers, $double = 0) { my @symbols = (scalar(@$integers), @$integers); my $bitstring = ''; my $rle = run_length(\@symbols); foreach my $cv (@$rle) { my ($c, $v) = @$cv; if ($c == 0) { $bitstring .= '0'; } elsif ($double) { my $t = sprintf('%b', abs($c) + 1); my $l = sprintf('%b', length($t)); $bitstring .= '1' . ('1' x (length($l) - 1)) . '0' . substr($l, 1) . substr($t, 1); } else { my $t = sprintf('%b', abs($c)); $bitstring .= '1' . ('1' x (length($t) - 1)) . '0' . substr($t, 1); } if ($v == 1) { $bitstring .= '0'; } else { my $t = sprintf('%b', $v); $bitstring .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } pack('B*', $bitstring); } sub RLEE_decoding ($bitstring, $double = 0) { open my $fh, '<:raw', \$bitstring; my @values; my $buffer = ''; my $len = 0; for (my $k = 0 ; $k <= $len ; ++$k) { my $bit = read_bit($fh, \$buffer) // last; if ($bit eq '0') { push @values, 0; } elsif ($double) { my $bl = 0; ++$bl while (read_bit($fh, \$buffer) eq '1'); my $bl2 = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)); my $int = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. ($bl2 - 1))); push @values, $int - 1; } else { my $n = 0; ++$n while (read_bit($fh, \$buffer) eq '1'); my $d = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $n)); push @values, $d; } my $bl = 0; while (read_bit($fh, \$buffer) == 1) { ++$bl; } if ($bl > 0) { my $run = oct('0b1' . join('', map { read_bit($fh, \$buffer) } 1 .. $bl)) - 1; $k += $run; push @values, ($values[-1]) x $run; } if ($k == 0) { $len = pop(@values); } } return \@values; } my @symbols = ( 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, 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 ); my $enc = RLEE_encoding([@symbols]); my $dec = RLEE_decoding($enc); say unpack('B*', $enc); say "@$dec"; "@$dec" eq "@symbols" or die "error"; do { my @integers = map { int(rand($_)) } 1 .. 1000; my $str = RLEE_encoding([@integers], 1); say "Encoded length: ", length($str); say "Rawdata length: ", length(join(' ', @integers)); my $decoded = RLEE_decoding($str, 1); join(' ', @integers) eq join(' ', @$decoded) or die "Decoding error"; { open my $fh, '<:raw', __FILE__; my $str = do { local $/; <$fh> }; my $encoded = RLEE_encoding([unpack('C*', $str)], 1); my $decoded = RLEE_decoding($encoded, 1); $str eq pack('C*', @$decoded) or die "error"; } } __END__ 111111100110010111010001111110000000110100010100110110010011000110100100100110001110000110001000010011000101000100100000 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 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 Encoded length: 1867 Rawdata length: 3606 ================================================ FILE: Encoding/string_to_integer_encoding_based_on_primes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 19 March 2021 # License: GPLv3 # https://github.com/trizen # A new text encoding scheme, encoding bytes into a large integer, based on prime numbers. # Given a string of bytes, the str2int() function returns back an integer that can be unambiguously # decoded by the int2str() function back into the original string of bytes, using primes and prime factorization. # This process becomes very slow for large strings, therefore it's recommended only for small strings (up to 500-1000 bytes). # The digits 0..9 are encoded as: # 853048, 260151, 438257, 1149418, 760322, 517496, 1269824, 885659, 605753, 1019968 # The letters 'a'..'z' are encoded as: # 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 # The codepoints 0..32 are encoded as: # 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 use utf8; use 5.020; use strict; use warnings; use open IO => ':utf8'; use experimental qw(signatures); use List::Util qw(max); use Encode qw(encode_utf8 decode_utf8); use ntheory qw(vecprod); use Math::Prime::Util::GMP qw(:all); use Test::More tests => 3; # Takes a string of bytes and returns an integer sub str2int ($str) { my @bytes = unpack('C*', $str); my $base = 1 + max(1, max(@bytes)); for (my $k = 1 ; $k < $base ; ++$k) { unshift @bytes, $k; push @bytes, 1; for (1 .. $k) { my $enc = fromdigits(\@bytes, ++$base); return vecprod($enc, $base) if is_prime($enc); } shift @bytes; pop @bytes; } die "Encoding failed!"; # should never happen } # Takes an integer, and returns a string of bytes sub int2str ($int) { my (@factors) = factor($int); my $enc = pop @factors; my $base = vecprod(@factors); my @bytes = todigits($enc, $base); shift @bytes; pop @bytes; pack('C*', @bytes); } is(join(', ', map { int2str(str2int($_)) } 'a' .. 'z'), join(', ', 'a' .. 'z')); is(join(', ', map { int2str(str2int($_)) } 0 .. 255), join(', ', 0 .. 255)); is(join(', ', map { ord(int2str(str2int(chr($_)))) } 0 .. 255), join(', ', 0 .. 255)); my $str = encode_utf8("Hello, world! 😃"); say str2int($str); say int2str(str2int($str)); __END__ 2020269913412456598059907107141359388654948090049817 Hello, world! 😃 ================================================ FILE: Encoding/swap_transform.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 09 November 2024 # https://github.com/trizen # A reversible transform, based on swapping of elements. use 5.036; sub swap_transform ($text, $extra = 1) { my @bits; my @arr = unpack('C*', $text); my $k = 0; foreach my $i (1 .. $#arr) { if ($arr[$i] < $arr[$i - 1 - $k]) { push @bits, 1; unshift @arr, splice(@arr, $i, 1); ++$k if $extra; } else { push @bits, 0; } } return (pack('C*', @arr), \@bits); } sub reverse_swap_transform ($text, $bits) { my @arr = unpack('C*', $text); for (my $i = $#arr ; $i >= 0 ; --$i) { if ($bits->[$i - 1] == 1) { splice(@arr, $i, 0, shift(@arr)); } } pack('C*', @arr); } foreach my $text ( "TOBEORNOTTOBEORTOBEORNOT", "abracadabra", "DABDDBBDDBA", "CoMpReSSeD", "AM SAM. I AM SAM. SAM I AM. THAT SAM-I-AM", do { open my $fh, '<:raw', __FILE__; local $/; <$fh>; } ) { my ($t, $bits) = swap_transform($text); my $rev = reverse_swap_transform($t, $bits); if (length($t) < 100) { say $t; say join('', @$bits); say $rev; say '-' x 80; } if ($rev ne $text) { die "Failed for: $text"; } } __END__ NEBOBNRBOTEOOTTOEORTOROT 11001100001000011100100 TOBEORNOTTOBEORTOBEORNOT -------------------------------------------------------------------------------- aaaaabrcdbr 0010101001 abracadabra -------------------------------------------------------------------------------- ABADBDDBDDB 1000100001 DABDDBBDDBA -------------------------------------------------------------------------------- eSRMCopeSD 010101010 CoMpReSSeD -------------------------------------------------------------------------------- --A A . I .A .A AMSMIAMSMSAMAMTHTSMIAM 0101011010010101100011100110010101010100 AM SAM. I AM SAM. SAM I AM. THAT SAM-I-AM -------------------------------------------------------------------------------- ================================================ FILE: Encoding/tlen_encoding.pl ================================================ #!?usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 04 May 2015 # Website: https://github.com/trizen # A very basic length encoder use 5.010; use strict; use warnings; use Data::Dump qw(pp); # produce encode and decode dictionary from a tree sub walk { my ($node, $code, $h) = @_; my $c = $node->[0]; if (ref $c) { walk($c->[$_], $code . $_, $h) for 0, 1 } else { $h->{$c} = $code } $h; } # make a tree, and return resulting dictionaries sub mktree { my %freq = @_; my @nodes = map([$_, $freq{$_}], keys %freq); if (@nodes == 1) { return {$nodes[0][0] => '0'}; } do { # poor man's priority queue @nodes = sort { $a->[1] <=> $b->[1] } @nodes; my ($x, $y) = splice @nodes, 0, 2; push @nodes, [[$x, $y], $x->[1] + $y->[1]]; } while (@nodes > 1); walk($nodes[0], '', {}, {}); } sub length_encoder { my ($str) = @_; my %table; my @chars = split(//, $str); my $lim = $#chars; my %t; for (my $i = 0 ; $i < $lim ; $i++) { for (my $j = $i + 1 ; $j <= $lim ; $j++) { last if $j + ($j - $i) + 1 > $lim; my $key = join('', @chars[$i .. $j]); if (join('', @chars[$j + 1 .. $j + ($j - $i) + 1]) eq $key) { if (not exists $t{$key}) { if (exists $t{substr($key, 0, -1)}) { last; } $t{$key} = length($key); } else { $t{$key}++; } } } } my ($dict) = keys(%t) ? mktree(%t) : {}; my @sorted_tokens = sort { length($dict->{$a}) <=> length($dict->{$b}) or $t{$b} <=> $t{$a} or $a cmp $b } keys %t; say "Weights: ", pp(\%t); say "Sorted: @sorted_tokens"; say "Bits: ", pp($dict); my $regex = do { my @tries = map { "(?\Q$_\E)(?(?:\Q$_\E)*+)" } @sorted_tokens; local $" = '|'; @sorted_tokens ? qr/^(?:@tries|(?.))/s : qr/^(?.)/s; }; my @len; my @pos; my $dec = ''; my $bin = ''; my $pos = 0; while ($str =~ s/$regex//) { my $m = $+{token}; my $r = $+{rest}; if (defined $r) { $pos += $-[0]; push @pos, $pos; push @len, (1 + length($r) / length($m)); $bin .= $dict->{$m}; } else { $dec .= $m; ++$pos; } } say "bin: $bin"; say "pos: @pos"; say "len: @len"; my $bbytes = pack('B*', $bin); my $pbytes = join('', map { chr } @pos); my $lbytes = join('', map { chr } @len); return chr(length($bbytes)) . chr(length($bin) % 8) . chr(length($pbytes)) . chr(length($lbytes)) . chr(length($dec)) . $bbytes . $pbytes . $lbytes . $dec; } foreach my $str ( qw( ABABABAB ABABABABAAAAAAAAAAAAAFFFFFFFFFFFFFFFFFFFDDDDDDDDDDDDDDDDDDDDJKLABABVADSABABAB DABDDB DABDDBBDDBA ABBDDD ABRACADABRA TOBEORNOTTOBEORTOBEORNOT ) ) { say "Encoding: $str"; say "Encoded: ", length_encoder($str); say "-" x 80; } ================================================ FILE: Encoding/variable_length_run_encoding.pl ================================================ #!/usr/bin/perl # Implementation of the Variable Length Run Encoding. # Reference: # Data Compression (Summer 2023) - Lecture 5 - Basic Techniques # https://youtube.com/watch?v=TdFWb8mL5Gk use 5.036; sub read_bit ($fh, $bitstring) { if (($$bitstring // '') eq '') { $$bitstring = unpack('b*', getc($fh) // return undef); } chop($$bitstring); } sub run_length ($arr) { @$arr || return []; my @result = [$arr->[0], 1]; my $prev_value = $arr->[0]; foreach my $i (1 .. $#{$arr}) { my $curr_value = $arr->[$i]; if ($curr_value eq $prev_value) { ++$result[-1][1]; } else { push(@result, [$curr_value, 1]); } $prev_value = $curr_value; } return \@result; } sub VLR_encoding ($bytes) { my $bitstream = ''; my $rle = run_length($bytes); foreach my $cv (@$rle) { my ($c, $v) = @$cv; $bitstream .= sprintf('%08b', $c); if ($v == 1) { $bitstream .= '0'; } else { my $t = sprintf('%b', $v); $bitstream .= join('', '1' x (length($t) - 1), '0', substr($t, 1)); } } pack('B*', $bitstream); } sub VLR_decoding ($bitstring) { my $decoded = ''; my $buffer = ''; open my $bits_fh, '<:raw', \$bitstring; while (!eof($bits_fh)) { my $s = join('', map { read_bit($bits_fh, \$buffer) } 1 .. 8); my $c = pack('B*', $s); my $bl = 0; while (read_bit($bits_fh, \$buffer) == 1) { ++$bl; } $decoded .= $c; if ($bl > 0) { $decoded .= $c x (oct('0b1' . join('', map { read_bit($bits_fh, \$buffer) } 1 .. $bl)) - 1); } } $decoded; } my $str = join('', 'a' x 13, 'b' x 14, 'c' x 10, 'd' x 3, 'e' x 1, 'f' x 1, 'g' x 4); my @bytes = unpack('C*', $str); my $enc = VLR_encoding(\@bytes); my $dec = VLR_decoding($enc); say unpack('B*', $enc); say $dec; $dec eq $str or die "error: $dec != $str"; ================================================ FILE: Encryption/RSA_encryption.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 09 January 2017 # https://github.com/trizen # A general purpose implementation of the RSA encryption algorithm. use utf8; use 5.010; use strict; use autodie; use warnings; use Math::AnyNum qw(:overload gcd irand powmod invmod); use Math::Prime::Util qw(random_strong_prime urandomm); use Config qw(%Config); use Getopt::Long qw(GetOptions); use constant shortsize => $Config{shortsize}; my $bits = 2048; my $decrypt = 0; my $generate = 0; my $sign = 0; my $public = 'public.rsa'; my $private = 'private.rsa'; my $in_fh = \*STDIN; my $out_fh = \*STDOUT; sub usage { print <<"EOT"; usage: $0 [options] [output] options: -g --generate! : generate the private and public keys -b --bits=i : size of the prime numbers in bits (default: $bits) -d --decrypt! : decrypt mode (default: ${\($decrypt ? 'true' : 'false')}) -s --sign! : sign/unsign mode (default: ${\($sign ? 'true' : 'false')}) --public=s : public key file (default: $public) --private=s : private key file (default: $private) -i --input=s : input file (default: /dev/stdin) -o --output=s : output file (default: /dev/stdout) -h --help : prints this message example: perl $0 --generate perl $0 < input.txt > enc.rsa perl $0 -d < enc.rsa > decoded.txt EOT exit; } GetOptions( 'bits=i' => \$bits, 'decrypt!' => \$decrypt, 'generate!' => \$generate, 'public=s' => \$public, 'private=s' => \$private, 'input=s' => \$in_fh, 'sign!' => \$sign, 'output=s' => \$out_fh, 'help' => \&usage, ) or die("Error in command line arguments\n"); if (!ref($in_fh)) { open my $fh, '<', $in_fh; $in_fh = $fh; } if (!ref($out_fh)) { open my $fh, '>', $out_fh; $out_fh = $fh; } if ($generate) { say "** Generating <<$public>> and <<$private>> files..."; # Make sure we have enough bits if ($bits < 128) { $bits = 128; } # Make sure `bits` is a power of two if ($bits & ($bits - 1)) { $bits = 2 << (log($bits) / log(2)); } my $p = Math::AnyNum->new(random_strong_prime($bits)); my $q = Math::AnyNum->new(random_strong_prime($bits)); my $n = $p * $q; my $ϕ = ($p - 1) * ($q - 1); # Choosing `e` (part of the public key) #<<< my $e; do { say "** Choosing e..."; $e = irand(65537, $n); } until ( $e < $ϕ and gcd($e, $ϕ ) == 1 and gcd($e - 1, $p - 1) == 2 and gcd($e - 1, $q - 1) == 2 ); #>>> # Computing `d` (part of the private key) my $d = invmod($e, $ϕ); open my $public_fh, '>', $public; print $public_fh "$bits $e $n"; close $public_fh; open my $private_fh, '>', $private; print $private_fh "$bits $d $n"; close $private_fh; say "** Done!"; exit; } sub decrypt { my ($bits, $d, $n) = map { Math::AnyNum->new($_) } do { open my $fh, '<', $private; split(' ', scalar <$fh>); }; $bits >>= 2; $bits += shortsize + shortsize; while (1) { my $len = read($in_fh, my ($message), $bits) || last; my ($s1, $s2, $msg) = unpack('SSb*', $message); my $c = Math::AnyNum->new(substr($msg, 0, $s1), 2); my $M = powmod($c, $d, $n); print $out_fh pack('b*', substr($M->as_bin, 1, $s2)); last if $len != $bits; } } sub encrypt { my ($bits, $e, $n) = map { Math::AnyNum->new($_) } do { open my $fh, '<', $public; split(' ', scalar <$fh>); }; my $L = $bits << 1; $bits >>= 2; $bits -= 1; while (1) { my $len = read($in_fh, my ($message), $bits) || last; my $B = '1' . unpack('b*', $message); if ($bits != $len) { $B .= join('', map { urandomm("2") } 1 .. ($L - ($len << 3) - 8)); } my $m = Math::AnyNum->new($B, 2); my $c = powmod($m, $e, $n); my $bin = $c->as_bin; print $out_fh pack("SSb$L", length($bin), $len << 3, $bin); last if $len != $bits; } } if ($sign) { ($private, $public) = ($public, $private); } if ($decrypt) { if (not -e $private) { die "File <<$private>> does not exists! (run --generate)\n"; } decrypt(); } else { if (not -e $public) { die "File <<$public>> does not exists! (run --generate)\n"; } encrypt(); } ================================================ FILE: Encryption/age-lf.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 02 February 2022 # Edit: 09 February 2022 # https://github.com/trizen # A large file encryption tool, inspired by Age, using Curve25519 and CBC+Serpent for encrypting data. # See also: # https://github.com/FiloSottile/age # https://metacpan.org/pod/Crypt::CBC # https://metacpan.org/pod/Crypt::PK::X25519 # This is a simplified version of `plage`, optimized for large files: # https://github.com/trizen/perl-scripts/blob/master/Encryption/plage.pl use 5.020; use strict; use warnings; use experimental qw(signatures); use Crypt::CBC; use Crypt::PK::X25519; use JSON::PP qw(encode_json decode_json); use Getopt::Long qw(GetOptions :config no_ignore_case); binmode(STDIN, ':raw'); binmode(STDOUT, ':raw'); use constant { SHORT_APPNAME => "age-lf", BUFFER_SIZE => 1024 * 1024, EXPORT_KEY_BASE => 62, VERSION => '0.01', }; my %CONFIG = ( cipher => 'Serpent', chain_mode => 'CBC', ); sub create_cipher ($pass, $cipher = $CONFIG{cipher}, $chain_mode = $CONFIG{chain_mode}) { Crypt::CBC->new( -pass => $pass, -cipher => 'Cipher::' . $cipher, -chain_mode => lc($chain_mode), -pbkdf => 'pbkdf2', ); } sub x25519_from_public ($hex_key) { Crypt::PK::X25519->new->import_key( { curve => "x25519", pub => $hex_key, } ); } sub x25519_from_private ($hex_key) { Crypt::PK::X25519->new->import_key( { curve => "x25519", priv => $hex_key, } ); } sub x25519_random_key { while (1) { my $key = Crypt::PK::X25519->new->generate_key; my $hash = $key->key2hash; next if substr($hash->{pub}, 0, 1) eq '0'; next if substr($hash->{priv}, 0, 1) eq '0'; next if substr($hash->{pub}, -1) eq '0'; next if substr($hash->{priv}, -1) eq '0'; return $key; } } sub encrypt ($fh, $public_key) { # Generate a random ephemeral key-pair. my $random_ephem_key = x25519_random_key(); # Create a shared secret, using the random key and the reciever's public key my $shared_secret = $random_ephem_key->shared_secret($public_key); my $cipher = create_cipher($shared_secret); my $ephem_pub = $random_ephem_key->key2hash->{pub}; my $dest_pub = $public_key->key2hash->{pub}; my %info = ( dest => $dest_pub, cipher => $CONFIG{cipher}, chain_mode => $CONFIG{chain_mode}, ephem_pub => $ephem_pub, ); my $json = encode_json(\%info); syswrite(STDOUT, pack("N*", length($json))); syswrite(STDOUT, $json); $cipher->start('encrypting'); while (sysread($fh, (my $buffer), BUFFER_SIZE)) { syswrite(STDOUT, $cipher->crypt($buffer) // ''); } syswrite(STDOUT, $cipher->finish); } sub decrypt ($fh, $private_key) { if (not defined $private_key) { die "No private key provided!\n"; } if (ref($private_key) ne 'Crypt::PK::X25519') { die "Invalid private key!\n"; } sysread($fh, (my $json_length), 32 >> 3); sysread($fh, (my $json), unpack("N*", $json_length)); my $enc = decode_json($json); # Make sure the private key is correct if ($enc->{dest} ne $private_key->key2hash->{pub}) { die "Incorrect private key!\n"; } # The ephemeral public key my $ephem_pub = $enc->{ephem_pub}; # Import the public key my $ephem_pub_key = x25519_from_public($ephem_pub); # Recover the shared secret my $shared_secret = $private_key->shared_secret($ephem_pub_key); # Create the cipher my $cipher = create_cipher($shared_secret, $enc->{cipher}, $enc->{chain_mode}); $cipher->start('decrypting'); while (sysread($fh, (my $buffer), BUFFER_SIZE)) { syswrite(STDOUT, $cipher->crypt($buffer) // ''); } syswrite(STDOUT, $cipher->finish); } sub export_key ($x_public_key) { require Math::BigInt; Math::BigInt->from_hex($x_public_key)->to_base(EXPORT_KEY_BASE); } sub decode_exported_key ($public_key) { require Math::BigInt; Math::BigInt->from_base($public_key, EXPORT_KEY_BASE)->to_hex; } sub decode_public_key ($key) { x25519_from_public(decode_exported_key($key)); } sub decode_private_key ($file) { if (not -T $file) { die "Invalid key file!\n"; } open(my $fh, '<:utf8', $file) or die "Can't open file <<$file>>: $!"; local $/; my $key = decode_json(<$fh>); x25519_from_private(decode_exported_key($key->{x_priv})); } sub generate_new_key { my $x25519_key = x25519_random_key(); my $x_key = $x25519_key->key2hash; my $x_public_key = $x_key->{pub}; my $x_private_key = $x_key->{priv}; my %info = ( x_pub => export_key($x_public_key), x_priv => export_key($x_private_key), ); say encode_json(\%info); warn sprintf("Public key: %s\n", $info{x_pub}); return 1; } sub help ($exit_code) { local $" = " "; my @chaining_modes = map { uc } qw(cbc pcbc cfb ofb ctr); my @valid_ciphers = sort grep { eval { require "Crypt/Cipher/$_.pm"; 1 }; } qw( AES Anubis Twofish Camellia Serpent SAFERP ); print <<"EOT"; usage: $0 [options] [output] Encryption and signing: -g --generate-key : Generate a new key-pair -e --encrypt=key : Encrypt data with a given public key -d --decrypt=key : Decrypt data with a given private key file --cipher=s : Change the symmetric cipher (default: $CONFIG{cipher}) valid: @valid_ciphers --chain-mode=s : Change the chaining mode (default: $CONFIG{chain_mode}) valid: @chaining_modes Examples: # Generate a key-pair $0 -g > key.txt # Encrypt a message for Alice $0 -e=RBZ17knALkL5N1AWYjAgBwZDpQpQmvLbuTphVAx7XQC < message.txt > message.enc # Decrypt a received message $0 -d=key.txt < message.enc > message.txt EOT exit($exit_code); } sub version { my $width = 20; printf("%-*s %s\n", $width, SHORT_APPNAME, VERSION); printf("%-*s %s\n", $width, 'Crypt::CBC', $Crypt::CBC::VERSION); printf("%-*s %s\n", $width, 'Crypt::PK::X25519', $Crypt::PK::X25519::VERSION); printf("%-*s %s\n", $width, 'Crypt::PK::Ed25519', $Crypt::PK::Ed25519::VERSION); exit(0); } GetOptions( 'cipher=s' => \$CONFIG{cipher}, 'chain-mode|mode=s' => \$CONFIG{chain_mode}, 'g|generate-key!' => \$CONFIG{generate_key}, 'e|encrypt=s' => \$CONFIG{encrypt}, 'd|decrypt=s' => \$CONFIG{decrypt}, 'v|version' => \&version, 'h|help' => sub { help(0) }, ) or die("Error in command line arguments\n"); if ($CONFIG{generate_key}) { generate_new_key(); exit 0; } sub get_input_fh { my $fh = \*STDIN; if (@ARGV and -t $fh) { sysopen(my $file_fh, $ARGV[0], 0) or die "Can't open file <<$ARGV[0]>> for reading: $!"; return $file_fh; } return $fh; } if (defined($CONFIG{encrypt})) { my $x_pub = decode_public_key($CONFIG{encrypt}); encrypt(get_input_fh(), $x_pub); exit 0; } if (defined($CONFIG{decrypt})) { my $x_priv = decode_private_key($CONFIG{decrypt}); decrypt(get_input_fh(), $x_priv); exit 0; } help(1); ================================================ FILE: Encryption/backdoored_rsa_with_x25519.pl ================================================ #!/usr/bin/perl # RSA key generation, backdoored using curve25519. # Inspired by: # https://gist.github.com/ryancdotorg/18235723e926be0afbdd # See also: # https://eprint.iacr.org/2002/183.pdf # https://www.reddit.com/r/crypto/comments/2ss1v5/rsa_key_generation_backdoored_using_curve25519/ use 5.020; use strict; use warnings; use experimental qw(signatures); use ntheory qw(:all); use Crypt::PK::X25519; sub generate_rsa_key ($bits = 2048, $ephem_pub = "", $pos = 80, $seed = undef) { if (defined($seed)) { csrand($seed); } my $p = random_strong_prime($bits >> 1); my $q = random_strong_prime($bits >> 1); if ($p > $q) { ($p, $q) = ($q, $p); } my $n = ($p * $q); # Embed the public key into the modulus my $n_hex = todigitstring($n, 16); substr($n_hex, $pos, length($ephem_pub), $ephem_pub); # Recompute n, reusing p in computing a new q $n = fromdigits($n_hex, 16); $q = next_prime(divint($n, $p)); $n = $p * $q; my $phi = ($p - 1) * ($q - 1); my $e = 0; for (my $k = 16 ; gcd($e, $phi) != 1 ; ++$k) { $e = 2**$k + 1; } my $d = invmod($e, $phi); return scalar { e => $e, p => $p, q => $q, d => $d, n => $n, }; } sub recover_rsa_key ($bits, $n, $master_private_key, $pos) { my $n_hex = todigitstring($n, 16); my $ephem_pub = substr($n_hex, $pos, 64); # extract the embeded public key # Import the public key my $ephem_pub_key = Crypt::PK::X25519->new->import_key( { curve => "x25519", pub => $ephem_pub, } ); # Import the master private key my $master_priv_key = Crypt::PK::X25519->new->import_key( { curve => "x25519", priv => $master_private_key, } ); # Recover the shared secret that was used as a seed value for the random number generator my $recovered_secret = $master_priv_key->shared_secret($ephem_pub_key); # Recompute the RSA key, given the embeded public key and the seed value generate_rsa_key($bits, $ephem_pub, $pos, $recovered_secret); } my $BITS = 2048; # must be >= 1024 my $POS = $BITS >> 5; # Public and private master keys my $MASTER_PUBLIC = "c10811d4e424305c6696f9b5f787efb67f80530e6115e367bd7967ba05093e3d"; my $MASTER_PRIVATE = "3a35b10511bcd20bcb9b12bd73ab9ad0bf8f7f469ffb70d2ae8fb110b761df97"; # Generate a random ephemeral key-pair. The private key will be used in creating # the shared secret, while the public key will be embeded in the RSA modulus. my $random_ephem_key = Crypt::PK::X25519->new->generate_key; # Import the master public key my $master_public_key = Crypt::PK::X25519->new->import_key( { curve => "x25519", pub => $MASTER_PUBLIC, } ); my $ephem_pub = $random_ephem_key->key2hash->{pub}; my $shared_secret = $random_ephem_key->shared_secret($master_public_key); # Generate the backdoored RSA key, using the ephemeral random public key, which will be embeded # in the RSA modulus, and pass the shared secret value as a seed for the random number generator. my $rsa_key = generate_rsa_key($BITS, $ephem_pub, $POS, $shared_secret); my $message = "Hello, world!"; my $m = fromdigits(unpack("H*", $message), 16); # message if ($m >= $rsa_key->{n}) { die "Message is too long!"; } my $c = powmod($m, $rsa_key->{e}, $rsa_key->{n}); # encoded message my $M = powmod($c, $rsa_key->{d}, $rsa_key->{n}); # decoded message say pack("H*", todigitstring($M, 16)); # Recover the RSA key, given the RSA modulus n and the private master key. my $recovered_rsa = recover_rsa_key($BITS, $rsa_key->{n}, $MASTER_PRIVATE, $POS); # Decode the encrypted message, using the recovered RSA key my $decoded_message = powmod($c, $recovered_rsa->{d}, $rsa_key->{n}); # Print the decoded message, decoded with the recovered key say pack("H*", todigitstring($decoded_message, 16)); ================================================ FILE: Encryption/cbc+xor_file_encrypter.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 18 March 2022 # https://github.com/trizen # A simple file encryption cihpher, using XOR with SHA-512 of the key and substring shuffling. # WARNING: should NOT be used for encrypting real-world data. # See also: # https://en.wikipedia.org/wiki/Block_cipher # https://en.wikipedia.org/wiki/XOR_cipher use 5.020; use strict; use warnings; use experimental qw(signatures); binmode(STDOUT, ':raw'); package SimpleXORCipher { require Digest::SHA; sub new ($class, %opt) { $opt{rounds} ||= 1; if (!defined($opt{key})) { die "Undefined key parameter"; } if ($opt{rounds} <= 0) { die "Number of rounds must be > 0"; } $opt{key} = Digest::SHA::sha512($opt{key}); bless \%opt, $class; } sub encrypt ($self, $str) { my $key = $self->{key}; $str ^= $key; my $i = my $l = length($str); for my $k (1 .. $self->{rounds}) { $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0); $str ^= Digest::SHA::sha512($key . $k); $str =~ s/(.{$i})(.)/$2$1/sg while (++$i < $l); $str ^= Digest::SHA::sha512($k . $key); } return $str; } sub decrypt ($self, $str) { my $key = $self->{key}; my $i = my $l = length($str); for my $k (reverse(1 .. $self->{rounds})) { $str ^= Digest::SHA::sha512($k . $key); $str =~ s/(.)(.{$i})/$2$1/sg while (--$i > 0); $str ^= Digest::SHA::sha512($key . $k); $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l); } $str ^= $key; return $str; } sub cbc_encrypt ($crypt, $iv, $result, $blocks) { my ($i, $r) = ($$iv, $$result); foreach (@$blocks) { $r .= $i = $crypt->encrypt($i ^ $_); } ($$iv, $$result) = ($i, $r); } sub cbc_decrypt ($crypt, $iv, $result, $blocks) { my ($i, $r) = ($$iv, $$result); foreach (@$blocks) { $r .= $i ^ $crypt->decrypt($_); $i = $_; } ($$iv, $$result) = ($i, $r); } sub generate_iv ($self) { my $iv = Digest::SHA::sha512($self->{key}); foreach my $i (1 .. $self->{rounds}) { $iv = Digest::SHA::sha512(($i % 2 == 0) ? $iv : scalar(reverse($iv))); } return $iv; } } use constant {BUFFER_SIZE => 1024 * 10,}; sub encrypt_file ($file, $key) { my $crypt = SimpleXORCipher->new(key => $key); my $iv = $crypt->generate_iv; open(my $fh, '<:raw', $file) or die "can't open file <<$file>> for reading: $!"; my $size = -s $file; $crypt->cbc_encrypt(\$iv, \(my $size_enc), [pack("N*", $size)]); print $size_enc; my $key_size = length($crypt->{key}); while (read($fh, (my $buffer), BUFFER_SIZE)) { my @blocks = unpack("(a$key_size)*", $buffer); $crypt->cbc_encrypt(\$iv, \(my $result), \@blocks); print $result; } close $fh; } sub decrypt_file ($file, $key) { my $crypt = SimpleXORCipher->new(key => $key); my $iv = $crypt->generate_iv; my $key_size = length($crypt->{key}); open(my $fh, '<:raw', $file) or die "can't open file <<$file>> for reading: $!"; read($fh, (my $size), $key_size); $crypt->cbc_decrypt(\$iv, \(my $size_dec), [$size]); $size = unpack("N*", substr($size_dec, 0, 4)); my $dec_size = 0; while (read($fh, (my $buffer), BUFFER_SIZE)) { my @blocks = unpack("(a$key_size)*", $buffer); $crypt->cbc_decrypt(\$iv, \(my $result), \@blocks); $dec_size += $key_size * scalar(@blocks); if ($dec_size > $size) { print substr($result, 0, (scalar(@blocks) - 1) * $key_size, ''); print substr($result, 0, $size % $key_size); last; } else { print $result; } } close $fh; } sub help ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input file] options: -k --key=s : encryption/decryption symmetric key -d --decrypt : decryption mode -h --help : print this message example: # Encrypt file perl $0 -k=foo msg.txt > msg.enc # Decrypt file perl $0 -d -k=foo msg.enc > msg.dec EOT exit($exit_code); } use Getopt::Long qw(GetOptions); my $key = undef; my $decrypt = 0; GetOptions( "d|decrypt" => \$decrypt, "key=s" => \$key, "h|help" => sub { help(0) }, ) or die("Error in command line arguments\n"); my $input_file = $ARGV[0] // help(2); if ($decrypt) { decrypt_file($input_file, $key); } else { encrypt_file($input_file, $key); } ================================================ FILE: Encryption/crypt_rsa.pl ================================================ #!/usr/bin/perl # Using Crypt::RSA with a specific private key. use 5.014; use Crypt::RSA; my $rsa = Crypt::RSA->new; my $key = Crypt::RSA::Key->new; my ($public, $private) = $key->generate( p => "94424081139901371883469166542407095517576260048697655243", q => "79084622052242264844238683495727691663247340251867615781", e => 65537, ) or die "error"; my $cyphertext = $rsa->encrypt( Message => "Hello world!", Key => $public, Armour => 1, ) || die $rsa->errstr(); say $cyphertext; my $plaintext = $rsa->decrypt( Cyphertext => $cyphertext, Key => $private, Armour => 1, ) || die $rsa->errstr(); say $plaintext; ================================================ FILE: Encryption/one-time_pad.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 13 November 2016 # https://github.com/trizen # One-time pad symmetric encryption, where the key is pseudo-randomly generated from a given seed. # See also: # https://en.wikipedia.org/wiki/One-time_pad #--------------------------------------------------- # !!! WARNING !!! #--------------------------------------------------- # This program is just a proof-of-concept. # Do NOT use this program to encrypt sensitive data! #--------------------------------------------------- use 5.010; use strict; use warnings; use Getopt::Std qw(getopts); my %opts; getopts('s:h', \%opts); use constant { READ_SIZE => 2 * 1024**2, # 2 MB }; sub usage { warn "\n[ERROR]: ", @_, "\n\n" if @_; print <<"USAGE"; usage: $0 [options] [output] options: -s SEED : random seed example: $0 -s 42 < input.txt > output.dat USAGE exit 1; } $opts{h} && usage(); encode_file( in_fh => \*STDIN, out_fh => \*STDOUT, seed => defined($opts{s}) ? $opts{s} : usage("No seed specified!"), ); sub generate_key { my ($length) = @_; pack('C*', map { int(rand(256)) } 1 .. $length); } sub encode_file { my %args = @_; srand($args{seed}); while (1) { my $len = read($args{in_fh}, my ($chunk), READ_SIZE); my $key = generate_key($len); print {$args{out_fh}} $chunk ^ $key; last if $len != READ_SIZE; } return 1; } ================================================ FILE: Encryption/plage.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 02 February 2022 # Edit: 09 February 2022 # https://github.com/trizen # A message encryption tool, inspired by Age and GnuPG, using Curve25519 and CBC+Serpent for encrypting data. # Main features include: # - ASCII armor # - generation of X25519 and Ed25519 key-pairs # - encryption and decryption of messages # - signing and verification of signatures # - compression support # - import and export of public keys # - local encryption of private keys # - local keyring, similar to PGP # - support for various modern ciphers, like: Serpent (default), Twofish, AES, etc. # - support for various chaining modes, like: CBC (default), PCBC, CFB, OFB, CTR. # See also: # https://github.com/FiloSottile/age # https://metacpan.org/pod/Crypt::CBC # https://metacpan.org/pod/Crypt::PK::X25519 # https://metacpan.org/pod/Crypt::PK::Ed25519 use 5.020; use strict; use warnings; no warnings 'once'; use experimental qw(signatures); use Crypt::CBC; use Digest::SHA qw(sha256); use Crypt::PK::X25519; use Crypt::PK::Ed25519; use Term::UI; use Term::ReadLine; use Term::ReadKey qw(ReadMode); use JSON::PP qw(encode_json decode_json); use Getopt::Long qw(GetOptions :config no_ignore_case); use MIME::Base64 qw(encode_base64 decode_base64); use File::Spec::Functions qw(catdir catfile curdir); use Storable qw(store retrieve); use constant { SHORT_APPNAME => "plage", JSON_LENGTH_WIDTH => 6, USER_ID_SIZE => 32, HASH_SIZE => 32, PK_HEX_SIZE => 64, SIGNATURE_SIZE => 64, EXPORT_KEY_BASE => 62, PASSPHRASE_CIPHER => 'Serpent', PASSPHRASE_CHAINING_MODE => 'CBC', VERSION => '0.01', }; my $term = Term::ReadLine->new(SHORT_APPNAME); my $plage_dir = catdir(get_config_dir(), SHORT_APPNAME); if (not -d $plage_dir) { require File::Path; File::Path::make_path($plage_dir) or die "Can't create directory: $plage_dir"; } my $keyring_file = catfile($plage_dir, 'keys.dat'); if (not -f $keyring_file) { store( { version => VERSION, }, $keyring_file ); } my %KEYRING = %{retrieve($keyring_file)}; my %CONFIG = ( cipher => 'Serpent', chain_mode => 'CBC', sign => 0, compress => 1, compress_method => 'gzip', ); my %COMPRESSION_METHODS = ( gzip => \&gzip_compress_data, zstd => \&zstd_compress_data, zip => \&zip_compress_data, xz => \&xz_compress_data, bzip2 => \&bzip2_compress_data, lzop => \&lzop_compress_data, lzf => \&lzf_compress_data, lzip => \&lzip_compress_data, ); sub create_cipher ($pass, $cipher = $CONFIG{cipher}, $chain_mode = $CONFIG{chain_mode}) { Crypt::CBC->new( -pass => $pass, -cipher => 'Cipher::' . $cipher, -chain_mode => lc($chain_mode), -pbkdf => 'pbkdf2', ); } sub get_config_dir { my $xdg_config_home = $ENV{XDG_CONFIG_HOME}; if ($xdg_config_home and -d -w $xdg_config_home) { return $xdg_config_home; } my $home_dir = $ENV{HOME} || $ENV{LOGDIR} || (($^O eq 'MSWin32') ? '\Local Settings\Application Data' : ((getpwuid($<))[7] || `echo -n ~`)); if (not -d -w $home_dir) { $home_dir = curdir(); } return catdir($home_dir, '.config'); } sub x25519_from_public ($hex_key) { Crypt::PK::X25519->new->import_key( { curve => "x25519", pub => $hex_key, } ); } sub ed25519_from_public ($hex_key) { Crypt::PK::Ed25519->new->import_key( { curve => "ed25519", pub => $hex_key, } ); } sub ed25519_from_private ($hex_key) { Crypt::PK::Ed25519->new->import_key( { curve => "ed25519", priv => $hex_key, } ); } sub x25519_from_private ($hex_key) { Crypt::PK::X25519->new->import_key( { curve => "x25519", priv => $hex_key, } ); } sub x25519_from_private_raw ($raw_key) { Crypt::PK::X25519->new->import_key_raw($raw_key, 'private'); } sub ed25519_from_private_raw ($raw_key) { Crypt::PK::Ed25519->new->import_key_raw($raw_key, 'private'); } sub x25519_random_key { while (1) { my $key = Crypt::PK::X25519->new->generate_key; my $hash = $key->key2hash; next if substr($hash->{pub}, 0, 1) eq '0'; next if substr($hash->{priv}, 0, 1) eq '0'; next if substr($hash->{pub}, -1) eq '0'; next if substr($hash->{priv}, -1) eq '0'; return $key; } } sub ed25519_random_key { while (1) { my $key = Crypt::PK::Ed25519->new->generate_key; my $hash = $key->key2hash; next if substr($hash->{pub}, 0, 1) eq '0'; next if substr($hash->{priv}, 0, 1) eq '0'; next if substr($hash->{pub}, -1) eq '0'; next if substr($hash->{priv}, -1) eq '0'; return $key; } } sub uncompress_data ($data) { require IO::Uncompress::AnyUncompress; IO::Uncompress::AnyUncompress::anyuncompress(\$data, \my $uncompressed) or die "anyuncompress failed: $IO::Uncompress::AnyUncompress::AnyUncompressError\n"; return $uncompressed; } sub gzip_compress_data ($data) { require IO::Compress::Gzip; IO::Compress::Gzip::gzip(\$data, \my $compressed) or die "gzip failed: $IO::Compress::Gzip::GzipError\n"; return $compressed; } sub zip_compress_data ($data) { require IO::Compress::Zip; IO::Compress::Zip::zip(\$data, \my $compressed) or die "zip failed: $IO::Compress::Zip::ZipError\n"; return $compressed; } sub lzop_compress_data ($data) { require IO::Compress::Lzop; IO::Compress::Lzop::lzop(\$data, \my $compressed) or die "lzop failed: $IO::Compress::Lzop::LzopError\n"; return $compressed; } sub lzip_compress_data ($data) { require IO::Compress::Lzip; IO::Compress::Lzip::lzip(\$data, \my $compressed) or die "lzop failed: $IO::Compress::Lzip::LzipError\n"; return $compressed; } sub lzf_compress_data ($data) { require IO::Compress::Lzf; IO::Compress::Lzf::lzf(\$data, \my $compressed) or die "lzop failed: $IO::Compress::Lzf::LzfError\n"; return $compressed; } sub bzip2_compress_data ($data) { require IO::Compress::Bzip2; IO::Compress::Bzip2::bzip2(\$data, \my $compressed) or die "bzip2 failed: $IO::Compress::Bzip2::Bzip2Error\n"; return $compressed; } sub xz_compress_data ($data) { require IO::Compress::Xz; IO::Compress::Xz::xz(\$data, \my $compressed) or die "xz failed: $IO::Compress::Xz::XzError\n"; return $compressed; } sub zstd_compress_data ($data) { require IO::Compress::Zstd; IO::Compress::Zstd::zstd(\$data, \my $compressed) or die "zstd failed: $IO::Compress::Zstd::ZstdError\n"; return $compressed; } sub sign_message ($data, $signature_private_key) { $signature_private_key->sign_message($data); } sub verify_signature ($data, $signature, $signature_public_key) { $signature_public_key->verify_message($signature, $data); } sub encrypt ($data, $public_key) { # Generate a random ephemeral key-pair. my $random_ephem_key = x25519_random_key(); # Create a shared secret, using the random key and the reciever's public key my $shared_secret = $random_ephem_key->shared_secret($public_key); if ($CONFIG{compress}) { $data = $COMPRESSION_METHODS{$CONFIG{compress_method}}($data); } my $cipher = create_cipher($shared_secret); my $ciphertext = $cipher->encrypt($data); my $ephem_pub = $random_ephem_key->key2hash->{pub}; my $dest_pub = $public_key->key2hash->{pub}; return { time => time, dest => $dest_pub, cipher => $CONFIG{cipher}, chain_mode => $CONFIG{chain_mode}, compressed => $CONFIG{compress}, ephem_pub => $ephem_pub, ciphertext => $ciphertext, }; } sub decrypt ($enc, $private_key) { if (not defined $private_key) { die "No private key provided!\n"; } if (ref($private_key) ne 'Crypt::PK::X25519') { die "Invalid private key!\n"; } my $ephem_pub = $enc->{ephem_pub}; my $ciphertext = $enc->{ciphertext}; # Import the public key my $ephem_pub_key = x25519_from_public($ephem_pub); # Recover the shared secret my $shared_secret = $private_key->shared_secret($ephem_pub_key); my $cipher = create_cipher($shared_secret, $enc->{cipher}, $enc->{chain_mode}); my $data = $cipher->decrypt($ciphertext); if ($enc->{compressed}) { $data = uncompress_data($data); } return $data; } sub create_clear_signed_message ($text, $ed_private_key) { if (not defined $ed_private_key) { die "No signature key provided!\n"; } if (ref($ed_private_key) ne 'Crypt::PK::Ed25519') { die "Invalid signature key provided!\n"; } my $signed_message = "-----BEGIN PLAGE SIGNED MESSAGE-----\n"; $text .= "\n"; my $signature = sign_message($text, $ed_private_key); $signed_message .= ($text =~ s/^/ /mgr); $signed_message .= "-----BEGIN PLAGE SIGNATURE-----\n"; my $ed_pub = $ed_private_key->key2hash->{pub}; my %info = ( time => time, sig => encode_base64($signature), ed_pub => $ed_pub, x_pub => $KEYRING{keys}{Ed25519}{$ed_pub}{x_pub}, ); my $json_data = encode_json(\%info); my $sha256 = sha256($json_data); $signed_message .= encode_base64($sha256 . sign_message($sha256, $ed_private_key) . $json_data); $signed_message .= "-----END PLAGE SIGNATURE-----\n"; return $signed_message; } sub get_user_info_for_ed25519_public ($ed_pub) { $KEYRING{keys}{Ed25519}{$ed_pub}; } sub verify_clear_signed_message ($message, $callback = sub { print $_[0] }) { my $collect_msg = 0; my $collect_sig = 0; my $msg = ''; my $base64_sig = ''; open my $fh, '<:raw', \$message; while (defined(my $line = <$fh>)) { if ($line =~ /^-----BEGIN PLAGE SIGNED MESSAGE-----\s*\z/) { $collect_msg = 1; } elsif ($line =~ /^-----BEGIN PLAGE SIGNATURE-----\s*\z/) { $collect_sig = 1; $collect_msg = 0; } elsif ($line =~ /^-----END PLAGE SIGNATURE-----\s*\z/) { last; } elsif ($collect_msg) { $msg .= ($line =~ s/^ //r); } elsif ($collect_sig) { $base64_sig .= $line; } } my $json_data = decode_base64($base64_sig); my $sha256 = substr($json_data, 0, HASH_SIZE, ''); my $sha256_sig = substr($json_data, 0, SIGNATURE_SIZE, ''); if ($sha256 eq '' or $sha256_sig eq '') { die "No signature found!\n"; } if (sha256($json_data) ne $sha256) { die "The signature has been modified: the SHA256 hash does not match!\n"; } my $info = eval { decode_json($json_data) } // die "Invalid JSON data!\n"; my $sig = decode_base64($info->{sig}); my $ed_pub = $info->{ed_pub}; my $x_pub = $info->{x_pub}; my $ed_pub_key = ed25519_from_public($ed_pub); my $user_info = get_user_info_for_ed25519_public($ed_pub); if (not verify_signature($sha256, $sha256_sig, $ed_pub_key)) { die "The signature has been modified: invalid signature for the SHA256 hash!\n"; } if (not verify_signature($msg, $sig, $ed_pub_key)) { die "Bad signature: the message has been modified!\n"; } $callback->($msg); if (defined $user_info) { if ($user_info->{x_pub} ne $x_pub) { die "The public X25519 key does not match!\n"; } if (export_key($info->{x_pub}, $ed_pub) ne $user_info->{public_key}) { die "Public key does not match!\n"; } warn "Signature from $user_info->{username}\n"; } else { warn "Public key: " . export_key($info->{x_pub}, $ed_pub) . "\n"; warn "WARNING: Could not find the key in our keyring!\n"; } warn "Created on: " . scalar localtime($info->{time}) . "\n"; warn "\nGood signature!\n\n"; return $user_info; } sub create_armor ($enc, $ed_key) { my $armor = "-----BEGIN PLAGE ENCRYPTED DATA-----\n"; my %info = %$enc; my $ciphertext = delete $info{ciphertext}; my $json = encode_json(\%info); my $length = length($json); my $content = sprintf("%*d%s%s", JSON_LENGTH_WIDTH, $length, $json, $ciphertext); my $sha256 = sha256($content); my $signature = sign_message($sha256, $ed_key); $armor .= encode_base64($sha256 . $signature . $content); $armor .= "-----END PLAGE ENCRYPTED DATA-----\n"; return $armor; } sub decode_armor ($armor) { my $collect = 0; my $base64_data = ''; open my $fh, '<:raw', \$armor; while (defined(my $line = <$fh>)) { if ($line =~ /^-----BEGIN PLAGE ENCRYPTED DATA-----\s*\z/) { $collect = 1; } elsif ($line =~ /^-----END PLAGE ENCRYPTED DATA-----\s*\z/) { last; } elsif ($collect) { $base64_data .= $line; } } my $content = decode_base64($base64_data); my $sha256 = substr($content, 0, HASH_SIZE, ''); my $sha256_sig = substr($content, 0, SIGNATURE_SIZE, ''); if ($sha256 eq '' or $sha256_sig eq '') { die "Invalid armor!\n"; } if (sha256($content) ne $sha256) { die "The message has been modified: the SHA256 hash does not match!\n"; } my $length = substr($content, 0, JSON_LENGTH_WIDTH, ''); if ($length =~ /^\s*([0-9]+)\z/) { $length = 0 + $1; } if (!$length or $length <= 0) { die "Invalid armor!\n"; } my $json = substr($content, 0, $length, ''); my $info = decode_json($json) // die "Invalid JSON data!\n"; if (not verify_signature($sha256, $sha256_sig, ed25519_from_public($info->{ed_pub}))) { die "Invalid armor: the signature of the SHA256 hash does not match!\n"; } $info->{ciphertext} = $content; return $info; } sub export_key ($x_public_key, $ed_public_key) { require Math::BigInt; my $x = Math::BigInt->from_hex($x_public_key)->to_base(EXPORT_KEY_BASE); my $ed = Math::BigInt->from_hex($ed_public_key)->to_base(EXPORT_KEY_BASE); join('-', $x, $ed); } sub decode_exported_key ($public_key) { require Math::BigInt; my ($x, $ed) = split(/\s*-\s*/, $public_key, 2); $x // return; $ed // return; #<<< ( Math::BigInt->from_base($x, EXPORT_KEY_BASE)->to_hex, Math::BigInt->from_base($ed, EXPORT_KEY_BASE)->to_hex ); #>>> } sub read_password ($text) { ReadMode('noecho'); my $passphrase = $term->readline($text); ReadMode('restore'); warn "\n"; return $passphrase; } sub create_cipher_password ($passphrase, $x_public_key, $ed_public_key) { #<<< unpack("H*", sha256( sha256(pack("H*", $x_public_key)) . sha256($passphrase) . sha256(pack("H*", $ed_public_key)) ) ); #>>> } sub decrypt_private_keys ($info, $prompt = 'Passphrase: ') { my $x_pub = $info->{x_pub}; my $x_priv = $info->{x_priv}; my $ed_pub = $info->{ed_pub}; my $ed_priv = $info->{ed_priv}; for (1 .. 10) { my $passphrase = ''; if ($info->{has_password}) { $passphrase = read_password($prompt) // last; } my $pass = create_cipher_password($passphrase, $x_pub, $ed_pub); my $cipher = create_cipher($pass, PASSPHRASE_CIPHER, PASSPHRASE_CHAINING_MODE); my $x_raw = $cipher->decrypt($x_priv); my $x_key = eval { x25519_from_private_raw($x_raw) } // next; if ($x_key->key2hash->{pub} ne $x_pub) { next; } my $ed_raw = $cipher->decrypt($ed_priv); my $ed_key = eval { ed25519_from_private_raw($ed_raw) } // next; if ($ed_key->key2hash->{pub} ne $ed_pub) { next; } return ($x_key, $ed_key); } return (undef, undef); } sub import_key ($public_key) { my ($x_pub, $ed_pub) = decode_exported_key($public_key); if ( not defined($x_pub) or not defined($ed_pub) or length($x_pub) != PK_HEX_SIZE or length($ed_pub) != PK_HEX_SIZE) { die "Invalid public key!\n"; } if (exists $KEYRING{keys}{X25519}{$x_pub}) { die "The X25519 key already exists for username: $KEYRING{keys}{X25519}{$x_pub}{username}\n"; } if (exists $KEYRING{keys}{Ed25519}{$ed_pub}) { die "The Ed25519 key already exists for username: $KEYRING{keys}{Ed25519}{$ed_pub}{username}\n"; } # Make sure the keys work my $x_key = x25519_from_public($x_pub); my $ed_key = ed25519_from_public($ed_pub); if ($x_key->key2hash->{pub} ne $x_pub) { die "Invalid X25519 key!\n"; } if ($ed_key->key2hash->{pub} ne $ed_pub) { die "Invalid Ed25519 key!\n"; } my $username = $CONFIG{name} // $term->readline('Username: ') // return; $username = make_unique_username($username, $x_pub); my %info = ( time => time, username => $username, x_pub => $x_pub, ed_pub => $ed_pub, public_key => export_key($x_pub, $ed_pub), ); $KEYRING{keys}{X25519}{$x_pub} = \%info; $KEYRING{keys}{Ed25519}{$ed_pub} = \%info; if (store(\%KEYRING, $keyring_file)) { say "Successfully imported key: $username"; } else { die "Failed to import key: $!\n"; } return 1; } sub remove_key ($username) { my @keys = find_keys($username); if (not @keys) { die "No keys found matching the given username.\n"; } my $removed = 0; foreach my $key (@keys) { say "Public key : $key->{public_key}"; say "Added on : " . localtime($key->{time}); if ($term->ask_yn(prompt => "Remove key $key->{username}?", default => 'n')) { if ($key->{mine} ? $term->ask_yn(prompt => "Are you sure?", default => 'n') : 1) { delete $KEYRING{keys}{X25519}{$key->{x_pub}}; delete $KEYRING{keys}{Ed25519}{$key->{ed_pub}}; ++$removed; } } } if ($removed and store(\%KEYRING, $keyring_file)) { say "Successfully removed $removed keys."; } else { say "No keys removed."; } return 1; } sub change_password ($username) { my @keys = grep { $_->{mine} } find_keys($username); if (not @keys) { die "No owned keys found matching the given username.\n"; } my $updated = 0; foreach my $key (@keys) { if ($term->ask_yn(prompt => "Change password for $key->{username}?", default => 'n')) { my ($x_key, $ed_key) = decrypt_private_keys($key, "Old passphrase: "); my $passphrase = read_confirmed_passphrase("New passphrase: "); if (not defined($passphrase) or $passphrase eq '') { if ($term->ask_yn(prompt => "Are you sure you want to use no password?", default => 'n')) { $passphrase = ''; } else { next; } } my $x_key_hash = $x_key->key2hash; my $ed_key_hash = $ed_key->key2hash; my $x_public_key = $x_key_hash->{pub}; my $ed_public_key = $ed_key_hash->{pub}; my ($x_private_key, $ed_private_key) = encrypt_private_keys($passphrase, $x_key_hash, $ed_key_hash); if ($passphrase eq '') { $key->{has_password} = 0; } else { $key->{has_password} = 1; } $key->{x_priv} = $x_private_key; $key->{ed_priv} = $ed_private_key; $KEYRING{keys}{X25519}{$x_public_key} = $key; $KEYRING{keys}{Ed25519}{$ed_public_key} = $key; ++$updated; } } if ($updated and store(\%KEYRING, $keyring_file)) { say "Successfully changed the password of $updated keys."; } else { say "No passwords changed."; } return 1; } sub make_unique_username ($username, $x_public_key) { $username = join('_', split(' ', $username)); if ($username ne '') { $username .= '-'; } $username .= substr($x_public_key, -(USER_ID_SIZE)); return $username; } sub read_confirmed_passphrase ($prompt = 'Passprhase: ') { my $passphrase = read_password($prompt) // return; while (1) { my $confirmed_passphrase = read_password('Confirm passphrase: ') // return; if ($passphrase eq $confirmed_passphrase) { last; } say "Passphrases do not match. Try again."; $passphrase = read_password($prompt) // return; } return $passphrase; } sub encrypt_private_keys ($passphrase, $x_key, $ed_key) { my $cipher_password = create_cipher_password($passphrase, $x_key->{pub}, $ed_key->{pub}); my $cipher = create_cipher($cipher_password, PASSPHRASE_CIPHER, PASSPHRASE_CHAINING_MODE); my $x_private_key = $cipher->encrypt(pack("H*", $x_key->{priv})); my $ed_private_key = $cipher->encrypt(pack("H*", $ed_key->{priv})); return ($x_private_key, $ed_private_key); } sub generate_new_key { my $username = $term->readline('Username: ') // return; my $passphrase = read_confirmed_passphrase() // return; my $default = $term->ask_yn(prompt => "Make this the default key?", default => 'y'); my $x25519_key = x25519_random_key(); my $ed25519_key = ed25519_random_key(); my $x_key = $x25519_key->key2hash; my $ed_key = $ed25519_key->key2hash; my $x_public_key = $x_key->{pub}; my $ed_public_key = $ed_key->{pub}; $username = make_unique_username($username, $x_public_key); my ($x_private_key, $ed_private_key) = encrypt_private_keys($passphrase, $x_key, $ed_key); my %info = ( time => time, mine => 1, username => $username, has_password => (($passphrase eq '') ? 0 : 1), x_pub => $x_public_key, x_priv => $x_private_key, ed_pub => $ed_public_key, ed_priv => $ed_private_key, public_key => export_key($x_public_key, $ed_public_key), ); $KEYRING{keys}{X25519}{$x_public_key} = \%info; $KEYRING{keys}{Ed25519}{$ed_public_key} = \%info; if ($default) { $KEYRING{keys}{default} = $x_public_key; } store(\%KEYRING, $keyring_file); say "Successfully generated key: $username"; return 1; } sub get_all_keys { my $xkeys = $KEYRING{keys}{X25519}; my @keys = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [CORE::fc($_->{username}), $_] } values %$xkeys; return @keys; } sub list_my_keys { my @my_keys = grep { $_->{mine} } get_all_keys(); foreach my $key (@my_keys) { say "Username : ", $key->{username}; say "Public key : ", $key->{public_key}; say "Created on : ", scalar localtime($key->{time}); say "Has password : ", ($key->{has_password} ? 'Yes' : 'No'); say "Default key : ", (($KEYRING{keys}{default} eq $key->{x_pub}) ? "Yes" : "No"); say ''; } return 1; } sub list_keys { my @keys = get_all_keys(); foreach my $key (@keys) { say "Username : ", $key->{username}; say "Public key : ", $key->{public_key}; say "Added on : ", scalar localtime($key->{time}); say ''; } return 1; } sub select_one_key ($keys) { if (scalar(@$keys) == 1) { return $keys->[0]; } if (scalar(@$keys) > 1) { die "Multiple usernames matched:\n\t" . join("\n\t", map { $_->{username} } @$keys) . "\n"; } die "No username could be matched.\n"; } sub find_keys ($username) { my @keys = get_all_keys(); my $regex = qr/\Q$username\E/i; my @found_keys; foreach my $key (@keys) { if ($key->{username} =~ $regex) { push @found_keys, $key; } } return @found_keys; } sub get_public_x25519_for_user ($username) { my @keys = find_keys($username); my $key = select_one_key(\@keys); return x25519_from_public($key->{x_pub}); } sub get_info_for_public_x25519 ($x_pub) { $KEYRING{keys}{X25519}{$x_pub}; } sub get_private_keys_for_public_x25519 ($x_pub) { my $info = get_info_for_public_x25519($x_pub); ref($info) eq 'HASH' or die "No decryption key found!\n"; $info->{mine} || die "Sorry! You don't have the private key of $info->{username}!\n"; decrypt_private_keys($info); } sub change_user ($username) { my @keys = grep { $_->{mine} } find_keys($username); my $key = select_one_key(\@keys); $KEYRING{keys}{default} = $key->{x_pub}; warn "Current user: $key->{username}\n"; return 1; } sub get_input_fh { my $fh = \*STDIN; if (@ARGV and -t $fh) { sysopen(my $file_fh, $ARGV[0], 0) or die "Can't open file <<$ARGV[0]>> for reading: $!"; return $file_fh; } return $fh; } sub read_input { my $fh = get_input_fh(); local $/; <$fh>; } sub help ($exit_code) { local $" = " "; my @compression_methods = grep { eval { uncompress_data($COMPRESSION_METHODS{$_}('test')) eq 'test' } } sort keys %COMPRESSION_METHODS; my @chaining_modes = map { uc } qw(cbc pcbc cfb ofb ctr); my @valid_ciphers = sort grep { eval { require "Crypt/Cipher/$_.pm"; 1 }; } qw( AES Anubis Twofish Camellia Serpent SAFERP ); print <<"EOT"; usage: $0 [options] [output] Encryption and signing: -e --encrypt=user : Encrypt data for a given user -d --decrypt : Decrypt data encrypted for you -s --sign! : Sign the message with your private key (default: $CONFIG{sign}) --clear-sign : Create a signed message, without encryption --verify-message : Verify a clear signed message --cipher=s : Change the symmetric cipher (default: $CONFIG{cipher}) valid: @valid_ciphers --chain-mode=s : Change the chaining mode (default: $CONFIG{chain_mode}) valid: @chaining_modes Users: --user=name : Change the default user temporarily --default-user=name : Set a new default user Keys: -l --list-keys : List all the keys -L --list-mine : List the keys that you own -g --generate-key : Generate a new key-pair -i --import=key : Import a given public key --name=s : Give a name to the imported key --export=name : Export a public key from your keyring --remove=name : Remove a given key from your keyring --password=name : Change the passphrase of your key Compression options: --compress! : Compress data before encryption (default: $CONFIG{compress}) --compress-method=s : Compression method (default: $CONFIG{compress_method}) valid: @compression_methods Examples: # Generate a key $0 -g # Import a key $0 -i [PublicKey] --name=Alice # Encrypt and sign a message for Alice $0 -e=Alice -s message.txt > message.enc # Decrypt a received message $0 -d message.enc > message.txt EOT exit($exit_code); } sub version { my $width = 20; printf("%-*s %s\n", $width, SHORT_APPNAME, VERSION); printf("%-*s %s\n", $width, 'Crypt::CBC', $Crypt::CBC::VERSION); printf("%-*s %s\n", $width, 'Crypt::PK::X25519', $Crypt::PK::X25519::VERSION); printf("%-*s %s\n", $width, 'Crypt::PK::Ed25519', $Crypt::PK::Ed25519::VERSION); exit(0); } GetOptions( 'cipher=s' => \$CONFIG{cipher}, 'chain-mode|mode=s' => \$CONFIG{chain_mode}, 'compress!' => \$CONFIG{compress}, 'compress-method=s' => \$CONFIG{compress_method}, 'name=s' => \$CONFIG{name}, 'user=s' => \$CONFIG{change_user}, 'default-user=s' => \$CONFIG{change_default_user}, 'password:s' => \$CONFIG{change_password}, 'a|armor' => \$CONFIG{armor}, 'l|list-keys' => \$CONFIG{list_keys}, 'L|list-mine' => \$CONFIG{list_my_keys}, 'i|import-key=s' => \$CONFIG{import}, 'export-key:s' => \$CONFIG{export}, 'remove-key:s' => \$CONFIG{remove}, 'g|generate-key!' => \$CONFIG{generate_key}, 'e|encrypt=s' => \$CONFIG{encrypt}, 'd|decrypt!' => \$CONFIG{decrypt}, 's|sign!' => \$CONFIG{sign}, 'clear-sign' => \$CONFIG{clear_sign}, 'verify-message' => \$CONFIG{verify_message}, 'v|version' => \&version, 'h|help' => sub { help(0) }, ) or die("Error in command line arguments\n"); if (not exists $COMPRESSION_METHODS{$CONFIG{compress_method}}) { die "Invalid compression method: $CONFIG{compress_method}\n"; } if (defined $CONFIG{change_user}) { change_user($CONFIG{change_user}); } if (defined $CONFIG{change_default_user}) { change_user($CONFIG{change_default_user}); store(\%KEYRING, $keyring_file); } if ($CONFIG{generate_key}) { generate_new_key(); exit 0; } if ($CONFIG{list_keys}) { list_keys(); exit 0; } if ($CONFIG{list_my_keys}) { list_my_keys(); exit 0; } if (defined($CONFIG{export})) { foreach my $key (find_keys($CONFIG{export})) { say "Username : $key->{username}"; say "Public key : $key->{public_key}"; say ''; } exit 0; } if (defined($CONFIG{import})) { import_key($CONFIG{import}); exit 0; } if (defined($CONFIG{remove})) { remove_key($CONFIG{remove}); exit 0; } if (defined($CONFIG{change_password})) { change_password($CONFIG{change_password}); exit 0; } my $local_user = sub { if (not defined($KEYRING{keys}{default}) or not defined($KEYRING{keys}{X25519}{$KEYRING{keys}{default}})) { die "No default user found!\nPass --user=s to select a key, or generate a new key with -g\n"; } state $x_key; state $ed_key; if (defined($x_key) and defined($ed_key)) { return ($x_key, $ed_key); } ($x_key, $ed_key) = decrypt_private_keys($KEYRING{keys}{X25519}{$KEYRING{keys}{default}}); return ($x_key, $ed_key); }; if ($CONFIG{clear_sign}) { my $text = read_input(); my ($x_key, $ed_key) = $local_user->(); print create_clear_signed_message($text, $ed_key); exit 0; } if ($CONFIG{verify_message}) { my $text = read_input(); verify_clear_signed_message($text); exit 0; } if (defined($CONFIG{encrypt})) { my $x_pub = get_public_x25519_for_user($CONFIG{encrypt}); my $text = read_input(); my $enc = encrypt($text, $x_pub); my $ed_key = undef; if ($CONFIG{sign}) { (undef, $ed_key) = $local_user->(); } else { $ed_key = ed25519_random_key(); } $enc->{ed_pub} = $ed_key->key2hash->{pub}; $enc->{signature} = encode_base64(sign_message($text, $ed_key)); my $armor = create_armor($enc, $ed_key); if ($CONFIG{sign}) { syswrite(STDOUT, create_clear_signed_message($armor, $ed_key)); } else { syswrite(STDOUT, $armor); } exit 0; } if ($CONFIG{decrypt}) { my $armor = read_input(); my $exped_info = undef; if ($armor =~ /^-----BEGIN PLAGE SIGNED MESSAGE-----\s*$/m) { $exped_info = verify_clear_signed_message($armor, sub ($msg) { $armor = $msg }); } my $enc = decode_armor($armor); if (defined($exped_info) and $enc->{ed_pub} ne $exped_info->{ed_pub}) { die "The expeditor public signature key does not match!\n"; } my $dest_info = get_info_for_public_x25519($enc->{dest}); if (not defined $dest_info) { die "Sorry! You don't have the private key to decrypt this message!\n"; } warn "Destination : " . $dest_info->{username} . "\n"; warn "Cipher used : " . join('+', uc($enc->{chain_mode}), $enc->{cipher}) . "\n"; warn "Compressed : " . ($enc->{compressed} ? "Yes" : "No") . "\n"; warn "Encrypted on : " . localtime($enc->{time}) . "\n"; my ($x_priv, undef) = get_private_keys_for_public_x25519($enc->{dest}); my $data = decrypt($enc, $x_priv); if (not verify_signature($data, decode_base64($enc->{signature}), ed25519_from_public($enc->{ed_pub}))) { die "The signature of the message does not match!\n"; } syswrite(STDOUT, $data); exit 0; } help(1); ================================================ FILE: Encryption/simple_XOR_cipher.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 03 March 2022 # https://github.com/trizen # A simple encryption cihpher, using XOR with SHA-512 of the key and substring shuffling. # WARNING: should NOT be used for encrypting real-world data. # See also: # https://en.wikipedia.org/wiki/Block_cipher # https://en.wikipedia.org/wiki/XOR_cipher use 5.020; use strict; use warnings; use experimental qw(signatures); use ntheory qw(random_bytes); use Digest::SHA qw(sha512); use constant { ROUNDS => 13, # how many encryption rounds to perform }; sub encrypt ($str, $key) { if (length($str) > 64) { die "Input string is too long. Max size: 64\n"; } if (length($str) != 64) { $str .= random_bytes(64 - length($str)); } $key = sha512($key); $str ^= $key; my $i = my $l = length($str); for my $k (1 .. ROUNDS) { $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0); $str ^= sha512($key . $k); $str =~ s/(.{$i})(.)/$2$1/sg while (++$i < $l); $str ^= sha512($k . $key); } return $str; } sub decrypt ($str, $key, $len = 64) { $key = sha512($key); my $i = my $l = length($str); for my $k (reverse(1 .. ROUNDS)) { $str ^= sha512($k . $key); $str =~ s/(.)(.{$i})/$2$1/sg while (--$i > 0); $str ^= sha512($key . $k); $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l); } $str ^= $key; $str = substr($str, 0, $len); return $str; } my $text = "Hello, world!"; my $key = "foo"; say decrypt(encrypt($text, $key), $key, length($text)); #=> "Hello, world!" ================================================ FILE: File Readers/ldump ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 February 2013 # https://github.com/trizen # Get the specified lines from a given file. use 5.010; use strict; use warnings; @ARGV == 2 or die <<"USAGE"; usage: ldump [file] [lines] example: ldump /tmp/file.txt 23-40,80,105 USAGE my @lines = map { /^(\d+)(?>-|\.\.)(\d+)\z/ ? ($1 .. $2) : $_ } split /\s*,\s*/, pop; my %lookup; @lookup{@lines} = (); while (<>) { print if exists($lookup{$.}); } ================================================ FILE: File Readers/multi-file-line-reader.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 13 April 2012 # https://github.com/trizen # If you saw this code on perlmonks.org, # posted by an Anonymous Monk, that was me. my (@files) = @ARGV ? @ARGV : ($0, $0); my @fh; my $i = 0; foreach my $file (@files) { next unless -f -r $file; open $fh[$i++], '<', $file or die "Cannot open ${file}: $!"; } while (1) { my @lines; foreach my $i (0 .. $#fh) { next unless ref $fh[$i] eq 'GLOB'; push @lines, scalar readline $fh[$i]; if (eof $fh[$i]) { close $fh[$i]; $fh[$i] = undef; } } last unless @lines; foreach my $line (@lines) { print $line; } } ================================================ FILE: File Readers/n_repeated_lines.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 April 2014 # Website: https://github.com/trizen # Print only the lines that repeat n times in one or more files. # usage: perl n_repeated_lines.pl [n] [file1.txt] [...] use strict; use warnings; my $n = @ARGV && not(-f $ARGV[0]) ? shift() : 2; my %seen; while (<>) { /\S/ || next; ++$seen{unpack('A*')} == $n && print; } ================================================ FILE: File Readers/tailz ================================================ #!/usr/bin/perl # Simple program to read the last n line(s) of a file. # Reads from the end of the file for efficiency. # Originally coded by zentara on 06 September 2002: # https://www.perlmonks.org/index.pl?node_id=195768 # Improved by Trizen on 11 February 2012 # usage tailz filename numberoflines my $filename = shift or die "usage: $0 file numlines\n"; my $numlines = shift // 10; my $byte; # Open the file in read mode open my $fh, '<', $filename or die "Couldn't open $filename: $!"; # Rewind from the end of the file until count of eol 's seek $fh, -1, 2; # get past last eol my $count = 0; while (tell($fh) > 0) { seek $fh, -1, 1; read $fh, $byte, 1; last if $byte eq "\n" and ++$count == $numlines; seek $fh, -1, 1; } local $/ = undef; print scalar <$fh>; ================================================ FILE: File Workers/arxiv_pdf_renamer.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 February 2024 # https://github.com/trizen # Rename PDFs downloaded from arxiv.org, to their paper title. # usage: perl script.pl [PDF files] use 5.036; use WWW::Mechanize; use File::Basename qw(dirname basename); use File::Spec::Functions qw(catfile); my $mech = WWW::Mechanize->new( autocheck => 0, show_progress => 0, stack_depth => 10, agent => 'Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:122.0) Gecko/20100101 Firefox/122.0', ); foreach my $pdf_file (@ARGV) { my $pdf_content = do { open my $fh, '<:raw', $pdf_file or do { warn "Can't open file <<$pdf_file>>: $!\n"; next; }; local $/; <$fh>; }; my $url = undef; if ($pdf_content =~ m{\bURI\s*\((https?://arxiv\.org/.*?)\)}) { $url = $1; $url =~ s{^http://}{https://}; } elsif (basename($pdf_file) =~ /^([0-9]+\.[0-9]+)\.pdf\z/i) { $url = "https://arxiv.org/abs/$1"; } my $title = undef; if (defined($url)) { my $resp = $mech->get($url); if ($resp->is_success) { $title = $resp->title; } } if (defined($title)) { $title =~ s{\[.*?\]\s*}{}; $title =~ s/: / - /g; $title =~ tr{:"*/?\\|}{;'+%!%%}; # " $title =~ tr/<>${}//d; $title = join(q{ }, split(q{ }, $title)); $title = substr($title, 0, 250); # make sure the filename is not too long $title .= ".pdf"; my $basename = basename($pdf_file); say "Renaming: $basename -> $title"; my $dest = catfile(dirname($pdf_file), $title); if (-e $dest) { warn "File <<$dest>> already exists... Skipping...\n"; } else { rename($pdf_file, $dest) or warn "Failed to rename: $!\n"; } } else { say "Not an arxiv PDF: $pdf_file"; } } __END__ # Example: $ perl arxiv_pdf_renamer.pl *.pdf ** GET https://arxiv.org/abs/math/0504119v1 ==> 200 OK (1s) Renaming: 0504119.pdf -> The Carmichael numbers up to 10^17.pdf ** GET https://arxiv.org/abs/2311.07048v1 ==> 200 OK Renaming: 2311.07048.pdf -> Gauss-Euler Primality Test.pdf ================================================ FILE: File Workers/auto_extensions.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 30 May 2020 # https://github.com/trizen # Automatically determine the mime type of files and add the corresponding file extensions. # Usage: # perl script.pl [dir] use 5.020; use autodie; use warnings; use List::Util qw(any); use File::Find qw(find); use File::MimeInfo::Magic qw(mimetype extensions); use File::Basename qw(dirname basename); use File::Spec::Functions qw(curdir catfile); my $dir = $ARGV[0] // curdir(); find( { no_chdir => 1, wanted => sub { return 1 if not -f $_; my $dirname = dirname($_); my $basename = basename($_); my @extensions = extensions(mimetype($_)); return 1 if not @extensions; if (any { defined($_) and $basename =~ /\.\Q$_\E\z/ } @extensions) { return 1; # already has extension -- skip } my $ext = $extensions[0] // return 1; my $newfile = catfile($dirname, $basename . '.' . $ext); if (-e $newfile) { say ":: $newfile already exists..."; } else { say ":: Renaming: $_ -> $newfile"; rename($_, $newfile); } }, } => $dir ); ================================================ FILE: File Workers/collect_gifs.pl ================================================ #!/usr/bin/perl # Collect and move GIF images into a specific directory, by scanning a given a directory (and its subdirectories) for GIF images. use 5.036; use File::Find qw(find); use File::Copy qw(move); use File::Path qw(make_path); use File::Basename qw(basename); use File::Spec::Functions qw(catfile curdir rel2abs); use Getopt::Long qw(GetOptions); my $use_exiftool = 0; # true to use `exiftool` instead of `File::MimeInfo::Magic` sub is_gif ($file) { if ($use_exiftool) { my $res = `exiftool \Q$file\E`; $? == 0 or return; defined($res) or return; return ($res =~ m{^MIME\s+Type\s*:\s*image/gif}mi); } require File::MimeInfo::Magic; (File::MimeInfo::Magic::magic($file) // '') eq 'image/gif'; } sub collect_gif ($file, $directory) { my $dest = catfile($directory, basename($file)); if (-e $dest) { warn "File <<$dest>> already exists...\n"; return; } move($file, $dest); } GetOptions('exiftool!' => \$use_exiftool,) or die "Error in command-line arguments!"; my @dirs = @ARGV; @dirs || die "usage: perl $0 [directory | files]\n"; my $directory = rel2abs("GIF images"); # directory where to move the files if (not -d $directory) { make_path($directory) or die "Can't create directory <<$directory>>: $!"; } if (not -d $directory) { die "<<$directory>> is not a directory!"; } find( { wanted => sub { if (-f $_ and is_gif($_)) { say ":: Moving file: $_"; collect_gif($_, $directory); } }, }, @dirs ); ================================================ FILE: File Workers/collect_videos.pl ================================================ #!/usr/bin/perl # Collect and move video files into a specific directory, by scanning a given a directory (and its subdirectories) for video files. # Requires `exiftool`. use 5.036; use File::Find qw(find); use File::Copy qw(move); use File::Path qw(make_path); use File::Basename qw(basename); use File::Spec::Functions qw(catfile curdir rel2abs); sub is_video ($file) { my $res = `exiftool \Q$file\E`; $? == 0 or return; defined($res) or return; $res =~ m{^MIME\s+Type\s*:\s*video/}mi; } sub collect_video ($file, $directory) { my $dest = catfile($directory, basename($file)); if (-e $dest) { warn "File <<$dest>> already exists...\n"; return; } move($file, $dest); } my @dirs = @ARGV; @dirs || die "usage: perl $0 [directory | files]\n"; my $directory = rel2abs("Videos"); # directory where to move the videos if (not -d $directory) { make_path($directory) or die "Can't create directory <<$directory>>: $!"; } if (not -d $directory) { die "<<$directory>> is not a directory!"; } find( { wanted => sub { if (-f $_ and is_video($_)) { say ":: Moving video: $_"; collect_video($_, $directory); } }, }, @dirs ); ================================================ FILE: File Workers/delete_if_exists.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # https://github.com/trizen # # Delete files from $delete_dir if exists in $compare_dir (or its sub-directories) # # Usage: perl delete_if_exists.pl /delete/dir /compare/dir # use strict; use warnings; use File::Find qw(find); use File::Spec::Functions qw(rel2abs catdir); my $delete_dir = rel2abs(shift); my $compare_dir = rel2abs(shift || die "usage: $0 [delete_dir] [compare_dir]\n"); find sub { return unless -f; my $delete_file = catdir($delete_dir, $_); if (-f $delete_file) { print unlink($delete_file) ? "** Deleted: $delete_file\n" : "[!] Can't delete $delete_file: $!\n"; } } => $compare_dir; ================================================ FILE: File Workers/dir_file_updater.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 04 November 2012 # https://github.com/trizen # Update files in a directory, with files from other dirs. # Example: perl dir_file_updater.pl -o /tmp /root # /tmp/file.txt is updated with the newest file from the /root dir, # or it's sub-directories, called file.txt, but only if the file is newer # than the file from the /tmp dir. This script updates only the files from # the OUTPUT_DIR, without checking it's sub-directories. use 5.010; use strict; use warnings; use File::Copy qw(copy); use File::Find qw(find); use Getopt::Std qw(getopts); use File::Compare qw(compare); use File::Spec::Functions qw(rel2abs catfile); my %opts; getopts('o:', \%opts); sub usage { die <<"EOH"; usage: $0 [options] [dirs] options: -o : update files in this directory example: $0 -o /my/path/out /my/path/input EOH } my $output_dir = $opts{o}; if ( not defined $output_dir or not -d $output_dir or not @ARGV) { usage(); } $output_dir = rel2abs($output_dir); my %table; sub update_files { my $file = $File::Find::name; return unless -f $file; if (not exists $table{$_} or -M ($table{$_}) > -M ($file)) { $table{$_} = $file; } } my @dirs; foreach my $dir (@ARGV) { if (not -d -r $dir) { warn "[!] Invalid dir '$dir': $!\n"; next; } push @dirs, rel2abs($dir); } find {wanted => \&update_files,} => @dirs; opendir(my $dir_h, $output_dir) or die "Can't read dir '$output_dir': $!\n"; while (defined(my $file = readdir($dir_h))) { next if $file eq q{.} or $file eq q{..}; my $filename = catfile($output_dir, $file); next unless -f $filename; if (exists $table{$file}) { if (-M ($table{$file}) < -M ($filename) and compare($table{$file}, $filename) != 0) { say "Updating: $table{$file} -> $filename"; copy($table{$file}, $filename) or do { warn "[!] Copy failed: $!\n" }; } } } closedir $dir_h; ================================================ FILE: File Workers/file-mover.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 23 August 2015 # Website: https://github.com/trizen # Sort and move a list of file names into a given directory use 5.016; use strict; use warnings; use open IO => ':utf8', ':std'; use File::Copy qw(move); use File::Basename qw(basename); use File::Spec::Functions qw(catfile); use Getopt::Long qw(GetOptions); my $reverse = 0; # bool my $sort_by = 'none'; # string my $output_dir; # string my $move = 'none'; # string my %sorts = ( none => sub { }, name => sub { $a cmp $b }, iname => sub { fc($a) cmp fc($b) }, length => sub { length($a) <=> length($b) }, size => sub { (-s $a) <=> (-s $b) }, atime => sub { (stat($a))[8] <=> (stat($b))[8] }, mtime => sub { (stat($a))[9] <=> (stat($b))[9] }, ctime => sub { (stat($a))[10] <=> (stat($b))[10] }, ); sub help { print <<"EOT"; usage: $0 [options] < [input.txt] options: -s --sort-by=s : sort the files by: name -> sort by filename iname -> sort by filename case-insensitively length -> sort by the length of the filename size -> sort by the size of the file atime -> sort by file access time mtime -> sort by file modification time ctime -> sort by file inode change time none -> don't do any sorting (default) -r --reverse! : reverse the sorting -o --out-dir=s : move the files into this directory -m --move=s : move the files as follows: first -> moves the first n-1 files last -> moves the last n-1 files all -> moves all files none -> don't move any file (default) example: $0 --sort-by=mtime --move=last --out-dir=/tmp < files.txt EOT exit 0; } GetOptions( 'm|move=s' => \$move, 'r|reverse!' => \$reverse, 'o|out-dir=s' => \$output_dir, 's|sort-by|sortby=s' => \$sort_by, 'h|help' => \&help, ) or die("error in command line arguments"); my $sort_code = $sorts{lc($sort_by)} // die "Invalid value `$sort_by' for option `--sort-by'"; if ($move ne 'none') { if (defined($output_dir)) { if (not -d $output_dir) { die "Invalid value `$output_dir' for option `--out-dir' (requires an existent directory)"; } } else { die "Please add the `--out-dir' option, in order to `--move` files"; } } sub process_files { my (@files) = @_; @files = do { my %seen; grep { !$seen{$_}++ } @files; }; if ($sort_by ne 'none') { @files = sort $sort_code @files; } if ($reverse) { @files = reverse(@files); } my @all_files = @files; if ($move eq 'none') { @files = (); } elsif ($move eq 'first') { @files = @files[0 .. $#files - 1]; } elsif ($move eq 'last') { @files = @files[1 .. $#files]; } elsif ($move eq 'all') { ## ok } else { die "Invalid value `$move' for `--move`"; } my %table; @table{@files} = (); foreach my $file (@all_files) { print $file; if (exists $table{$file}) { my $basename = basename($file); my $dest = catfile($output_dir, $basename); print " -> $dest"; if (-e $dest) { print " (error: already exists)"; } else { if (move($file, $dest)) { print " (OK)"; } else { print " (error: $!)"; } } } print "\n"; } if (@all_files) { say "-" x 80; } } my @files; while (defined(my $line = <>)) { chomp($line); if (-e $line) { push @files, $line; } elsif (@files) { process_files(@files); @files = (); } } process_files(@files) if @files; ================================================ FILE: File Workers/file_updater.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 04 November 2012 # https://github.com/trizen # Update files in a directory, with files from other dirs. # Example: perl file_updater.pl -o /tmp /root # /tmp/dir/file.txt is updated with /root/dir/file.txt # if the file from the /root dir is newer than the file from the /tmp dir. use 5.010; use strict; use warnings; use File::Copy qw(copy); use File::Find qw(find); use Getopt::Std qw(getopts); use File::Compare qw(compare); use File::Spec::Functions qw(rel2abs catfile); my %opts; getopts('o:', \%opts); sub usage { die <<"EOH"; usage: $0 [options] [dirs] options: -o : update files in this directory example: $0 -o /my/path/out /my/path/input EOH } my $output_dir = $opts{o}; if ( not defined $output_dir or not -d $output_dir or not @ARGV) { usage(); } $output_dir = rel2abs($output_dir); my @dirs; foreach my $dir (@ARGV) { if (not -d -r $dir) { warn "[!] Invalid dir '$dir': $!\n"; next; } push @dirs, rel2abs($dir); } sub update_files { return if $_ eq $output_dir; return unless -f; my $filename = substr($_, length($output_dir) + 1); my $mdays = -M _; foreach my $dir (@dirs) { my $file = catfile($dir, $filename); if (-e $file and -M (_) < $mdays and compare($file, $_) == 1) { say "Updating: $file -> $_"; copy($file, $_) or do { warn "[!] Copy failed: $!\n" }; } } } find { no_chdir => 1, wanted => \&update_files, } => $output_dir; ================================================ FILE: File Workers/filename_cmp_del.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 16 June 2014 # Website: https://github.com/trizen # Delete files from [del dir] which does NOT exists in [cmp dir] # NOTE: Only the base names are compared, without their extensions! use 5.014; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Spec::Functions qw(catfile); sub usage { my ($code) = @_; print <<"EOT"; usage: $0 [options] [cmp dir] [del dir] options: -d : delete the files -h : print this message example: $0 -d /my/cmp_dir /my/del_dir EOT exit $code; } # Options getopts('dh', \my %opt); $opt{h} and usage(0); # Dirs @ARGV == 2 or usage(2); my $cmp_dir = shift; my $del_dir = shift; my $rem_suffix = qr/\.\w{1,5}\z/; # Read the [cmp dir] and store the filenames in %cmp my %cmp; opendir(my $cmp_h, $cmp_dir); while (defined(my $file = readdir($cmp_h))) { my $abs_path = catfile($cmp_dir, $file); if (-f $abs_path) { undef $cmp{$file =~ s/$rem_suffix//r}; } } closedir($cmp_h); # Delete each file which doesn't exists in [cmp dir] opendir(my $del_h, $del_dir); while (defined(my $file = readdir($del_h))) { my $abs_path = catfile($del_dir, $file); if (-f $abs_path) { my $name = $file =~ s/$rem_suffix//r; if (not exists $cmp{$name}) { say $abs_path; unlink $abs_path if $opt{d}; } } } closedir($del_h); ================================================ FILE: File Workers/keep_this_formats.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 12 September 2012 # Edit: 11 August 2017 # https://github.com/trizen # Keep only one or more type of file formats in a directory and its sub-directories. # List and remove the other formats (when -r is specified). use 5.010; use strict; use warnings; use File::Find qw(find); use Getopt::Std qw(getopts); sub usage { die <<"USAGE"; usage: $0 [options] options: -f : the list of formats (comma separated) -r : remove the other formats (default: off) example: $0 -f 'mp3,ogg,wma' /home/Music USAGE } my %opts; getopts('f:r', \%opts); $opts{f} // usage(); @ARGV || usage(); my $formats_re = do { local $" = '|'; my @a = map { quotemeta } split(/\s*,\s*/, $opts{f}); qr/\.(?:@a)\z/i; }; find { wanted => sub { if (not /$formats_re/ and -f) { say $_; if ($opts{r}) { unlink($_) or warn "Can't remove file '$_': $!"; } } }, no_chdir => 1, } => @ARGV; ================================================ FILE: File Workers/make_filenames_portable.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 16 June 2014 # Website: https://github.com/trizen # Replace unsafe characters with safe characters in filenames # making the files portable to another FS (like FAT32) use 5.014; use strict; use autodie; use warnings; use Getopt::Std qw(getopts); use File::Spec::Functions qw(catfile); sub usage { my ($code) = @_; print <<"EOT"; usage: $0 [options] [dir1] [dir2] [...] options: -r : rename the files -h : print this message example: $0 -r /my/dir EOT exit $code; } # Parse arguments getopts('rh', \my %opt); usage(0) if $opt{h}; usage(2) if !@ARGV; # Iterate over directories while (defined(my $dir = shift @ARGV)) { opendir(my $dir_h, $dir); while (defined(my $file = readdir($dir_h))) { my $orig_name = catfile($dir, $file); if (-f $orig_name and $file =~ tr{:"*/?\\|}{;'+%$%%}) { my $new_name = catfile($dir, $file); say "$orig_name -> $new_name"; rename($orig_name, $new_name) if $opt{r}; } } closedir($dir_h); } ================================================ FILE: File Workers/md5_rename.pl ================================================ #!/usr/bin/perl # Rename files to their MD5 hex value in a given directory (and its subdirectories). # Example: # "IMG_20231024_094115.jpg" becomes "571b4ba928ae62e103b54727721ebe56.jpg" use 5.036; use Digest::MD5 qw(); use File::Find qw(find); use File::Basename qw(dirname basename); use File::Spec::Functions qw(catfile); sub md5_rename_file ($file) { open my $fh, '<:raw', $file or return; my $ctx = Digest::MD5->new; $ctx->addfile($fh); my $digest = $ctx->hexdigest; close $fh; my $dirname = dirname($file); my $basename = basename($file); if ($basename =~ s{^.*\.(\w+)\z}{$digest.$1}s) { ## ok } else { $basename = $digest; } my $new_file = catfile($dirname, $basename); if (-e $new_file) { # new file already exists return; } rename($file, $new_file) or return; return $basename; } my @dirs = @ARGV; @dirs || die "usage: $0 [files | dirs]\n"; find( { wanted => sub { if (-f $_) { say ":: Renaming file: $_"; my $basename = md5_rename_file($_); if (defined($basename)) { say "-> renamed to: $basename"; } else { say "-> failed to rename..."; } } }, }, @dirs ); ================================================ FILE: File Workers/multiple_backups.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 11 September 2023 # https://github.com/trizen # Create multiple backups of a list of filenames and update them as necessary. use 5.036; use Getopt::Long; use File::Basename qw(basename); use File::Copy qw(copy); use File::Spec::Functions qw(catfile curdir); my $backup_dir = curdir(); sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [filenames] options: --dir=s : directory where to save the backups (default: $backup_dir) EOT exit($exit_code); } GetOptions("d|dir=s" => \$backup_dir, 'h|help' => sub { usage(0) },) or die("Error in command line arguments\n"); my %timestamps = ( "1h" => 1 / 24, "1d" => 1, "3d" => 3, "30d" => 30, "1y" => 365, ); @ARGV || usage(2); foreach my $file (@ARGV) { say ":: Processing: $file"; foreach my $key (sort keys %timestamps) { my $checkpoint_time = $timestamps{$key}; my $backup_file = catfile($backup_dir, basename($file) . '.' . $key); if (not -e $backup_file or ((-M $backup_file) >= $checkpoint_time)) { say " > writing backup: $backup_file"; copy($file, $backup_file) or warn "Can't copy <<$file>> to <<$backup_file>>: $!"; } } } ================================================ FILE: File Workers/remove_eof_newlines.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Remove newline characters from the end of files # WARNING: No backup files are created! use strict; use warnings; use Tie::File; foreach my $filename (grep { -f } @ARGV) { print "** Processing $filename\n"; tie my @file, 'Tie::File', $filename or die "Unable to tie: $!\n"; pop @file while $file[-1] eq q{}; untie @file or die "Unable to untie: $!\n"; print "** Done.\n\n"; } ================================================ FILE: File Workers/split_to_n_lines.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Website: https://github.com/trizen # Split a text file into sub files of 'n' lines each other use strict; use warnings; use Getopt::Std qw(getopts); use File::Spec::Functions qw(catfile); my %opts; getopts('l:', \%opts); my $lines_n = $opts{l} ? int($opts{l}) : 100; if (not @ARGV) { die "Usage: $0 -l [i] \n"; } sub print_to_file { my ($array_ref, $foldername, $num) = @_; open(my $out_fh, '>', catfile($foldername, "$num.txt")) or return; print $out_fh @{$array_ref}; close $out_fh; return 1; } foreach my $filename (@ARGV) { -f $filename or do { warn "$0: skipping '$filename': is not a file\n"; next; }; my $foldername = $filename; if (not $foldername =~ s/\.\w{1,5}$//) { $foldername .= '_files'; } if (-d $foldername) { warn "$0: directory '${foldername}' already exists...\n"; next; } else { mkdir $foldername or do { warn "$0: Can't create directory '${foldername}': $!\n"; next; }; } open my $fh, '<', $filename or do { warn "$0: Can't open file '${filename}' for read: $!\n"; next; }; my @lines; my $num = 0; while (defined(my $line = <$fh>)) { push @lines, $line; if (@lines == $lines_n or eof $fh) { print_to_file(\@lines, $foldername, ++$num); undef @lines; } } close $fh; } ================================================ FILE: File Workers/sub_renamer.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 1st December 2014 # License: GPLv3 # https://github.com/trizen use utf8; use 5.014; use strict; use warnings; use Encode qw(decode_utf8); use File::Find qw(find); use Getopt::Long qw(GetOptions); binmode(STDOUT, ':utf8'); my $rename = 0; my $single_file = 0; my $min_percentage = 50; sub help { my ($code) = @_; print <<"HELP"; Rename subtitles to match the video files usage: $0 /my/videos [...] options: -r --rename : rename the file names (default: $rename) -s --single-file : one video and one subtitle in a dir (default: $single_file) -p --percentage=i : minimum percentage of approximation (default: $min_percentage) Match subtitles to video names across directories and rename them accordingly. The match is done heuristically, using an approximation comparison algorithm. When there are more subtitles and more videos inside a directory, the script makes decisions based on the filename approximations and rename the file if they are at least 50% similar. (this percent is customizable) The script has, also, several special cases for serials (S00E00) and for single video files with one subtitle in the same directory. Usage example: $0 -s -p=75 ~/Videos Copyright (C) 2014 Daniel "Trizen" Șuteu License: GPLv3 or later, at your choice. See HELP exit($code // 0); } GetOptions( 'p|percentage=i' => \$min_percentage, 'r|rename!' => \$rename, 's|single-file!' => \$single_file, 'h|help' => sub { help() }, ) or die("Error in command line arguments"); my @dirs = grep { -d } @ARGV; @dirs || help(2); # Source: https://en.wikipedia.org/wiki/Video_file_format my @video_formats = qw( avi mp4 wmv mkv webm flv ogv ogg drc mng mov qt rm rmvb asf m4p m4v mpg mp2 mpeg mpe mpv m4v 3gp 3g2 mxf roq nsv yuv ); # Source: https://en.wikipedia.org/wiki/Subtitle_%28captioning%29#Subtitle_formats my @subtitle_formats = qw( aqt gsub jss sub ttxt pjs psb rt smi stl ssf srt ssa ass usf ); sub acmp { my ($name1, $name2, $percentage) = @_; my ($len1, $len2) = (length($name1), length($name2)); if ($len1 > $len2) { ($name2, $len2, $name1, $len1) = ($name1, $len1, $name2, $len2); } return -1 if (my $min = int($len2 * $percentage / 100)) > $len1; my $diff = $len1 - $min; foreach my $i (0 .. $diff) { foreach my $j ($i .. $diff) { if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) { return 0; } } } return 1; } my $videos_re = do { local $" = '|'; qr/\.(?:@video_formats)\z/i; }; my $subs_re = do { local $" = '|'; qr/\.(?:@subtitle_formats)\z/i; }; my $serial_re = qr/S([0-9]{2,})E([0-9]{2,})/; if (not $rename) { warn "\n[!] To actually rename the files, execute me with option '-r'.\n\n"; } my %content; find { no_chdir => 0, wanted => sub { if (/$videos_re/) { my $name = decode_utf8($_) =~ s/$videos_re//r; push @{$content{$File::Find::dir}{videos}{$name}}, decode_utf8($File::Find::name); } elsif (/$subs_re/) { my $name = decode_utf8($_) =~ s/$subs_re//r; push @{$content{$File::Find::dir}{subs}{$name}}, decode_utf8($File::Find::name); } }, } => @dirs; sub ilc { my ($string) = @_; $string =~ s/[[:punct:]]+/ /g; $string = join(' ', split(' ', $string)); lc($string); } foreach my $dir (sort keys %content) { my $subs = $content{$dir}{subs} // next; my $videos = $content{$dir}{videos} // next; # Make a table with scores and rename the subtitles # accordingly to each video it belongs (using heuristics) my (%table, %seen, %subs_taken); my @subs = sort keys %{$subs}; my @videos = sort keys %{$videos}; my %memo; foreach my $sub (@subs) { foreach my $video (@videos) { PERCENT: for (my $i = 100 ; $i >= $min_percentage ; $i--) { # Break if subtitle has the same name as video # and mark it as already taken. if ($sub eq $video) { $subs_taken{$sub}++; last; } if (acmp($memo{$sub} //= ilc($sub), $memo{$video} //= ilc($video), $i) == 0) { # A subtitle can't be shared with more videos if (exists $seen{$sub}) { foreach my $key (@{$seen{$sub}}) { if (@{$table{$key}}) { if ($i > $table{$key}[-1][1]) { pop @{$table{$key}}; } else { last PERCENT; } } } } push @{$table{$video}}, [$sub, $i]; push @{$seen{$sub}}, $video; last; } } } } if (@subs == 1 and @videos == 1 and not keys %table) { my ($sub, $video) = (@subs, @videos); next if $sub eq $video; $table{$video} = [[$sub, 0]]; } # Rename the files foreach my $video (sort keys %table) { @{$table{$video}} || next; my ($sub, $percentage) = @{(sort { $b->[1] <=> $a->[1] } @{$table{$video}})[0]}; next if exists $subs_taken{$sub}; foreach my $subfile (@{$subs->{$sub}}) { # If it is a serial (SxxExx) # skip if subtitle contains a serial number # that is different from that of the video. if ($video =~ /$serial_re/) { my ($vs, $ve) = ($1, $2); if ($sub =~ /$serial_re/) { my ($ss, $se) = ($1, $2); if ($vs ne $ss or $ve ne $se) { next; } } } my $new_name = $subfile =~ s/\Q$sub\E(?=$subs_re)/$video/r; say "** Renaming: $subfile -> $new_name ($percentage%)"; # Skip file if the current percentage is lower than the minimum percentage if ($percentage < $min_percentage) { if (@subs == 1 and @videos == 1) { if (not $single_file) { warn "\t[!] I will rename this if you execute me with option '-s'.\n"; next; } } else { # this will not happen warn "\t[!] Percentage is lower than $min_percentage%. Skipping file...\n"; next; } } # Rename the file (if rename is enabled) if ($rename) { if (-e $new_name) { warn "\t[!] File already exists... Skipping...\n"; next; } rename($subfile, $new_name) || warn "\t[!] Can't rename file: $!\n"; } } } } ================================================ FILE: File Workers/timestamp_rename.pl ================================================ #!/usr/bin/perl # Rename files to their MD5 hex value in a given directory (and its subdirectories). # Example: # "IMG_20231024_094115.jpg" becomes "571b4ba928ae62e103b54727721ebe56.jpg" use 5.036; use Digest::MD5 qw(); use File::Find qw(find); use File::Basename qw(dirname basename); use File::Spec::Functions qw(catfile); sub md5_rename_file ($file) { my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($file); my $dirname = dirname($file); my $basename = basename($file); if ($basename =~ s{^.*\.(\w+)\z}{$ctime.$1}s) { ## ok } else { $basename = $ctime; } my $new_file = catfile($dirname, $basename); if (-e $new_file) { # new file already exists return; } rename($file, $new_file) or return; return $basename; } my @dirs = @ARGV; @dirs || die "usage: $0 [files | dirs]\n"; find( { wanted => sub { if (-f $_) { say ":: Renaming file: $_"; my $basename = md5_rename_file($_); if (defined($basename)) { say "-> renamed to: $basename"; } else { say "-> failed to rename..."; } } }, }, @dirs ); ================================================ FILE: File Workers/undir.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10th August 2014 # Website: https://github.com/trizen # Move all the files from a directory's sub-directories into the main directory (with depth control) use 5.010; use strict; use warnings; use Getopt::Std qw(getopts); use File::Copy qw(move); use File::Find qw(find); use File::Basename qw(basename); use File::Spec::Functions qw(catfile splitdir); sub usage { my ($code) = @_; print <<"USAGE"; usage: $0 [options] [dirs] options: -u : undir the files -d : delete empty directories -t int : depth limit (default: unlimited) example: $0 -u -t 2 /my/dir USAGE exit($code // 0); } getopts('udht:', \my %opt); $opt{h} && usage(0); my @dirs = grep { -d } @ARGV; @dirs || usage(2); foreach my $dir (@dirs) { my $depth = splitdir($dir); my %dirs; my @files; find( { no_chdir => 1, wanted => sub { return if $File::Find::dir eq $dir; if (defined $opt{t}) { return if (splitdir($File::Find::dir) - $depth > $opt{t}); } $dirs{$File::Find::dir} //= 1; push @files, $_ if -f; } } => $dir ); my $error = 0; foreach my $file (@files) { say $file; if ($opt{u}) { my $basename = basename($file); my $newfile = catfile($dir, $basename); if (-e $newfile) { warn "File `$basename' already exists in dir `$dir'..."; ++$error; } else { move($file, $newfile) || do { warn "Can't move file `$file' to `$newfile': $!"; ++$error; }; } } } if ($error == 0 and $opt{d}) { foreach my $key (keys %dirs) { rmdir($key); } } } ================================================ FILE: File Workers/unidec_renamer.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 29 October 2012 # Edit: 23 June 2013 # https://github.com/trizen # Unidecode filename renamer. # Ex: fișier.mp3 -> fisier.mp3 # Usage: unidec_renamer.pl -r use utf8; use 5.005; use strict; use warnings; use File::Find qw(find); use Getopt::Std qw(getopts); use File::Basename qw(basename); use Text::Unidecode qw(unidecode); use File::Spec::Functions qw(catfile catdir splitdir); my %opts; getopts('r', \%opts); my @dirs = grep { -d } @ARGV; @dirs || die "usage: $0 [-r] \n"; binmode(STDOUT, ':utf8'); sub unidec_rename_file { my ($filename, $new_filename) = @_; if (not -e $new_filename) { rename $filename, $new_filename or do { warn "Can't rename: $!\n"; return }; } else { warn "'$new_filename' already exists! Skipping...\n"; } return 1; } my @dirs_for_rename; find { no_chdir => 1, wanted => sub { my $filename = basename($File::Find::name); utf8::decode($filename); my $new_name = unidecode($filename); if ($filename ne $new_name) { my $dir = $File::Find::dir; utf8::decode($dir); print "[", qw(DIR FILE) [-f $_], "] $filename -> $new_name\n"; my $new_filename = (-f _) ? catfile($dir, $new_name) : do { push @dirs_for_rename, [$_, ($dir eq $filename ? $new_name : catdir($dir, $new_name))]; return; }; if ($opts{r}) { unidec_rename_file($_ => $new_filename); } } }, } => @dirs; if ($opts{r}) { foreach my $array_ref ( map { $_->[1] } sort { $b->[0] <=> $a->[0] } map { [scalar(splitdir($_->[0])), $_] } @dirs_for_rename ) { unidec_rename_file($array_ref->[0], $array_ref->[1]); } } ================================================ FILE: Finders/ampath ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 27 December 2011 # Edit: 18 February 2012 # Edit: 16 November 2021 # https://github.com/trizen # Find files which have the exact or almost the exact name in a path. use 5.010; use strict; use warnings; use Getopt::Long; use experimental qw(smartmatch); sub usage { print <<"HELP"; usage: $0 [options] [dir] options: --approx=i : amount of approximateness (default: 0) --hidden! : verify hidden files and folders (default: false) example: $0 --approx=4 /my/dir HELP exit 0; } my $show_hidden_files; my $approximate_n; GetOptions( 'approximate=i' => \$approximate_n, 'hidden!' => \$show_hidden_files, 'help|h' => \&usage, ) or die "Error in command-line arguments!"; if (defined $approximate_n) { $approximate_n += 1; } my @files; sub locate_files { foreach my $dir (@{$_[0]}) { $dir = readlink $dir and chop $dir if -l $dir; next unless opendir(my $dir_h, $dir); my @dirs; while (defined(my $file = readdir $dir_h)) { if ($show_hidden_files) { if ($file eq '.' || $file eq '..') { next; } } else { next if chr ord $file eq '.'; } if (-d "$dir/$file") { push @dirs, "$dir/$file"; } elsif (-f _) { push @files, {lc $file, "$dir/$file", 'file', lc $file}; } } closedir $dir_h; locate_files(\@dirs); } } sub editdist { my %h; $h{$_}++ for split //, lc shift; $h{$_}-- for split //, lc shift; my $t = 0; $t += ($_ > 0 ? $_ : -$_) for values %h; $t; } sub find_similar_names { my ($name, $array_ref) = @_; my (@names) = sort { $a->[1] <=> $b->[1] } grep { defined } map { my $d = editdist($_, $name); $d < $approximate_n ? [$_, $d] : undef; } grep { $_ ne $name } @$array_ref; if (@names) { my $best = $names[0][1]; @names = map { $_->[0] } grep { $_->[1] == $best } @names; } \@names; } sub diff { my %alike; my %table; my @found; if (defined $approximate_n) { my (@names) = map { $_->{'file'} } @files; foreach my $file (@files) { my (@names) = map { $_->{'file'} } grep { my $length_1 = length $_->{'file'}; my $length_2 = length $file->{'file'}; ($length_1 <= $length_2 + $approximate_n) and ($length_1 >= $length_2 - $approximate_n) or ($length_1 == $length_2) if ($_->{'file'} ne $file->{'file'}); } @files; push @{$table{$file->{$file->{'file'}}}}, @{find_similar_names $file->{'file'}, \@names}; } foreach my $array_1_ref (values %table) { next unless $array_1_ref; while (my ($file, $array_2_ref) = each %table) { if (@{$array_2_ref} and $array_1_ref ~~ $array_2_ref) { $alike{$file} = (); } } } return map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [lc(substr($_, rindex($_, '/'))), $_] } keys %alike; } foreach my $file (@files, @files) { $alike{$file->{$file->{'file'}}} = () if $table{$file->{'file'}}++ >= 2; } return map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [lc(substr($_, rindex($_, '/'))), $_] } grep { length } keys %alike; } foreach my $arg (@ARGV) { $arg =~ s[(?<=.)/+$][]; my (@dir) = (-d $arg) ? $arg : next; local $, = "\n"; say diff(locate_files(\@dir)); undef @files; } ================================================ FILE: Finders/dup_subtr_finder.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 11 December 2013 # https://trizenx.blogspot.com # Find the longest duplicated sub-strings inside a string/file (based on a given minimum length). use 5.010; use strict; use autodie; use warnings; use List::Util qw(first); use Data::Dump qw(pp); use Getopt::Std qw(getopts); sub find_substrings (&@) { my ($code, $str, $min) = @_; my @substrings; my $len = length($str); my $max = int($len / 2); my @pos; for (my $i = $max ; $i >= $min ; $i--) { for (my $j = 0 ; $j <= $len - $i * 2 ; $j++) { #die $i if $i > ($len - ($j + $i)); # not gonna happen #say "=>> ", substr($str, $j, $i); if (defined(my $arr = first { $j >= $_->[0] && $j <= $_->[1] } @pos)) { $j = $arr->[1]; next; } if ((my $pos = index($str, substr($str, $j, $i), $j + $i)) != -1) { $code->({pos => [$j, $pos], len => $i, substr => substr($str, $j, $i)}); push @pos, [$j, $j + $i]; # don't match again in substr #push @pos, [$pos, $pos + $i]; # don't match again in dup-substr $j += $i; } } } =old for (my $j = 0 ; $j <= $len ; $j++) { for (my $i = $len - $j > $max ? $max : $len - $j ; $i >= $min ; $i--) { next if $i > ($len - ($j + $i)); if ((my $pos = index($str, substr($str, $j, $i), $j + $i)) != -1) { $code->({pos => [$j, $pos], len => $i, substr => substr($str, $j, $i)}); $j += $i; last; } } } =cut return @substrings; } # ## MAIN # sub usage { print <<"USAGE"; usage: $0 [options] [input-file] options: -m : the minimum sub-string length example: perl $0 -m 50 file.txt USAGE exit 1; } my %opt; getopts('m:', \%opt); my $file = @ARGV && (-f $ARGV[0]) ? shift() : usage(); my $minLen = $opt{m} || (-s $file) / 10; # Dearly spider find_substrings { say pp(shift) } ( do { local $/; open my $fh, '<', $file; <$fh>; }, $minLen ); ================================================ FILE: Finders/fcheck.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 23th September 2013 # https://trizenx.blogspot.com # Display all the files from a given directory with # size greater than N and modified in or after a given date. # usage: perl fcheck.pl [/my/dir] [MB size] [day.month.year] use strict; use warnings; use File::Spec qw(); use File::Find qw(find); use Time::Local qw(timelocal); my $dir = @ARGV ? shift() # first argument : File::Spec->curdir(); # or current directory my $min_size = @ARGV ? shift() * 1024**2 # second argument : 100 * 1024**2; # 100MB my $min_date = @ARGV ? shift() # third argument : '10.09.2013'; # 10th September 2013 # Converting date into seconds my ($mday, $mon, $year, $hour, $min, $sec) = split(/[\s.:]+/, $min_date); my $min_time = timelocal($sec, $min, $hour, $mday, $mon - 1, $year); sub check_file { lstat; -f _ or return; # ignore non-files -l _ and return; # ignore links (-s _) > $min_size or return; # ignore smaller files (stat(_))[9] >= $min_time or return; # ignore older files print "$_\n"; # we have a match } find {no_chdir => 1, wanted => \&check_file} => $dir; ================================================ FILE: Finders/fdf ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 01 January 2012 # Edit: 24 August 2024 # https://github.com/trizen # Find and list duplicate files from one or more paths, with options for # deleting or replacing duplicate files with symbolic links to the main file. use 5.005; use strict; use warnings; use File::Find qw(find); use File::Compare qw(compare); use File::Basename qw(basename); use Getopt::Long qw(GetOptions); my %order_callbacks = ( path => sub { sort @_ }, name => sub { map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [basename($_), $_] } @_; }, time => sub { map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [-M $_, $_] } @_; }, ); my @dirs = grep { (-d) or (-f) } @ARGV; die <<"HELP" if !@dirs; usage: $0 [options] /my/path [...] Options: -f, --first : keep only the first duplicated file -l, --last : keep only the last duplicated file -s, --symlink : replace duplicate files with symbolic links (with -f or -l) -o, --order=type : order the results by: path, name or time -m, --min-size=i : minimum size in bytes (default: 0) HELP my $keep_first; my $keep_last; my $create_symlinks; my $order_by = 'time'; my $min_size = 0; GetOptions( 'f|first!' => \$keep_first, 'l|last!' => \$keep_last, 's|symlink!' => \$create_symlinks, 'o|order|order-by=s' => \$order_by, 'm|min-size=i' => \$min_size, ) or die("$0: error in command line arguments\n"); if (not exists $order_callbacks{$order_by}) { local $" = ", "; die "$0: invalid value `$order_by` for `--order`: valid values are: @{[sort keys %order_callbacks]}\n"; } sub find_duplicated_files (&@) { my $callback = shift; my %files; find { no_chdir => 1, wanted => sub { lstat; (-f _) && (not -l _) && ((-s _) >= $min_size) && push @{$files{-s _}}, $_; } } => @_; foreach my $files (values %files) { next if $#{$files} < 1; my %dups; foreach my $i (0 .. $#{$files} - 1) { for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) { if (compare($files->[$i], $files->[$j]) == 0) { push @{$dups{$files->[$i]}}, splice @{$files}, $j--, 1; } } } while (my ($fparent, $fdups) = each %dups) { $callback->($order_callbacks{$order_by}($fparent, @{$fdups})); } } return; } { local $, = "\n"; local $\ = "\n"; find_duplicated_files { my (@files) = @_; print @files, "-" x 80; my $main_file = ( $keep_first ? shift(@files) : $keep_last ? pop(@files) : return ); foreach my $file (@files) { print ":: Removing: `$file`"; unlink($file) or do { warn "error: can't delete file `$file': $!\n"; next; }; if ($create_symlinks) { print ":: Symlinking: `$main_file` <- `$file`"; symlink($main_file, $file) or do { warn "error: can't create symbolic link for `$file': $!\n"; next; }; } } } @dirs; } ================================================ FILE: Finders/fdf-attr ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 22 January 2012 # https://github.com/trizen # Find files which have the same attributes # ## WARNING! For strict duplicates, use the 'fdf' script: # https://github.com/trizen/perl-scripts/blob/master/Finders/fdf # use 5.005; use strict; use warnings; use File::Find qw(find); use Getopt::Std qw(getopts); my @dirs = grep { -d } @ARGV; die <<"HELP" if !@dirs; usage: $0 [options] /my/path [...] Options: -f : keep only the first duplicated file -l : keep only the last duplicated file HELP my %opts; if (@ARGV) { getopts("fl", \%opts); } sub find_duplicated_files (&@) { my $code = shift; my %files; find { no_chdir => 1, wanted => sub { lstat; return if ((-s _) < 4 * 1024); # skip files smaller than 4KB (-f _) && (not -l _) && push @{ $files{ join($;, (-r _), (-w _), (-x _), (-o _), (-R _), (-W _), (-X _), (-O _), (-s _), (-u _), (-g _), (-k _), ) } }, $_; } } => @_; foreach my $files (values %files) { next if $#{$files} < 1; $code->(@{$files}); } return; } { local $, = "\n"; local $\ = "\n"; find_duplicated_files { print @_, "-" x 80 if @_; foreach my $i ( $opts{f} ? (1 .. $#_) : $opts{l} ? (0 .. $#_ - 1) : () ) { unlink $_[$i] or warn "[error]: Can't delete: $!\n"; } } @dirs; } ================================================ FILE: Finders/fdf-filename ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 June 2012 # https://github.com/trizen # Find and list duplicated files from one or more paths # ## WARNING! For strict duplicates, use the 'fdf' script: # https://github.com/trizen/perl-scripts/blob/master/Finders/fdf # use 5.005; use strict; use warnings; use File::Find qw(find); use File::Basename qw(basename); use Getopt::Std qw(getopts); my @dirs = grep { -d } @ARGV; die <<"HELP" if !@dirs; usage: $0 [options] /my/path [...] Options: -f : keep only the first duplicated file -l : keep only the last duplicated file HELP my %opts; if (@ARGV) { getopts("fl", \%opts); } sub compare_strings ($$) { my ($name1, $name2) = @_; return 0 if $name1 eq $name2; if (length($name1) > length($name2)) { ($name2, $name1) = ($name1, $name2); } my $len1 = length($name1); my $len2 = length($name2); my $min = int(0.5 + $len2 / 2); return -1 if $min > $len1; my $diff = $len1 - $min; foreach my $i (0 .. $diff) { foreach my $j ($i .. $diff) { if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) { return 0; } } } return 1; } sub find_duplicated_files (&@) { my $code = shift; my %files; find { no_chdir => 1, wanted => sub { lstat; return if ((-s _) < 4 * 1024); # skips files smaller than 4KB -f _ && (not -l _) && push @{$files{-s _}}, $_; } } => @_; foreach my $files (values %files) { next if $#{$files} < 1; my %dups; foreach my $i (0 .. $#{$files} - 1) { for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) { if (compare_strings(basename($files->[$i]), basename($files->[$j])) == 0) { push @{$dups{$files->[$i]}}, splice @{$files}, $j--, 1; } } } while (my ($fparent, $fdups) = each %dups) { $code->(sort $fparent, @{$fdups}); } } return; } { local $, = "\n"; local $\ = "\n"; find_duplicated_files { print @_, "-" x 80 if @_; foreach my $i ( $opts{f} ? (1 .. $#_) : $opts{l} ? (0 .. $#_ - 1) : () ) { unlink $_[$i] or warn "[error]: Can't delete: $!\n"; } } @dirs; } ================================================ FILE: Finders/file_binsearch.pl ================================================ #!/usr/bin/perl # Code from "Mastering Algorithms with Perl" book # derived from code by Nathan Torkington # Code improved by Daniel "Trizen" Șuteu # Added support for very large files and locale support # Date: 29 November 2013 # Edit: 17 April 2023 # https://github.com/trizen use 5.010; use strict; use autodie; use warnings; # Use locale when '-l' switch is specified use if $#ARGV >= 0 && $ARGV[0] eq '-l' => 'locale'; # Using Math::BigInt to work with very large files use Math::BigInt try => 'GMP,Pari'; # For parsing the command line switches use Getopt::Std qw(getopts); my %opts; getopts('lnh', \%opts); sub usage { my ($code) = @_; print <<"USAGE"; usage: $0 [options] options: -l : use the current locale for string comparisons -n : use numeric comparisons example: perl $0 -l "hello world" bigList.txt USAGE exit $code; } usage(0) if $opts{h}; usage(-1) if $#ARGV != 1; my ($word, $file) = @ARGV; open(my $fh, '<', $file); my $position = binary_search_file($fh, $word); if (defined $position) { print "$word occurs at position $position\n" } else { print "$word does not occur in $file.\n" } sub compare { my ($word1, $word2) = @_; chomp $word1; $opts{n} ? (Math::BigInt->new($word1) <=> Math::BigInt->new($word2)) : ($word1 cmp $word2); } sub binary_search_file { my ($file, $word) = @_; my $low = Math::BigInt->new(0); # Guaranteed to be the start of a line. my $high = Math::BigInt->new(-s $file); # Might not be the start of a line. my $line; while ($high != $low) { my $mid = ($high + $low) >> 1; seek($file, $mid, 0); # $mid is probably in the middle of a line, so read the rest # and set $mid2 to that new position. scalar <$file>; my $mid2 = Math::BigInt->new(tell($file)); if ($mid2 < $high) { # We're not near file's end, so read on. $mid = $mid2; $line = <$file>; } else { # $mid plunked us in the last line, so linear search. seek($file, $low, 0); while (defined($line = <$file>)) { last if compare($line, $word) >= 0; $low = Math::BigInt->new(tell($file)); } last; } compare($line, $word) == -1 ? do { $low = $mid } : do { $high = $mid }; } compare($line, $word) == 0 ? $low : (); } ================================================ FILE: Finders/find_perl_scripts.pl ================================================ #!/usr/bin/perl # Author: Trizen # License: GPLv3 # Date: 15 March 2012 # Find perl scripts in a directory and its subdirectories use 5.010; use File::Find qw(find); my @dirs = grep { -d } @ARGV or die "usage: $0 [dirs]\n"; find { wanted => sub { if (/\.p[lm]$/i) { say } elsif (-T and open my $fh, '<', $_) { my $head = <$fh> || return; if ($head =~ m{^\s*#\s*!.*\bperl\d*\b}) { say } } }, no_chdir => 1 }, @dirs ================================================ FILE: Finders/find_similar_filenames.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 22 June 2012 # https://github.com/trizen # Find files which have exactly or *ALMOST* # exactly the same name in a given path. # Improved version here: # https://github.com/trizen/perl-scripts/blob/master/Finders/fsfn.pl use 5.014; use strict; use warnings; use File::Find qw(find); use Getopt::Std qw(getopts); my @dirs = grep { -d } @ARGV; die <<"HELP" if !@dirs; usage: $0 [options] /my/path [...] Options: -f : keep only the first file -l : keep only the last file HELP my %opts; if (@ARGV) { getopts("fl", \%opts); } sub compare_strings ($$) { my ($name1, $name2) = @_; return 0 if $name1 eq $name2; if (length($name1) > length($name2)) { ($name2, $name1) = ($name1, $name2); } my $len1 = length($name1); my $len2 = length($name2); my $min = int(0.5 + $len2 / 2); return -1 if $min > $len1; my $diff = $len1 - $min; foreach my $i (0 .. $diff) { foreach my $j ($i .. $diff) { if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) { return 0; } } } return 1; } sub find_similar_filenames (&@) { my $code = shift; my %files; find { wanted => sub { !(-d) && push @{$files{"key"}}, # to group files by size, change the "key" to '-s _' (unquoted) { name => do { utf8::decode($_); lc(s{\.\w+\z}{}r) }, real_name => $File::Find::name, }; } } => @_; foreach my $files (values %files) { next if $#{$files} < 1; my %dups; foreach my $i (0 .. $#{$files} - 1) { for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) { if (compare_strings($files->[$i]{name}, $files->[$j]{name}) == 0) { push @{$dups{$files->[$i]{real_name}}}, ${splice @{$files}, $j--, 1}{real_name}; } } } while (my ($fparent, $fdups) = each %dups) { $code->(sort $fparent, @{$fdups}); } } return 1; } { local $, = "\n"; find_similar_filenames { say @_, "-" x 80 if @_; foreach my $i ( $opts{f} ? (1 .. $#_) : $opts{l} ? (0 .. $#_ - 1) : () ) { unlink $_[$i] or warn "[error]: Can't delete: $!\n"; } } @dirs; } ================================================ FILE: Finders/find_similar_filenames_unidec.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 22 June 2012 # https://github.com/trizen # Find files which have exactly or *ALMOST* # exactly the same name in a given path. # Improved version here: # https://github.com/trizen/perl-scripts/blob/master/Finders/fsfn.pl use 5.014; use strict; use warnings; use File::Find qw(find); use Getopt::Std qw(getopts); use Text::Unidecode qw(unidecode); my @dirs = grep { -d } @ARGV; die <<"HELP" if !@dirs; usage: $0 [options] /my/path [...] Options: -f : keep only the first file -l : keep only the last file HELP my %opts; if (@ARGV) { getopts("fl", \%opts); } sub compare_strings ($$) { my ($name1, $name2) = @_; return 0 if $name1 eq $name2; if (length($name1) > length($name2)) { ($name2, $name1) = ($name1, $name2); } my $len1 = length($name1); my $len2 = length($name2); my $min = int(0.5 + $len2 / 2); return -1 if $min > $len1; my $diff = $len1 - $min; foreach my $i (0 .. $diff) { foreach my $j ($i .. $diff) { if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) { return 0; } } } return 1; } sub find_duplicated_files (&@) { my $code = shift; my %files; find { wanted => sub { lstat; -f _ && (not -l _) && push @{$files{"key"}}, # to group files by size, change the "key" to '-s _' (unquoted) { name => do { utf8::decode($_); lc(unidecode($_) =~ s{\.\w+\z}{}r) }, real_name => $File::Find::name, }; } } => @_; foreach my $files (values %files) { next if $#{$files} < 1; my %dups; foreach my $i (0 .. $#{$files} - 1) { for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) { if (compare_strings($files->[$i]{name}, $files->[$j]{name}) == 0) { push @{$dups{$files->[$i]{real_name}}}, ${splice @{$files}, $j--, 1}{real_name}; } } } while (my ($fparent, $fdups) = each %dups) { $code->(sort $fparent, @{$fdups}); } } return 1; } { local $, = "\n"; find_duplicated_files { say @_, "-" x 80 if @_; foreach my $i ( $opts{f} ? (1 .. $#_) : $opts{l} ? (0 .. $#_ - 1) : () ) { unlink $_[$i] or warn "[error]: Can't delete: $!\n"; } } @dirs; } ================================================ FILE: Finders/fsf.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 23 July 2015 # https://github.com/trizen # Find files which have almost the same content (at least, mathematically). # ## WARNING! For strict duplicates, use the 'fdf' script: # https://github.com/trizen/perl-scripts/blob/master/Finders/fdf # use 5.014; use strict; use warnings; use Math::BigInt (try => 'GMP'); use File::Find qw(find); use Getopt::Long qw(GetOptions); sub help { my ($code) = @_; print <<"HELP"; usage: $0 [options] /my/path [...] Options: -w --whitespaces! : remove whitespaces (default: false) -u --unique! : don't include a file in more groups (default: false) -h --help : print this message and exit Example: $0 -w ~/Documents HELP exit($code // 0); } my $strip_spaces = 0; # bool my $unique = 0; # bool GetOptions( 'w|whitespaces!' => \$strip_spaces, 'u|unique!' => \$unique, 'h|help' => \&help, ) or die("Error in command line arguments"); sub hash ($) { my ($str) = @_; $strip_spaces and $str =~ s/\s+//g; state $ten = Math::BigInt->new(10); my $hash1 = Math::BigInt->new(0); my $pow = Math::BigInt->new(1); state $chars = {}; my @chars = map { $chars->{$_} //= Math::BigInt->new($_) } unpack("C*", $str); foreach my $char (@chars) { $hash1->badd($pow->copy->bmul($char)); $pow->bmul($ten); } return $hash1; } sub hash_file ($) { my ($file) = @_; open my $fh, '<:raw', $file; hash( do { local $/; <$fh> } ); } sub alike_hashes ($$) { my ($h1, $h2) = @_; my $pow = abs($h1->copy->blog(10) - $h2->copy->blog(10)); my $ratio = ($h2 > $h1 ? ($h2 / $h1) : ($h1 / $h2)); my $limit = 10**$pow; $ratio == $limit; } sub find_similar_files (&@) { my $code = shift; my @files; find { wanted => sub { (-f) && push @files, { hash => hash_file($File::Find::name), name => $File::Find::name, }; } } => @_; my %dups; foreach my $i (0 .. $#files - 1) { for (my $j = $i + 1 ; $j <= $#files ; $j++) { if (alike_hashes($files[$i]{hash}, $files[$j]{hash})) { push @{$dups{$files[$i]{name}}}, ( $unique ? ${splice @files, $j--, 1}{name} : $files[$j]{name} ); } } } while (my ($fparent, $fdups) = each %dups) { $code->(sort $fparent, @{$fdups}); } return 1; } { @ARGV || help(1); local $, = "\n"; find_similar_files { say @_, "-" x 80 if @_; } @ARGV; } ================================================ FILE: Finders/fsfn.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 22 June 2013 # Improved: 18 October 2014 # Latest edit on: 18 October 2015 # Website: https://github.com/trizen # Find files which have exactly or *ALMOST* exactly # the same name in a given path (+Levenshtein distance). # Review: # https://trizenx.blogspot.com/2013/06/finding-similar-file-names.html # To move files into another directory, please see: # https://github.com/trizen/perl-scripts/blob/master/File%20Workers/file-mover.pl use 5.014; use strict; use warnings; use experimental qw(refaliasing); use File::Find qw(find); use List::Util qw(first min max); use Encode qw(decode_utf8); use Getopt::Long qw(GetOptions :config no_ignore_case); use File::Basename qw(basename); sub help { my ($code) = @_; print <<"HELP"; usage: $0 [options] /my/path [...] Options: -f --first! : keep only the first file from each group -l --last! : keep only the last file from each group -g --groups=[s] : group individually files which contain these words -G --nogroups=[s] : group together files which contain these words -c --contains=[s] : ignore files which doesn't contain these words -C --nocontains=[s] : ignore files which contain these words -i --insensitive : make all words case-insensitive -s --size! : group files by size (default: off) -S --sort=s : sort files by: 'name' or 'size' -p --percentage=f : mark the files as similar based on this percent -r --round-up! : round up the percentage (default: off) -L --levenshtein! : use the Levenshtein distance algorithm -J --jaro! : use the Jaro distance algorithm -u --unidecode! : normalize Unicode characters to ASCII equivalents Usage example: $0 --percentage=75 ~/Music NOTE: The values for -c, -C, -g and -G are regular expressions. Each of the above options can be specified more than once. WARNING: Options '-f' and '-l' will, permanently, delete your files! HELP exit($code); } my @groups; my @no_groups; my @contains; my @no_contains; my $first = 0; # bool my $last = 0; # bool my $round_up = 0; # bool my $group_by_size = 0; # bool my $unidecode = 0; # bool my $insensitive = 0; # bool my $levenshtein = 0; # bool my $jaro_distance = 0; # bool my $percentage; # float my $sort_by = undef; GetOptions( 'f|first!' => \$first, 'l|last!' => \$last, 'g|groups=s' => \@groups, 'G|nogroups=s' => \@no_groups, 'c|contains=s' => \@contains, 'C|nocontains=s' => \@no_contains, 'r|round-up!' => \$round_up, 'i|insensitive!' => \$insensitive, 'p|percentage=f' => \$percentage, 'L|levenshtein!' => \$levenshtein, 'u|unidecode!' => \$unidecode, 'J|jaro!' => \$jaro_distance, 's|size!' => \$group_by_size, 'S|sort=s' => \$sort_by, 'h|help' => sub { help(0) }, ) or die("Error in command line arguments"); @groups = map { $insensitive ? qr/$_/i : qr/$_/ } (@groups, '.'); @no_groups = map { $insensitive ? qr/$_/i : qr/$_/ } @no_groups; @contains = map { $insensitive ? qr/$_/i : qr/$_/ } @contains; @no_contains = map { $insensitive ? qr/$_/i : qr/$_/ } @no_contains; # Determine what algorithm to use for comparison my $algorithm = $levenshtein ? \&lev_cmp : $jaro_distance ? \&jaro_cmp : \&index_cmp; # Default percentage $percentage //= $jaro_distance ? 70 : 50; sub index_cmp ($$) { my ($name1, $name2) = @_; return 0 if $name1 eq $name2; my ($len1, $len2) = (length($name1), length($name2)); if ($len1 > $len2) { ($name2, $len2, $name1, $len1) = ($name1, $len1, $name2, $len2); } my $min = $round_up ? int($percentage / 100 + $len2 * $percentage / 100) : int($len2 * $percentage / 100); return -1 if $min > $len1; my $diff = $len1 - $min; foreach my $i (0 .. $diff) { foreach my $j ($i .. $diff) { if (index($name2, substr($name1, $i, $min + $j - $i)) != -1) { return 0; } } } return -1; } # Levenshtein's distance function (optimized for speed) sub lev_cmp ($$) { my ($s, $t) = @_; my $len1 = @$s; my $len2 = @$t; my ($min, $max) = $len1 < $len2 ? ($len1, $len2) : ($len2, $len1); my $diff = $round_up ? int($percentage / 100 + $max * (100 - $percentage) / 100) : int($max * (100 - $percentage) / 100); return -1 if ($max - $min) > $diff; my @d = ([0 .. $len2], map { [$_] } 1 .. $len1); foreach my $i (1 .. $len1) { foreach my $j (1 .. $len2) { $d[$i][$j] = $$s[$i - 1] eq $$t[$j - 1] ? $d[$i - 1][$j - 1] : min($d[$i - 1][$j], $d[$i][$j - 1], $d[$i - 1][$j - 1]) + 1; } } ($d[-1][-1] // $min) <= $diff ? 0 : -1; } sub jaro_cmp($$) { my ($s, $t) = @_; my $s_len = @{$s}; my $t_len = @{$t}; ($s, $s_len, $t, $t_len) = ($t, $t_len, $s, $s_len) if $s_len > $t_len; $s_len || return -1; my $diff = $round_up ? int($percentage / 100 + $t_len * (100 - $percentage) / 100) : int($t_len * (100 - $percentage) / 100); return -1 if ($t_len - $s_len) > $diff; my $match_distance = int(max($s_len, $t_len) / 2) - 1; my @s_matches; my @t_matches; \my @s = $s; \my @t = $t; my $matches = 0; foreach my $i (0 .. $#s) { my $start = max(0, $i - $match_distance); my $end = min($i + $match_distance + 1, $t_len); foreach my $j ($start .. $end - 1) { $t_matches[$j] and next; $s[$i] eq $t[$j] or next; $s_matches[$i] = 1; $t_matches[$j] = 1; $matches++; last; } } return -1 if $matches == 0; my $k = 0; my $transpositions = 0; foreach my $i (0 .. $#s) { $s_matches[$i] or next; while (not $t_matches[$k]) { ++$k } $s[$i] eq $t[$k] or ++$transpositions; ++$k; } (($matches / $s_len) + ($matches / $t_len) + (($matches - $transpositions / 2) / $matches)) / 3 * 100 >= $percentage ? 0 : -1; } sub normalize_filename { my $str = shift; $str = decode_utf8($str); if ($unidecode) { require Text::Unidecode; $str = Text::Unidecode::unidecode($str); } join(' ', split(' ', lc($str =~ s{\.\w{1,5}\z}{}r =~ s/[^\pN\pL]+/ /gr))); } sub sort_files { my (@files) = @_; my %seen; @files = grep { !$seen{$_}++ } @files; if (defined($sort_by)) { if ($sort_by =~ /size/i) { @files = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @files; } elsif ($sort_by =~ /name/i) { @files = map { $_->[0] } sort { $a->[1] cmp $b->[1] } map { [$_, lc(basename($_))] } @files; } } else { @files = sort @files; } return @files; } sub find_similar_filenames (&@) { my $code = shift; my %files; find { wanted => sub { if (@contains) { defined(first { $File::Find::name =~ $_ } @contains) || return; } if (@no_contains) { defined(first { $File::Find::name =~ $_ } @no_contains) && return; } if (-f) { push @{$files{$group_by_size ? (-s _) : 'key'}}, { name => do { my $str = normalize_filename($_); ($levenshtein || $jaro_distance) ? [$str =~ /\X/g] : $str; }, real_name => $File::Find::name, }; } } } => @_; foreach my $files (values %files) { next if $#{$files} < 1; my %dups; my @files; foreach my $i (0 .. $#{$files} - 1) { for (my $j = $i + 1 ; $j <= $#{$files} ; $j++) { if (defined(my $word1 = first { $files->[$i]{real_name} =~ $_ } @groups)) { if (defined(my $word2 = first { $files->[$j]{real_name} =~ $_ } @groups)) { next if $word1 ne $word2; } } if ($algorithm->($files->[$i]{name}, $files->[$j]{name}) == 0) { if ( defined(first { $files->[$i]{real_name} =~ $_ } @no_groups) and defined(first { $files->[$j]{real_name} =~ $_ } @no_groups)) { push @files, $files->[$i]{real_name}, ${splice @{$files}, $j--, 1}{real_name}; } else { push @{$dups{$files->[$i]{real_name}}}, ${splice @{$files}, $j--, 1}{real_name}; } } } } while (my ($fparent, $fdups) = each %dups) { $code->(sort_files($fparent, @{$fdups})); } $code->(sort_files(@files)); } return 1; } { @ARGV || help(1); local $, = "\n"; find_similar_filenames { say @_, "-" x 80 if @_; foreach my $i ( $first ? (1 .. $#_) : $last ? (0 .. $#_ - 1) : () ) { unlink $_[$i] or warn "[error]: Can't delete: $!\n"; } } @ARGV; } ================================================ FILE: Finders/human-like_finder.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 20 April 2014 # Website: https://github.com/trizen # A smart human-like substring finder # Steps: # 1. loop from i=1 and count up to int(sqrt(len(text))) # 2. loop from pos=(i-1)*len(substr)*2 and add int(len(text)/i) to pos while pos <= len(text) # 3. jump to position pos and scan back and forward and stop if the string is found somewhere nearby # 4. loop #2 end # 5. loop #1 end # 6. return -1 use 5.010; use strict; use warnings; my $TOTAL = 0; # count performance sub DEBUG () { 1 } # verbose mode sub random_find { my ($text, $substr) = @_; my $tlen = length($text); my $slen = length($substr); my $tmax = $tlen - $slen; my $smax = int($slen / 2); # this value influences the performance my $counter = 0; my $locate = sub { my ($pos, $guess) = @_; for my $i (0 .. $smax) { ++$counter if DEBUG; # measure performance if ( $pos + $i <= $tmax and substr($guess, $i) eq substr($substr, 0, $slen - $i) and substr($text, $pos + $i, $slen) eq $substr) { printf("RIGHT (i: %d; counter: %d):\n> %*s\n> %s\n", $i, $counter, $i + $slen, $substr, $guess) if DEBUG; $TOTAL += $counter if DEBUG; return $pos + $i; } elsif ( $pos - $i >= 0 and substr($substr, $i) eq substr($guess, 0, $slen - $i) and substr($text, $pos - $i, $slen) eq $substr) { printf("LEFT (i: %d; counter: %d):\n> %s\n> %*s\n", $i, $counter, $substr, $i + $slen, $guess) if DEBUG; $TOTAL += $counter if DEBUG; return $pos - $i; } } return; }; foreach my $i (1 .. int(sqrt($tlen))) { my $delta = int($tlen / $i); for (my $pos = ($i - 1) * $slen * 2 ; $pos <= $tlen ; $pos += $delta) { say "POS: $pos" if DEBUG; if ($pos + $slen <= $tlen) { if (defined(my $i = $locate->($pos, substr($text, $pos, $slen)))) { say "** FORWARD MATCH!" if DEBUG; return $i; } } if ($pos >= $slen) { if (defined(my $i = $locate->($pos - $slen, substr($text, $pos - $slen, $slen)))) { say "** BACKWARD MATCH!" if DEBUG; return $i; } } } } return -1; } my $text = join('', ); my $split = 30; foreach my $str (unpack("(A$split)*", $text)) { if (random_find($text, $str) == -1) { die "Error!"; } say '-' x 80 if DEBUG; } say "TOTAL: ", $TOTAL if DEBUG; __END__ The data structure has one node for every prefix of every string in the dictionary. So if (bca) is in the dictionar then there will be nodes for (bca), (bc), (b), and (). If is in the dictionary then it is blue node. Otherwise it i There is a black directed "child" arc from each node to a is found by appending one character. So there is a black There is a blue directed "suffix" arc from each node to t possible strict suffix of it in the graph. For example, f are (aa) and (a) and (). The longest of these that exists graph is (a). So there is a blue arc from (caa) to (a). T a green "dictionary suffix" arc from each node to the nex in the dictionary that can be reached by following blue a example, there is a green arc from (bca) to (a) because ( node in the dictionary (i.e. a blue node) that is reached the blue arcs to (ca) and then on to (a). ================================================ FILE: Finders/large_file_search.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 28 July 2014 # https://github.com/trizen # Search for a list of keywords inside a very large file use 5.010; use strict; use autodie; use warnings; use Fcntl qw(SEEK_CUR); use List::Util qw(max); use Term::ANSIColor qw(colored); use Getopt::Long qw(GetOptions); # Input file for search my $file = __FILE__; # Print before and after characters my $before = 5; my $after = 5; # Buffer size my $buffer = 1024**2; # 1 MB sub usage { my ($code) = @_; print <<"USAGE"; usage: $0 [options] [keywords] options: --file=s : a very large file --buffer=i : buffer size (default: $buffer bytes) --before=i : display this many characters before match (default: $before) --after=i : display this many characters after match (default: $after) --help : print this message and exit example: $0 --file=document.txt "Foo Bar" USAGE exit($code // 0); } GetOptions( 'buffer=i' => \$buffer, 'file=s' => \$file, 'before=i' => \$before, 'after=i' => \$after, 'help|h' => sub { usage(0) }, ); @ARGV || usage(1); my @keys = @ARGV; my $max = max(map { length } @keys); if ($buffer <= $max) { die "The buffer value can't be <= than the length of the longest keyword!\n"; } sysopen(my $fh, $file, 0); while ((my $size = sysread($fh, (my $chunk), $buffer)) > 0) { # Search for a given keyword foreach my $keyword (@keys) { my $idx = -1; while (($idx = index($chunk, $keyword, $idx + 1)) != -1) { # Take the sub-string my $len = length($keyword); my $bar = '-' x (40 - $len / 2); my $from = $idx > $before ? $idx - $before : 0; my $sstr = substr($chunk, $from, $len + $after + $before); # Split the sub-string my $pos = index($sstr, $keyword); my $bef = substr($sstr, 0, $pos); my $cur = substr($sstr, $pos, $len); my $aft = substr($sstr, $pos + $len); # Highlight and print the results say $bar, $keyword, $bar, '-' x ($len % 2); say $bef, colored($cur, 'red'), $aft; say '-' x 80; { # Unpack and print the results as character-values local $, = ' '; say unpack('C*', $bef), colored(join($,, unpack('C*', $cur)), 'red'), unpack('C*', $aft); } say '-' x 80; } } # Rewind back a little bit because we # might be in the middle of a keyword if ($size == $buffer) { sysseek($fh, sysseek($fh, 0, SEEK_CUR) - $max, 0); } } close($fh); ================================================ FILE: Finders/locatepm ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 February 2012 # Edit: 08 August 2012 # https://github.com/trizen # Find installed Perl modules matching a regular expression use 5.014; use File::Find qw(find); use Getopt::Std qw(getopts); sub usage { die <<"HELP"; usage: perl $0 [options] 'REGEX'\n options: -p : print full path -b : both: path + name -i : case insensitive\n example: perl $0 -b ^File:: ^Term HELP } my %opts; getopts('pbih', \%opts); (!@ARGV || $opts{h}) && usage(); sub reduce_dirs { my %substring_count; @substring_count{@_} = (); for my $x (@_) { for my $y (@_) { next if $x eq $y; if (index($x, $y) == 0) { $substring_count{$x}++; } } } grep { !$substring_count{$_} } keys %substring_count; } my @dirs; for my $dirname (@INC) { if (-d $dirname) { next if chr ord $dirname eq q{.}; $dirname =~ tr{/}{/}s; chop $dirname if substr($dirname, -1) eq '/'; push @dirs, $dirname; } } @dirs = reduce_dirs(@dirs); my $inc_re = do { local $" = q{|}; qr{^(?>@{[map { quotemeta(s{/}{::}gr) } @dirs]})::}; }; foreach my $arg (@ARGV) { my $regex = $opts{i} ? qr{$arg}i : qr{$arg}; find { wanted => sub { my $name = $_; say $opts{b} ? "$name\n$_\n" : $opts{p} ? $_ : $name if substr($name, -3, 3, '') eq '.pm' and $name =~ s{/}{::}g and $name =~ s{$inc_re}{}o and $name =~ /$regex/; }, no_chdir => 1, } => @dirs; } ================================================ FILE: Finders/longest_substring.pl ================================================ #!/usr/bin/perl # Finding the longest repeated substring # Java code from: # https://stackoverflow.com/questions/10355103/finding-the-longest-repeated-substring use 5.010; use strict; use warnings; no warnings 'recursion'; my $max_len = 0; my $max_str = ""; sub insert_in_suffix_tree { my ($root, $str, $index, $original_suffix, $level) = @_; $level //= 0; push @{$root->{indexes}}, $index; if ($#{$root->{indexes}} > 0 && $max_len < $level) { $max_len = $level; $max_str = substr($original_suffix, 0, $level); } return if ($str eq q{}); my $child; my $first_char = substr($str, 0, 1); if (not exists $root->{children}{$first_char}) { $child = {}; $root->{children}{$first_char} = $child; } else { $child = $root->{children}{$first_char}; } insert_in_suffix_tree($child, substr($str, 1), $index, $original_suffix, $level + 1); } my $str = @ARGV ? join('', <>) : "abracadabra"; my %root; foreach my $i (0 .. length($str) - 1) { my $s = substr($str, $i); insert_in_suffix_tree(\%root, $s, $i, $s); } say "[$max_len]: $max_str"; ================================================ FILE: Finders/mimefind.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 17 April 2023 # Edit: 21 September 2023 # https://github.com/trizen # Find files from a given directory (and its subdirectories) that have a specific mimetype. use 5.036; use File::Find qw(find); use Getopt::Std qw(getopts); sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [files | dirs] options: -T : display only text files -B : display only binary files -t TYPE : display files with this mimetype (regex) -n : display non-matching files -f : display only files -e : use `exiftool` to determine the MIME types (slow) -h : display this message and exit examples: perl $0 -t video ~/Music # find video files perl $0 -Bft . ~/Documents # find binary files perl $0 -fn -t audio ~/Music # find non-audio files perl $0 -fn -t 'audio|video' ~/Music # find non audio/video files EOT exit($exit_code); } getopts('TBefhnt:', \my %opts); $opts{t} || usage(1); $opts{h} && usage(0); my $type_re = qr/$opts{t}/i; sub determine_mime_type ($file) { if (-d $file) { return 'inode/directory'; } if ($opts{e}) { my $res = `exiftool \Q$file\E`; $? == 0 or return; defined($res) or return; if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) { return $1; } return; } require File::MimeInfo::Magic; File::MimeInfo::Magic::mimetype($file); } find( { wanted => sub { if ($opts{f}) { (-f $_) or return; } if ($opts{B}) { (-B $_) or return; } if ($opts{T}) { (-T $_) or return; } my $mimetype = determine_mime_type($_) // return; my $ok = ($mimetype =~ $type_re); $ok = !$ok if $opts{n}; if ($ok) { say $File::Find::name; } }, no_chdir => 1, }, @ARGV ); ================================================ FILE: Finders/model_matching_system.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 12 June 2015 # Edit: 25 July 2016 # https://github.com/trizen # ## A very fast complex matching system # # It works by creating a nested hash with words stored as paths, # then it walks this nested hash from path to path, looking for matches. # It matches in (case|word order|space|punctuation)-insensitive mode. # The results are sorted to match the input keywords as best as possible. use 5.010; use strict; use warnings; use List::Util qw(all); sub split_entry { grep { $_ ne '' } split(/\W+/, lc($_[0])); } sub update_model { my ($model, $entry) = @_; foreach my $word (split_entry($entry)) { my $ref = $model; foreach my $char (split(//, $word)) { $ref = $ref->{$char} //= {}; push @{$ref->{values}}, \$entry; } } return 1; } sub find { my ($model, $entry) = @_; my @tokens = split_entry($entry); my (@words, @matches, %analyzed); foreach my $word (@tokens) { my $ref = $model; foreach my $char (split(//, $word)) { if (exists $ref->{$char}) { $ref = $ref->{$char}; } else { $ref = undef; last; } } if (defined $ref and exists $ref->{values}) { push @words, $word; foreach my $match (@{$ref->{values}}) { if (not exists $analyzed{$match}) { undef $analyzed{$match}; unshift @matches, $$match; } } } else { @matches = (); # don't include partial matches last; } } foreach my $token (@tokens) { @matches = grep { index(lc($_), $token) != -1 } @matches; } # Sort and return the matches map { $_->[0] } sort { $b->[1] <=> $a->[1] } map { my @parts = split_entry($_); my $end_w = $#words; my $end_p = $#parts; my $min_end = $end_w < $end_p ? $end_w : $end_p; my $order_score = 0; for (my $i = 0 ; $i <= $min_end ; ++$i) { my $word = $words[$i]; for (my $j = $i ; $j <= $end_p ; ++$j) { my $part = $parts[$j]; my $matched; my $continue = 1; while ($part eq $word) { $order_score += 1 - 1 / (length($word) + 1)**2; $matched ||= 1; $part = $parts[++$j] // do { $continue = 0; last }; $word = $words[++$i] // do { $continue = 0; last }; } if ($matched) { $order_score += 1 - 1 / (length($word) + 1) if ($continue and index($part, $word) == 0); last; } elsif (index($part, $word) == 0) { $order_score += length($word) / length($part); last; } } } my $prefix_score = 0; all { ($parts[$_] eq $words[$_]) ? do { $prefix_score += 1; 1; } : (index($parts[$_], $words[$_]) == 0) ? do { $prefix_score += length($words[$_]) / length($parts[$_]); 0; } : 0; } 0 .. $min_end; ## printf("score('@parts', '@words') = %.4g + %.4g = %.4g\n", ## $order_score, $prefix_score, $order_score + $prefix_score); [$_, $order_score + $prefix_score] } @matches; } # ## Usage example # my %model; while () { chomp($_); update_model(\%model, $_); } sub search { my ($str) = @_; say "* Results for '$str':"; use Data::Dump qw(pp); say pp([find(\%model, $str)]), "\n"; } search('I love'); search('love'); search('a love'); search('love a'); search('actually love'); search('Paris love'); search('love Berlin'); __DATA__ My First Lover A Lot Like Love Funny Games (2007) Cinderella Man (2005) Pulp Fiction (1994) Don't Say a Word (2001) Secret Window (2004) The Lookout (2007) 88 Minutes (2007) The Mothman Prophecies Love Actually (2003) From Paris with Love (2010) P.S. I Love You (2007) ================================================ FILE: Finders/path_diff.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 12 October 2017 # https://github.com/trizen # Compare two paths file-by-file and display the filenames of (non-)duplicate files. use 5.010; use strict; use warnings; use Cwd qw(abs_path); use File::Find qw(find); use File::Compare qw(compare); use Getopt::Long qw(GetOptions); use File::Spec::Functions qw(catdir catfile catpath splitdir splitpath); my $show_duplicates = 0; sub usage { print <<"EOT"; usage: $0 [options] [dir1] [dir2] options: -e --equal : display filenames of duplicate files (default: $show_duplicates) EOT exit; } GetOptions('e|equal!' => \$show_duplicates, 'h|help' => \&usage,) or die("Error in command line arguments!"); my ($dir1, $dir2) = map { abs_path($_) } grep { -d } @ARGV; if (not defined($dir1) or not defined($dir2)) { die "usage: $0 [dir1] [dir2]\n"; } my ($dir1_volume, $dir1_path) = splitpath($dir1, 1); my ($dir2_volume, $dir2_path) = splitpath($dir2, 1); my @dir1_parts = splitdir($dir1_path); my @dir2_parts = splitdir($dir2_path); find { no_chdir => 1, wanted => sub { (-f $_) || return; my $file1 = $_; my (undef, $directory, $file) = splitpath($file1); my @parts = splitdir($directory); splice(@parts, 0, scalar(@dir1_parts)); my $file2 = catpath($dir2_volume, catdir(@dir2_parts, @parts), $file); (-f $file2) || return; my $are_equal = ((-s $file1) == (-s $file2) and compare($file1, $file2) == 0); if ($show_duplicates) { say catfile(@parts, $file) if $are_equal; } else { say catfile(@parts, $file) if !$are_equal; } } } => $dir1; ================================================ FILE: Finders/plocate.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 20 April 2012 # https://github.com/trizen # Perl locate - a pretty efficient file locater use 5.010; use strict; use Getopt::Std qw(getopts); use File::Find qw(find); use File::Spec::Functions qw(rel2abs); my $DB_FILE = rel2abs('plocate.db'); sub usage { print <<"HELP"; usage: $0 [options] [dirs] options: -g : generate a $DB_FILE file -i : insensitive match -h : show this message example: $0 -g /my/dir $0 /tmp/(work|shop).doc HELP exit 0; } @ARGV or do { warn "$0: no pattern to search for specified\n"; exit 1 }; my %opt; getopts('gih', \%opt); $opt{h} && usage(); if ($opt{g}) { open my $DB_FH, '>', $DB_FILE or die "$0: Can't open $DB_FILE: $!"; say {$DB_FH} q{<<'__END_OF_THE_DATABASE__';}; find { no_chdir => 1, wanted => sub { say {$DB_FH} rel2abs($_); }, } => @ARGV ? grep { -d } @ARGV : q{.}; say {$DB_FH} q{__END_OF_THE_DATABASE__}; close $DB_FH; exit 0; } -e $DB_FILE or usage(); my $files = do $DB_FILE; study $files; foreach my $re (@ARGV) { $re = $opt{i} ? qr{$re}i : qr{$re}; while ($files =~ /^.*?$re.*/gmp) { say ${^MATCH}; } } ================================================ FILE: Finders/similar_files_levenshtein.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 13 January 2016 # https://github.com/trizen # Finds files which have almost the same content, using the Levenshtein distance. # ## WARNING! For strict duplicates, use the 'fdf' script: # https://github.com/trizen/perl-scripts/blob/master/Finders/fdf # use 5.010; use strict; use warnings; use Fcntl qw(O_RDONLY); use File::Find qw(find); use Getopt::Long qw(GetOptions); use Text::LevenshteinXS qw(distance); use Number::Bytes::Human qw(parse_bytes); my $unique = 0; my $threshold = 70; my $max_size = '100KB'; sub help { my ($code) = @_; print <<"HELP"; usage: $0 [options] [/dir/a] [/dir/b] [...] options: -s --size=s : maximum file size (default: $max_size) -u --unique! : don't include a file in more groups (default: false) -t --threshold=f : threshold percentage (default: $threshold) Example: perl $0 ~/Documents HELP exit($code // 0); } GetOptions( 's|size=s' => \$max_size, 'u|unique!' => \$unique, 't|threshold=f' => \$threshold, 'h|help' => \&help, ) or die("Error in command line arguments"); @ARGV || help(); $max_size = parse_bytes($max_size); sub look_similar { my ($f1, $f2) = @_; sysopen my $fh1, $f1, O_RDONLY or return; sysopen my $fh2, $f2, O_RDONLY or return; my $s1 = (-s $f1) || (-s $fh1); my $s2 = (-s $f2) || (-s $fh2); my ($min, $max) = $s1 < $s2 ? ($s1, $s2) : ($s2, $s1); my $diff = int($max * (100 - $threshold) / 100); ($max - $min) > $diff and return; sysread($fh1, (my $c1), $s1) || return; sysread($fh2, (my $c2), $s2) || return; distance($c1, $c2) <= $diff; } sub find_similar_files (&@) { my $code = shift; my %files; find { no_chdir => 1, wanted => sub { lstat; (-f _) && (not -l _) && do { my $size = -s _; if ($size <= $max_size) { # TODO: better grouping push @{$files{int log $size}}, $File::Find::name; } }; } } => @_; foreach my $key (sort { $a <=> $b } keys %files) { next if $#{$files{$key}} < 1; my @files = @{$files{$key}}; my %dups; foreach my $i (0 .. $#files - 1) { for (my $j = $i + 1 ; $j <= $#files ; $j++) { if (look_similar($files[$i], $files[$j])) { push @{$dups{$files[$i]}}, ( $unique ? splice(@files, $j--, 1) : $files[$j] ); } } } while (my ($fparent, $fdups) = each %dups) { $code->(sort $fparent, @{$fdups}); } } return 1; } { local $, = "\n"; find_similar_files { say @_, "-" x 80 if @_; } @ARGV; } ================================================ FILE: Formatters/ascii_table_csv.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 15 March 2013 # https://github.com/trizen # Print a CSV file to standard output as an ASCII table. use 5.010; use strict; use autodie; use warnings; use open IO => ':utf8'; use Text::CSV qw(); use Text::ASCIITable qw(); use Getopt::Std qw(getopts); binmode(STDOUT, ':utf8'); my %opt = ( s => 0, d => ',', ); getopts('sw:d:', \%opt); my $csv_file = shift() // die <<"USAGE"; usage: $0 [options] [csv_file] options: -s : allow whitespace in CSV (default: $opt{s}) -d <> : separator character (default: '$opt{d}') -w <> : maximum width for table (default: no limit) example: $0 -s -d ';' -w 80 file.csv USAGE my %esc = ( a => "\a", t => "\t", r => "\r", n => "\n", e => "\e", b => "\b", f => "\f", ); $opt{d} =~ s{(?new( { binary => 1, allow_whitespace => $opt{s}, sep_char => $opt{d}, } ) or die "Cannot use CSV: " . Text::CSV->error_diag(); my $columns = $csv->getline($fh); my $lines = 0; while (my $row = $csv->getline($fh)) { foreach my $i (0 .. $#{$columns}) { push @{$record{$columns->[$i]}}, $row->[$i]; } ++$lines; } $csv->eof() or die "CSV ERROR: " . $csv->error_diag(), "\n"; close $fh; return ($columns, \%record, $lines); } ## Create the ASCII table sub create_ascii_table { my ($columns, $record, $lines) = @_; my $table = Text::ASCIITable->new(); $table->setCols(@{$columns}); if ($opt{w}) { foreach my $column (@{$columns}) { $table->setColWidth($column, $opt{w} / @{$columns}); } } foreach my $i (0 .. $lines - 1) { $table->addRow(map { $_->[$i] } @{$record}{@{$columns}}); } return $table; } { local $| = 1; print create_ascii_table(parse_file($csv_file)); } ================================================ FILE: Formatters/file_columner.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 August 2013 # https://github.com/trizen # Put two or more files together as columns. use 5.010; use strict; use autodie; use warnings; use List::Util qw(any); use Getopt::Std qw(getopts); binmode(\*STDOUT, ':encoding(UTF-8)'); my %opt = (s => 25); getopts('s:h', \%opt); sub usage { die <<"USAGE"; usage: $0 [options] [files] options: -s : number of spaces between columns (default: $opt{s}) -h : print this message and exit Example: perl $0 -s 40 file1.txt file2.txt > output.txt USAGE } my @files = grep { -f or warn "`$_' is not a file!\n"; -f _; } @ARGV; if ($opt{h} || !@files) { usage(); } my @fhs = map { open my $fh, '<:encoding(UTF-8):crlf', $_; $fh; } @files; while (any { !eof($_) } @fhs) { printf "%-$opt{s}s " x $#fhs . "%s\n", map { chomp( my $line = eof($_) ? q{} : scalar(<$_>) ); $line; } @fhs; } ================================================ FILE: Formatters/fstab_beautifier.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 March 2014 # https://trizenx.blogspot.com # Realign the columns of a space-delimited file (with support for comments and empty lines) use 5.010; use strict; use warnings; sub fstab_beautifier { my ($fh, $code) = @_; my @data; while (defined(my $line = <$fh>)) { if ($line =~ /^#/) { # it's a comment push @data, {comment => $line}; } elsif (not $line =~ /\S/) { # it's an empty line push @data, {empty => ""}; } else { # hopefully, it's a line with columns push @data, {fields => [split(' ', $line)]}; } } # Indicate the EOF (this is used to flush the buffer) push @data, {eof => 1}; # Store the columns and the width of each column my @buffer; my @widths; for (my $i = 0 ; $i <= $#data ; $i++) { my $line = $data[$i]; if (exists $line->{fields}) { # it's a line with columns # Collect the maximum width of each column while (my ($i, $item) = each @{$line->{fields}}) { if ((my $len = length($item)) > ($widths[$i] //= 0)) { $widths[$i] = $len; } } # Store the line in the buffer # and continue looping to the next line push @buffer, $line->{fields}; next; } elsif (exists $line->{comment}) { # it's a comment $code->(unpack("A*", $line->{comment})); } if (@buffer) { # buffer is not empty # Create the format for 'sprintf' my $format = join("\t", map { "%-${_}s" } splice(@widths)); # For each line of the buffer, format it and send it further while (defined(my $line = shift @buffer)) { $code->(unpack("A*", sprintf($format, @{$line}))); } } if (exists $line->{empty}) { # empty line $code->($line->{empty}); } } } my $fh = @ARGV ? do { open my $fh, '<', $ARGV[0] or die "Can't open file `$ARGV[0]' for reading: $!"; $fh; } : \*DATA; # Call the function with a FileHandle and CODE fstab_beautifier($fh, sub { say $_[0] }); __END__ # My system partitions /dev/sda7 swap swap defaults 0 0 /dev/sda1 / ext3 defaults 1 1 /dev/sda2 /home ext3 defaults 1 2 # My /mnt partitions /dev/sr0 /mnt/dvd_sr0 auto noauto,user,ro 0 0 /dev/sr1 /mnt/dvd_sr1 auto noauto,user,ro 0 0 /dev/fd0 /mnt/floppy auto rw,noauto,user,sync 0 0 /dev/sdd4 /mnt/zip vfat rw,noauto,user,sync 0 0 /dev/sde1 /mnt/usb auto rw,noauto,user,sync 0 0 # My /home/vtel57/ partitions /dev/sda8 /home/vtel57/vtel57_archives ext2 defaults 0 2 /dev/sdc1 /home/vtel57/vtel57_backups ext2 defaults 0 2 /dev/sdc7 /home/vtel57/vtel57_common vfat rw,gid=users,uid=vtel57 0 0 # My /dev partitions devpts /dev/pts devpts gid=5,mode=620 0 0 proc /proc proc defaults 0 0 tmpfs /dev/shm tmpfs defaults 0 0 ================================================ FILE: Formatters/js_beautify ================================================ #!/usr/bin/perl use strict; use warnings; use File::Slurper qw(read_text); use JavaScript::Beautifier qw(js_beautify); @ARGV && -f $ARGV[0] or die "usage: $0 \n"; print js_beautify( scalar read_text(shift) => { indent_size => 1, indent_character => "\t", } ); ================================================ FILE: Formatters/reformat_literal_perl_strings.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 12 November 2017 # https://github.com/trizen # Reformat the literal quoted strings in a Perl source code, using Perl::Tokenizer and Data::Dump. # Example: # 'foo姓bar' -> "foo\x{59D3}bar" # '\'foo\'' -> "'foo'" # The literal quoted strings (quoted as: q{...}, qq{...}, '...' or "...") will be reformatted as "...". # Strings which (potentially) include variable interpolations, are ignored. # The input source code must be UTF-8 encoded. use utf8; use 5.018; use warnings; use open IO => ':encoding(UTF-8)', ':std'; use Data::Dump qw(pp); use Perl::Tokenizer qw(perl_tokens); # usage: perl script.pl < source.pl my $code = join('', <>); perl_tokens { my ($name, $i, $j) = @_; if ( $name eq 'single_quoted_string' or $name eq 'double_quoted_string' or $name eq 'qq_string' or $name eq 'q_string') { my $str = substr($code, $i, $j - $i); my $eval_code = join( ';', 'my $str = qq{' . quotemeta($str) . '}', # quoted string 'die if $str =~ tr/@$//', # skip strings with interpolation '$str = eval $str', # evaluate string 'die if $@', # check the status of eval() '$str', # string content ); my $raw_str = eval($eval_code); if (defined($raw_str) and !$@) { print scalar pp($raw_str); return; } } print substr($code, $i, $j - $i); } $code; ================================================ FILE: Formatters/replace_html_links.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 07 December 2017 # https://github.com/trizen # Replace URLs inside an HTML file with a given URL. use strict; use warnings; use open IO => ':utf8'; # use UTF-8 I/O encoding use HTML::TreeBuilder; use File::Path qw(make_path); use File::Basename qw(basename); use File::Spec::Functions qw(catfile); # Directory where to write processed HTML files my $output_dir = 'Processed HTML files'; # The URL used in replacing the other URLs inside the HTML files my $url; #$url = 'http://example.net'; # predefined URL $url //= shift(@ARGV); # or URL specified in the first command-line argument if (not defined($url)) { die "usage: $0 [url] [HTML files]\n"; } if (not -d $output_dir) { make_path($output_dir) or die "Can't create directory `$output_dir': $!"; } foreach my $file (grep { -f } @ARGV) { # Open the input HTML file for reading open my $in_fh, '<', $file or do { warn "Can't open file `$file' for reading: $!"; next; }; # Create a new HTML::TreeBuilder object my $tree = HTML::TreeBuilder->new; # Parse the HTML content $tree->parse_file($in_fh); # Traverse the HTML tree and replace URLs $tree->traverse( [ sub { my ($elem) = @_; if ( ref($elem) eq 'HTML::Element' and $elem->tag eq 'a' and defined($elem->attr('href')) ) { $elem->attr('href', $url); } return HTML::Element::OK; }, ] ); # The output HTML filename my $output_file = catfile($output_dir, basename($file)); # Create the new HTML content my $new_html = $tree->as_HTML; # Open the output HTML file for writing open my $out_fh, '>', $output_file or do { warn "Can't open file `$output_file' for writing: $!"; next; }; # Write the new HTML content print $out_fh $new_html, "\n"; # Close the output file-handle close $out_fh; } ================================================ FILE: Formatters/sort_perl_subroutines.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 12 April 2024 # https://github.com/trizen # Sort the subroutines inside a Perl script, using alphabetical order. # Additionally, subroutines that are used by other subroutines, are defined earlier. use 5.036; use Perl::Tokenizer qw(perl_tokens); binmode(STDOUT, ':utf8'); my $perl_script = $ARGV[0] // die "usage: $0 [perl_script.pl]\n"; my $perl_code = do { open my $fh, '<:utf8', $perl_script or die "Cannot open file <<$perl_script>> for reading: $!"; local $/; <$fh>; }; my %subs; my $header = ''; my $sub_header = ''; my $header_state = 1; my $sub_header_state = 0; my $sub_state = 0; my $prev_token = ''; my $prev_token_2 = ''; my $extract_name = 0; my $sub_name = ''; my $sub_content = ''; my %calls; my $curly_bracket_count = 0; perl_tokens { my ($token, $pos_beg, $pos_end) = @_; my $value = substr($perl_code, $pos_beg, $pos_end - $pos_beg); if ( $token eq 'keyword' and $value eq 'sub' and ( $prev_token eq 'vertical_space' or ( $prev_token eq 'horizontal_space' and $prev_token_2 eq 'vertical_space') ) ) { $header_state = 0; $sub_header_state = 0; $sub_state = 1; $sub_content .= 'sub'; $extract_name = 1; } elsif ($header_state) { $header .= $value; } elsif ($sub_header_state) { $sub_header .= $value; } elsif ($sub_state) { if ($extract_name and $token eq 'sub_name') { $sub_name = $value; $extract_name = 0; } $sub_content .= $value; if ($token eq 'bare_word') { ++$calls{$value}; } if ($token eq 'curly_bracket_open') { ++$curly_bracket_count; } elsif ($token eq 'curly_bracket_close') { --$curly_bracket_count; if ($curly_bracket_count == 0) { if ($sub_name eq '') { $header .= $sub_content; } else { push @{$subs{$sub_name}}, { code => $sub_header . $sub_content, calls => [sort keys %calls], }; } $sub_header_state = 1; $sub_state = 0; $sub_content = ''; $sub_header = ''; undef %calls; } } } ($prev_token_2, $prev_token) = ($prev_token, $token); } $perl_code; sub order_subroutines (@keys) { my @subs; foreach my $key (@keys) { exists($subs{$key}) or next; my $entry = delete $subs{$key}; foreach my $sub (@$entry) { my @calls = grep { exists($subs{$_}) and $_ ne $key } @{$sub->{calls}}; push(@subs, order_subroutines(@calls)) if @calls; push @subs, $sub->{code}; } } return @subs; } my @keys = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { [CORE::fc($_) =~ s{^_}{\xff}r, $_] } keys %subs; my @subs_content = order_subroutines(@keys); @subs_content = map { unpack('A*', s{^\s+}{}r) } @subs_content; print $header; print join("\n\n", @subs_content); print $sub_header . $sub_content; ================================================ FILE: Formatters/word_columner.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 29 August 2012 # Edit: 18 January 2015 # Website: https://github.com/trizen # Put two or more lines together as columns. (with unicode char width support) use strict; use warnings; use open IO => ':encoding(UTF-8)', ':std'; use Getopt::Std qw(getopts); my %opt = ( c => 2, s => 25, l => 0, r => 0, u => 0, ); getopts('c:s:l:ruh', \%opt); sub usage { die <<"USAGE"; usage: $0 [options] [files] options: -c : number of columns (default: $opt{c}) -s : number of spaces between words (default: $opt{s}) -l : number of leading spaces (default: $opt{l}) -u : use the unicode char width feature -r : reverse columns Example: perl $0 -l 3 -s 40 file.txt > output.txt USAGE } usage() if $opt{h} or not @ARGV; foreach my $file (@ARGV) { open my $fh, '<', $file or do { warn "$0: Can't open file '$file' for read: $!\n"; next }; my @lines; while (<$fh>) { chomp; push @lines, $_; if ($. % $opt{c} == 0 || eof $fh and @lines) { my @cols = $opt{r} ? reverse splice @lines : splice @lines; my $format = ' ' x $opt{l}; if ($opt{u}) { require Text::CharWidth; foreach my $i (0 .. $#cols - 1) { my $diff = abs(Text::CharWidth::mbswidth($cols[$i]) - length($cols[$i])); $format .= "%-" . ($opt{s} - $diff) . 's'; } } else { $format = "%-$opt{s}s " x $#cols; } $format .= "%s\n"; printf $format, @cols; } } } ================================================ FILE: GD/AND_sierpinski_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 20 January 2017 # https://github.com/trizen # Generation of the Sierpinski triangle, # by plotting the values of the function # # f(n) = n AND n^2 # # See also: # https://oeis.org/A213541 # https://en.wikipedia.org/wiki/Sierpinski_triangle use 5.010; use strict; use warnings; use Imager; my $size = 1300; my $factor = 100; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => $size, ysize => $size); foreach my $n (1 .. $size * $factor) { $img->setpixel( x => $n / $factor, y => $size - ($n & ($n * $n)) / $factor, color => $red ); } $img->write(file => 'sierpinski_triangle.png'); ================================================ FILE: GD/LSystem/LSystem.pm ================================================ #!/usr/bin/perl # Written by jreed@itis.com, adapted by John Cristy. # Later adopted and improved by Daniel "Trizen" Șuteu. # Defined rules: # + Turn clockwise # - Turn counter-clockwise # : Mirror # [ Begin branch # ] End branch # Any upper case letter draws a line. # Any lower case letter is a no-op. package LSystem { use 5.010; use strict; use warnings; use lib qw(.); use Turtle; use Image::Magick; use Math::Trig qw(deg2rad); sub new { my ($class, %opt) = @_; my %state = ( theta => deg2rad($opt{angle} // 90), scale => $opt{scale} // 1, xoff => $opt{xoff} // 0, yoff => $opt{yoff} // 0, len => $opt{len} // 5, color => $opt{color} // 'black', turtle => Turtle->new($opt{width} // 1000, $opt{height} // 1000, deg2rad($opt{turn} // 0), 1), ); bless \%state, $class; } sub translate { my ($self, $letter) = @_; my %table = ( '+' => sub { $self->{turtle}->turn($self->{theta}); }, # Turn clockwise '-' => sub { $self->{turtle}->turn(-$self->{theta}); }, # Turn counter-clockwise ':' => sub { $self->{turtle}->mirror(); }, # Mirror '[' => sub { push(@{$self->{statestack}}, [$self->{turtle}->state()]); }, # Begin branch ']' => sub { $self->{turtle}->setstate(@{pop(@{$self->{statestack}})}); }, # End branch ); if (exists $table{$letter}) { $table{$letter}->(); } elsif ($letter =~ /^[[:upper:]]\z/) { $self->{turtle}->forward($self->{len}, $self); } } sub turtle { my ($self) = @_; $self->{turtle}; } sub execute { my ($self, $string, $repetitions, $filename, %rules) = @_; for (1 .. $repetitions) { $string =~ s{(.)}{$rules{$1} // $1}eg; } foreach my $command (split(//, $string)) { $self->translate($command); } $self->{turtle}->save_as($filename); } } 1; ================================================ FILE: GD/LSystem/Turtle.pm ================================================ package Turtle { use 5.010; use strict; use warnings; # Written by jreed@itis.com, adapted by John Cristy. # Later adopted and improved by Daniel "Trizen" Șuteu. sub new { my $class = shift; my %opt; @opt{qw(x y theta mirror)} = @_; # Create the main image my $im = Image::Magick->new(size => $opt{x} . 'x' . $opt{y}); $im->ReadImage('canvas:white'); $opt{im} = $im; bless \%opt, $class; } sub forward { my ($self, $r, $opt) = @_; my ($newx, $newy) = ($self->{x} + $r * sin($self->{theta}), $self->{y} + $r * -cos($self->{theta})); $self->draw( primitive => 'line', points => join(' ', $self->{x} * $opt->{scale} + $opt->{xoff}, $self->{y} * $opt->{scale} + $opt->{yoff}, $newx * $opt->{scale} + $opt->{xoff}, $newy * $opt->{scale} + $opt->{yoff}, ), stroke => $opt->{color}, strokewidth => 1 ); ($self->{x}, $self->{y}) = ($newx, $newy); # change the old coords } sub draw { my ($self, %opt) = @_; $self->{im}->Draw(%opt); } sub composite { my ($self, %opt) = @_; $self->{im}->Composite(%opt); } sub save_as { my ($self, $filename) = @_; $self->{im}->Write($filename); } sub turn { my ($self, $dtheta) = @_; $self->{theta} += $dtheta * $self->{mirror}; } sub state { my ($self) = @_; @{$self}{qw(x y theta mirror)}; } sub setstate { my $self = shift; @{$self}{qw(x y theta mirror)} = @_; } sub mirror { my ($self) = @_; $self->{mirror} *= -1; } } 1; ================================================ FILE: GD/LSystem/honeycomb.pl ================================================ #!/usr/bin/perl use 5.010; use strict; use warnings; use lib qw(.); use LSystem; my %rules = ( A => '-A-B+B+B+B+', B => '-A+B+A+B+A+B+A-', ); my $lsys = LSystem->new( width => 1000, height => 1000, scale => 1, xoff => -500, yoff => -400, len => 20, angle => 60, color => 'orange', ); $lsys->execute('A', 6, "honeycomb.png", %rules); ================================================ FILE: GD/LSystem/honeycomb_2.pl ================================================ #!/usr/bin/perl use 5.010; use strict; use warnings; use lib qw(.); use LSystem; my %rules = ( F => '+F-F-F-F-F-F-F-F-F+', # or: '+F-F-F-F-F-F-F+' ); my $lsys = LSystem->new( width => 1200, height => 1000, scale => 1, xoff => -600, yoff => -180, len => 20, angle => 60, color => 'orange', ); $lsys->execute('F', 5, "honeycomb_2.png", %rules); ================================================ FILE: GD/LSystem/plant.pl ================================================ #!/usr/bin/perl use 5.010; use strict; use warnings; use lib qw(.); use LSystem; my %rules = (S => 'SS+[+S-S-S]-[-S+S+S]'); my $lsys = LSystem->new( width => 1000, height => 1000, xoff => -600, len => 8, angle => 25, color => 'dark green', ); $lsys->execute('S', 5, "plant.png", %rules); ================================================ FILE: GD/LSystem/plant_2.pl ================================================ #!/usr/bin/perl use 5.010; use strict; use warnings; use lib qw(.); use LSystem; my %rules = ( S => 'T-[[S]+S]+T[+TS]-S', T => 'TT', # or: 'T[S]T' ); my $lsys = LSystem->new( width => 1000, height => 1000, scale => 0.7, xoff => -200, yoff => 300, len => 8, angle => 25, color => 'dark green', ); $lsys->execute('S', 6, "plant_2.png", %rules); ================================================ FILE: GD/LSystem/plant_3.pl ================================================ #!/usr/bin/perl use 5.010; use strict; use warnings; use lib qw(.); use LSystem; my %rules = (F => 'FF-[-F+F-F]+[+F-F]'); my $lsys = LSystem->new( width => 1000, height => 1000, xoff => -350, len => 8, angle => 25, color => 'dark green', ); $lsys->execute('F', 5, "plant_3.png", %rules); ================================================ FILE: GD/LSystem/sierpinski_triangle.pl ================================================ #!/usr/bin/perl use 5.010; use strict; use warnings; use lib qw(.); use LSystem; my %rules = ( S => 'S--S--S--T', T => 'TT', ); my $lsys = LSystem->new( width => 1000, height => 1000, scale => 0.4, xoff => -280, yoff => 400, len => 30, angle => 120, turn => 30, color => 'dark red', ); $lsys->execute('S--S--S', 7, "sierpinski_triangle.png", %rules); ================================================ FILE: GD/LSystem/tree.pl ================================================ #!/usr/bin/perl use strict; use warnings; use lib qw(.); use LSystem; my %rules = ( a => 'S[---l:a][++++b]', b => 'S[++lb][--c]', c => 'S[-----lb]gS[+:c]', l => '[{S+S+S+S+S+S}]' ); my $lsys = LSystem->new( width => 800, height => 800, xoff => -400, len => 35, angle => 5, color => 'dark green', ); $lsys->execute('a', 10, "tree.png", %rules); ================================================ FILE: GD/XOR_pattern.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 30 October 2017 # https://github.com/trizen # Generation of a colored-table of values `n^k (mod m)`, where `n` are the rows and `k` are the columns. use 5.010; use strict; use warnings; use Imager; my $size = 1000; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => $size, ysize => $size); my $mod = 7; my @colors = map { Imager::Color->new(sprintf("#%x", rand(256**3))) } 1 .. $mod; foreach my $n (0 .. $size - 1) { foreach my $k (0 .. $size - 1) { $img->setpixel(x => $k, y => $n, color => $colors[($n ^ $k) % $mod]); } } $img->write(file => 'xor_pattern.png'); ================================================ FILE: GD/abstract_map.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 07 June 2015 # https://github.com/trizen # ## Generate a complex shape using basic mathematics. # use 5.010; use strict; use warnings; use GD::Simple; my $max = 1200000; my $limit = int(sqrt($max)) - 1; # create a new image my $img = GD::Simple->new($limit * 4, $limit * 2); # move to right $img->moveTo($limit * 3.20, $limit); my $j = 1; foreach my $i (1 .. $limit) { for my $n ($j .. $i**2) { $img->line(2); $img->turn($n**2 / $i); ++$j; } } open my $fh, '>:raw', "abstract_map.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/barnsley_fern_fractal.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 20 March 2016 # Website: https://github.com/trizen # Perl implementation of the Barnsley fern fractal. # See: https://en.wikipedia.org/wiki/Barnsley_fern use Imager; my $w = 640; my $h = 640; my $img = Imager->new(xsize => $w, ysize => $h, channels => 3); my $green = Imager::Color->new('#00FF00'); my ($x, $y) = (0, 0); foreach (1 .. 1e5) { my $r = rand(100); ($x, $y) = $r <= 1 ? ( 0.00 * $x - 0.00 * $y, 0.00 * $x + 0.16 * $y + 0.00) : $r <= 8 ? ( 0.20 * $x - 0.26 * $y, 0.23 * $x + 0.22 * $y + 1.60) : $r <= 15 ? (-0.15 * $x + 0.28 * $y, 0.26 * $x + 0.24 * $y + 0.44) : ( 0.85 * $x + 0.04 * $y, -0.04 * $x + 0.85 * $y + 1.60) ; $img->setpixel(x => $w / 2 + $x * 60, y => $y * 60, color => $green); } $img->flip(dir => 'v'); $img->write(file => 'barnsleyFern.png'); ================================================ FILE: GD/binary_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 16 January 2017 # https://github.com/trizen # Draws a balanced binary triangle with n branches on each side. use 5.010; use strict; use warnings; use Imager; use ntheory qw(:all); sub line { my ($img, $x, $y, $d, $n) = @_; my $x2 = $x + $n * $d; my $y2 = $y + $n * ($d ? 1 : 0); $img->line( color => 'red', x1 => $x, x2 => $x2, y1 => $y, y2 => $y2, ); return if $n <= 1; line($img, $x2, $y2, +1, $n >> 1); line($img, $x2, $y2, -1, $n >> 1); } my $n = 1024; my $img = Imager->new(xsize => $n * 2, ysize => $n); line($img, $n, 0, 0, $n); $img->write(file => 'binary_triangle.png'); ================================================ FILE: GD/black_star_turtle.pl ================================================ #!/usr/bin/perl use integer; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(1000, 1000); $img->moveTo(700, 500); my $nr = 442; sub t { $img->turn($_[0]) } sub l { $img->line($_[0]) } for (0 .. $nr) { t 45; #l $nr+$_; t -180; l $nr/ 2; t 45; l $nr / 2; t -180; l $nr; #t -180; #l $nr / 2; #t 90; #l $nr/2; t -180; l $nr+ $_; } my $image_name = 'black_star_turtle.png'; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/black_yellow_number_triangles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 May 2015 # https://github.com/trizen # ## Generate magic triangles with n gaps between numbers # use 5.010; use strict; use warnings; use GD::Simple; use File::Spec::Functions qw(catfile); my $num_triangles = shift(@ARGV) // 100; # duration: about 6 minutes sub generate { my ($n, $j, $data) = @_; foreach my $i (1 .. $n) { if ($i % $j == 0) { $data->{$i} = 1; } } return $n; } my $dir = "Number Triangles"; if (not -d $dir) { mkdir($dir) or die "Can't create dir `$dir': $!"; } foreach my $k (1 .. $num_triangles) { my %data; my $max = generate(921600, $k, \%data); my $limit = int(sqrt($max)) - 1; say "[$k of $num_triangles] Generating..."; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); $img->bgcolor('black'); $img->rectangle(0, 0, $limit * 2, $limit + 1); my $i = 1; my $j = 1; my $black = 0; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { if (exists $data{$j}) { $black = 0; $img->fgcolor('yellow'); } elsif (not $black) { $black = 1; $img->fgcolor('black'); } $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', catfile($dir, sprintf("%04d.png", $k)); print $fh $img->png; close $fh; } ================================================ FILE: GD/box_pattern.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 24 May 2017 # https://github.com/trizen # Generates an interesting pattern. use 5.010; use strict; use warnings; use Imager; my $size = 1000; my $img = Imager->new(xsize => $size, ysize => $size); foreach my $x (1 .. $size) { foreach my $y (1 .. $size) { if (($x * $y) % (int(sqrt($x)) + int(sqrt($y))) == 0) { $img->setpixel(x => $x - 1, y => $y - 1, color => 'red'); } } } $img->write(file => 'box_pattern.png'); ================================================ FILE: GD/chaos_game_pentagon.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 29 April 2017 # https://github.com/trizen # Chaos game, generating a Sierpinski pentagon. # See also: # https://www.youtube.com/watch?v=kbKtFN71Lfs # https://www.youtube.com/watch?v=e0JaZuLfZ_0 (starting from 18:03) use 5.010; use strict; use warnings; use Imager; my $width = 1000; my $height = 1000; my @points = ( [$width/2, 0], [0, $height/2.5], [$width, $height/2.5], [$width/5, $height], [$width-$width/5, $height], ); my $img = Imager->new( xsize => $width, ysize => $height, channels => 3, ); my $color = Imager::Color->new('#ff0000'); my $r = [$points[rand(@points)], $points[rand(@points)]]; foreach my $i (1 .. 100000) { my $p = $points[rand @points]; my $h = [ sprintf('%.0f',($p->[0] + $r->[0]) / 3) + $width/6, sprintf('%.0f',($p->[1] + $r->[1]) / 3) + $height/5, ]; $img->setpixel( x => $h->[0], y => $h->[1], color => $color, ); $r = $h; } $img->write(file => 'chaos_game_pentagon.png'); ================================================ FILE: GD/chaos_game_tetrahedron.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 August 2016 # https://github.com/trizen # Chaos game, generating a Sierpinski Tetrahedron. # https://en.wikipedia.org/wiki/Chaos_game use 5.010; use strict; use warnings; use Imager; my $width = 2000; my $height = 2000; my @points = ( [int($width/2), 0], [ 0, int($height-$height/4)], [ $width-1, int($height-$height/4)], [int($width/2), $height-1], ); my $img = Imager->new( xsize => $width, ysize => $height, channels => 3, ); my $color = Imager::Color->new('#ff0000'); my $r = [int(rand($width)), int(rand($height))]; foreach my $i (1 .. 200000) { my $p = $points[rand @points]; my $h = [ int(($p->[0] + $r->[0]) / 2), int(($p->[1] + $r->[1]) / 2), ]; $img->setpixel( x => $h->[0], y => $h->[1], color => $color, ); $r = $h; } $img->write(file => 'chaos_game_tetrahedron.png'); ================================================ FILE: GD/chaos_game_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 August 2016 # https://github.com/trizen # Chaos game, generating a Sierpinski triangle, as described by Keith Peters in his presentation. # See: https://www.youtube.com/watch?v=e0JaZuLfZ_0 (starting from 18:03) use 5.010; use strict; use warnings; use Imager; my $width = 1000; my $height = 1000; my @points = ( [int(rand($width)), 0], [0, int(rand($height))], [int(rand($height)), $height - 1], ); my $img = Imager->new( xsize => $width, ysize => $height, channels => 3, ); my $color = Imager::Color->new('#ff0000'); my $r = [int(rand($width)), int(rand($height))]; foreach my $i (1 .. 100000) { my $p = $points[rand @points]; my $h = [ int(($p->[0] + $r->[0]) / 2), int(($p->[1] + $r->[1]) / 2), ]; $img->setpixel( x => $h->[0], y => $h->[1], color => $color, ); $r = $h; } $img->write(file => 'chaos_game_triangle.png'); ================================================ FILE: GD/circular_prime_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 02 April 2016 # https://github.com/trizen # Generate a triangle with highlighted numbers in the form of: floor(sqrt(prime(i)^2 + i^2)) use 5.010; use strict; use warnings; use Imager; use List::Util qw(max); use ntheory qw(nth_prime); my %data; sub generate { my ($n) = @_; foreach my $i (1 .. $n) { undef $data{int(sqrt(nth_prime($i)**2 + $i * $i))}; } return 1; } generate(100000); my $i = 1; my $j = 1; my $max = max(keys %data); my $limit = int(sqrt($max)) - 1; # Create a new image my $img = Imager->new(xsize => $limit * 2, ysize => $limit + 1); my $red = Imager::Color->new(255, 0, 0); for my $m (0 .. $limit) { my $x = $limit - $m; for my $n ($j .. $m**2) { if (exists $data{$j}) { $img->setpixel(x => $x, y => $m, color => $red); } ++$x; ++$j; } } $img->write(file => 'prime_triangle.png'); ================================================ FILE: GD/circular_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 08 June 2015 # https://github.com/trizen # ## Generate a circular triangle based on triangular numbers. # use 5.010; use strict; use warnings; use GD::Simple; my $from = 0; my $step = 1; my $max = 3_000_000; my $limit = int(sqrt($max)); # create a new image my $img = GD::Simple->new($limit * 6, $limit * 6); # move to right $img->moveTo($limit * 2.75, $limit * 1.75); my $j = 1; foreach my $i (1 .. $limit) { for my $n ($j .. $i**2) { $img->line(1); $img->turn(($from + $i) * (($i - $from) / $step + 1) / 2); ++$j; } ++$i; } open my $fh, '>:raw', "circular_triangle.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/collatz_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 May 2015 # https://github.com/trizen # ## Generate a triangle with the collatz numbers # # Each pixel is highlighted based on the path frequency; # For example: 4 2 1 are the most common number paths and # they have the highest frequency and a hotter color (reddish), # while a less frequent path is represented by colder color (bluish); # in the middle lies the average frequency, represented by a greenish color. use 5.010; use strict; use warnings; use GD::Simple; use List::Util qw(max sum); my %collatz; sub collatz { my ($n) = @_; while ($n > 1) { if ($n % 2 == 0) { $n /= 2; } else { $n = $n * 3 + 1; } $collatz{$n}++; } return 1; } my $k = 10000; # maximum number (duration: about 2 minutes) for my $i (1 .. $k) { collatz($i); } my $i = 1; my $j = 1; my $avg = sum(values %collatz) / scalar(keys %collatz); say "Avg: $avg"; my $max = max(keys %collatz); my $limit = int(sqrt($max)) - 1; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $white = 0; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { if (exists $collatz{$j}) { my $v = $collatz{$j}; my $ratio = $avg / $v; my $red = 255 - int(255 * $ratio); my $blue = 255 - int(255 / $ratio); $red = 0 if $red < 0; $blue = 0 if $blue < 0; $img->fgcolor($red, 255 - (int(($red + $blue) / 2)), $blue); $white = 0; } elsif (not $white) { $white = 1; $img->fgcolor('white'); } $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', 'collatz.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/color_wheel.pl ================================================ #!/usr/bin/perl # Draw a HSV color wheel. # Algorithm from: # https://rosettacode.org/wiki/Color_wheel use 5.010; use strict; use warnings; use Imager; use Math::GComplex qw(cplx i); my ($width, $height) = (300, 300); my $center = cplx($width / 2, $height / 2); my $img = Imager->new(xsize => $width, ysize => $height); my $pi = atan2(0, -1); foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $vector = $center - $x - $y * i; my $magnitude = 2 * abs($vector) / $width; my $direction = ($pi + atan2($vector->real, $vector->imag)) / (2 * $pi); $img->setpixel( x => $x, y => $y, color => {hsv => [360 * $direction, $magnitude, $magnitude < 1 ? 1 : 0]} ); } } $img->write(file => 'color_wheel.png'); ================================================ FILE: GD/complex_square.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # Date: 07 January 2016 # License: GPLv3 # Website: https://github.com/trizen # Illustration of the complex square root function use 5.010; use strict; use warnings; use Imager; use Math::AnyNum; my $img = Imager->new(xsize => 2000, ysize => 1500); my $white = Imager::Color->new('#ffffff'); my $black = Imager::Color->new('#000000'); $img->box(filled => 1, color => $black); for my $i (1 .. 400) { for my $j (1 .. 400) { my $x = Math::AnyNum->new_c($i, $j)->sqrt; my ($re, $im) = ($x->real->numify, $x->imag->numify); $img->setpixel(x => 300 + int(60 * $re), y => 400 + int(60 * $im), color => $white); } } $img->write(file => 'complex_square.png'); ================================================ FILE: GD/congruence_of_squares_triangle.pl ================================================ #!/usr/bin/perl # Highlight integers `k` in a triangle such that `k^2 (mod N)` # is a square and leads to a non-trivial factorization of `N`. use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(:all); # Composite integer N for which x^2 == y^2 (mod N) # and { gcd(x-y, N), gcd(x+y, N) } are non trivial factors of N. my $N = 43 * 79; my $i = 1; my $j = 1; my $n = shift(@ARGV) // 1000000; my $limit = int(sqrt($n)) - 1; my $img = GD::Simple->new($limit * 2, $limit + 1); $img->bgcolor('black'); $img->rectangle(0, 0, $limit * 2, $limit + 1); my $white = 0; for (my $m = $limit; $m > 0; --$m) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { my $copy = $j; ## $j = ($copy*$copy + 3*$copy + 1); my $x = mulmod($j, $j, $N); my $root = sqrtint($x); my $r = gcd($root - $j, $N); my $s = gcd($root + $j, $N); if (is_square($x) and ($j % $N) != $root and (($r > 1 and $r < $N) and ($s > 1 and $s < $N))) { $white = 0; $img->fgcolor('white'); } elsif (not $white) { $white = 1; $img->fgcolor('black'); } $img->line(1); $j = $copy; ++$j; } ++$i; } open my $fh, '>:raw', 'congruence_of_squares.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/cuboid_turtle.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2000, 2000); $img->moveTo(670, 800); my $pi = atan2(1, -'inf'); my $nr = $pi * 100; for (0 .. 280) { $img->fgcolor('black'); $img->turn($nr); $img->line(-$nr); $img->turn(-134.2); $img->line(-$nr); $img->turn($nr); $img->line(-$nr); $img->turn(-134.1); $img->line(-$nr); $img->turn($nr); $img->line(-$nr); $img->turn(-134.2); $img->line(-$nr); $img->turn($nr); $img->line(-$nr); $img->fgcolor('red'); $img->turn(134.1); $img->line(-$nr); $img->fgcolor('black'); $img->turn(-134.1); $img->line($nr); $img->line(-$nr); $img->turn(-90); $img->line($nr); $img->line(-$nr); $img->turn(90); $img->line(-$nr); } my $image_name = 'cuboid_turtle.png'; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/cuboid_turtle3.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2500, 2500); $img->moveTo(1370, 1580); my $nr = 314.9; for (0 .. 55) { $img->fgcolor('black'); $img->turn($nr); $img->line(-$nr); $img->turn(-$nr); $img->line(-$nr); $img->turn($nr); $img->line($nr); $img->fgcolor('gray'); $img->turn(-$nr); $img->line($nr); $img->line($nr); $img->turn($nr); $img->line(-$nr); $img->turn($nr); $img->line(-$nr); $img->fgcolor('red'); $img->turn(-$nr); $img->line($nr); $img->line(-$nr); $img->turn($nr); $img->line(-$nr); $img->fgcolor('blue'); $img->turn(-$nr); $img->line($nr); $img->turn($nr); $img->line($nr); $img->line($nr); $img->fgcolor('purple'); $img->turn(-$nr); $img->line(-$nr); $img->line(-$nr); $img->fgcolor('green'); $img->turn($nr); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->line($nr); $img->fgcolor('gray'); $img->turn(-$nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->fgcolor('blue'); $img->turn(-$nr); $img->line($nr); $img->fgcolor('purple'); $img->turn($nr); $img->line(-$nr); $img->fgcolor('red'); $img->line(-$nr); $img->line(-$nr); } my $image_name = 'cuboid_turtle_3.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/cuboid_turtle_2.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(3000, 3000); $img->moveTo(1660, 1780); my $nr = 314.9; for (0 .. 44) { $img->fgcolor('black'); $img->turn($nr); $img->line(-$nr); $img->turn(-$nr); $img->line(-$nr); $img->turn($nr); $img->line($nr); $img->fgcolor('gray'); $img->turn(-$nr); $img->line($nr); $img->line($nr); $img->turn($nr); $img->line(-$nr); $img->turn($nr); $img->line(-$nr); $img->fgcolor('red'); $img->turn(-$nr); $img->line($nr); $img->line(-$nr); $img->turn($nr); $img->line(-$nr); $img->fgcolor('blue'); $img->turn(-$nr); $img->line($nr); $img->turn($nr); $img->line($nr); $img->line($nr); $img->fgcolor('purple'); $img->turn(-$nr); $img->line(-$nr); $img->line(-$nr); } my $image_name = 'cuboid_turtle_2.png'; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/dancing_shapes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 April 2014 # Website: https://github.com/trizen # Generate mathematical shapes # -- feel free to play with the numbers -- use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(3000, 3000); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } my $dirname = "Dancing shapes"; -d $dirname or do { mkdir($dirname) or die "Can't mkdir '$dirname': $!"; }; chdir($dirname) or die "Can't chdir into '$dirname': $!"; foreach my $t (1 .. 179) { # turn from 1 to 179 for my $k (5 .. 9) { # draw this many pictures for each turn # Info to STDOUT say "$t:$k"; $img->clear; $img->moveTo(1500, 1500); # hopefully, at the center of the image for my $i (1 .. $t) { # another interesting set is from 1..$k for my $j (1 .. $k) { $img->fgcolor('green'); l(40 * $j); # the length of a given line (in pixels) $img->fgcolor('blue'); l(-40 * ($j / 2)); # if you happen to love textiles, comment this line :) t $t; } $img->fgcolor('red'); l 40; ##last; # to generate only the basic shapes, uncomment this line. } my $image_name = sprintf('%03d-%02d.png', $t, $k); open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ## View the image as soon as it is generated #system "gliv", $image_name; # edit this line #$? == 0 or die "Non-zero exit code of the image viewer: $?"; } } ================================================ FILE: GD/divisor_circles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 14 September 2016 # Website: https://github.com/trizen # For each divisor `d` of a number `n`, draw a circle in such a # way that the line of the circle passes through both `n` and `d`. use 5.014; use strict; use warnings; use Imager; use ntheory qw(divisors); my $limit = 1000; my $scale = 10; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => $limit * $scale, ysize => $limit * $scale,); sub get_circle { my ($n, $f) = @_; my $r = ($n * $scale - $f * $scale) / 2; ($r, $r + $f * $scale, $limit * $scale / 2); } foreach my $n (1 .. $limit) { foreach my $f (divisors($n)) { my ($r, $x, $y) = get_circle($n, $f); $img->circle( x => $x, y => $y, r => $r, color => $red, filled => 0 ); } } $img = $img->rotate(degrees => 90); $img->write(file => 'divisor_circles.png'); ================================================ FILE: GD/divisor_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 14 September 2016 # Website: https://github.com/trizen # Generates a triangle with non-prime and non-power numbers, # each number connected through a line to its divisors. use strict; use warnings; use Imager; use ntheory qw(is_prime is_power divisors); use POSIX qw(ceil); use Memoize qw(memoize); memoize('get_point'); my $limit = 10; my $scale = 1000; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => 2 * $limit * $scale, ysize => $limit * $scale); sub get_point { my ($n) = @_; my $row = ceil(sqrt($n)); my $cell = 2 * $row - 1 - $row**2 + $n; ($scale * $cell, $scale * $row); } foreach my $n (1 .. $scale) { if (not is_prime($n) and not is_power($n)) { my ($x1, $y1) = get_point($n); foreach my $divisor (divisors($n)) { my ($x2, $y2) = get_point($divisor); $img->line( x1 => ($limit * $scale - $y1 - 1) + $x1, y1 => $y1, x2 => ($limit * $scale - $y2 - 1) + $x2, y2 => $y2, color => $red ); } } } $img->write(file => 'divisor_triangle.png'); ================================================ FILE: GD/elementary_cellular_automaton_generalized.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 16 October 2019 # https://github.com/trizen # Generalization of the elementary cellular automaton, by using `n` color-states and looking at `k` neighbors left-to-right. # 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. # See also: # https://en.wikipedia.org/wiki/Cellular_automaton # https://en.wikipedia.org/wiki/Elementary_cellular_automaton # https://rosettacode.org/wiki/Elementary_cellular_automaton # YouTube lectures: # https://www.youtube.com/watch?v=S3tYzCPuVsA # https://www.youtube.com/watch?v=pGGIE5uhPRQ use 5.020; use strict; use warnings; use Imager; use ntheory qw(:all); use experimental qw(signatures); use Algorithm::Combinatorics qw(variations_with_repetition); sub automaton ($n, $k, $iter, $rule, $cells = [1]) { my %colors = ( 0 => 'black', 1 => 'white', 2 => 'red', 3 => 'blue', 4 => 'green', 5 => 'yellow', ); say "Generating $n x $k with rule $rule."; my $size = $iter; my $img = Imager->new(xsize => $size, ysize => $size >> 1); my @states = variations_with_repetition([0 .. $n - 1], 2 * $k + 1); my @digits = reverse todigits($rule, $n); my @lookup; foreach my $i (0 .. $#states) { $lookup[fromdigits($states[$i], $n)] = $digits[$i] // 0; } my @padding = (0) x (($iter - scalar(@$cells)) >> 1); my @cells = (@padding, @$cells, @padding); my @neighbors_range = (-$k .. $k); my $len = scalar(@cells); for my $i (0 .. ($iter >> 1) - 1) { foreach my $j (0 .. $#cells) { if ($cells[$j]) { $img->setpixel( y => $i, x => $j, color => $colors{$cells[$j]}, ); } } @cells = @lookup[ map { my $i = $_; fromdigits([map { $cells[($i + $_) % $len] } @neighbors_range], $n) } 0 .. $#cells ]; } return $img; } automaton(2, 1, 1000, "30")->write(file => "rule_30.png"); automaton(3, 1, 1000, "3760220742240")->write(file => "sierpinski_3x1.png"); automaton(3, 1, 1000, "2646595889467")->write(file => "random_3x1-1.png"); automaton(3, 1, 1000, "4018294395539")->write(file => "random_3x1-2.png"); automaton(3, 1, 1000, "5432098941", [2])->write(file => "random_2x2-3.png"); automaton(2, 2, 1000, "413000741")->write(file => "random_2x2.png"); ================================================ FILE: GD/fact_exp_primorial_growing.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 19 August 2015 # Website: https://github.com/trizen # Plot the growing of exponentiation, factorial and primorial. # blue is n! # green is n^n # red is n-primorial # The plot is logarithmic in base e. use 5.010; use strict; use warnings; use Imager qw(); use ntheory qw(nth_prime); my $xsize = 250; my $ysize = 600; my $img = Imager->new(xsize => $xsize, ysize => $ysize); my $white = Imager::Color->new('#ffffff'); my $red = Imager::Color->new('#ff0000'); my $blue = Imager::Color->new('#0000ff'); my $green = Imager::Color->new('#00ff00'); $img->box(filled => 1, color => $white); my $x = 0; { use Math::AnyNum qw(:overload); my $f = 1; my $p = 1; for (my $i = 1 ; $i <= 100 ; ++$i) { $f *= $i + 1; $p *= nth_prime($i); $img->setpixel(x => $x, y => (abs(log($p) - $ysize))->as_int, color => $red); $img->setpixel(x => $x, y => (abs(log($f) - $ysize))->as_int, color => $blue); $img->setpixel(x => $x, y => (abs(log($i**$i) - $ysize))->as_int, color => $green); $x++; } } $img->write(file => 'grow.png'); ================================================ FILE: GD/factor_circles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 14 September 2016 # Website: https://github.com/trizen # For each factor `f` of a composite number `n`, draw a circle # in such a way that the line of the circle passes through both `n` and `f`. use 5.014; use strict; use warnings; use Imager; use List::Util qw(uniq); use ntheory qw(is_prime factor); my $limit = 1000; my $scale = 10; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => $limit * $scale, ysize => $limit * $scale,); sub get_circle { my ($n, $f) = @_; my $r = ($n * $scale - $f * $scale) / 2; ($r, $r + $f * $scale, $limit * $scale / 2); } foreach my $n (1 .. $limit) { if (not is_prime($n)) { foreach my $f (uniq(factor($n))) { my ($r, $x, $y) = get_circle($n, $f); $img->circle( x => $x, y => $y, r => $r, color => $red, filled => 0 ); } } } $img = $img->rotate(degrees => 90); $img->write(file => 'factor_circles.png'); ================================================ FILE: GD/factor_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 14 September 2016 # Website: https://github.com/trizen # Generates a triangle with non-prime and non-power numbers, # each number connected through a line to its prime factors. # The triangles that are forming, are the prime numbers. # For example, the first two triangles are 2 and 3 respectively. use strict; use warnings; use Imager; use ntheory qw(is_prime is_power factor); use POSIX qw(ceil); use List::Util qw(uniq); use Memoize qw(memoize); memoize('get_point'); my $limit = 10; my $scale = 1000; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => 2 * $limit * $scale, ysize => $limit * $scale); sub get_point { my ($n) = @_; my $row = ceil(sqrt($n)); my $cell = 2 * $row - 1 - $row**2 + $n; ($scale * $cell, $scale * $row); } foreach my $n (1 .. $scale) { if (not is_prime($n) and not is_power($n)) { my ($x1, $y1) = get_point($n); my @f = uniq(factor($n)); foreach my $factor (@f) { my ($x2, $y2) = get_point($factor); $img->line( x1 => ($limit * $scale - $y1 - 1) + $x1, y1 => $y1, x2 => ($limit * $scale - $y2 - 1) + $x2, y2 => $y2, color => $red ); } } } $img->write(file => 'factor_triangle.png'); ================================================ FILE: GD/factorial_turtles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 20 July 2015 # Website: https://github.com/trizen # An image generator based on the following formula: n!/(n-1)!, n!/(n-2)!, ... n!/(n-n)! # Simplified as: # n!/(n-1)! = n # n!/(n-2)! = n * (n-1) # n!/(n-3)! = n * (n-1) * (n-2) use 5.010; use strict; use warnings; use GD::Simple; use Math::AnyNum; use File::Spec::Functions qw(catfile); my $beg = 3; # start point my $end = 30; # end point my $dir = 'Factorial turtles'; # where to output the images if (not -d $dir) { mkdir($dir) or die "Can't mkdir `$dir': $!"; } foreach my $n ($beg .. $end) { { local $| = 1; printf("[%3d of %3d]\r", $n, $end); } my $img = 'GD::Simple'->new(5000, 5000); $img->moveTo(2500, 2500); $img->fgcolor('red'); my @values; my $p = Math::AnyNum->new(1); foreach my $j (0 .. $n - 1) { $p *= $n - $j; push @values, $p; } for my $i (1 .. 100) { foreach my $value (@values) { $img->line($i); $img->turn($value); } } my $image_name = catfile($dir, sprintf('%03d.png', $n)); open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; } ================================================ FILE: GD/factors_of_two_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 09 August 2016 # https://github.com/trizen # ## Generates a number triangle, highlighting the number of ## factors of two with a different color for each number n. # use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(factor); use List::Util qw(max shuffle); my @colors = shuffle(grep { !/black|gradient/ } GD::Simple->color_names); my %data; sub generate { my ($n) = @_; foreach my $i (0 .. $n) { $data{$i} = grep { $_ == 2 } factor($i); } return 1; } generate(1000000); # takes about 10 seconds my $i = 1; my $j = 1; my $max = max(keys %data); my $limit = int(sqrt($max)) - 1; my $img = GD::Simple->new($limit * 2, $limit + 1); for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { if ($data{$j} > 0) { $img->fgcolor($colors[$data{$j}]); } else { $img->fgcolor('black'); } $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', 'factors_of_two.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/farey_turnings_plot.pl ================================================ #!/usr/bin/perl # Plot the turnings in the Farey approximation process. # See also: # https://en.wikipedia.org/wiki/Farey_sequence # https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree use 5.020; use strict; use warnings; use GD::Simple; use Math::AnyNum qw(abs); use experimental qw(signatures); sub farey_approximation ($r) { my ($m, $n) = abs($r)->rat_approx->nude; my $enc = ''; for (; ;) { if ((($m <=> $n) || last) < 0) { $enc .= '0'; $n -= $m; } else { $enc .= '1'; $m -= $n; } } return $enc; } my $turns = do { local $Math::AnyNum::PREC = 30000; farey_approximation(Math::AnyNum::tau()); }; say substr($turns, 0, 50); my $width = 2000; my $height = 2000; my $img = 'GD::Simple'->new($width, $height); $img->moveTo($width / 1.75, $height / 1.25); my $angle = 60; foreach my $t (split(//, $turns)) { $t ? $img->turn($angle) : $img->turn(-$angle); $img->line(5); } open my $fh, '>:raw', 'farey_plot.png' or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/fgraph.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 02 July 2014 # Edit: 15 July 2014 # https://github.com/trizen # Map a mathematical function on the xOy axis. # usage: perl fgraph.pl 'function' 'graph-size' 'from' 'to' # usage: perl fgraph.pl '$x**2 + 1' use 5.010; use strict; use warnings; my $e = exp(1); my $pi = atan2(0, -'inf'); my $function = @ARGV ? shift @ARGV : (); my $f = defined($function) ? (eval("sub {my(\$x) = \@_; $function}") // die "Invalid function '$function': $@") : sub { my ($x) = @_; $x**2 + 1 }; my $size = 150; my $range = [-8, 8]; if (@ARGV) { $size = shift @ARGV; } if (@ARGV) { $range->[0] = shift @ARGV; } if (@ARGV) { $range->[1] = shift @ARGV; } if (@ARGV) { die "Too many arguments! (@ARGV)"; } # Generic creation of a matrix sub create_matrix { my ($size, $val) = @_; int($size / 2), [map { [($val) x ($size)] } 0 .. $size - 1]; } # Create a matrix my ($i, $matrix) = create_matrix($size, ' '); # Assign the point inside the matrix sub assign { my ($x, $y, $value) = @_; $x += $i; $y += $i; $matrix->[-$y][$x] = $value; } # Map the function foreach my $x ($range->[0] .. $range->[1]) { my $y = eval { $f->($x) }; if ($@) { warn "Function f(x)=${\($function=~s/\$//rg=~s/\*\*/^/rg)} is not defined for x=$x\n"; next; } say "($x, $y)"; # this line prints the coordinates assign($x, $y, 'o'); # this line maps the value of (x, f(x)) on the graph } # Init the GD::Simple module require GD::Simple; my $img = GD::Simple->new($i * 2, $i * 2); my $imgFile = 'graph.png'; sub l { $img->line(shift); } sub c { $img->fgcolor(shift); } sub mv { $img->moveTo(@_); } mv(0, 0); # Create the image from the 2D-matrix while (my ($k, $row) = each @{$matrix}) { while (my ($l, $col) = each @{$row}) { if ($col eq ' ') { if ($k == $i) { # the 'x' line c('white'); l(1); } elsif ($l == $i) { # the 'y' line c('white'); l(1); } else { # space c('black'); l(1); } } else { # everything else c('red'); l(1); } } mv(0, $k + 1); } # Create the PNG file open my $fh, '>', $imgFile; print {$fh} $img->png; close $fh; ================================================ FILE: GD/fgraph_precision.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 02 July 2014 # Edit: 15 July 2014 # https://github.com/trizen # Map a mathematical function on the xOy axis. use 5.010; use strict; use autodie; use warnings; use GD::Simple qw(); use Getopt::Long qw(GetOptions); my $e = exp(1); my $pi = atan2(0, -'inf'); my $size = 150; my $step = 1e-2; my $from = -5; my $to = abs($from); my $v = !1; my $f = sub { my ($x) = @_; $x**2 + 1 }; my $output_file = 'function_graph.png'; GetOptions( 'size|s=f' => \$size, 'step=f' => \$step, 'from=f' => \$from, 'to|t=f' => \$to, 'verbose|v!' => \$v, 'output|o=s' => \$output_file, 'function|f=s' => sub { my (undef, $value) = @_; $f = eval("sub {my(\$x) = \@_; $value}") // die "Invalid function '$value': $@"; }, ) || die("Error in command line arguments\n"); # Generic creation of a matrix sub create_matrix { my ($size, $val) = @_; int($size / 2), [map { [($val) x ($size)] } 0 .. $size - 1]; } # Create a matrix my ($i, $matrix) = create_matrix($size, ' '); # Assign the point inside the matrix sub assign { my ($x, $y, $value) = @_; $x += $i; $y += $i; $matrix->[-$y][$x] = $value; } # Map the function for (my $x = $from ; $x <= $to ; $x += $step) { my $y = eval { $f->($x) }; if ($@) { warn "f($x) is not defined!\n"; next; } $y = sprintf('%.0f', $y); say "($x, $y)" if $v; # this line prints the coordinates assign($x, $y, 'o'); # this line maps the value of (x, f(x)) on the graph } # Init the GD::Simple module my $img = GD::Simple->new($i * 2, $i * 2); sub l { $img->line(shift); } sub c { $img->fgcolor(shift); } sub mv { $img->moveTo(@_); } mv(0, 0); # Create the image from the 2D-matrix while (my ($k, $row) = each @{$matrix}) { while (my ($l, $col) = each @{$row}) { if ($col eq ' ') { if ($k == $i) { # the 'x' line c('white'); l(1); } elsif ($l == $i) { # the 'y' line c('white'); l(1); } else { # space c('black'); l(1); } } else { # everything else c('red'); l(1); } } mv(0, $k + 1); } # Create the PNG file open my $fh, '>', $output_file or die "$output_file: $!"; print {$fh} $img->png; close $fh; ================================================ FILE: GD/fibonacci_gd.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 May 2014 # https://github.com/trizen use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(1500, 1000); $img->moveTo(250, 530); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } sub fib { my ($n) = @_; my $res = $n < 2 ? $n : fib($n - 2) + fib($n - 1); l($res * 4); t(90); $res; } fib(14); my $image_name = 'fibonacci_turtle.png'; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/fibonacci_spirals.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 July 2015 # https://github.com/trizen # ## Generate a Fibonacci cluster of spirals. # use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(8000, 8000); $img->moveTo(3500, 3500); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } sub fibonacci(&$) { my ($callback, $n) = @_; my @fib = (1, 1); for (1 .. $n - 2) { $callback->($fib[0]); @fib = ($fib[-1], $fib[-1] + $fib[-2]); } $callback->($_) for @fib; } c 'red'; for my $i (1 .. 180) { fibonacci { l $_[0]**(1 / 11); t $i; } $i; t 0; } my $image_name = 'fibonacci_spirals.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/generator_turtle.pl ================================================ #!/usr/bin/perl use GD::Simple; $img = 'GD::Simple'->new(1000, 1000); $img->moveTo(445, 275); my $nr = 124; sub t { $img->turn($_[0]) } sub l { $img->line($_[0]) } for (0 .. 125) { l $nr; t 90; l -$nr; l $nr; t -90; l $nr; l $nr/ 2; t 90; l $nr/ 2; t 90; l $nr; t -90; l $nr* 2; t -90; l $nr* 2; t -90; l $nr* 2; t -90; l $nr; t -180; l $nr; t 45; l $nr; t -180; l $nr; t -45; l $nr* 2; t -45; l $nr; t 90; l -$nr; t -45; l -$nr * 2; t -45; l -$nr; #last; } my $image_name = 'turtle_generator.png'; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/geometric_shapes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 02th December 2013 # Website: https://trizenx.blgospot.com # This script tries to generate geometric shapes with a consistent internal angle size use 5.010; use strict; use autodie; use warnings; use GD::Simple; my $width = 3000; my $height = 3000; my $step = 1; my $len = 500; my $sides = 360; my $max_angle = 160; my $dir = 'Geometric shapes'; (-d $dir) || (mkdir($dir)); chdir($dir); for (my $angle = 30 ; $angle <= $max_angle ; $angle += $step) { my $p = GD::Simple->new($width, $height); $p->fgcolor('blue'); $p->moveTo(1500, 1000); my %seen; my $text = ''; my $valid = 0; foreach my $i (1 .. $sides) { if ($seen{join $;, $p->curPos}++) { $text = sprintf "%d degrees internal angle with %d sides", 180 - $angle, $i - 1; $valid = 1; last; } $p->turn($angle); $p->line($len); } $valid || next; say $text; # $p->moveTo($width / 2 - length($text) * 3, $height - 100); # $p->string($text); open my $fh, '>', sprintf("%05d.png", 180 - $angle); print {$fh} $p->png; close $fh; #system "geeqie", $img_file; #$? && exit $? << 8; } ================================================ FILE: GD/goldbach_conjecture_possibilities.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 29 July 2015 # Website: https://github.com/trizen # Plot the number of possibilities of each number for the Goldbach conjecture. # Example: # 16 = {3+13; 5+11} => 2 possibilities for the number 16 use 5.010; use strict; use warnings; use Imager qw(); use ntheory qw(primes is_prime); my $limit = 1e4; my $xsize = $limit; my $ysize = int($limit / (1 / 5 * log($limit)**2)); # approximation my ($x, $y) = (0, $ysize); my $img = Imager->new(xsize => $xsize, ysize => $ysize); my $white = Imager::Color->new('#ffffff'); my $gray = Imager::Color->new('#5f5d5d'); $img->box(filled => 1, color => $white); my @primes; my $last_n = 2; foreach my $i (3 .. $limit) { my $n = 2 * $i; push @primes, @{primes($last_n, $n - 2)}; $last_n = $n - 2; my %seen; my $count = 0; foreach my $prime (@primes) { exists($seen{$prime}) && last; if (is_prime($n - $prime)) { ++$count; undef $seen{$n - $prime}; } } foreach my $i (1 .. $count) { $img->setpixel(x => $x, y => $y - $i, color => $gray); } $x += 1; } $img->write(file => "goldbach_possibilities.png"); ================================================ FILE: GD/horsie_art.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 08 June 2015 # https://github.com/trizen # ## Generate a "horsie" image based on simple mathematics. # use 5.010; use strict; use warnings; use GD::Simple; my $max = 3_500_000; my $limit = int(sqrt($max)); # create a new image my $img = GD::Simple->new($limit * 6, $limit * 6); # move to right $img->moveTo($limit * 4, $limit * 4); my $j = 1; foreach my $i (1 .. $limit) { my $t = $i; for my $n ($j .. $i**2) { $img->line(1); $img->turn($t); $t += $i; ++$j; } ++$i; } open my $fh, '>:raw', "horsie_art.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/julia_set.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 07 March 2016 # Edit: 25 January 2018 # Website: https://github.com/trizen # See also: # https://en.wikipedia.org/wiki/Julia_set # https://trizenx.blogspot.com/2016/05/julia-set.html use 5.010; use strict; use warnings; use Imager; use Math::GComplex qw(cplx); my($w, $h, $zoom) = (1000, 1000, 0.7); my $img = Imager->new(xsize => $w, ysize => $h, channels => 3); my $color = Imager::Color->new('#000000'); my $I = 255; my $L = 2; my $c = cplx(-0.7, 0.27015); my ($moveX, $moveY) = (0, 0); foreach my $x (0 .. $w - 1) { foreach my $y (0 .. $h - 1) { my $z = cplx( (2 * $x - $w) / ($w * $zoom) + $moveX, (2 * $y - $h) / ($h * $zoom) + $moveY, ); my $i = $I; while (abs($z) < $L and --$i) { $z = $z*$z + $c; } $color->set(hsv => [$i / $I * 360 - 120, 1, $i / $I]); $img->setpixel(x => $x, y => $y, color => $color); } } $img->write(file => 'julia_set.png'); ================================================ FILE: GD/julia_set_complex.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 27 March 2016 # Website: https://github.com/trizen # Generate 100 random Julia sets. # Formula: f(z) = z^2 + c # See also: https://en.wikipedia.org/wiki/Julia_set # https://rosettacode.org/wiki/Julia_set use strict; use warnings; use Imager; use Inline 'C'; for (1 .. 100) { my ($w, $h) = (800, 600); my $zoom = 1; my $moveX = 0; my $moveY = 0; my $img = Imager->new(xsize => $w, ysize => $h, channels => 3); ##my $maxIter = int(rand(200))+50; my $maxIter = 50; ##my ($cx, $cy) = (-rand(1), rand(1)); ##my ($cx, $cy) = (1-rand(2), 1-rand(2)); # cool my ($cx, $cy) = (1 - rand(2), rand(1)); # nice ##my ($cx, $cy) = (1 - rand(2), 2 - rand(3)); ##my ($cx, $cy) = ((-1)**((1,2)[rand(2)]) * rand(2), (-1)**((1,2)[rand(2)]) * rand(2)); my $color = Imager::Color->new('#000000'); foreach my $x (0 .. $w - 1) { foreach my $y (0 .. $h - 1) { my $i = iterate( 3/2 * (2*($x+1) - $w) / ($w * $zoom) + $moveX, 1/1 * (2*($y+1) - $h) / ($h * $zoom) + $moveY, $cx, $cy, $maxIter ); $color->set(hsv => [$i / $maxIter * 360 - 120, 1, $i]); $img->setpixel(x => $x, y => $y, color => $color); } } print "Writing new image...\n"; $img->write(file => "i=$maxIter;c=$cx+$cy.png"); } __END__ __C__ #include int iterate(double zx, double zy, double cx, double cy, int i) { double complex z = zx + zy * I; double complex c = cx + cy * I; while (cabs(z) < 2 && --i) { z = z*z + c; //z = z * cexp(z) + c; //z = ccosh(z) + c; //z = z * csinh(z) + c; //z = z * ccosh(z) + c; //z = clog(csinh(z)) + c; //z = csqrt(cexp(z) + ccosh(z)) + c; } return i; } ================================================ FILE: GD/julia_set_random.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 March 2016 # Website: https://github.com/trizen # Generate 100 random Julia sets. # Formula: f(z) = z^2 + c # See also: https://en.wikipedia.org/wiki/Julia_set # https://rosettacode.org/wiki/Julia_set use strict; use warnings; use Imager; use Inline 'C'; for (1 .. 100) { my ($w, $h) = (800, 600); my $zoom = 1; my $moveX = 0; my $moveY = 0; my $img = Imager->new(xsize => $w, ysize => $h, channels => 3); #my $maxIter = int(rand(200))+50; my $maxIter = 50; #my ($cX, $cY) = (-rand(1), rand(1)); #my ($cX, $cY) = (1-rand(2), 1-rand(2)); # cool my ($cX, $cY) = (1 - rand(2), rand(1)); # nice my $color = Imager::Color->new('#000000'); foreach my $x (0 .. $w - 1) { foreach my $y (0 .. $h - 1) { my $zx = 3/2 * (2*($x+1) - $w) / ($w * $zoom) + $moveX; my $zy = 1/1 * (2*($y+1) - $h) / ($h * $zoom) + $moveY; my $i = iterate($zx, $zy, $cX, $cY, $maxIter); $color->set(hsv => [$i / $maxIter * 360, 1, $i]); $img->setpixel(x => $x, y => $y, color => $color); } } $img->write(file => "i=$maxIter;x=$cX;y=$cY.png"); } __END__ __C__ int iterate(double zx, double zy, double cX, double cY, int i) { double tmp1; double tmp2; while(1) { tmp1 = zx*zx; tmp2 = zy*zy; if (!((tmp1 + tmp2 < 4) && (--i > 0))) { break; } zy = 2 * zx*zy + cY; zx = tmp1 - tmp2 + cX; } return i; } ================================================ FILE: GD/julia_set_rperl.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 27 March 2016 # Website: https://github.com/trizen # Generate a Julia set, using Will Braswell's "MathPerl::Fractal::Julia" RPerl module. use 5.010; use strict; use warnings; use Imager; use MathPerl::Fractal::Julia; my ($w, $h) = (800, 600); my $maxIter = 250; my $cx = -0.7; my $cy = 0.27015; my $matrix = MathPerl::Fractal::Julia::julia_escape_time( $cx, $cy, $w, $h, $maxIter, -2.5, 1.0, -1.0, 1.0, 0, ); my $img = Imager->new(xsize => $w, ysize => $h, channels => 3); my $color = Imager::Color->new('#000000'); my $y = 0; foreach my $row (@{$matrix}) { my $x = 0; foreach my $pixel (@{$row}) { my $i = $maxIter - $pixel / 255 * $maxIter; $color->set(hsv => [$i / $maxIter * 360, 1, $i]); $img->setpixel(x => $x, y => $y, color => $color); ++$x; } ++$y; } $img->write(file => "julia_set.png"); ================================================ FILE: GD/koch_snowflakes.pl ================================================ #!/usr/bin/perl # Draw Koch snowflakes as concentric rings, using Math::PlanePath. # See also: # https://en.wikipedia.org/wiki/Koch_snowflake # https://metacpan.org/pod/Math::PlanePath::KochSnowflakes use 5.010; use strict; use warnings; use Math::PlanePath::KochSnowflakes; my $path = Math::PlanePath::KochSnowflakes->new; use Imager; my $img = Imager->new(xsize => 1000, ysize => 1000); my $red = Imager::Color->new('#ff0000'); foreach my $n (1 .. 100000) { my ($x, $y) = $path->n_to_xy($n); $img->setpixel(x => 500 + $x, y => 500 + $y, color => $red); } $img->write(file => 'Koch_snowflakes.png'); ================================================ FILE: GD/langton_s_ant_gd.pl ================================================ #!/usr/bin/perl # Author: Trizen # License: GPLv3 # Date: 15 December 2013 # Website: https://trizenx.blgospot.com # Variation of: https://rosettacode.org/wiki/Langton%27s_ant#Perl # More info about Langton's ant: https://en.wikipedia.org/wiki/Langton%27s_ant use 5.010; use strict; use warnings; use GD::Simple; my $width = 1920; my $height = 1080; my $line = 10; # line length my $size = 100; # pattern size my $turn_left_color = 'red'; my $turn_right_color = 'black'; my $img_file = 'langton_s_ant.png'; my $p = GD::Simple->new($width, $height); $p->moveTo($width / 2, $height / 2); # Using screen coordinates - 0,0 in upper-left, +X right, +Y down - # these directions (right, up, left, down) are counterclockwise # so advance through the array to turn left, retreat to turn right my @dirs = ([1, 0], [0, -1], [-1, 0], [0, 1]); # we treat any false as white and true as black, so undef is fine for initial all-white grid my @plane; for (0 .. $size - 1) { $plane[$_] = [] } # start out in approximate middle my ($x, $y) = ($size / 2, $size / 2); # pointing in a random direction my $dir = int rand @dirs; # turn in a random direction $p->turn(90 * $dir); my $move; for ($move = 0 ; $x >= 0 && $x < $size && $y >= 0 && $y < $size ; $move++) { # toggle cell's value (white->black or black->white) if ($plane[$x][$y] = 1 - ($plane[$x][$y] ||= 0)) { # if it's now true (black), then it was white, so turn right $p->fgcolor($turn_right_color); $p->line($line); # for more interesting patterns, try multiplying 90 with $dir $p->turn(90); $dir = ($dir - 1) % @dirs; } else { # otherwise it was black, so turn left $p->fgcolor($turn_left_color); $p->line($line); $p->turn(-90); $dir = ($dir + 1) % @dirs; } $x += $dirs[$dir][0]; $y += $dirs[$dir][1]; } open my $fh, '>', $img_file or die "$img_file: $!"; print {$fh} $p->png; close $fh; ================================================ FILE: GD/line_pattern_triangles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 May 2015 # https://github.com/trizen # ## Generate line-pattern triangles # use 5.010; use strict; use warnings; use GD::Simple; use File::Spec::Functions qw(catfile); my $num_triangles = shift(@ARGV) // 15; # duration: about 1 minute sub generate { my ($n, $k, $data) = @_; my $acc = 1; for (my $i = 1 ; $i <= $n ;) { if ($acc % $k == 0) { foreach my $j (1 .. $acc) { $data->{$i + $j} = 1; } } $i += $acc; $acc++; } return $n; } my $dir = "Line-pattern Triangles"; if (not -d $dir) { mkdir($dir) or die "Can't create dir `$dir': $!"; } foreach my $k (1 .. $num_triangles) { my %data; my $max = generate(921600, $k, \%data); my $limit = int(sqrt($max)) - 1; say "[$k of $num_triangles] Generating..."; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); $img->bgcolor('black'); $img->rectangle(0, 0, $limit * 2, $limit + 1); my $i = 1; my $j = 1; my $black = 0; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { if (exists $data{$j}) { $black = 0; $img->fgcolor('yellow'); } elsif (not $black) { $black = 1; $img->fgcolor('black'); } $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', catfile($dir, sprintf("%04d.png", $k)); print $fh $img->png; close $fh; } ================================================ FILE: GD/magic_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 May 2015 # https://github.com/trizen # ## Generate a magic triangle using a simple series of numbers # use 5.010; use strict; use warnings; use GD::Simple; use List::Util qw(max); my %data; sub generate { my ($n) = @_; my $sum = 0; # will be incremented by 1, 2, 3, ... foreach my $i (1 .. $n) { $sum += $i; $data{$sum} = 1; } return 1; } generate(400); my $i = 1; my $j = 1; my $max = max(keys %data); my $limit = int(sqrt($max)) - 1; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $black = 0; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { if (exists $data{$j}) { $black = 0; $img->fgcolor('red'); } elsif (not $black) { $black = 1; $img->fgcolor('black'); } $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', 'magic_triangle.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/mandelbrot_like_set.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 04 October 2017 # https://github.com/trizen # Generates a Mandelbrot-like set, using the formula: z = z^(1/c). # See also: # https://en.wikipedia.org/wiki/Mandelbrot_set # https://trizenx.blogspot.com/2017/01/mandelbrot-set.html use 5.010; use strict; use warnings; use Imager; use Inline 'C'; sub mandelbrot_like_set { my ($w, $h) = (800, 800); my $zoom = 1; # the zoom factor my $moveX = 0; # the amount of shift on the x axis my $moveY = 0; # the amount of shift on the y axis my $L = 100; # the maximum value of |z| my $I = 30; # the maximum number of iterations my $img = Imager->new(xsize => $w, ysize => $h); my $color = Imager::Color->new('#000000'); foreach my $x (1 .. $w) { foreach my $y (1 .. $h) { my $i = iterate( (2 * $x - $w) / ($w * $zoom) + $moveX, (2 * $y - $h) / ($h * $zoom) + $moveY, $L, $I, ); $color->set(hsv => [$i / $I * 360 - 120, 1, $i / $I]); $img->setpixel(x => $x - 1, y => $y - 1, color => $color); } } return $img; } mandelbrot_like_set()->write( file => 'mandelbrot_like_set.png' ); __END__ __C__ #include int iterate(double zx, double zy, int L, int i) { double complex z = zx + zy * I; double complex c = 1/z; while (cabs(z) < L && --i) { z = cpow(z, c); } return i; } ================================================ FILE: GD/mandelbrot_like_set_gcomplex.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 January 2018 # https://github.com/trizen # Generates a Mandelbrot-like set, using the formula: z = z^(1/c). # See also: # https://en.wikipedia.org/wiki/Mandelbrot_set # https://trizenx.blogspot.com/2017/01/mandelbrot-set.html use 5.010; use strict; use warnings; use Imager; use Math::GComplex qw(cplx); sub mandelbrot_like_set { my ($w, $h) = (1000, 1000); my $zoom = 1; # the zoom factor my $moveX = 0; # the amount of shift on the x axis my $moveY = 0; # the amount of shift on the y axis my $L = 100; # the maximum value of |z| my $I = 30; # the maximum number of iterations my $img = Imager->new(xsize => $w, ysize => $h); my $color = Imager::Color->new('#000000'); foreach my $x (1 .. $w) { foreach my $y (1 .. $h) { my $z = cplx( (2 * $x - $w) / ($w * $zoom) + $moveX, (2 * $y - $h) / ($h * $zoom) + $moveY, ); my $i = $I; my $c = 1/sqrt($z); while (abs($z) < $L && --$i) { $z **= $c; } $color->set(hsv => [$i / $I * 360 + 120, 1, $i / $I]); $img->setpixel(x => $x - 1, y => $y - 1, color => $color); } } return $img; } mandelbrot_like_set()->write( file => 'mandelbrot_like_set.png' ); ================================================ FILE: GD/mathematical_butt.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 29 April 2014 # https://github.com/trizen # A funny fanny shape. :-) use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(1000, 1000); $img->moveTo(500, 500); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } for my $i (1 .. 180) { c 'red'; for (1 .. 360) { l 4; # size t 1; } t 0; } my $image_name = 'mathematical_butt.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/mathematical_shapes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 April 2014 # Website: https://github.com/trizen # Generate mathematical shapes # -- feel free to play with the numbers -- use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(3000, 3000); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } my $dirname = "Mathematical shapes"; -d $dirname or do { mkdir($dirname) or die "Can't mkdir '$dirname': $!"; }; chdir($dirname) or die "Can't chdir into '$dirname': $!"; foreach my $t (1 .. 179) { # turn from 1 to 179 for my $k (5 .. 9) { # draw this many pictures for each turn # Info to STDOUT say "$t:$k"; $img->clear; $img->moveTo(1500, 1500); # hopefully, at the center of the image for my $i (1 .. $t) { # another interesting set is from 1..$k for my $j (1 .. $k) { $img->fgcolor('green'); l 40 * $j; # the length of a given line (in pixels) $img->fgcolor('blue'); l -40 * $j; # if you happen to love textiles, comment this line :) t $t; } $img->fgcolor('red'); l 40; ##last; # to generate only the basic shapes, uncomment this line. } my $image_name = sprintf('%03d-%02d.png', $t, $k); open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ## View the image as soon as it is generated #system "gliv", $image_name; # edit this line #$? == 0 or die "Non-zero exit code of the image viewer: $?"; } } ================================================ FILE: GD/mirror_shells.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 April 2014 # Website: https://github.com/trizen use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(1000, 600); $img->moveTo(220, 240); # hopefully, at the center of the image sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } my $loop = 50; t 260; # From inside-out for my $j (1 .. $loop) { l $j; t $loop- $j + 1; } t 180; # From outside-in for my $j (1 .. $loop) { l $loop- $j + 1; t $j; } my $image_name = "mirror_shells.png"; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/moebius_walking_line.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 13 November 2016 # Website: https://github.com/trizen # Draw a line using the values of the Möbius function: μ(n) # The rules are the following: # when μ(n) = -1, the angle is changed to -45 degrees # when μ(n) = +1, the angle is changed to +45 degrees # when μ(n) = 0, the angle is changed to 0 degrees # In all three cases, a pixel is recorded for each value of μ(n). use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(moebius); my $width = 1000; my $height = 100; my $img = GD::Simple->new($width, $height); $img->moveTo(0, $height / 2); foreach my $u (moebius(1, $width)) { if ($u == 1) { $img->angle(45); } elsif ($u == -1) { $img->angle(-45); } else { $img->angle(0); } $img->line(1); } open my $fh, '>:raw', 'moebius_walking_like.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/number_triangles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 May 2015 # https://github.com/trizen # ## Generate magic triangles with n gaps between numbers # use 5.010; use strict; use warnings; use GD::Simple; use File::Spec::Functions qw(catfile); my $num_triangles = shift(@ARGV) // 30; # duration: about 2 minutes sub generate { my ($n, $j, $data) = @_; foreach my $i (1 .. $n) { if ($i % $j == 0) { $data->{$i} = 1; } } return $n; } my $dir = "Blue Number Triangles"; if (not -d $dir) { mkdir($dir) or die "Can't create dir `$dir': $!"; } foreach my $k (1 .. $num_triangles) { my %data; my $max = generate(500000, $k, \%data); my $limit = int(sqrt($max)) - 1; say "[$k of $num_triangles] Generating..."; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $i = 1; my $j = 1; my $black = 0; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { if (exists $data{$j}) { $black = 0; $img->fgcolor('blue'); } elsif (not $black) { $black = 1; $img->fgcolor('black'); } $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', catfile($dir, sprintf("%04d.png", $k)); print $fh $img->png; close $fh; } ================================================ FILE: GD/numeric_circles.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 27 November 2016 # https://github.com/trizen # Generates circle-like shapes for arbitrary numerical values (based on Euler's formula). use 5.010; use strict; use warnings; use GD::Simple; my ($width, $height) = (1000, 1000); my $img = 'GD::Simple'->new($width, $height); my $center = ($width + $height) >> 2; $img->moveTo($width >> 1, $height >> 1); my $number = 9; # draw a representation for this number my $granularity = 3000; # the amount of granularity / detail my $step1 = $number / $granularity; my $step2 = $step1 / $number; my $tau = 2 * atan2(0, -'inf'); my $scale = 300; my $color = $img->colorAllocate(255, 0, 0); for (my ($i, $j) = (0, 0) ; $j <= $tau ; $i += $step1, $j += $step2) { my ($x1, $y1, $x2, $y2) = ( map { $_ * $scale + $center } (cos($i), sin($i), cos($j), sin($j)) ); $img->setPixel(($x1 + $x2) >> 1, ($y1 + $y2) >> 1, $color); } my $image_name = "circle_$number.png"; open my $fh, '>:raw', $image_name or die "error: $!"; print {$fh} $img->png; close $fh; ================================================ FILE: GD/pascal-fibonacci_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 25 March 2019 # https://github.com/trizen # Generate a visual representation of the Pascal-Fibonacci triangle. # Definition by Elliott Line, Mar 22 2019: # Consider a version of Pascal's Triangle: a triangular array with a single 1 on row 0, # with numbers below equal to the sum of the two numbers above it if and only if that sum # appears in the Fibonacci sequence. If the sum is not a Fibonacci number, `1` is put in its place. # OEIS sequence: # https://oeis.org/A307069 use 5.010; use strict; use warnings; use Imager qw(); use ntheory qw(is_square); use experimental qw(signatures); sub is_fibonacci($n) { my $m = 5 * $n * $n; is_square($m - 4) or is_square($m + 4); } my $size = 1000; # the size of the triangle my $img = Imager->new(xsize => $size, ysize => $size); my $black = Imager::Color->new('#000000'); my $red = Imager::Color->new('#ff00000'); $img->box(filled => 1, color => $black); sub pascal_fibonacci { my ($rows) = @_; my @row = (1); foreach my $n (1 .. $rows - 1) { my $i = 0; my $offset = ($rows - $n) / 2; foreach my $elem (@row) { $img->setpixel( x => $offset + $i++, y => $n, color => { hsv => [$elem == 1 ? 0 : (360 / sqrt($elem)), 1 - 1 / $elem, 1 - 1 / $elem] } ); } if ($n <= 10) { say "@row"; } #<<< @row = (1, (map { my $t = $row[$_] + $row[$_ + 1]; is_fibonacci($t) ? $t : 1; } 0 .. $n - 2), 1); #>>> } } pascal_fibonacci($size); $img->write(file => "pascal_fibonacci_triangle.png"); ================================================ FILE: GD/pascal_powers_of_two_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 06 May 2019 # https://github.com/trizen # Generate a visual representation of the Pascal powers of two triangle. # OEIS sequence: # https://oeis.org/A307433 use 5.010; use strict; use warnings; use Imager qw(); use Math::GMPz; use experimental qw(signatures); sub is_power_of_two ($n) { (($n) & ($n - 1)) == 0; } my $two_power = 10; my $size = 1 << $two_power; my $img = Imager->new(xsize => $size, ysize => $size); my $black = Imager::Color->new('#000000'); my $red = Imager::Color->new('#ff00000'); $img->box(filled => 1, color => $black); my $ONE = Math::GMPz->new(1); sub map_value { my ($value, $in_min, $in_max, $out_min, $out_max) = @_; ((($value - $in_min) * ($out_max - $out_min)) / ($in_max - $in_min)) + $out_min; } sub pascal_powers_of_two { my ($rows) = @_; my @row = ($ONE); foreach my $n (1 .. $rows) { my $i = 0; my $offset = ($rows - $n) / 2; foreach my $elem (@row) { my $t = Math::GMPz::Rmpz_sizeinbase($elem, 2); my $hue = ($elem == 1) ? 0 : map_value($t, 0, 1 << ($two_power - 1), 1, 360); $img->setpixel( x => $offset + $i++, y => $n, color => { hsv => [$hue, 1, ($elem == 1) ? 0 : 1] } ); } if ($n <= 11) { say "@row"; } #<<< @row = ($ONE, (map { my $t = $row[$_] + $row[$_ + 1]; is_power_of_two($t) ? $t : $ONE; } 0 .. $n - 2), $ONE); #>>> } } pascal_powers_of_two($size); $img->write(file => "pascal_powers_of_two_triangle.png"); ================================================ FILE: GD/pascal_s_triangle_multiples.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 29 November 2015 # Website: https://github.com/trizen # Highlight multiples inside the Pascal's triangle. use 5.010; use strict; use warnings; use Imager qw(); use ntheory qw(binomial); my $div = 3; # highlight multiples of this integer my $size = 243; # the size of the triangle my $img = Imager->new(xsize => $size * 2, ysize => $size); my $black = Imager::Color->new('#000000'); my $red = Imager::Color->new('#ff00000'); $img->box(filled => 1, color => $black); sub pascal { my ($rows) = @_; for my $n (1 .. $rows - 1) { my $i = 0; for my $elem (map { binomial(2 * $n, $_) } 0 .. 2 * $n) { if ($elem % $div == 0) { $img->setpixel(x => $rows - $n + $i++, y => $n, color => $black); } else { $img->setpixel(x => $rows - $n + $i++, y => $n, color => $red); } } } } pascal($size); $img->write(file => "pascal_s_triangle.png"); ================================================ FILE: GD/pascal_special_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 06 May 2019 # https://github.com/trizen # Generate a visual representation of a special Pascal triangle, where all entries satisfy a certain condition. # 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. # OEIS sequences: # https://oeis.org/A307116 # https://oeis.org/A307433 use 5.010; use strict; use warnings; use Imager qw(); use ntheory qw(:all); use Math::AnyNum; use experimental qw(signatures); my $VALUE = Math::AnyNum->new(2); # constant value my $size = 1000; my $img = Imager->new(xsize => $size, ysize => $size); my $black = Imager::Color->new('#000000'); my $red = Imager::Color->new('#ff00000'); $img->box(filled => 1, color => $black); sub isok ($n) { # condition kronecker($n - 1, $n) == 1; } sub map_value ($value, $in_min, $in_max, $out_min, $out_max) { ((($value - $in_min) * ($out_max - $out_min)) / ($in_max - $in_min)) + $out_min; } sub special_pascal_triangle ($rows) { my @rows; my @row = ($VALUE); foreach my $n (1 .. $rows) { push @rows, [@row]; if ($n <= 10) { say join(' ', map { $_->round } @row); } #<<< @row = ($VALUE, (map { my $t = $row[$_] + $row[$_ + 1]; isok($t) ? $t : $VALUE; } 0 .. $n - 2), $VALUE); #>>> } foreach my $row (@rows) { @$row = map { log($_) } @$row; } my $min_value = vecmin(map { @$_ } @rows); my $max_value = vecmax(map { @$_ } @rows); say "Min: $min_value"; say "Max: $max_value"; foreach my $n (1 .. @rows) { my $i = 0; my $offset = ($rows - $n) / 2; my $row = $rows[$n - 1]; foreach my $elem (@$row) { my $hue = map_value($elem, $min_value, $max_value, 1, 360); $img->setpixel( x => $offset + $i++, y => $n, color => { hsv => [$hue, 1, ($elem == $min_value) ? 0 : 1] } ); } } } special_pascal_triangle($size); $img->write(file => "special_pascal_triangle.png"); ================================================ FILE: GD/pattern_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 May 2015 # https://github.com/trizen # ## Generate a pattern triangle based on square numbers (scaled down by a trivial constant) # use 5.010; use strict; use warnings; use GD::Simple; sub generate { my ($n, $data) = @_; foreach my $i (0 .. $n) { $data->{sprintf('%.0f', ($i**2) / 12000)} = 1; } return $n; } say "** Generating..."; my %data; my $max = generate(500000, \%data); my $limit = int(sqrt($max)) - 1; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $i = 1; my $j = 1; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { $img->fgcolor(exists($data{$j}) ? 'red' : 'black'); $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', "pattern_triangle.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/peacock_triangles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 August 2015 # https://github.com/trizen # ## Generate an interesting image containing some triangles with "peacock tails" # use 5.010; use strict; use warnings; use GD::Simple; my $max = 1200000; # duration: about 6 seconds my $limit = int(sqrt($max)) - 1; my $img = GD::Simple->new($limit * 12, $limit * 4); my $i = 1; my $j = 1; $img->turn(0.001); say "** Generating..."; for my $m (reverse(0 .. $limit)) { $img->moveTo($m * 12, 2 * ($i - 1)); for my $n ($j .. $i**2) { $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', "peacock_triangles.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/pi_abstract_art.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 02 February 2022 # https://github.com/trizen # Generate a random art, using the digits of Pi in a given base. # See also: # https://yewtu.be/watch?v=tkC1HHuuk7c use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(Pi todigits); my $width = 4000; my $height = 5000; # create a new image my $img = GD::Simple->new($width, $height); # move to the center $img->moveTo($width >> 1, $height >> 1); my $digits = 100000; # how many of digits of pi to use my $base = 4; # base my $line_size = 7; # size of the line my $pi = join '', Pi($digits); $pi =~ s/\.//; my @digits = todigits($pi, $base); my $theta = 360 / $base; for my $d (@digits) { $img->turn($theta * $d); $img->line($line_size); } open my $fh, '>:raw', "pi_abstract_art.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/pi_turtle.pl ================================================ #!/usr/bin/perl use 5.014; use strict; use warnings; use GD::Simple; my $pi = do { local $/; =~ tr/0-9//dcr; }; my $img = 'GD::Simple'->new(10000, 6000); $img->fgcolor('blue'); $img->moveTo(5000, 3000); sub pi { my $x = substr($pi, 0, 2, ''); $x =~ s/^0+//; pi() if !length($x) and length($pi); $x; } while (length($pi)) { $img->fgcolor('white'); my $p_i = pi() || 0; $img->line($p_i * ($p_i / sqrt($p_i + 1)) + $p_i); foreach $_ (0 .. $p_i + $p_i) { $img->fgcolor('green'); $img->turn($p_i); $img->line(-$p_i); $img->line(-$p_i); $img->line(-$p_i); $img->line(-$p_i); $img->fgcolor('gray'); $img->turn(-$p_i); $img->line($p_i); $img->line($p_i); $img->line($p_i); $img->line($p_i); $img->fgcolor('blue'); $img->turn(-$p_i); $img->line($p_i); $img->fgcolor('purple'); $img->turn($p_i); $img->line(-$p_i); $img->fgcolor('red'); $img->turn($p_i); $img->line(-$p_i); } } my $image_name = 'pi_art_turtle.png'; open my $p, '>:raw', $image_name or die $!; print $p $img->png; close $p; __DATA__ 3.14159265358979323846264338327950288419716939937510582097494459230 7816406286208998628034825342117067982148086513282306647093844609550 5822317253594081284811174502841027019385211055596446229489549303819 6442881097566593344612847564823378678316527120190914564856692346034 8610454326648213393607260249141273724587006606315588174881520920962 8292540917153643678925903600113305305488204665213841469519415116094 3305727036575959195309218611738193261179310511854807446237996274956 7351885752724891227938183011949129833673362440656643086021394946395 2247371907021798609437027705392171762931767523846748184676694051320 0056812714526356082778577134275778960917363717872146844090122495343 0146549585371050792279689258923542019956112129021960864034418159813 6297747713099605187072113499999983729780499510597317328160963185950 2445945534690830264252230825334468503526193118817101000313783875288 6587533208381420617177669147303598253490428755468731159562863882353 7875937519577818577805321712268066130019278766111959092164201989380 ================================================ FILE: GD/prime_consecutive_sums.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 August 2015 # Website: https://github.com/trizen # This script plots the sums of consecutive primes ## Example: # 2 + 2 = 4 # 3 + 2 = 5 # 3 + 3 = 6 # 5 + 2 = 7 # 5 + 3 = 8 # 5 + 5 = 10 # 7 + 2 = 9 # 7 + 3 = 10 # 7 + 5 = 12 # 7 + 7 = 14 # There are larger and larger overlaps, which suggests that # the ratio between p(n+1) and p(n) get smaller and smaller. use 5.010; use strict; use integer; use Imager qw(); use ntheory qw(primes); my $primes = primes(500); my $xsize = @{$primes}**2 + 1; my $ysize = $primes->[-1] * 2 + 1; my ($x, $y) = (0, $ysize); my $img = Imager->new(xsize => $xsize, ysize => $ysize); my $white = Imager::Color->new('#ffffff'); my $red = Imager::Color->new('#ff0000'); $img->box(filled => 1, color => $white); foreach my $p1 (@{$primes}) { foreach my $p2 (@{$primes}) { foreach my $i (1 .. ($p1 + $p2)) { $img->setpixel(x => $x, y => $y - $i, color => $red); } $x += 1; } say $p1; } $img->write(file => "prime_sums.png"); ================================================ FILE: GD/prime_gaps.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 29 July 2015 # Website: https://github.com/trizen # Plot the differences between any two consecutive primes. # Example: # 29 - 23 = 6 # 43 - 41 = 2 use 5.010; use strict; use warnings; use Imager qw(); use ntheory qw(next_prime nth_prime); my $limit = 1e4; my $max = -'inf'; my $last_prime = nth_prime($limit**3 * 3); # start with this prime my $xsize = $limit; my $ysize = int(log($last_prime) * 10); # approximation for the maximum difference my ($x, $y) = (0, $ysize); my $img = Imager->new(xsize => $xsize, ysize => $ysize); my $white = Imager::Color->new('#FFFFFF'); my $gray = Imager::Color->new('#5f5d5d'); $img->box(filled => 1, color => $white); foreach my $i (1 .. $limit) { my $prime = next_prime($last_prime); my $diff = $prime - $last_prime; $max = $diff if $diff > $max; foreach my $i (1 .. $diff) { $img->setpixel(x => $x, y => $y - $i, color => $gray); } $last_prime = $prime; $x += 1; } say "Maximum difference: $max"; say "Predicted difference: $ysize"; $img->write(file => "prime_gaps.png"); ================================================ FILE: GD/prime_rectangles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 23 May 2016 # Website: https://github.com/trizen # Draw overlapping prime rectangles. use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(forprimes prev_prime); my $P = prev_prime(1000) + 1; my $img = GD::Simple->new($P, $P); $img->bgcolor(undef); $img->fgcolor('red'); forprimes { my $p = $_; forprimes { $img->rectangle(1, 1, $_, $p); } 0, $P; } 0, $P; open my $fh, '>:raw', 'prime_rectangles.png'; print {$fh} $img->png; close $fh; ================================================ FILE: GD/prime_stripe_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 02 April 2016 # https://github.com/trizen # Generate a triangle with highlighted numbers that satisfy: (isqrt(n)-1)! = isqrt(n)-1 (mod isqrt(n)). # See also: https://oeis.org/A267016 use 5.010; use strict; use warnings; use Imager; use List::Util qw(max); use Math::AnyNum qw(isqrt factorial); my %data; sub generate { my ($n) = @_; foreach my $i (1 .. $n) { my $j = isqrt($i); if (factorial($j - 1) % $j == $j - 1) { undef $data{$i + 1}; } } return 1; } generate(400000); my $i = 1; my $j = 1; my $max = max(keys %data); my $limit = int(sqrt($max)) - 1; # Create a new image my $img = Imager->new(xsize => $limit * 2, ysize => $limit + 1); my $red = Imager::Color->new(255, 0, 0); for my $m (0 .. $limit) { my $x = $limit - $m; my $has = 0; for my $n ($j .. $m**2) { if (exists $data{$j}) { $img->setpixel(x => $x, y => $m, color => $red); $has ||= 1; } ++$x; ++$j; } say $m- 1 if $has; } $img->write(file => 'prime_stripe_triangle.png'); ================================================ FILE: GD/prime_triangle_90deg.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 14 September 2016 # License: GPLv3 # https://github.com/trizen use strict; use warnings; use Imager; use POSIX qw(ceil); use ntheory qw(is_prime); my $limit = 1000; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => 2 * $limit, ysize => $limit,); sub get_point { my ($n) = @_; my $row = ceil(sqrt($n)); my $cell = 2 * $row - 1 - $row**2 + $n; ($cell, $row); } foreach my $n (1 .. $limit**2) { if (is_prime($n)) { my ($x, $y) = get_point($n); $img->setpixel(x => $x, y => $y, color => $red); } } $img->write(file => 'prime_triangle_90deg.png'); ================================================ FILE: GD/pythagoras_tree.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 08 June 2016 # Website: https://github.com/trizen # See: https://rosettacode.org/wiki/Pythagoras_tree # https://en.wikipedia.org/wiki/Pythagoras_tree_(fractal) use Imager; sub tree { my ($img, $x1, $y1, $x2, $y2, $depth) = @_; return () if $depth <= 0; my $dx = ($x2 - $x1); my $dy = ($y1 - $y2); my $x3 = ($x2 - $dy); my $y3 = ($y2 - $dx); my $x4 = ($x1 - $dy); my $y4 = ($y1 - $dx); my $x5 = ($x4 + 0.5 * ($dx - $dy)); my $y5 = ($y4 - 0.5 * ($dx + $dy)); # Square $img->polygon( points => [ [$x1, $y1], [$x2, $y2], [$x3, $y3], [$x4, $y4], ], color => [0, 255 / $depth, 0], ); # Triangle $img->polygon( points => [ [$x3, $y3], [$x4, $y4], [$x5, $y5], ], color => [0, 255 / $depth, 0], ); tree($img, $x4, $y4, $x5, $y5, $depth - 1); tree($img, $x5, $y5, $x3, $y3, $depth - 1); } my ($width, $height) = (1920, 1080); my $img = Imager->new(xsize => $width, ysize => $height); $img->box(filled => 1, color => 'white'); tree($img, $width/2.3, $height, $width/1.8, $height, 10); $img->write(file => 'pythagoras_tree.png'); ================================================ FILE: GD/random_abstract_art.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 08 June 2015 # https://github.com/trizen # ## Generate complex random art based on simple mathematics. # use 5.010; use strict; use warnings; use GD::Simple; use List::Util qw(shuffle); my $max = 1_000_000; my $limit = int(sqrt($max)); say "Possible combinations: $limit!"; # create a new image my $img = GD::Simple->new($limit * 3, $limit * 3); # move to the center $img->moveTo($limit * 1.5, $limit * 1.5); my $i = 1; my $j = 1; for my $m (shuffle(1 .. $limit)) { for my $n ($j .. $i**2) { $img->line(1); $img->turn($n**2 / $m); ++$j; } ++$i; } open my $fh, '>:raw', "random_abstract_art.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/random_abstract_art_2.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 08 June 2015 # https://github.com/trizen # ## Generate complex random art based on simple mathematics. # use 5.010; use strict; use warnings; use GD::Simple; my $max = 1_000_000; my $limit = int(sqrt($max)); # create a new image my $img = GD::Simple->new($limit * 3, $limit * 3); # move to the center $img->moveTo($limit * 1.5, $limit * 1.5); my $i = 1; my $j = 1; for my $m (map { rand($limit) - rand($limit) } (1 .. $limit)) { for my $n ($j .. $i**2) { $img->line(1); $img->turn($n**2 / $m); ++$j; } ++$i; } open my $fh, '>:raw', "random_abstract_art_2.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/random_langton_s_ant.pl ================================================ #!/usr/bin/perl # Author: Trizen # License: GPLv3 # Date: 15 December 2013 # Website: https://trizenx.blgospot.com # Variation of: https://rosettacode.org/wiki/Langton%27s_ant#Perl # More info about Langton's ant: https://en.wikipedia.org/wiki/Langton%27s_ant use 5.010; use strict; use warnings; use GD::Simple; my $width = 12480; my $height = 7020; my $line = 10; # line length my $size = 1000; # pattern size my $turn_left_color = 'red'; my $turn_right_color = 'black'; my $img_file = 'random_langton_s_ant.png'; my $p = GD::Simple->new($width, $height); $p->moveTo($width / 2, $height / 2); # Using screen coordinates - 0,0 in upper-left, +X right, +Y down - # these directions (right, up, left, down) are counterclockwise # so advance through the array to turn left, retreat to turn right my @dirs = ([1, 0], [0, -1], [-1, 0], [0, 1]); # we treat any false as white and true as black, so undef is fine for initial all-white grid my @plane; for (0 .. $size - 1) { $plane[$_] = [(map {int(rand(2))} 1..rand(100)) x rand(100)] } # start out in approximate middle my ($x, $y) = ($size / 2, $size / 2); # pointing in a random direction my $dir = int rand @dirs; # turn in a random direction $p->turn(90 * $dir); my $move; for ($move = 0 ; $x >= 0 && $x < $size && $y >= 0 && $y < $size ; $move++) { # toggle cell's value (white->black or black->white) if ($plane[$x][$y] = 1 - ($plane[$x][$y] ||= 0)) { # if it's now true (black), then it was white, so turn right $p->fgcolor($turn_right_color); $p->line($line); # for more interesting patterns, try multiplying 90 with $dir $p->turn(90); $dir = ($dir - 1) % @dirs; } else { # otherwise it was black, so turn left $p->fgcolor($turn_left_color); $p->line($line); $p->turn(-90); $dir = ($dir + 1) % @dirs; } $x += $dirs[$dir][0]; $y += $dirs[$dir][1]; } open my $fh, '>', $img_file or die "$img_file: $!"; print {$fh} $p->png; close $fh; ================================================ FILE: GD/random_looking_pattern_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 May 2015 # https://github.com/trizen # ## Generate a random-looking pattern triangle (but it's not random!) # use 5.010; use strict; use warnings; use GD::Simple; sub generate { my ($n, $data) = @_; my $sum = 0; foreach my $i (1 .. $n) { if ($sum >= $i) { $data->{$sum} = 1; $sum -= int(sqrt($i) + 1); # this is the "random" line } else { $sum += $i; } } return $n; } say "** Generating..."; my %data; my $max = generate(100000, \%data); my $limit = int(sqrt($max)) - 1; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $i = 1; my $j = 1; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { $img->fgcolor(exists($data{$j}) ? 'red' : 'black'); $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', "random_looking_triangle.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/random_machinery_art.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 July 2015 # https://github.com/trizen # ## Generate a complex machine-like art based on simple mathematics. # use 5.010; use strict; use warnings; use GD::Simple; use List::Util qw(shuffle); my $max = 1_000_000; my $limit = int(sqrt($max)); say "Possible combinations: $limit!"; # create a new image my $img = GD::Simple->new($limit * 3, $limit * 3); # move to the center $img->moveTo($limit * 1.5, $limit * 1.5); my $i = 1; my $j = 1; for my $m (shuffle(1 .. $limit)) { for my $n ($j .. $i**2) { $img->line(1); $img->turn($n * $i + $m); ++$j; } ++$i; } open my $fh, '>:raw', "random_machinery.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/random_noise_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 May 2015 # https://github.com/trizen # ## Generate a random pattern triangle # use 5.010; use strict; use warnings; use GD::Simple; sub generate { my ($n, $data) = @_; foreach my $i (1 .. $n) { if (rand(1) < 0.5) { $data->{$i} = 1; } } return $n; } say "** Generating..."; my %data; my $max = generate(300000, \%data); my $limit = int(sqrt($max)) - 1; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $i = 1; my $j = 1; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { $img->fgcolor(exists($data{$j}) ? 'red' : 'black'); $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', "random_noise_triangle.png"; print $fh $img->png; close $fh; ================================================ FILE: GD/random_turtles.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; #use ntheory ('is_prime'); print "** Generating image...\n"; my $img = 'GD::Simple'->new(10000, 6000); $img->fgcolor('blue'); $img->moveTo(1000, 2000); for (my $nr = 200 ; $nr <= 300 ; $nr += int rand 7) { $img->fgcolor('white'); #$img->turn(-$nr); #$img->line(300) if $nr < 100; #$img->line($nr); $img->line($nr * 2); #$img->line( -$nr ); #$img->line($nr); #if ( is_prime($nr) ) { #$img->turn($nr); #$img->turn($nr); #$img->line( int rand -$nr ); #$img->turn( -$nr ); #$img->line( rand $nr ); #$img->line($nr); #print "$nr\n"; foreach $_ (0 .. (rand(100)) + 30) { $img->fgcolor('green'); $img->turn($nr); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->fgcolor('gray'); $img->turn(-$nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); #$img->line(-$nr); #$img->line($nr); #$img->line(-$nr); #$img->line($nr); #$img->line($nr); #$img->line($nr); $img->fgcolor('blue'); $img->turn(-$nr); $img->line($nr); #$img->line($nr); #$img->line($nr); #$img->line($nr); $img->fgcolor('purple'); $img->turn($nr); #$img->line( $nr ); #$img->line( $nr ); $img->line(-$nr); #$img->line(-$nr); #$img->line( $nr ); $img->fgcolor('red'); $img->turn($nr); #$img->line( -$nr ); #$img->line( $nr ); $img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); } #} #$img->fgcolor('white'); #$img->turn(-$nr); my $a = ($nr * (int rand 4)) + (int rand 2000) + 4000; my $b = ($nr * (int rand 4)) + (int rand 1000) + 1000; $img->moveTo($a, $b) if $nr =~ /5$/; #$img->turn(-$nr); #$img->turn(-$nr); #$img->line(-$nr*5+100); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line($nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line(-$nr); #$img->line($nr); #$img->line($nr); #$img->line($nr); #$img->line($nr); #$img->line($nr); #$img->line($nr); #$img->line($nr); } open(my $fh, '>:raw', 'random_turtles.png') or die $!; print {$fh} $img->png; close $fh; print "** Done\n"; ================================================ FILE: GD/real_shell.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 April 2014 # Website: https://github.com/trizen use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(500, 600); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } $img->clear; $img->moveTo(250, 300); # hopefully, at the center of the image my $loop = 5; for (my $j = 0.01 ; $j <= $loop ; $j += 0.01) { l $j; t $loop- $j + 1; } my $image_name = "shell.png"; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/recursive_squares.pl ================================================ #!/usr/bin/perl # A nice recursive pattern, using the following rule: # --- |---| # | goes to | which goes to | and so on. # --- |---| use 5.014; use Imager; my $xsize = 800; my $ysize = 800; my $img = Imager->new(xsize => $xsize, ysize => $ysize, channels => 3); my $color = Imager::Color->new('#ff0000'); sub a { my ($x, $y, $len, $rep) = @_; $img->line( x1 => $x, x2 => $x, y1 => $y, y2 => $y + $len, color => $color, ); f($x, $y, $len, $rep); } sub f { my ($x, $y, $len, $rep) = @_; $rep <= 0 and return; $img->line( x1 => $x - $len / 2, x2 => $x + $len / 2, y1 => $y, y2 => $y, color => $color, ); g($x - $len / 2, $y, $len, $rep - 1); $img->line( x1 => $x - $len / 2, x2 => $x + $len / 2, y1 => $y + $len, y2 => $y + $len, color => $color, ); g($x - $len / 2, $y + $len, $len, $rep - 1); } sub g { my ($x, $y, $len, $rep) = @_; $rep <= 0 and return; $img->line( x1 => $x, x2 => $x, y1 => $y - $len / 2, y2 => $y + $len / 2, color => $color, ); f($x, $y - $len / 2, $len, $rep - 1); $img->line( x1 => $x + $len, x2 => $x + $len, y1 => $y - $len / 2, y2 => $y + $len / 2, color => $color, ); f($x + $len, $y - $len / 2, $len, $rep - 1); } a($xsize / 2, $ysize / 2, sqrt($xsize + $ysize), 12); $img->write(file => "recursive_squares.png"); ================================================ FILE: GD/regular_poligons.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 16 July 2014 # Website: https://github.com/trizen use strict; use warnings; use GD::Simple; my $img; sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } my $dir = 'Regular poligons'; if (not -d $dir) { mkdir($dir) || die "Can't mkdir `$dir': $!"; } chdir($dir) || die "Can't chdir `$dir': $!"; foreach my $i (1 .. 144) { if (360 % (180 - $i) == 0) { my $sides = 360 / (180 - $i); printf("Angle: %d\tSides: %d\n", $i, $sides); $img = 'GD::Simple'->new(1000, 1000); $img->moveTo(500, 500); for (1 .. $sides) { l 150; t 180 - $i; } my $image_name = sprintf("%03d.png", $i); open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; } } ================================================ FILE: GD/reversed_prime_triangles.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 July 2015 # Website: https://github.com/trizen # Generate a reversed set of number triangles # with the prime numbers represented by blue pixels. use 5.010; use strict; use warnings; use Imager qw(); use ntheory qw(is_prime); sub triangle { my ($rows, $type) = @_; my @triangle = ([1]); my $n = 1; foreach my $i (1 .. $rows) { if ($type == 1) { foreach my $j (0 .. $#triangle) { push @{$triangle[$j]}, ++$n; unshift @{$triangle[$j]}, ++$n; } } elsif ($type == 2) { foreach my $j (reverse 0 .. $#triangle) { push @{$triangle[$j]}, ++$n; unshift @{$triangle[$j]}, ++$n; } } elsif ($type == 3) { foreach my $j (0 .. $#triangle) { unshift @{$triangle[$j]}, ++$n; } foreach my $j (reverse 0 .. $#triangle) { push @{$triangle[$j]}, ++$n; } } elsif ($type == 4) { foreach my $j (reverse 0 .. $#triangle) { unshift @{$triangle[$j]}, ++$n; } foreach my $j (0 .. $#triangle) { push @{$triangle[$j]}, ++$n; } } else { die "Invalid type: $type"; } unshift @triangle, [++$n]; } return \@triangle; } sub triangle2img { my ($triangle) = @_; my $rows = $#{$triangle} + 1; my $blue = Imager::Color->new('#0000FF'); my $white = Imager::Color->new('#FFFFFF'); my $img = Imager->new(xsize => $rows * 2, ysize => $rows); $img->box(filled => 1, color => $white); foreach my $i (0 .. $rows - 1) { my $row = $triangle->[$i]; foreach my $j (0 .. $#{$row}) { my $num = $row->[$j]; if (is_prime($num)) { $img->setpixel(x => $rows - $i + $j, y => $i, color => $blue); } else { $img->setpixel(x => $rows - $i + $j, y => $i, color => $white); } } } return $img; } my $max = 4; my $rows = 1000; foreach my $i (1 .. $max) { say "** Generating triangle $i of $max..."; my $triangle = triangle($rows, $i); my $img = triangle2img($triangle); $img->write(file => "reversed_triangle_$i.png"); } ================================================ FILE: GD/right_triangle_primes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 11 April 2015 # https://github.com/trizen # A number triangle, with the primes highlighted in blue # (there are some lines that have more primes than others) use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(is_prime); my $n = 1000000; # duration: about 5 seconds sub limit { my ($n) = @_; (sqrt(8 * $n + 1) - 1) / 2; } sub round { my ($n) = @_; ($n**2 + $n) / 2; } my $lim = int(limit($n)); my $num = round($lim); # create a new image my $img = GD::Simple->new($lim, $lim); my $counter = 1; my $white = 1; $img->fgcolor('white'); foreach my $i (0 .. $lim - 1) { $img->moveTo(0, $i); foreach my $j (0 .. $i) { ##print $counter, ' '; if (is_prime($counter)) { if ($white) { $img->fgcolor('blue'); $white = 0; } } elsif (not $white) { $img->fgcolor('white'); $white = 1; } $img->line(1); ++$counter; } ##print "\n"; } open my $fh, '>:raw', 'right_triangle_primes.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/sandpiles.pl ================================================ #!/usr/bin/perl # Simulate the toppling of sandpiles. # See also: # https://en.wikipedia.org/wiki/Abelian_sandpile_model # https://www.youtube.com/watch?v=1MtEUErz7Gg -- ‎Sandpiles - Numberphile # https://www.youtube.com/watch?v=diGjw5tghYU -- ‎Coding Challenge #107: Sandpiles (by Daniel Shiffman) use 5.020; use strict; use warnings; use Imager; use experimental qw(signatures); package Sandpile { sub new ($class, %opt) { my $state = { width => 100, height => 100, %opt, }; bless $state, $class; } sub create_plane ($self) { [map { [(0) x $self->{width}] } 1 .. $self->{height}]; } sub topple ($self, $plane) { my $nextplane = $self->create_plane; foreach my $y (0 .. $self->{height} - 1) { foreach my $x (0 .. $self->{width} - 1) { my $pile = $plane->[$y][$x]; if ($pile < 4) { $nextplane->[$y][$x] = $pile; } } } foreach my $y (1 .. $self->{height} - 2) { foreach my $x (1 .. $self->{width} - 2) { my $pile = $plane->[$y][$x]; if ($pile >= 4) { $nextplane->[$y][$x] += $pile - 4; $nextplane->[$y - 1][$x]++; $nextplane->[$y + 1][$x]++; $nextplane->[$y][$x - 1]++; $nextplane->[$y][$x + 1]++; } } } return $nextplane; } sub generate ($self, $pile_of_sand, $topple_times) { my $plane = $self->create_plane; $plane->[$self->{height} / 2][$self->{width} / 2] = $pile_of_sand; for (1 .. $topple_times) { $plane = $self->topple($plane); } my $img = Imager->new(xsize => $self->{width}, ysize => $self->{height}); my @colors = map { Imager::Color->new($_) } ('black', 'blue', 'green', 'white'); foreach my $y (0 .. $self->{height} - 1) { foreach my $x (0 .. $self->{width} - 1) { my $pile = $plane->[$y][$x]; if ($pile <= 3) { $img->setpixel(x => $x, y => $y, color => $colors[$pile]); } } } return $img; } } my $obj = Sandpile->new; my $img = $obj->generate(10**5, 10**4); $img->write(file => 'sandpiles.png'); ================================================ FILE: GD/sierpinski_fibonacci_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 12 October 2017 # https://github.com/trizen # Generation of the Sierpinski triangle form a lagged Fibonacci sequence mod 2. # See also: # https://projecteuler.net/problem=258 # https://en.wikipedia.org/wiki/Sierpinski_triangle use 5.020; use strict; use warnings; use Imager; use experimental qw(signatures); my $size = 1000; my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => $size, ysize => $size); sub fibmod_seq ($n, $lag, $mod) { my @g = (1) x $lag; foreach my $k ($lag .. $n) { my $x = $g[$k - $lag]; my $y = $g[$k - $lag - 1]; $g[$k] = ($x + $y) % $mod; } return @g; } my $n = $size**2; my $lag = $size; my $mod = 2; my @g = fibmod_seq($n, $lag, $mod); foreach my $i (0 .. $#g) { if ($g[$i]) { $img->setpixel( x => $i % $lag, y => int($i / $lag), color => $red, ); } } $img->write(file => 'sierpinski_fibonacci_triangle.png'); ================================================ FILE: GD/sierpinski_triangle.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 20 December 2014 # https://github.com/trizen # Generate a graphical Sierpinski triangle of a given size. use 5.010; use strict; use warnings; use GD::Simple; sub sierpinski { my ($n) = @_; my @down = '*'; my $space = ' '; foreach (1 .. $n) { @down = (map({ $space . $_ . $space } @down), map({ $_ . ' ' . $_ } @down)); $space = $space . $space; } return @down; } my @lines = sierpinski(8); my $size = $ARGV[0] // 2; my $img = GD::Simple->new(length($lines[0]) * $size, scalar(@lines) * $size); foreach my $i (0 .. $#lines) { foreach my $j ($i * $size .. $i * $size + $size) { $img->moveTo(0, $j); my $row = $lines[$i]; while (1) { if ($row =~ s/^(\s+)//) { $img->fgcolor('black'); $img->line($size * length($1)); } elsif ($row =~ s/^(\S+)//) { $img->fgcolor('red'); $img->line($size * length($1)); } else { last; } } } } open my $fh, '>:raw', 'triangle.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/spinning_shapes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 April 2014 # Website: https://github.com/trizen use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2000, 2000); $img->fgcolor('blue'); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } my $dir = 'Spinning Shapes'; if (not -d $dir) { mkdir($dir) || die "Can't mkdir `$dir': $!"; } chdir($dir) || die "Can't chdir `$dir': $!"; for (my $i = 1 ; $i <= 180 ; $i += 1) { say "$i degrees"; $img->clear; $img->moveTo(1000, 1000); # hopefully, at the center of the image for my $j (1 .. 360) { l($j * 2); t $i; } my $image_name = sprintf("%03d.png", $i); open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; } ================================================ FILE: GD/spiral_matrix_primes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 13 April 2015 # https://github.com/trizen # A number spiral matrix, with the primes highlighted in blue # (there are some lines that have more primes than others) # Inspired by: https://www.youtube.com/watch?v=iFuR97YcSLM use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(is_prime); my $n = 1847; # duration: about 22 seconds sub spiral { my ($n, $x, $y, $dx, $dy, @a) = (shift, 0, 0, 1, 0); foreach my $i (0 .. $n**2 - 1) { $a[$y][$x] = $i; my ($nx, $ny) = ($x + $dx, $y + $dy); ($dx, $dy) = $dx == 1 && ($nx == $n || defined $a[$ny][$nx]) ? (0, 1) : $dy == 1 && ($ny == $n || defined $a[$ny][$nx]) ? (-1, 0) : $dx == -1 && ($nx < 0 || defined $a[$ny][$nx]) ? (0, -1) : $dy == -1 && ($ny < 0 || defined $a[$ny][$nx]) ? (1, 0) : ($dx, $dy); ($x, $y) = ($x + $dx, $y + $dy); } return \@a; } say "** Generating the matrix..."; my $matrix = spiral($n); say "** Generating the image..."; my $img = GD::Simple->new($n, $n); my $white = 1; $img->fgcolor('white'); foreach my $y (0 .. $#{$matrix}) { $img->moveTo(0, $y); foreach my $num (@{$matrix->[$y]}) { if (is_prime($num)) { if ($white) { $img->fgcolor('blue'); $white = 0; } } elsif (not $white) { $img->fgcolor('white'); $white = 1; } $img->line(1); } } open my $fh, '>:raw', 'spiral_primes.png'; print $fh $img->png; close $fh; say "** Done!"; ================================================ FILE: GD/spiral_tree.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 13 August 2015 # https://github.com/trizen # Generate a spiral tree with branches # Inspired from: https://www.youtube.com/watch?v=RWAcbV4X7C8 use GD::Simple; my $img = GD::Simple->new(1000, 700); $img->moveTo(500, 650); $img->turn(-90); sub branch { my ($len) = @_; $img->line($len); $len *= 0.64; if ($len > 2) { my @pos1 = $img->curPos; my $angle1 = $img->angle; $img->turn(45); branch($len); $img->moveTo(@pos1); $img->angle($angle1); my @pos2 = $img->curPos; my $angle2 = $img->angle; $img->turn(-90); branch($len); $img->moveTo(@pos2); $img->angle($angle2); } } branch(250); open my $fh, '>:raw', 'spiral_tree.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/square_of_circles.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 19 December 2016 # https://github.com/trizen # Draws a square with diagonals made out of circles. use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(1000, 1000); $img->fgcolor('blue'); $img->bgcolor(undef); $img->moveTo(200, 150); my $n = 15; my $size = 45; my $dsize = $size / (1 + sqrt(2)); my $dmove = $size / 4; for (1 .. $n) { my ($x, $y) = $img->curPos; $img->moveTo($x, $y + $size); $img->ellipse($size, $size); } for (1 .. $n - 1) { my ($x, $y) = $img->curPos; $img->moveTo($x + $size, $y); $img->ellipse($size, $size); } for (1 .. $n - 1) { my ($x, $y) = $img->curPos; $img->moveTo($x, $y - $size); $img->ellipse($size, $size); } my ($x, $y) = $img->curPos; for (1 .. $n - 1) { my ($x, $y) = $img->curPos; $img->moveTo($x - $size, $y); $img->ellipse($size, $size); } for (1 .. 4 * ($n - 1) - 2) { my ($x, $y) = $img->curPos; $img->moveTo($x + $dmove, $y + $dmove); $img->ellipse($dsize, $dsize) if $_ > 1; } $img->moveTo($x, $y); for (1 .. 4 * ($n - 1) - 2) { my ($x, $y) = $img->curPos; $img->moveTo($x - $dmove, $y + $dmove); $img->ellipse($dsize, $dsize) if $_ > 1; } open my $fh, '>:raw', 'square_of_circles.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/star_turtle.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2500, 2500); $img->moveTo(1220, 1220); my $nr = 360.01; for (0 .. 150) { $img->turn(-$nr); $img->line($nr); $img->turn(180); $img->line(-$nr); $img->line($nr); $img->turn(45); $img->line(-$nr); $img->turn(180); $img->line($nr); $img->line(-$nr); $img->turn(45); $img->line($nr); $img->turn(180); $img->line(-$nr); $img->line($nr); $img->turn(45); $img->line(-$nr); $img->turn(180); $img->line($nr); $img->line(-$nr); $img->turn(45); $img->line($nr); $img->turn(180); $img->line(-$nr); $img->line($nr); $img->turn(45); $img->line(-$nr); $img->turn(180); $img->line($nr); $img->line(-$nr); $img->turn(45); $img->line($nr); $img->turn(180); $img->line(-$nr); $img->line($nr); $img->turn(45); $img->line(-$nr); $img->turn(180); $img->line($nr); $img->line(-$nr); } my $image_name = 'star_turtle.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/stern_brocot_shapes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 July 2015 # https://github.com/trizen # ## Generate an interesting cluster of shapes based on the Stern-Brocot sequence. # use 5.010; use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(5000, 5000); $img->moveTo(2100, 2500); sub t($) { $img->turn(shift); } sub l($) { $img->line(shift); } sub c($) { $img->fgcolor(shift); } sub stern_brocot(&$) { my ($callback, $n) = @_; my @fib = (1, 1); foreach my $i (1 .. $n) { push @fib, $fib[0] + $fib[1], $fib[1]; $callback->($fib[0]); shift @fib; } $callback->($_) for @fib; } c 'red'; for my $i (1 .. 180) { stern_brocot { l $i/ $_[0]; t $i; } $i; t 0; } my $image_name = 'stern_brocot_shapes.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/triangle_factors.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 07 August 2016 # https://github.com/trizen # A number triangle, where each number is highlighted with # a different color based on the number of its prime factors. use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(factor is_prime); use List::Util qw(shuffle); my @color_names = grep { !/white|gradient/ } shuffle(GD::Simple->color_names); my $i = 1; my $j = 1; my $n = shift(@ARGV) // 1000000; # duration: about 10 seconds my $limit = int(sqrt($n)) - 1; my %colors; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $white = 0; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { my $f = factor($j); if ($f > 0 and $f <= @color_names) { $img->fgcolor($color_names[$f - 1]); $colors{$f} = $color_names[$f - 1]; } else { $img->fgcolor('white'); } $img->line(1); ++$j; } ++$i; } foreach my $key (sort { $a <=> $b } keys %colors) { say "$key\t : $colors{$key}"; } open my $fh, '>:raw', 'triangle_factors.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/triangle_primes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10 April 2015 # https://github.com/trizen # A number triangle, with the primes highlighted in blue # (there are some lines that have more primes than others) # Inspired by: https://www.youtube.com/watch?v=iFuR97YcSLM use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(is_prime); my $i = 1; my $j = 1; my $n = shift(@ARGV) // 8000000; # duration: about 45 seconds my $limit = int(sqrt($n)) - 1; my %top; # count the number of primes on vertical lines my $top = 10; # how many lines to display at the end # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $white = 0; for my $m (reverse(0 .. $limit)) { ##print " " x $m; my $pos = $m; $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { ##print $j; if (is_prime($j)) { $white = 0; $img->fgcolor('blue'); $top{$pos}{count}++; $top{$pos}{first} //= $j; } elsif (not $white) { $white = 1; $img->fgcolor('white'); } $img->line(1); ++$pos; ++$j; } ++$i; ##print "\n"; } say "=> Top vertical lines: "; foreach my $i (sort { $top{$b}{count} <=> $top{$a}{count} } keys %top) { state $counter = 0; say "$i:\t$top{$i}{count} (first prime: $top{$i}{first})"; last if ++$counter == $top; } open my $fh, '>:raw', 'triangle_primes.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/triangle_primes_2.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 April 2015 # https://github.com/trizen # A number triangle, with the primes highlighted in blue # (there are some lines that have more primes than others) # Inspired by: https://www.youtube.com/watch?v=iFuR97YcSLM use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(is_prime); my $i = 1; my $max = 2000; # duration: about 11 seconds # create a new image my $img = GD::Simple->new($max, $max); my $white = 0; $img->fgcolor('blue'); foreach my $x (1 .. $max) { $img->moveTo(0, $x - 1); foreach my $y (1 .. $x) { if (is_prime($i)) { $white = 0; $img->fgcolor('blue'); } elsif (not $white) { $white = 1; $img->fgcolor('white'); } $img->line(1); ++$i; } } open my $fh, '>:raw', 'triangle_primes_2.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/triangle_primes_irregular.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10 April 2015 # https://github.com/trizen # A number triangle, with the primes highlighted in blue ## Vertical lines are represented by: # n^2 - 2n + 2 # n^2 - n + 1 # n^2 # n^2 + n - 1 # n^2 + 2n - 2 # ... ## Horizontal lines are represented by: # 1 # n + 1 # 2n + 3 # 3n + 7 # 4n + 13 # 5n + 21 # 6n + 31 # 7n + 43 # ... use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(is_prime); my $rows = shift(@ARGV) // 2000; # duration: about 12 seconds my $white = 1; # create a new image my $img = GD::Simple->new($rows, $rows); $img->fgcolor('white'); foreach my $i (0 .. $rows - 1) { $img->moveTo(0, $i); foreach my $j ($i .. $rows - 1) { my $num = $i * $j + 1; #printf "%3d%s", $num, ' '; if (is_prime($num)) { if ($white) { $img->fgcolor('blue'); $white = 0; } } elsif (not $white) { $img->fgcolor('white'); $white = 1; } $img->line(1); } #print "\n"; } open my $fh, '>:raw', 'triangle_primes_irregular.png'; print $fh $img->png; close $fh; __END__ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 5 7 9 11 13 15 17 19 21 23 25 27 29 31 33 35 37 39 10 13 16 19 22 25 28 31 34 37 40 43 46 49 52 55 58 17 21 25 29 33 37 41 45 49 53 57 61 65 69 73 77 26 31 36 41 46 51 56 61 66 71 76 81 86 91 96 37 43 49 55 61 67 73 79 85 91 97 103 109 115 50 57 64 71 78 85 92 99 106 113 120 127 134 65 73 81 89 97 105 113 121 129 137 145 153 82 91 100 109 118 127 136 145 154 163 172 101 111 121 131 141 151 161 171 181 191 122 133 144 155 166 177 188 199 210 145 157 169 181 193 205 217 229 170 183 196 209 222 235 248 197 211 225 239 253 267 226 241 256 271 286 257 273 289 305 290 307 324 325 343 362 ================================================ FILE: GD/trizen_fan_turtle.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2503, 2500); $img->moveTo(540, 1980); my $nr = 360; for (0 .. 20) { # T $img->fgcolor('purple'); $img->turn(-90); $img->line(--$nr / 10); $img->turn(90); $img->line($nr); $img->turn(90); $img->line($nr / 10); $img->turn(90); $img->move($nr / 2); $img->turn(90); $img->move($nr / 10); $img->turn(-180); $img->line($nr); $img->turn(-90); # R $img->fgcolor('green'); $img->move($nr / 1.5); $img->turn(-90); $img->line($nr); $img->turn(90); $img->line($nr / 2 - ($nr / 10)); $img->turn(45); $img->line($nr / 10); $img->turn(90 - 45); $img->line($nr / 2 - ($nr / 10)); $img->turn(45); $img->line($nr / 10); $img->turn(90 - 45); $img->line($nr / 2 - ($nr / 10)); $img->turn(-180 + 45); $img->line($nr / 2 + ($nr / 4) - ($nr / 10)); $img->turn(-180 + 45); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $nr -= ($_); # I $img->fgcolor('black'); # blue $img->turn(-90); $img->move($nr / 4); $img->turn(-90); $img->line($nr); $img->move($nr / 10); $img->turn(180); $img->move($nr / 10 + 12 + (12 / 2)); $img->turn(-90); $img->move($nr / 5); # star $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $img->turn(45); $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $img->turn(45); $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $img->turn(45); $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $nr += ($_); # Z $img->fgcolor('red'); $img->turn(-45); $img->move($nr + (12 * 6)); $img->turn(-90); $img->move($nr / 7); $img->turn(-65); $img->line($nr + ($nr / 10)); $img->turn(-180 + 65); $img->line($nr / 2); $img->turn(-90); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $img->turn(90 + 65); $img->move($nr + ($nr / 10)); $img->turn(-90 - 65); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $img->turn(90); $img->line($nr / 2 - ($nr / 7) / 2); $img->turn(180 - 65); $img->move(($nr + ($nr / 10)) / 2); $img->turn(-180 + 65); $img->line($nr / 4); $img->turn(-90); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $img->turn(90); $img->line($nr / 2); $img->turn(-90); $img->line($nr / 10); # E $img->fgcolor('orange'); $img->turn(180); $img->move($nr / 2 + ($nr / 10)); $img->turn(-90); $img->move($nr / 5); $img->turn(-90); $img->line($nr); $img->turn(90); $img->line($nr / 2); $img->turn(90); $img->move($nr / 2); $img->turn(90); $img->line($nr / 2); $img->turn(-90); $img->move($nr / 2); $img->line($nr / 2); # N $img->fgcolor('blue'); $img->turn(0); $img->move($nr / 4); $img->turn(-90); $img->line($nr); $img->turn(90 + 65); $img->line($nr + ($nr / 10)); $img->turn(-90 - 65); $img->line($nr); } $nr = 308.5 - (308.5 / 8); $img->moveTo(830, 1380); for (0 .. 623) { $img->fgcolor('green'); $img->turn($nr); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->fgcolor('black'); $img->turn(-$nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->turn(-$nr); $img->line($nr); $img->fgcolor('red'); $img->turn($nr); $img->line(-$nr); $img->fgcolor('red'); $img->line(-$nr); } my $image_name = 'trizen_fan_turtle.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/trizen_flat_logo.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2300, 2300); $img->moveTo(465, 1305); my $nr = 308.5; for (0 .. 222) { $img->fgcolor(qw(blue green) [$_ % 2]); $img->turn(45); $img->line(-$nr - $_); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->fgcolor(qw(green blue) [$_ % 2]); $img->turn(-45); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->fgcolor('black'); $img->turn(45); $img->line($nr + $_); $img->fgcolor('purple'); $img->turn(-45); $img->line(-$nr); $img->line(-$nr); } my $image_name = 'trizen_flat_logo.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/trizen_new_logo.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2000, 2000); $img->moveTo(510, 1100); my $nr = 308.5; for (0 .. 280) { $img->fgcolor('green'); $img->turn($nr); for (1 .. 4) { $img->line(-$nr); } $img->fgcolor('gray'); $img->turn(-$nr); for (1 .. 4) { $img->line($nr); } $img->fgcolor('blue'); $img->line($nr); $img->fgcolor('purple'); $img->turn($nr); $img->line(-$nr); $img->fgcolor('red'); $img->line(-$nr); } my $image_name = 'trizen_new_logo.png'; open my $fh, '>:raw', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/trizen_old_logo.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(1000, 1000); $img->moveTo(285, 80); my $nr = 257; for (0 .. 100) { $img->fgcolor('green'); $img->turn($nr); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->line(-$nr); $img->fgcolor('gray'); $img->turn(-$nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->line($nr); $img->fgcolor('blue'); $img->turn(-$nr); $img->line($nr); $img->fgcolor('purple'); $img->turn($nr); $img->line(-$nr); $img->fgcolor('red'); $img->turn($nr); $img->line(-$nr); } my $image_name = 'trizen_old_logo.png'; open my $fh, '>', $image_name or die $!; print {$fh} $img->png; close $fh; ================================================ FILE: GD/trizen_text_art.pl ================================================ #!/usr/bin/perl use strict; use warnings; use GD::Simple; my $img = 'GD::Simple'->new(2503, 2500); $img->moveTo(540, 1980); my $nr = 360; foreach $_ (0 .. 410) { $img->fgcolor('purple'); $img->turn(-90); $img->line(--$nr / 10); $img->turn(90); $img->line($nr); $img->turn(90); $img->line($nr / 10); $img->turn(90); $img->move($nr / 2); $img->turn(90); $img->move($nr / 10); $img->turn(-180); $img->line($nr); $img->turn(-90); $img->fgcolor('green'); $img->move($nr / 1.5); $img->turn(-90); $img->line($nr); $img->turn(90); $img->line($nr / 2 - $nr / 10); $img->turn(45); $img->line($nr / 10); $img->turn(45); $img->line($nr / 2 - $nr / 10); $img->turn(45); $img->line($nr / 10); $img->turn(45); $img->line($nr / 2 - $nr / 10); $img->turn(-135); $img->line($nr / 2 + $nr / 4 - $nr / 10); $img->turn(-135); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $nr -= $_; $img->fgcolor('black'); $img->turn(-90); $img->move($nr / 4); $img->turn(-90); $img->line($nr); $img->move($nr / 10); $img->turn(180); $img->move($nr / 10 + 12 + 6); $img->turn(-90); $img->move($nr / 5); $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $img->turn(45); $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $img->turn(45); $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $img->turn(45); $img->line(12); $img->turn(180); $img->line(-12); $img->line(12); $img->turn(45); $img->line(-12); $img->turn(180); $img->line(12); $img->line(-12); $nr += $_; $img->fgcolor('red'); $img->turn(-45); $img->move($nr + 72); $img->turn(-90); $img->move($nr / 7); $img->turn(-65); $img->line($nr + $nr / 10); $img->turn(-115); $img->line($nr / 2); $img->turn(-90); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $img->turn(155); $img->move($nr + $nr / 10); $img->turn(-155); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $img->turn(90); $img->line($nr / 2 - $nr / 7 / 2); $img->turn(115); $img->move(($nr + $nr / 10) / 2); $img->turn(-115); $img->line($nr / 4); $img->turn(-90); $img->line($nr / 10); $img->turn(180); $img->move($nr / 10); $img->turn(90); $img->line($nr / 2); $img->turn(-90); $img->line($nr / 10); $img->fgcolor('orange'); $img->turn(180); $img->move($nr / 2 + $nr / 10); $img->turn(-90); $img->move($nr / 5); $img->turn(-90); $img->line($nr); $img->turn(90); $img->line($nr / 2); $img->turn(90); $img->move($nr / 2); $img->turn(90); $img->line($nr / 2); $img->turn(-90); $img->move($nr / 2); $img->line($nr / 2); $img->fgcolor('blue'); $img->turn(0); $img->move($nr / 4); $img->turn(-90); $img->line($nr); $img->turn(155); $img->line($nr + $nr / 10); $img->turn(-155); $img->line($nr); } my $image_name = 'trizen_text_art.png'; open my $fh, '>:raw', $image_name or die $!; print $fh $img->png; close $fh; ================================================ FILE: GD/tupper_s_self-referential_formula.pl ================================================ #!/usr/bin/perl # Tupper's self-referential formula. # Plot the inequality: # 1/2 < floor(mod(floor(y/17)*2^(-17*floor(x)-mod(floor(y), 17)),2)) # See also: # https://www.youtube.com/watch?v=_s5RFgd59ao # https://en.wikipedia.org/wiki/Tupper's_self-referential_formula use 5.010; use strict; use warnings; use Imager; use Math::AnyNum qw(PREC 2048 :overload floor mod); my $red = Imager::Color->new('#ff0000'); my $img = Imager->new(xsize => 111, ysize => 17); my $k = Math::AnyNum->new('960939379918958884971672962127852754715004339660129306651505519271702802395266424689642842174350718121267153782770623355993237280874144307891325963941337723487857735749823926629715517173716995165232890538221612403238855866184013235585136048828693337902491454229288667081096184496091705183454067827731551705405381627380967602565625016981482083418783163849115590225610003652351370343874461848378737238198224849863465033159410054974700593138339226497249461751545728366702369745461014655997933798537483143786841806593422227898388722980000748404719'); foreach my $x (0 .. 110) { foreach my $y (0 .. 16) { if (1/2 < floor(mod(exp(log(floor(($y + $k) / 17)) + log(2) * (-17 * $x - mod($y + $k, 17))), 2))) { $img->setpixel(x => '110' - $x - '2', y => $y, color => $red); } } } $img->write(file => 'tupper_formula.png'); ================================================ FILE: GD/wavy_triangle.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 May 2015 # https://github.com/trizen # ## Generate a wavy triangle using the power of 2.5 (scaled down by a trivial constant) # use 5.010; use strict; use warnings; use GD::Simple; sub generate { my ($n, $data) = @_; for my $i (0 .. $n) { $data->{int(($i**2.5) / 12000)} = 1; } return $n; } say "** Generating..."; my %data; my $max = generate(500000, \%data); my $limit = int(sqrt($max)) - 1; # create a new image my $img = GD::Simple->new($limit * 2, $limit + 1); my $i = 1; my $j = 1; my $black = 0; for my $m (reverse(0 .. $limit)) { $img->moveTo($m, $i - 1); for my $n ($j .. $i**2) { if (exists $data{$j}) { $black = 0; $img->fgcolor('red'); } elsif (not $black) { $black = 1; $img->fgcolor('black'); } $img->line(1); ++$j; } ++$i; } open my $fh, '>:raw', 'wavy_triangle.png'; print $fh $img->png; close $fh; ================================================ FILE: GD/zeta_real_half_terms.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 08 August 2017 # https://github.com/trizen # Plotting of the terms in the series: # # zeta(1/2 + s*i) = Sum_{n>=1} 1/(n^(1/2 + s*i)) # # where we have the identity: # 1/(n^(1/2 + s*i)) = (cos(log(n) * s) - i*sin(log(n) * s)) / sqrt(n) use 5.010; use strict; use warnings; use Imager; my $red = Imager::Color->new('#ff0000'); my $size = 1000; my $img = Imager->new(xsize => $size, ysize => $size); my $s = 14.134725142; foreach my $n (1 .. 3000) { my ($x, $y) = ( cos(log($n) * $s) / sqrt($n), -sin(log($n) * $s) / sqrt($n), ); $img->setpixel( x => ($size / 2 + $size / 2 * $x), y => ($size / 2 + $size / 2 * $y), color => $red, ); } $img->write(file => 'zeta_real_half.png'); ================================================ FILE: GD/zig-zag_primes.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 11 April 2015 # https://github.com/trizen # A zig-zag matrix with the primes highlighted in blue use 5.010; use strict; use warnings; use GD::Simple; use ntheory qw(is_prime); sub zig_zag { my ($w, $h) = @_; # ## Code from: https://rosettacode.org/wiki/Zig-zag_matrix#Perl # my (@r, $n); $r[$_->[1]][$_->[0]] = $n++ for sort { $a->[0] + $a->[1] <=> $b->[0] + $b->[1] or ($a->[0] + $a->[1]) % 2 ? $a->[1] <=> $b->[1] : $a->[0] <=> $b->[0] } map { my $e = $_; map { [$e, $_] } 0 .. $w - 1 } 0 .. $h - 1; return \@r; } my $x = 1000; my $y = 1000; my $matrix = zig_zag($x, $y); # create a new image my $img = GD::Simple->new($x, $y); my $white = 1; $img->fgcolor('white'); foreach my $i (0 .. $x - 1) { $img->moveTo(0, $i); foreach my $j (0 .. $y - 1) { if (is_prime($matrix->[$i][$j])) { if ($white) { $img->fgcolor('blue'); $white = 0; } } elsif (not $white) { $img->fgcolor('white'); $white = 1; } $img->line(1); } } open my $fh, '>:raw', 'zig-zag_primes.png'; print $fh $img->png; close $fh; ================================================ FILE: GTK+/mouse_position.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 14 November 2017 # https://github.com/trizen # Get the current location of the mouse cursor. use 5.010; use strict; use warnings; use Gtk2 ('-init'); my (undef, $x, $y) = 'Gtk2::Window'->new->get_screen->get_display->get_pointer; say "x=$x y=$y"; ================================================ FILE: GTK+/tray-file-browser.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 15 May 2014 # https://github.com/trizen # A simple Gtk2 tray applet file browser - first release. use utf8; use 5.016; use strict; use warnings; use Gtk2 qw(-init); use File::Spec::Functions qw(catfile); my $dir = defined $ARGV[0] && -d $ARGV[0] # start dir ? $ARGV[0] : $ENV{HOME}; my $cmd = 'pcmanfm'; # command to open files with # Add content of a directory as a submenu for an item sub create_submenu { my ($item, $abs_path) = @_; # Create a new menu my $menu = 'Gtk2::Menu'->new; # Append 'Browser here...' my $browse_here = 'Gtk2::ImageMenuItem'->new("Browse here..."); $browse_here->signal_connect('activate' => sub { system "$cmd \Q$abs_path\E &" }); $menu->append($browse_here); # Append an horizontal separator $menu->append('Gtk2::SeparatorMenuItem'->new); # Add the dir content in this new menu add_content($menu, $abs_path); # Set submenu for item to this new menu $item->set_submenu($menu); # Make menu content visible $menu->show_all; } # Append a directory to a submenu sub append_dir { my ($submenu, $dirname, $abs_path) = @_; # Create the dir submenu my $dirmenu = 'Gtk2::Menu'->new; # Create a new menu item my $item = 'Gtk2::ImageMenuItem'->new($dirname); # Set icon $item->set_image('Gtk2::Image'->new_from_icon_name('inode-directory', 'menu')); # Set a signal (activates on click) $item->signal_connect('activate' => sub { create_submenu($item, $abs_path) }); # Set the submenu to the entry item $item->set_submenu($dirmenu); # Append the item to the submenu $submenu->append($item); } # Append a file to a submenu sub append_file { my ($submenu, $filename, $abs_path) = @_; # Create a new menu item my $item = Gtk2::ImageMenuItem->new($filename); # Set icon $item->set_image('Gtk2::Image'->new_from_icon_name('gtk-file', 'menu')); # Set a signal (activates on click) $item->signal_connect('activate' => sub { system "$cmd \Q$abs_path\E &" }); # Append the item to the submenu $submenu->append($item); } # Read a content directory and add it to a submenu sub add_content { my ($submenu, $dir) = @_; my (@dirs, @files); opendir(my $dir_h, $dir) or return; while (defined(my $filename = readdir($dir_h))) { # Ignore hidden files next if chr ord $filename eq '.'; # Join directory with filename -r (my $abs_path = catfile($dir, $filename)) or next; # UTF-8 decode the filename shown in menu utf8::decode($filename); # Collect the files and dirs push @{(-d _) ? \@dirs : \@files}, [$filename =~ s/_/__/gr, $abs_path]; } closedir $dir_h; my @calls = ([\&append_file => \@files], [\&append_dir => \@dirs]); foreach my $call (1 ? reverse(@calls) : @calls) { $call->[0]->($submenu, $_->[0], $_->[1]) for sort { fc($a->[0]) cmp fc($b->[0]) } @{$call->[1]}; } return 1; } # Create the main menu and populate it with the content of $dir sub create_main_menu { my ($icon, $dir) = @_; my $menu = 'Gtk2::Menu'->new; add_content($menu, $dir); $menu->show_all; $menu->popup(undef, undef, sub { Gtk2::StatusIcon::position_menu($menu, 0, 0, $icon) }, [1, 1], 0, 0); return 1; } # ## Main menu # my $icon = 'Gtk2::StatusIcon'->new; $icon->set_from_icon_name('file-manager'); $icon->set_visible(1); $icon->signal_connect('button-release-event' => sub { create_main_menu($icon, $dir) }); 'Gtk2'->main; ================================================ FILE: Game solvers/asciiplanes-player-v2.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 27 April 2023 # https://github.com/trizen # Solver for the asciiplanes game. # # The solver maintains an "info board" recording what the opponent has told us # (air/hit/head) and a "play board" representing the solver's current hypothesis # about where the remaining planes are. Each turn it picks the best cell to # probe, asks the opponent (or the simulator) for a score, updates both boards, # and repeats until all planes are destroyed. use utf8; use 5.036; use Text::ASCIITable; use Getopt::Long qw(GetOptions); use List::Util qw(any all shuffle max sum zip); binmode(STDOUT, ':utf8'); ## Package variables my $pkgname = 'asciiplanes-player'; my $version = 0.02; use constant { AIR => '`', # cell that is known to be empty sky BLANK => ' ', # cell not yet probed / not yet placed HIT => 'O', # cell that is part of a plane body HEAD => 'X', # cell that is the nose (head) of a plane }; my %score_table = ( air => AIR, head => HEAD, hit => HIT, ); # --------------------------------------------------------------------------- # Runtime configuration (may be overridden by command-line options) # --------------------------------------------------------------------------- my $BOARD_SIZE = 8; my $PLANES_NUM = 3; my $wrap_plane = 0; my $simulate = 0; my $hit_char = HIT; my $miss_char = AIR; my $head_char = HEAD; my $seed = 0; my $use_colors = eval { require Term::ANSIColor; 1; }; ## CLI Argument Parsing if (@ARGV) { GetOptions( 'board-size|size=i' => \$BOARD_SIZE, 'planes-num=i' => \$PLANES_NUM, 'head-char=s' => \$head_char, 'hit-char=s' => \$hit_char, 'miss-char=s' => \$miss_char, 'wrap!' => \$wrap_plane, 'simulate!' => \$simulate, 'colors!' => \$use_colors, 'seed=i' => \$seed, 'help|h|?' => \&usage, 'version|v' => \&version, ) or die("$0: error in command line arguments!\n"); } srand($seed) if $seed; ## Plane Direction Shapes (Coordinate Offsets) my @DIRECTIONS = ( # UP [[0, 0], [1, -1], [1, 0], [1, 1], [2, 0], [3, -1], [3, 0], [3, 1]], # DOWN [[-3, -1], [-3, 0], [-3, 1], [-2, 0], [-1, -1], [-1, 0], [-1, 1], [0, 0]], # LEFT [[-1, 1], [-1, 3], [0, 0], [0, 1], [0, 2], [0, 3], [1, 1], [1, 3]], # RIGHT [[-1, -3], [-1, -1], [0, -3], [0, -2], [0, -1], [0, 0], [1, -3], [1, -1]] ); my $TOTAL_CELLS = $BOARD_SIZE * $BOARD_SIZE; ## Mapping Utilities my %letters2indices; my %indices2letters; { my $char = 'a'; for my $i (0 .. $BOARD_SIZE - 1) { $letters2indices{$char} = $i; $indices2letters{$i} = $char; $char++; } } ## --- Ahead-of-Time Precomputation --- # Precompute valid plane indices for every cell and direction. # $PRECOMPUTED_PLANES->[$pos][$dir] = [ idx1, idx2, ... ] or undef my $PRECOMPUTED_PLANES = []; sub init_planes { for my $x (0 .. $BOARD_SIZE - 1) { for my $y (0 .. $BOARD_SIZE - 1) { my $pos = $x * $BOARD_SIZE + $y; for my $dir (0 .. $#DIRECTIONS) { my @indices; my $valid = 1; for my $offset (@{$DIRECTIONS[$dir]}) { my $nx = $x + $offset->[0]; my $ny = $y + $offset->[1]; if ($wrap_plane) { $nx %= $BOARD_SIZE; $ny %= $BOARD_SIZE; } elsif ($nx < 0 || $nx >= $BOARD_SIZE || $ny < 0 || $ny >= $BOARD_SIZE) { $valid = 0; last; } push @indices, $nx * $BOARD_SIZE + $ny; } $PRECOMPUTED_PLANES->[$pos][$dir] = $valid ? \@indices : undef; } } } } init_planes(); ## --- Core Game Logic (1D Arrays) --- sub make_play_board { return [(BLANK) x $TOTAL_CELLS]; } sub assign ($board, $pos, $dir, $force = 0) { my $indices = $PRECOMPUTED_PLANES->[$pos][$dir] or return; if (!$force) { for my $idx (@$indices) { return unless $board->[$idx] eq BLANK; } } $board->[$_] = HIT for @$indices; $board->[$pos] = HEAD; return 1; } sub valid_assignment ($play_board, $info_board, $extra = 0) { for my $i (0 .. $TOTAL_CELLS - 1) { my $info = $info_board->[$i]; if ($info eq AIR) { return 0 if $play_board->[$i] ne BLANK; } elsif ($extra && $info ne BLANK) { return 0 if $info ne $play_board->[$i]; } } return 1; } sub create_planes ($play_board) { my $count = 0; my $max_tries = $BOARD_SIZE**4; while ($count != $PLANES_NUM) { die "FATAL ERROR: try to increase the size of the grid (--size=x).\n" if --$max_tries <= 0; my $pos = int rand($TOTAL_CELLS); my $dir = int rand(4); ++$count if assign($play_board, $pos, $dir); } return 1; } sub guess ($info_board, $play_board, $plane_count) { my $count = 0; my $max_tries = $TOTAL_CELLS; my @indices = shuffle(0 .. $TOTAL_CELLS - 1); while ($count != ($PLANES_NUM - $plane_count)) { my $pos; while (@indices) { $pos = pop @indices; last if $play_board->[$pos] eq BLANK && $info_board->[$pos] eq BLANK; undef $pos; } return unless defined $pos; return if --$max_tries <= 0; my @good_dirs; for my $dir (0 .. 3) { my $indices = $PRECOMPUTED_PLANES->[$pos][$dir]; push @good_dirs, $dir if $indices && all { $info_board->[$_] ne AIR } @$indices; } ++$count if any { assign($play_board, $pos, $_) } shuffle(@good_dirs); } return 1; } sub get_head_positions ($board) { my @headshots; push @headshots, $_ for grep { $board->[$_] eq HEAD } 0 .. $TOTAL_CELLS - 1; return @headshots; } sub make_play_boards ($info_board) { my @headshots = get_head_positions($info_board); my @boards = ([make_play_board(), 0]); for my $pos (@headshots) { for my $dir (0 .. 3) { for my $board_entry (map { [[@{$_->[0]}], $_->[1]] } @boards) { next unless assign($board_entry->[0], $pos, $dir); push @boards, [$board_entry->[0], $board_entry->[1] + 1]; } } } my $max_count = max(0, map { $_->[1] } @boards); return grep { valid_assignment($_->[0], $info_board) } grep { $_->[1] == $max_count } @boards; } ## --- Solver Heuristics --- sub _sort_by_center_distance (@positions) { my $center = ($BOARD_SIZE - 1) / 2; return map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { my $x = int($_ / $BOARD_SIZE); my $y = $_ % $BOARD_SIZE; [$_, ($center - $x)**2 + ($center - $y)**2] } @positions; } sub _score_and_sort_by_hits ($info_board, @positions) { my @scored; for my $pos (@positions) { next unless $info_board->[$pos] eq BLANK; my @valid_planes; for my $dir (0 .. 3) { my $indices = $PRECOMPUTED_PLANES->[$pos][$dir]; push @valid_planes, $indices if $indices && all { $info_board->[$_] ne AIR } @$indices; } if (@valid_planes) { my $hits = sum( 0, map { scalar grep { $info_board->[$_] eq HIT } @$_ } @valid_planes ); push @scored, [$pos, $hits]; } } return map { $_->[0] } sort { $b->[1] <=> $a->[1] } @scored; } sub solve ($callback) { my $tries = 0; my $info_board = make_play_board(); my @boards = make_play_boards($info_board); while (1) { for my $board_entry (@boards) { my ($board, $plane_count) = @$board_entry; my $play_board = [@$board]; # Native ultra-fast shallow copy next unless guess($info_board, $play_board, $plane_count); next unless valid_assignment($play_board, $info_board, 1); my @head_pos = _sort_by_center_distance(get_head_positions($play_board)); @head_pos = _score_and_sort_by_hits($info_board, @head_pos); my $all_dead = 1; my $new_info = 0; for my $pos (@head_pos) { next if $info_board->[$pos] ne BLANK; $all_dead = 0; my $score = $callback->($pos, $play_board, $info_board) // return; $score = AIR if $score eq BLANK; ++$tries; $info_board->[$pos] = $score; if ($score eq HEAD) { $new_info = 1; @boards = make_play_boards($info_board); next; } elsif ($score eq AIR) { $new_info = 1; @boards = reverse(grep { valid_assignment($_->[0], $info_board) } @boards); } last; } return $tries if $all_dead; last if $new_info; } } } ## --- IO and Main Execution --- sub print_ascii_table (@boards) { my @ascii_tables; for my $board (@boards) { my $table = Text::ASCIITable->new({headingText => "$pkgname $version"}); $table->setCols(' ', 1 .. $BOARD_SIZE); my $char = 'a'; for my $x (0 .. $BOARD_SIZE - 1) { # Extract 2D row from 1D board my @row = @{$board}[$x * $BOARD_SIZE .. ($x + 1) * $BOARD_SIZE - 1]; $table->addRow([$char++, @row]); $table->addRowLine(); } my $t = $table->drawit; if ($use_colors) { my $hit_color = Term::ANSIColor::colored($hit_char, "bold red"); my $miss_color = Term::ANSIColor::colored($miss_char, "yellow"); my $head_color = Term::ANSIColor::colored($head_char, "bold green"); $t =~ s{\Q$hit_char\E}{$hit_color}g; $t =~ s{\Q$miss_char\E}{$miss_color}g; $t =~ s{\Q$head_char\E}{$head_color}g; } push @ascii_tables, [split(/\n/, $t)]; } for my $row (zip(@ascii_tables)) { say join(' ', @$row); } } sub process_user_input ($pos, $play_board, $info_board) { require Term::ReadLine; state $term = Term::ReadLine->new("ASCII Planes Player"); my $i = int($pos / $BOARD_SIZE); my $j = $pos % $BOARD_SIZE; print_ascii_table($play_board, $info_board); while (1) { say "=> My guess: " . join('', $indices2letters{$i}, $j + 1); say "=> Score (hit, head or air)"; my $input = lc($term->readline("> ") // return); return if $input eq 'q' or $input eq 'quit'; $input =~ s/^\s+|\s+\z//g; unless (exists $score_table{$input}) { say "\n:: Invalid score...\n"; next; } return $score_table{$input}; } } sub usage { print <<"EOT"; usage: $0 [options] main: --size=i : length side of the board (default: $BOARD_SIZE) --planes=i : the total number of planes (default: $PLANES_NUM) --wrap! : wrap the plane around the play board (default: $wrap_plane) --head=s : character used for the head of the plane (default: "$head_char") --hit=s : character used when a plane is hit (default: "$hit_char") --miss=s : character used when a plane is missed (default: "$miss_char") --colors! : use ANSI colors (requires Term::ANSIColor) (default: $use_colors) --simulate! : run a random simulation (default: $simulate) --seed=i : run with a given pseudorandom seed value > 0 (default: $seed) help: --help : print this message and exit --version : print the version number and exit example: $0 --size=12 --planes=6 --hit='*' EOT exit; } sub version { print "$pkgname $version\n"; exit; } if ($simulate) { # Simulation mode: place planes randomly, then let the solver probe them. my $board = make_play_board(); create_planes($board); my $tries = solve( sub ($pos, $play_board, $info_board) { print_ascii_table($play_board, $info_board); $board->[$pos]; } ); say "It took $tries tries to solve:"; print_ascii_table($board); } else { # Interactive mode: ask the human to score each probe. my $tries = solve(\&process_user_input); say "\n:: All planes destroyed in $tries tries!\n" if defined($tries); } ================================================ FILE: Game solvers/asciiplanes-player.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 27 April 2023 # https://github.com/trizen # Solver for the asciiplanes game. # # The solver maintains an "info board" recording what the opponent has told us # (air/hit/head) and a "play board" representing the solver's current hypothesis # about where the remaining planes are. Each turn it picks the best cell to # probe, asks the opponent (or the simulator) for a score, updates both boards, # and repeats until all planes are destroyed. use utf8; use 5.036; use Text::ASCIITable; use List::Util qw(any all shuffle max sum zip); use Getopt::Long; binmode(STDOUT, ':utf8'); ## Package variables my $pkgname = 'asciiplanes-player'; my $version = 0.01; use constant { AIR => '`', # cell that is known to be empty sky BLANK => ' ', # cell not yet probed / not yet placed HIT => 'O', # cell that is part of a plane body HEAD => 'X', # cell that is the nose (head) of a plane }; my %score_table = ( air => AIR, head => HEAD, hit => HIT, ); # --------------------------------------------------------------------------- # Runtime configuration (may be overridden by command-line options) # --------------------------------------------------------------------------- my $BOARD_SIZE = 8; my $PLANES_NUM = 3; my $wrap_plane = 0; my $simulate = 0; my $hit_char = HIT; my $miss_char = AIR; my $head_char = HEAD; my $seed = 0; my $use_colors = eval { require Term::ANSIColor; 1; }; ## CLI Argument Parsing if (@ARGV) { GetOptions( 'board-size|size=i' => \$BOARD_SIZE, 'planes-num=i' => \$PLANES_NUM, 'head-char=s' => \$head_char, 'hit-char=s' => \$hit_char, 'miss-char=s' => \$miss_char, 'wrap!' => \$wrap_plane, 'simulate!' => \$simulate, 'colors!' => \$use_colors, 'seed=i' => \$seed, 'help|h|?' => \&usage, 'version|v' => \&version, ) or die("$0: error in command line arguments!\n"); } srand($seed) if $seed; ## Plane Direction Shapes #<<< my $UP = [ [+0, +0], [+1, -1], [+1, +0], [+1, +1], [+2, +0], [+3, -1], [+3, +0], [+3, +1], ]; my $DOWN = [ [-3, -1], [-3, +0], [-3, +1], [-2, +0], [-1, -1], [-1, +0], [-1, +1], [+0, +0], ]; my $LEFT = [ [-1, +1], [-1, +3], [+0, +0], [+0, +1], [+0, +2], [+0, +3], [+1, +1], [+1, +3], ]; my $RIGHT = [ [-1, -3], [-1, -1], [+0, -3], [+0, -2], [+0, -1], [+0, +0], [+1, -3], [+1, -1], ]; #>>> my @DIRECTIONS = ($UP, $DOWN, $LEFT, $RIGHT); my @PAIR_INDICES = map { my $i = $_; map { [$i, $_] } 0 .. $BOARD_SIZE - 1 } 0 .. $BOARD_SIZE - 1; ## Mapping Utilities my %letters2indices = get_letters(); my %indices2letters = reverse %letters2indices; ## --- Core Game Logic --- # Given a board, a head position (x, y), and a direction (array of offsets), # return references to the board cells that the plane would occupy. # Returns an empty list if any cell is out of bounds (unless $wrap_plane is set). sub pointers ($board, $x, $y, $indices) { my @refs; for my $offset (@$indices) { my ($row, $col) = ($x + $offset->[0], $y + $offset->[1]); if ($wrap_plane) { $row %= $BOARD_SIZE; $col %= $BOARD_SIZE; } return () if $row < 0 or $row >= $BOARD_SIZE; return () if $col < 0 or $col >= $BOARD_SIZE; push @refs, \$board->[$row][$col]; } return @refs; } # Try to place a plane on $board with its head at ($x, $y) facing $dir. # All cells must currently be BLANK (unless $force is true). # Returns 1 on success, undef on failure. sub assign ($board, $dir, $x, $y, $force = 0) { my @plane = pointers($board, $x, $y, $dir); return unless @plane; if (!$force) { for my $point (@plane) { return unless $$point eq BLANK; } } $$_ = HIT for @plane; $board->[$x][$y] = HEAD; return 1; } # --------------------------------------------------------------------------- # Board validation # --------------------------------------------------------------------------- # Return true if $play_board is consistent with $info_board. # In strict mode ($extra true), HIT/HEAD cells must also match. sub valid_assignment ($play_board, $info_board, $extra = 0) { for my $i (0 .. $BOARD_SIZE - 1) { for my $j (0 .. $BOARD_SIZE - 1) { my $play = $play_board->[$i][$j]; my $info = $info_board->[$i][$j]; if ($info eq AIR) { return 0 if $play ne BLANK; } elsif ($extra && $info ne BLANK) { return 0 if $info ne $play; } } } return 1; } # --------------------------------------------------------------------------- # Plane generation (for simulation mode) # --------------------------------------------------------------------------- # Place $PLANES_NUM non-overlapping planes randomly on $play_board. sub create_planes ($play_board) { my $count = 0; my $max_tries = $BOARD_SIZE**4; while ($count != $PLANES_NUM) { my $x = int rand($BOARD_SIZE); my $y = int rand($BOARD_SIZE); my $dir = $DIRECTIONS[rand @DIRECTIONS]; die "FATAL ERROR: try to increase the size of the grid (--size=x).\n" if --$max_tries <= 0; ++$count if assign($play_board, $dir, $x, $y); } return 1; } # Speculatively fill $play_board with the remaining unconfirmed planes, # trying random blank positions and directions compatible with $info_board. sub guess ($info_board, $play_board, $plane_count) { my $count = 0; my $max_tries = $BOARD_SIZE * $BOARD_SIZE; my @indices = shuffle(@PAIR_INDICES); while ($count != ($PLANES_NUM - $plane_count)) { my ($x, $y); while (@indices) { ($x, $y) = @{pop(@indices)}; last if $play_board->[$x][$y] eq BLANK && $info_board->[$x][$y] eq BLANK; undef $x; } return unless defined $x; return if --$max_tries <= 0; my @good_directions = grep { my @plane = pointers($info_board, $x, $y, $_); @plane && all { $$_ ne AIR } @plane; } @DIRECTIONS; ++$count if any { assign($play_board, $_, $x, $y) } shuffle(@good_directions); } return 1; } # Return a list of [row, col] pairs for every HEAD cell on the board. sub get_head_positions ($board) { my @headshots; for my $i (0 .. $#{$board}) { for my $j (0 .. $#{$board->[$i]}) { push @headshots, [$i, $j] if $board->[$i][$j] eq HEAD; } } return @headshots; } sub make_play_board { [map { [(BLANK) x $BOARD_SIZE] } 1 .. $BOARD_SIZE]; } sub clone_board ($board) { [map { [@$_] } @$board]; } # --------------------------------------------------------------------------- # Hypothesis management # --------------------------------------------------------------------------- # Build all possible board configurations consistent with $info_board, # anchoring any confirmed HEAD positions from the info board. sub make_play_boards ($info_board) { my @headshots = get_head_positions($info_board); my @boards = ([make_play_board(), 0]); for my $pos (@headshots) { for my $dir (@DIRECTIONS) { for my $board (map { [clone_board($_->[0]), $_->[1]] } @boards) { next unless assign($board->[0], $dir, $pos->[0], $pos->[1]); push @boards, [$board->[0], $board->[1] + 1]; } } } my $max_count = max(map { $_->[1] } @boards); return grep { valid_assignment($_->[0], $info_board) } grep { $_->[1] == $max_count } @boards; } ## --- Solver Heuristics --- # Sort HEAD positions: descending by number of HIT cells in viable directions # (prefer planes with the most confirmed body cells), then ascending by # distance from board centre (prefer central cells as a tiebreaker). sub _sort_by_center_distance (@head_positions) { my $center = ($BOARD_SIZE - 1) / 2; return map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { my ($x, $y) = @$_; [$_, ($center - $x)**2 + ($center - $y)**2] } @head_positions; } # Annotate each HEAD position with the directions still viable from it # (no AIR cell in the way) and the number of HIT cells they collectively cover. sub _score_and_sort_by_hits ($info_board, @head_positions) { my @scored; for my $pos (@head_positions) { my ($x, $y) = @$pos; next unless $info_board->[$x][$y] eq BLANK; my @valid_planes; for my $dir (@DIRECTIONS) { my @plane = pointers($info_board, $x, $y, $dir); push @valid_planes, \@plane if @plane && all { $$_ ne AIR } @plane; } if (@valid_planes) { my $hits = sum( 0, map { scalar grep { $$_ eq HIT } @$_ } @valid_planes ); push @scored, [$pos, $hits]; } } return map { $_->[0] } sort { $b->[1] <=> $a->[1] } @scored; } # --------------------------------------------------------------------------- # Main solver loop # --------------------------------------------------------------------------- # Drive the solving process. For each turn, pick the best cell to probe and # invoke $callback->($row, $col, $play_board, $info_board). # The callback returns the score (AIR/HIT/HEAD) or undef to abort. # Returns the total number of probes on success. sub solve ($callback) { my $tries = 0; my $info_board = make_play_board(); my @boards = make_play_boards($info_board); while (1) { for my $board_entry (@boards) { my ($board, $plane_count) = @$board_entry; # Build a full speculative board from this hypothesis. my $play_board = clone_board($board); next unless guess($info_board, $play_board, $plane_count); next unless valid_assignment($play_board, $info_board, 1); # Apply Heuristics: Center proximity first, then filter and rank by potential hits my @head_pos = _sort_by_center_distance(get_head_positions($play_board)); @head_pos = _score_and_sort_by_hits($info_board, @head_pos); my $all_dead = 1; my $new_info = 0; for my $pos (@head_pos) { my ($i, $j) = @$pos; next if $info_board->[$i][$j] ne BLANK; $all_dead = 0; # Ask the human (or simulator) for the result of probing this cell. my $score = $callback->($i, $j, $play_board, $info_board) // return; $score = AIR if $score eq BLANK; ++$tries; $info_board->[$i][$j] = $score; if ($score eq HEAD) { # A confirmed head -- rebuild all hypotheses. $new_info = 1; @boards = make_play_boards($info_board); next; } elsif ($score eq AIR) { # A miss -- prune inconsistent hypotheses. $new_info = 1; @boards = reverse(grep { valid_assignment($_->[0], $info_board) } @boards); } last; } return $tries if $all_dead; last if $new_info; } } } ## --- IO and Main Execution --- sub get_letters { my %letters; my $char = 'a'; $letters{$char++} = $_ for 0 .. $BOARD_SIZE - 1; return %letters; } # Print one or more boards side by side. sub print_ascii_table (@boards) { my @ascii_tables; for my $board (@boards) { my $table = Text::ASCIITable->new({headingText => "$pkgname $version"}); $table->setCols(' ', 1 .. $BOARD_SIZE); my $char = 'a'; for my $row (@$board) { $table->addRow([$char++, @$row]); $table->addRowLine(); } my $t = $table->drawit; if ($use_colors) { my $hit_color = Term::ANSIColor::colored($hit_char, "bold red"); my $miss_color = Term::ANSIColor::colored($miss_char, "yellow"); my $head_color = Term::ANSIColor::colored($head_char, "bold green"); $t =~ s{\Q$hit_char\E}{$hit_color}g; $t =~ s{\Q$miss_char\E}{$miss_color}g; $t =~ s{\Q$head_char\E}{$head_color}g; } push @ascii_tables, [split(/\n/, $t)]; } for my $row (zip(@ascii_tables)) { say join(' ', @$row); } } # --------------------------------------------------------------------------- # Interactive mode # --------------------------------------------------------------------------- sub process_user_input ($i, $j, $play_board, $info_board) { require Term::ReadLine; state $term = Term::ReadLine->new("ASCII Planes Player"); print_ascii_table($play_board, $info_board); while (1) { say "=> My guess: " . join('', $indices2letters{$i}, $j + 1); say "=> Score (hit, head or air)"; my $input = lc($term->readline("> ") // return); return if $input eq 'q' or $input eq 'quit'; $input =~ s/^\s+|\s+\z//g; unless (exists $score_table{$input}) { say "\n:: Invalid score...\n"; next; } return $score_table{$input}; } } sub usage { print <<"EOT"; usage: $0 [options] main: --size=i : length side of the board (default: $BOARD_SIZE) --planes=i : the total number of planes (default: $PLANES_NUM) --wrap! : wrap the plane around the play board (default: $wrap_plane) --head=s : character used for the head of the plane (default: "$head_char") --hit=s : character used when a plane is hit (default: "$hit_char") --miss=s : character used when a plane is missed (default: "$miss_char") --colors! : use ANSI colors (requires Term::ANSIColor) (default: $use_colors) --simulate! : run a random simulation (default: $simulate) --seed=i : run with a given pseudorandom seed value > 0 (default: $seed) help: --help : print this message and exit --version : print the version number and exit example: $0 --size=12 --planes=6 --hit='*' EOT exit; } sub version { print "$pkgname $version\n"; exit; } if ($simulate) { # Simulation mode: place planes randomly, then let the solver probe them. my $board = make_play_board(); create_planes($board); my $tries = solve( sub ($i, $j, $play_board, $info_board) { print_ascii_table($play_board, $info_board); $board->[$i][$j]; } ); say "It took $tries tries to solve:"; print_ascii_table($board); } else { # Interactive mode: ask the human to score each probe. my $tries = solve(\&process_user_input); say "\n:: All planes destroyed in $tries tries!\n" if defined($tries); } ================================================ FILE: Game solvers/dice_game_solver.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 20 May 2013 # https://github.com/trizen # Dice game solver use 5.010; use strict; use warnings; my $board = [ [4, 1, 3, 3, 5, 2], [3, 4, 1, 2, 0, 3], [5, 1, 5, 5, 4, 2], [1, 3, 2, 5, 2, 1], [6, 2, 4, 1, 5, 4], [6, 2, 1, 6, 6, 3], ]; my %moves = ( 'up' => [-1, +0], 'up-right' => [-1, +1], 'up-left' => [-1, -1], 'right' => [+0, +1], 'left' => [+0, -1], 'down' => [+1, +0], 'down-left' => [+1, -1], 'down-right' => [+1, +1], ); my @directions = keys %moves; sub valid_move { my ($row, $col) = @_; if ($row < 0 or not exists $board->[$row]) { return; } if ($col < 0 or not exists $board->[$row][$col]) { return; } return 1; } while (1) { my %map; my %seen; my @dirs; my %spos; my $current_pos = [$#{$board}, 0]; my $current_num = $board->[$current_pos->[0]][$current_pos->[1]]; $spos{join('|', @{$current_pos})}++; foreach my $num (1 .. @{$board}**2) { my $dir = ( exists $map{$current_num} ? $map{$current_num} : do { my %table; @table{values %map} = (); my $d; do { $d = $directions[rand @directions]; } while (exists($table{$d})); $d; } ); my $pos = $moves{$dir}; my $row = $current_pos->[0] + $pos->[0]; my $col = $current_pos->[1] + $pos->[1]; valid_move($row, $col) || last; if (++$spos{join('|', $row, $col)} > 1) { last; } push @dirs, {dir => $dir, num => $current_num, pos => $current_pos}; $map{$current_num} //= $dir; $current_pos = [$row, $col]; $current_num = $board->[$current_pos->[0]][$current_pos->[1]]; $seen{$current_num}++; if ($current_num == 0) { if ($seen{$board->[$current_pos->[0] - $pos->[0]][$current_pos->[1] - $pos->[1]]} > 1) { use Data::Dump qw(pp); pp \@dirs; exit; } last; } } } ================================================ FILE: Game solvers/peg-solitaire-solver ================================================ #!/usr/bin/perl # This program solves the (English) peg solitaire # Perl translate from Go code (see __END__) # Translator: Trizen # Date: 27 February 2012 use 5.010; use strict; use warnings; use utf8; binmode *STDOUT, ':encoding(utf-8)'; my $N = 11 + 1; # length of a board row (+1 for \n) # The board must be surrounded by 2 illegal fields # in each direction so that move() doesn't need to # check the board boundaries. Periods represent # illegal fields, ● are pegs, and ○ are holes. my @board = unpack( 'C*', '........... ........... ....●●●.... ....●●●.... ..●●●●●●●.. ..●●●○●●●.. ..●●●●●●●.. ....●●●.... ....●●●.... ........... ........... ' ); # center is the position of the center hole if # there is a single one; otherwise it is -1. my $center; { my $n = 0; for (my $i = 0 ; $i <= $#board ; ++$i) { if (chr $board[$i] eq '○') { $center = $i; $n++; last; } } if ($n != 1) { $center = -1; # no single hole } } my $moves; # number of times move is called # move tests if there is a peg at position pos that # can jump over another peg in direction dir. If the # move is valid, it is executed and move returns true. # Otherwise, move returns false. sub move { my ($pos, $dir) = @_; ++$moves; if (chr $board[$pos] eq '●' and chr $board[$pos + $dir] eq '●' and chr $board[$pos + 2 * $dir] eq '○') { $board[$pos] = ord '○'; $board[$pos + $dir] = ord '○'; $board[$pos + 2 * $dir] = ord '●'; return 1; } return 0; } # unmove reverts a previously executed valid move. sub unmove { my ($pos, $dir) = @_; $board[$pos] = ord '●'; $board[$pos + $dir] = ord '●'; $board[$pos + 2 * $dir] = ord '○'; return 1; } # solve tries to find a sequence of moves such that # there is only one peg left at the end; if center is # >= 0, that last peg must be in the center position. # If a solution is found, solve prints the board after # each move in a backward fashion (i.e., the last # board position is printed first, all the way back to # the starting board position). sub solve { my ($last, $n); foreach my $pos (0 .. $#board) { # try each board position if (chr $board[$pos] eq '●') { # found a peg foreach my $dir (-1, -$N, +1, +$N) { # try each direction if (move($pos, $dir)) { # a valid move was found and executed, # see if this new board has a solution if (solve()) { unmove($pos, $dir); say map { chr } @board; return 1; } unmove($pos, $dir); } } $last = $pos; $n++; } } # tried each possible move if ($n == 1 && ($center < 0 || $last == $center)) { # there's only one peg left say map { chr } @board; return 1; } # no solution found for this board return 0; } if (!solve()) { say "no solution found"; } say "$moves moves tried"; __END__ // This program solves the (English) peg solitaire // board game. See also: // https://en.wikipedia.org/wiki/Peg_solitaire package main import "fmt" const N = 11 + 1 // length of a board row (+1 for \n) // The board must be surrounded by 2 illegal fields // in each direction so that move() doesn't need to // check the board boundaries. Periods represent // illegal fields, ● are pegs, and ○ are holes. var board = []int( `........... ........... ....●●●.... ....●●●.... ..●●●●●●●.. ..●●●○●●●.. ..●●●●●●●.. ....●●●.... ....●●●.... ........... ........... `) // center is the position of the center hole if // there is a single one; otherwise it is -1. var center int func init() { n := 0 for pos, field := range board { if field == '○' { center = pos n++ } } if n != 1 { center = -1 // no single hole } } var moves int // number of times move is called // move tests if there is a peg at position pos that // can jump over another peg in direction dir. If the // move is valid, it is executed and move returns true. // Otherwise, move returns false. func move(pos, dir int) bool { moves++ if board[pos] == '●' && board[pos+dir] == '●' && board[pos+2*dir] == '○' { board[pos] = '○' board[pos+dir] = '○' board[pos+2*dir] = '●' return true } return false } // unmove reverts a previously executed valid move. func unmove(pos, dir int) { board[pos] = '●' board[pos+dir] = '●' board[pos+2*dir] = '○' } // solve tries to find a sequence of moves such that // there is only one peg left at the end; if center is // >= 0, that last peg must be in the center position. // If a solution is found, solve prints the board after // each move in a backward fashion (i.e., the last // board position is printed first, all the way back to // the starting board position). func solve() bool { var last, n int for pos, field := range board { // try each board position if field == '●' { // found a peg for _, dir := range [...]int{-1, -N, +1, +N} { // try each direction if move(pos, dir) { // a valid move was found and executed, // see if this new board has a solution if solve() { unmove(pos, dir) println(string(board)) return true } unmove(pos, dir) } } last = pos n++ } } // tried each possible move if n == 1 && (center < 0 || last == center) { // there's only one peg left println(string(board)) return true } // no solution found for this board return false } func main() { if !solve() { fmt.Println("no solution found") } fmt.Println(moves, "moves tried") } ================================================ FILE: Game solvers/reaction_time_test.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 16 August 2019 # https://github.com/trizen # A simple program to cheat in the "Reaction time test". # https://www.humanbenchmark.com/tests/reactiontime use 5.014; use strict; use warnings; use GD; use Time::HiRes qw(sleep); say "Starting..."; sleep 5; system("xdotool", "click", "1"); # click to start my $count = 0; while (1) { my $gd = GD::Image->new(scalar `maim --geometry '20x20+1+300' --format=jpg /dev/stdout`); my $pixel = $gd->getPixel(0, 0); # test first pixel my ($r, $g, $b) = $gd->rgb($pixel); if ($g > 100) { # test for greenness say "Detected green..."; system("xdotool", "click", "1"); # green detected last if ++$count == 5; sleep(2); system("xdotool", "click", "1"); # click to continue sleep 2; } sleep 0.0001; } ================================================ FILE: Game solvers/reflex_sheep_game.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 02 October 2015 # Website: https://github.com/trizen # A simple program which plays the Reflex Sheep game by itself. # See: https://youtu.be/FrYFE4m8jc0 use strict; use warnings; use GD; use Time::HiRes qw(sleep); my $count = 0; ROOT: while (1) { my $gd = GD::Image->new(scalar `maim -x 640 -y 150 -w 1 -h 850 --format=jpg /dev/stdout`); #my $gd = GD::Image->new(scalar `maim -x 555 -y 100 -w 10 -h 650 --format=jpg /dev/stdout`); # faster, but buggy my ($width, $height) = $gd->getBounds; OUTER: foreach my $y (0 .. $height - 1) { my $pixel = $gd->getPixel(0, $y); my ($r, $g, $b) = $gd->rgb($pixel); my $avg = ($r + $g + $b) / 3; if ($avg < 50) { sleep(0.085); # let the ship run a little bit more system("xdotool", "click", "1"); sleep(1); # sleep a little bit after the click ++$count == 5 ? last ROOT: last OUTER; } } } ================================================ FILE: Game solvers/sudoku_dice_game_solver.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 June 2013 # https://github.com/trizen # Sudoku dice game solver use strict; use warnings; use List::Util qw(first shuffle); sub valid_move { my ($row, $col, $table) = @_; if (($row < 0 or not exists $table->[$row]) || ($col < 0 or not exists $table->[$row][$col])) { return; } return 1; } { my @moves = ( {dir => 'left', pos => [+0, -1]}, {dir => 'right', pos => [+0, +1]}, {dir => 'up', pos => [-1, +0]}, {dir => 'down', pos => [+1, +0]}, ); sub get_moves { my ($table, $row, $col, $number) = @_; my @next_pos; foreach my $move (@moves) { if (valid_move($row + $move->{pos}[0], $col + $move->{pos}[1], $table)) { if ( $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] != 0 and $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] == $number + 1) { push @next_pos, $move; } } } return \@next_pos; } } my @steps; sub init_universe { # recursion at its best my ($table, $pos) = @_; my ($row, $col) = @{$pos}; my $number = $table->[$row][$col]; $table->[$row][$col] = 0; if ($number == 0) { pop @steps; return $table; } $number = 0 if $number == 3; my $moves = get_moves($table, $row, $col, $number); if (@{$moves}) { foreach my $move (@{$moves}) { push @steps, $move; my $universe = init_universe([map { [@{$_}] } @{$table}], [$row + $move->{pos}[0], $col + $move->{pos}[1]]); if ( not first { first { $_ != 0 } @{$_}; } @{$universe} ) { die "solved\n"; } } return init_universe($table, [$row, $col]); } else { pop @steps; return $table; } } # ## MAIN # { my @rows = qw( 321321313 123312222 321213131 312231123 213112321 231323123 132231231 123113322 321322113 ); my @table; foreach my $row (@rows) { push @table, [split //, $row]; } my @positions; foreach my $i (0 .. $#table) { foreach my $j (0 .. $#{$table[$i]}) { if ($table[$i][$j] == 1) { push @positions, [$i, $j]; } } } foreach my $pos (shuffle @positions) { # tested solution from position[6] eval { init_universe([map { [@{$_}] } @table], $pos); }; if ($@ eq "solved\n") { printf "** Locate row %d, column %d, click on it and follow the steps:\n", ($pos->[0] + 1, $pos->[1] + 1); my $i = 1; my $count = 1; my $prev_step = (shift @steps)->{dir}; foreach my $step (@steps) { if ($step->{dir} eq $prev_step) { ++$count; } else { printf "%2d. Go %-8s%s", $i++, $prev_step, ($count == 1 ? "\n" : "($count times)\n"); $count = 1; $prev_step = $step->{dir}; } } print "\n"; @steps = (); } } } ================================================ FILE: Game solvers/sudoku_generator.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 30 January 2017 # Edit: 20 December 2021 # https://github.com/trizen # Recursive brute-force Sudoku generator and solver. # See also: # https://en.wikipedia.org/wiki/Sudoku use 5.020; use strict; use List::Util qw(shuffle); use experimental qw(signatures); sub check ($i, $j) { use integer; my ($id, $im) = ($i / 9, $i % 9); my ($jd, $jm) = ($j / 9, $j % 9); $jd == $id && return 1; $jm == $im && return 1; $id / 3 == $jd / 3 and $jm / 3 == $im / 3; } my @lookup; foreach my $i (0 .. 80) { foreach my $j (0 .. 80) { $lookup[$i][$j] = check($i, $j); } } sub solve_sudoku ($callback, $grid) { sub { foreach my $i (0 .. 80) { if (!$grid->[$i]) { my %t; undef @t{@{$grid}[grep { $lookup[$i][$_] } 0 .. 80]}; foreach my $k (shuffle(1 .. 9)) { if (!exists $t{$k}) { $grid->[$i] = $k; __SUB__->(); $grid->[$i] = 0; } } return; } } $callback->(@$grid); } ->(); } sub generate_sudoku ($known, $solution_count = 1) { my @grid = (0) x 81; eval { solve_sudoku( sub { my (@solution) = @_; my %table; @table{(shuffle(0 .. $#solution))[0 .. $known - 1]} = (); my @candidate = map { exists($table{$_}) ? $solution[$_] : 0 } 0 .. $#solution; my $res = eval { my $count = 0; solve_sudoku(sub { die "error" if (++$count > $solution_count) }, [@candidate]); $count; }; if (defined($res) and $res == $solution_count) { @grid = @candidate; die "found"; } }, \@grid ); }; return @grid; } sub display_grid_as_ascii_table { my (@grid) = @_; my $t = Text::ASCIITable->new(); $t->setCols(map { '1 2 3' } 1 .. 3); $t->setOptions({hide_HeadLine => 1, hide_HeadRow => 1}); my @collect; foreach my $i (0 .. $#grid) { push @collect, $grid[$i] ? $grid[$i] : '0'; if (($i + 1) % 9 == 0) { my @row = splice(@collect); my @chunks; while (@row) { push @chunks, join ' ', splice(@row, 0, 3); } $t->addRow(@chunks); } if (($i + 1) % 27 == 0) { $t->addRowLine(); } } print $t; } sub display_grid { my (@grid) = @_; my $has_ascii_table = eval { require Text::ASCIITable; 1 }; if ($has_ascii_table) { return display_grid_as_ascii_table(@grid); } foreach my $i (0 .. $#grid) { print "$grid[$i] "; print " " if ($i + 1) % 3 == 0; print "\n" if ($i + 1) % 9 == 0; print "\n" if ($i + 1) % 27 == 0; } } my $known = 35; # number of known entries my $solution_count = 1; # number of solutions the puzzle must have my @sudoku = generate_sudoku($known, $solution_count); say "\n:: Random Sudoku with $known known entries:\n"; display_grid(@sudoku); say "\n:: Solution(s):\n"; solve_sudoku( sub { my (@solution) = @_; display_grid(@solution); }, \@sudoku ); __END__ :: Random Sudoku with 35 known entries: .-----------------------. | 8 9 0 | 6 4 5 | 2 0 3 | | 7 4 0 | 8 0 0 | 9 0 0 | | 0 0 5 | 0 3 0 | 8 1 4 | +-------+-------+-------+ | 3 0 0 | 0 0 9 | 0 0 1 | | 0 1 2 | 4 7 0 | 5 0 8 | | 0 8 0 | 0 0 0 | 4 3 0 | +-------+-------+-------+ | 1 0 0 | 0 6 0 | 3 0 0 | | 0 0 0 | 0 0 0 | 0 0 5 | | 0 0 0 | 0 5 4 | 7 0 0 | '-------+-------+-------' :: Solution(s): .-----------------------. | 8 9 1 | 6 4 5 | 2 7 3 | | 7 4 3 | 8 2 1 | 9 5 6 | | 2 6 5 | 9 3 7 | 8 1 4 | +-------+-------+-------+ | 3 7 4 | 5 8 9 | 6 2 1 | | 6 1 2 | 4 7 3 | 5 9 8 | | 5 8 9 | 2 1 6 | 4 3 7 | +-------+-------+-------+ | 1 5 8 | 7 6 2 | 3 4 9 | | 4 2 7 | 3 9 8 | 1 6 5 | | 9 3 6 | 1 5 4 | 7 8 2 | '-------+-------+-------' ================================================ FILE: Game solvers/sudoku_solver.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 January 2017 # https://github.com/trizen # Recursive brute-force Sudoku solver. # See also: # https://en.wikipedia.org/wiki/Sudoku use 5.016; use strict; sub check { my ($i, $j) = @_; use integer; my ($id, $im) = ($i / 9, $i % 9); my ($jd, $jm) = ($j / 9, $j % 9); $jd == $id && return 1; $jm == $im && return 1; $id / 3 == $jd / 3 and $jm / 3 == $im / 3; } my @lookup; foreach my $i (0 .. 80) { foreach my $j (0 .. 80) { $lookup[$i][$j] = check($i, $j); } } sub solve_sudoku { my ($callback, @grid) = @_; sub { foreach my $i (0 .. 80) { if (!$grid[$i]) { my %t; undef @t{@grid[grep { $lookup[$i][$_] } 0 .. 80]}; foreach my $k (1 .. 9) { if (!exists $t{$k}) { $grid[$i] = $k; __SUB__->(); $grid[$i] = 0; } } return; } } $callback->(@grid); }->(); } #<<< my @grid = qw( 5 3 0 0 7 0 0 0 0 6 0 0 1 9 5 0 0 0 0 9 8 0 0 0 0 6 0 8 0 0 0 6 0 0 0 3 4 0 0 8 0 3 0 0 1 7 0 0 0 2 0 0 0 6 0 6 0 0 0 0 2 8 0 0 0 0 4 1 9 0 0 5 0 0 0 0 8 0 0 7 9 ); @grid = qw( 0 0 0 8 0 1 0 0 0 0 0 0 0 0 0 0 4 3 5 0 0 0 0 0 0 0 0 0 0 0 0 7 0 8 0 0 0 0 0 0 0 0 1 0 0 0 2 0 0 3 0 0 0 0 6 0 0 0 0 0 0 7 5 0 0 3 4 0 0 0 0 0 0 0 0 2 0 0 6 0 0 ) if 0; @grid = qw( 8 0 0 0 0 0 0 0 0 0 0 3 6 0 0 0 0 0 0 7 0 0 9 0 2 0 0 0 5 0 0 0 7 0 0 0 0 0 0 0 4 5 7 0 0 0 0 0 1 0 0 0 3 0 0 0 1 0 0 0 0 6 8 0 0 8 5 0 0 0 1 0 0 9 0 0 0 0 4 0 0 ) if 0; #>>> solve_sudoku( sub { say "Solution:"; my (@solution) = @_; foreach my $i (0 .. $#solution) { print "$solution[$i] "; print " " if ($i + 1) % 3 == 0; print "\n" if ($i + 1) % 9 == 0; print "\n" if ($i + 1) % 27 == 0; } }, @grid ); ================================================ FILE: Game solvers/sudoku_solver_backtracking.pl ================================================ #!/usr/bin/perl # Solve Sudoku puzzle (recursive solution). use 5.036; sub is_valid ($board, $row, $col, $num) { # Check if the number is not present in the current row and column foreach my $i (0 .. 8) { if (($board->[$row][$i] == $num) || ($board->[$i][$col] == $num)) { return 0; } } # Check if the number is not present in the current 3x3 subgrid my ($start_row, $start_col) = (3 * int($row / 3), 3 * int($col / 3)); foreach my $i (0 .. 2) { foreach my $j (0 .. 2) { if ($board->[$start_row + $i][$start_col + $j] == $num) { return 0; } } } return 1; } sub find_empty_location ($board) { # Find an empty position (cell with 0) foreach my $i (0 .. 8) { foreach my $j (0 .. 8) { if ($board->[$i][$j] == 0) { return ($i, $j); } } } return (undef, undef); # If the board is filled } sub solve_sudoku ($board) { my ($row, $col) = find_empty_location($board); if (!defined($row) && !defined($col)) { return 1; # Puzzle is solved } foreach my $num (1 .. 9) { if (is_valid($board, $row, $col, $num)) { # Try placing the number $board->[$row][$col] = $num; # Recursively try to solve the rest of the puzzle if (__SUB__->($board)) { return 1; } # If placing the current number doesn't lead to a solution, backtrack $board->[$row][$col] = 0; } } return 0; # No solution found } #<<< # Example usage: # Define the Sudoku puzzle as a 9x9 list with 0 representing empty cells my $sudoku_board = [ [2, 0, 0, 0, 7, 0, 0, 0, 3], [1, 0, 0, 0, 0, 0, 0, 8, 0], [0, 0, 4, 2, 0, 9, 0, 0, 5], [9, 4, 0, 0, 0, 0, 6, 0, 8], [0, 0, 0, 8, 0, 0, 0, 9, 0], [0, 0, 0, 0, 0, 0, 0, 7, 0], [7, 2, 1, 9, 0, 8, 0, 6, 0], [0, 3, 0, 0, 2, 7, 1, 0, 0], [4, 0, 0, 0, 0, 3, 0, 0, 0] ]; $sudoku_board = [ [0, 0, 0, 8, 0, 1, 0, 0, 0], [0, 0, 0, 0, 0, 0, 0, 4, 3], [5, 0, 0, 0, 0, 0, 0, 0, 0], [0, 0, 0, 0, 7, 0, 8, 0, 0], [0, 0, 0, 0, 0, 0, 1, 0, 0], [0, 2, 0, 0, 3, 0, 0, 0, 0], [6, 0, 0, 0, 0, 0, 0, 7, 5], [0, 0, 3, 4, 0, 0, 0, 0, 0], [0, 0, 0, 2, 0, 0, 6, 0, 0] ] if 0; $sudoku_board = [ [8, 0, 0, 0, 0, 0, 0, 0, 0], [0, 0, 3, 6, 0, 0, 0, 0, 0], [0, 7, 0, 0, 9, 0, 2, 0, 0], [0, 5, 0, 0, 0, 7, 0, 0, 0], [0, 0, 0, 0, 4, 5, 7, 0, 0], [0, 0, 0, 1, 0, 0, 0, 3, 0], [0, 0, 1, 0, 0, 0, 0, 6, 8], [0, 0, 8, 5, 0, 0, 0, 1, 0], [0, 9, 0, 0, 0, 0, 4, 0, 0] ] if 0; #>>> sub display_grid ($grid) { foreach my $i (0 .. $#$grid) { print "$grid->[$i] "; print " " if ($i + 1) % 3 == 0; print "\n" if ($i + 1) % 9 == 0; print "\n" if ($i + 1) % 27 == 0; } } if (solve_sudoku($sudoku_board)) { display_grid([map { @$_ } @$sudoku_board]); } else { say "No solution exists."; } ================================================ FILE: Game solvers/sudoku_solver_iterative.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 12 February 2024 # https://github.com/trizen # Fast algorithm to solve the Sudoku puzzle (iterative solution). use 5.036; sub is_valid ($board, $row, $col, $num) { # Check if the number is not present in the current row and column foreach my $i (0 .. 8) { if (($board->[$row][$i] == $num) || ($board->[$i][$col] == $num)) { return 0; } } # Check if the number is not present in the current 3x3 subgrid my ($start_row, $start_col) = (3 * int($row / 3), 3 * int($col / 3)); foreach my $i (0 .. 2) { foreach my $j (0 .. 2) { if ($board->[$start_row + $i][$start_col + $j] == $num) { return 0; } } } return 1; } sub find_empty_locations ($board) { my @locations; # Find all empty positions (cells with 0) foreach my $i (0 .. 8) { foreach my $j (0 .. 8) { if ($board->[$i][$j] == 0) { push @locations, [$i, $j]; } } } return @locations; } sub find_empty_location ($board) { # Find an empty position (cell with 0) foreach my $i (0 .. 8) { foreach my $j (0 .. 8) { if ($board->[$i][$j] == 0) { return ($i, $j); } } } return (undef, undef); # If the board is filled } sub solve_sudoku_fallback ($board) { # fallback method my ($row, $col) = find_empty_location($board); if (!defined($row) && !defined($col)) { return 1; # Puzzle is solved } foreach my $num (1 .. 9) { if (is_valid($board, $row, $col, $num)) { # Try placing the number $board->[$row][$col] = $num; # Recursively try to solve the rest of the puzzle if (__SUB__->($board)) { return 1; } # If placing the current number doesn't lead to a solution, backtrack $board->[$row][$col] = 0; } } return 0; # No solution found } sub solve_sudoku ($board) { while (1) { (my @empty_locations = find_empty_locations($board)) || last; my $found = 0; # Solve easy cases foreach my $ij (@empty_locations) { my ($i, $j) = @$ij; my ($count, $value) = (0, 0); foreach my $n (1 .. 9) { is_valid($board, $i, $j, $n) || next; last if (++$count > 1); $value = $n; } if ($count == 1) { $board->[$i][$j] = $value; $found ||= 1; } } next if $found; # Solve more complex cases my @stats; foreach my $ij (@empty_locations) { my ($i, $j) = @$ij; $stats[$i][$j] = [grep { is_valid($board, $i, $j, $_) } 1 .. 9]; } my (@rows, @cols, @subgrid); foreach my $ij (@empty_locations) { my ($i, $j) = @$ij; foreach my $v (@{$stats[$i][$j]}) { ++$cols[$j][$v]; ++$rows[$i][$v]; ++$subgrid[3 * int($i / 3)][3 * int($j / 3)][$v]; } } foreach my $ij (@empty_locations) { my ($i, $j) = @$ij; foreach my $v (@{$stats[$i][$j]}) { if ( $cols[$j][$v] == 1 or $rows[$i][$v] == 1 or $subgrid[3 * int($i / 3)][3 * int($j / 3)][$v] == 1) { $board->[$i][$j] = $v; $found ||= 1; } } } next if $found; # Give up and try brute-force solve_sudoku_fallback($board); return $board; } return $board; } #<<< # Example usage: # Define the Sudoku puzzle as a 9x9 list with 0 representing empty cells my $sudoku_board = [ [2, 0, 0, 0, 7, 0, 0, 0, 3], [1, 0, 0, 0, 0, 0, 0, 8, 0], [0, 0, 4, 2, 0, 9, 0, 0, 5], [9, 4, 0, 0, 0, 0, 6, 0, 8], [0, 0, 0, 8, 0, 0, 0, 9, 0], [0, 0, 0, 0, 0, 0, 0, 7, 0], [7, 2, 1, 9, 0, 8, 0, 6, 0], [0, 3, 0, 0, 2, 7, 1, 0, 0], [4, 0, 0, 0, 0, 3, 0, 0, 0] ]; $sudoku_board = [ [0, 0, 0, 8, 0, 1, 0, 0, 0], [0, 0, 0, 0, 0, 0, 0, 4, 3], [5, 0, 0, 0, 0, 0, 0, 0, 0], [0, 0, 0, 0, 7, 0, 8, 0, 0], [0, 0, 0, 0, 0, 0, 1, 0, 0], [0, 2, 0, 0, 3, 0, 0, 0, 0], [6, 0, 0, 0, 0, 0, 0, 7, 5], [0, 0, 3, 4, 0, 0, 0, 0, 0], [0, 0, 0, 2, 0, 0, 6, 0, 0] ] if 1; $sudoku_board = [ [8, 0, 0, 0, 0, 0, 0, 0, 0], [0, 0, 3, 6, 0, 0, 0, 0, 0], [0, 7, 0, 0, 9, 0, 2, 0, 0], [0, 5, 0, 0, 0, 7, 0, 0, 0], [0, 0, 0, 0, 4, 5, 7, 0, 0], [0, 0, 0, 1, 0, 0, 0, 3, 0], [0, 0, 1, 0, 0, 0, 0, 6, 8], [0, 0, 8, 5, 0, 0, 0, 1, 0], [0, 9, 0, 0, 0, 0, 4, 0, 0] ] if 0; #>>> sub display_grid ($grid) { foreach my $i (0 .. $#$grid) { print "$grid->[$i] "; print " " if ($i + 1) % 3 == 0; print "\n" if ($i + 1) % 9 == 0; print "\n" if ($i + 1) % 27 == 0; } } my $solution = solve_sudoku($sudoku_board); if ($solution) { display_grid([map { @$_ } @$solution]); } else { warn "No unique solution exists!\n"; } ================================================ FILE: Game solvers/sudoku_solver_stack.pl ================================================ #!/usr/bin/perl # Solve Sudoku puzzle (iterative solution // stack-based). use 5.036; sub is_valid ($board, $row, $col, $num) { # Check if the number is not present in the current row and column foreach my $i (0 .. 8) { if (($board->[$row][$i] == $num) || ($board->[$i][$col] == $num)) { return 0; } } # Check if the number is not present in the current 3x3 subgrid my ($start_row, $start_col) = (3 * int($row / 3), 3 * int($col / 3)); foreach my $i (0 .. 2) { foreach my $j (0 .. 2) { if ($board->[$start_row + $i][$start_col + $j] == $num) { return 0; } } } return 1; } sub find_empty_location ($board) { # Find an empty position (cell with 0) foreach my $i (0 .. 8) { foreach my $j (0 .. 8) { if ($board->[$i][$j] == 0) { return ($i, $j); } } } return (undef, undef); # If the board is filled } sub solve_sudoku ($board) { my @stack = ($board); while (@stack) { my $current_board = pop @stack; my ($row, $col) = find_empty_location($current_board); if (!defined($row) && !defined($col)) { return $current_board; } foreach my $num (1 .. 9) { if (is_valid($current_board, $row, $col, $num)) { my @new_board = map { [@$_] } @$current_board; $new_board[$row][$col] = $num; push @stack, \@new_board; } } } return undef; } #<<< # Example usage: # Define the Sudoku puzzle as a 9x9 list with 0 representing empty cells my $sudoku_board = [ [2, 0, 0, 0, 7, 0, 0, 0, 3], [1, 0, 0, 0, 0, 0, 0, 8, 0], [0, 0, 4, 2, 0, 9, 0, 0, 5], [9, 4, 0, 0, 0, 0, 6, 0, 8], [0, 0, 0, 8, 0, 0, 0, 9, 0], [0, 0, 0, 0, 0, 0, 0, 7, 0], [7, 2, 1, 9, 0, 8, 0, 6, 0], [0, 3, 0, 0, 2, 7, 1, 0, 0], [4, 0, 0, 0, 0, 3, 0, 0, 0] ]; $sudoku_board = [ [0, 0, 0, 8, 0, 1, 0, 0, 0], [0, 0, 0, 0, 0, 0, 0, 4, 3], [5, 0, 0, 0, 0, 0, 0, 0, 0], [0, 0, 0, 0, 7, 0, 8, 0, 0], [0, 0, 0, 0, 0, 0, 1, 0, 0], [0, 2, 0, 0, 3, 0, 0, 0, 0], [6, 0, 0, 0, 0, 0, 0, 7, 5], [0, 0, 3, 4, 0, 0, 0, 0, 0], [0, 0, 0, 2, 0, 0, 6, 0, 0] ] if 0; $sudoku_board = [ [8, 0, 0, 0, 0, 0, 0, 0, 0], [0, 0, 3, 6, 0, 0, 0, 0, 0], [0, 7, 0, 0, 9, 0, 2, 0, 0], [0, 5, 0, 0, 0, 7, 0, 0, 0], [0, 0, 0, 0, 4, 5, 7, 0, 0], [0, 0, 0, 1, 0, 0, 0, 3, 0], [0, 0, 1, 0, 0, 0, 0, 6, 8], [0, 0, 8, 5, 0, 0, 0, 1, 0], [0, 9, 0, 0, 0, 0, 4, 0, 0] ] if 0; #>>> sub display_grid ($grid) { foreach my $i (0 .. $#$grid) { print "$grid->[$i] "; print " " if ($i + 1) % 3 == 0; print "\n" if ($i + 1) % 9 == 0; print "\n" if ($i + 1) % 27 == 0; } } my $solution = solve_sudoku($sudoku_board); if ($solution) { display_grid([map { @$_ } @$solution]); } else { say "No solution exists."; } ================================================ FILE: Game solvers/visual_memory_test.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 22 September 2019 # https://github.com/trizen # A simple program that can solve the "Visual Memory Test" from Human Benchmark. # https://www.humanbenchmark.com/tests/memory # The program uses the `maim` and `swarp` tools to control the mouse. # See also: # https://github.com/naelstrof/maim # https://tools.suckless.org/x/swarp/ # The current highest level reached by this program is 38. use 5.020; use strict; use warnings; use GD qw(); use Time::HiRes qw(sleep); use experimental qw(signatures); GD::Image->trueColor(1); sub avg { ($_[0] + $_[1] + $_[2]) / 3; } sub img2ascii ($image) { my $size = 1920; my $img = GD::Image->new($image) // return; my ($width, $height) = $img->getBounds; if ($size != 0) { my $scale_width = $size; my $scale_height = int($height / ($width / ($size / 2))); my $resized = GD::Image->new($scale_width, $scale_height); $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height); ($width, $height) = ($scale_width, $scale_height); $img = $resized; } my $avg = 0; my @averages; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $index = $img->getPixel($x, $y); push @averages, avg($img->rgb($index)); $avg += $averages[-1] / $width / $height; } } unpack("(A$width)*", join('', map { $_ < $avg ? 1 : 0 } @averages)); } sub solve (@lines) { my $width_offset = 760; my $height_offset = 130; @lines = @lines[$height_offset - 1 .. 320]; while (@lines and $lines[0] =~ /^1+\z/) { shift @lines; ++$height_offset; } @lines = map { substr($_, $width_offset, 385) } @lines; my $square_height = 0; foreach my $i (0 .. $#lines) { if ($lines[$i] =~ /0/) { ++$square_height; } if ($square_height > 0 and $lines[$i] !~ /0/) { last; } } if ($square_height == 0) { warn "Can't determine square height..."; return; } my $left_index = 0; my $square_width = 0; OUTER: foreach my $i (0 .. 100) { foreach my $line (@lines) { if (substr($line, $i, 1) eq '0') { $left_index = $i; $line =~ /^1*(0+)/; $square_width = length($1); last OUTER; } } } if ($square_width == 0) { warn "Can't determine square width..."; return; } say "Left index: $left_index"; say "Square width: $square_width"; say "Square height: $square_height"; my @grid; my $size = int(length($lines[0]) / $square_width); if ($size < 3) { warn "Can't determine the size of the grid..."; return; } if ($size > 20) { warn "Incorrect size of the grid..."; return; } my $width_gap = 10; my $height_gap = 4; if ($size >= 6) { $width_gap = 9; $height_gap = 3; } if ($size >= 8) { $width_gap = 8; } if ($size >= 10) { $width_gap = 5; } if ($size >= 11) { $width_gap = 4; $height_gap = 2; } say "Size: $size x $size"; foreach my $i (0 .. $size - 1) { foreach my $j (0 .. $size - 1) { my @square; foreach my $line ( @lines[$square_height * $i + $height_gap * $i .. $square_height * $i + $height_gap * $i + $square_height - 1]) { push @square, substr($line, $square_width * $j + $width_gap * $j, $square_width); } $grid[$i][$j] = \@square; } } my @matrix; foreach my $i (0 .. $#grid) { my $row = $grid[$i]; foreach my $j (0 .. $#$row) { my $square = $row->[$j]; my %freq = ('0' => 0, '1' => 0); ++$freq{$_} for split(//, join('', @$square)); $matrix[$i][$j] = ($freq{'0'} > $freq{'1'}) ? 1 : 0; } } say "@$_" for @matrix; foreach my $i (0 .. $#matrix) { foreach my $j (0 .. $#{$matrix[0]}) { if ($matrix[$i][$j]) { my $x = int($width_offset + $square_width * $j + $square_width / 2 + $width_gap * $j); my $y = int(2 * $height_offset + $square_height * 2 * $i + $square_height / 2 + 2 * $height_gap * $i); #say "Changing pointer to ($x, $y)"; system("swarp", $x, $y); #say "Clicking square..."; system("xdotool", "click", "1"); } } } } if (@ARGV) { solve(img2ascii($ARGV[0])); exit; } while (1) { print "Press to take screenshot: "; my $prompt = ; my $sshot = `maim --geometry '1920x700+0+0' --format=jpg /dev/stdout`; my @lines = img2ascii($sshot); sleep 1; solve(@lines); system("swarp", 1700, 800); system("xdotool", "click", "1"); } ================================================ FILE: Games/arrow-key_drawer.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 June 2015 # Edit: 26 February 2023 # Website: https://github.com/trizen # Draw right-angle abstract-art using the arrow-keys. use utf8; use 5.010; use strict; use warnings; use Time::HiRes qw(sleep); use Term::ANSIColor qw(colored); use Term::ReadKey qw(ReadMode ReadLine); binmode(STDOUT, ':utf8'); use constant { VOID => 0, HEAD => 1, BODY => 2, }; use constant { LEFT => [+0, -1], RIGHT => [+0, +1], UP => [-1, +0], DOWN => [+1, +0], }; use constant {BG_COLOR => 'on_black'}; use constant {PEN_COLOR => ('bold green' . ' ' . BG_COLOR)}; use constant { U_HEAD => colored('▲', PEN_COLOR), D_HEAD => colored('▼', PEN_COLOR), L_HEAD => colored('◀', PEN_COLOR), R_HEAD => colored('▶', PEN_COLOR), U_BODY => colored('■', PEN_COLOR), D_BODY => colored('■', PEN_COLOR), L_BODY => colored('■', PEN_COLOR), R_BODY => colored('■', PEN_COLOR), A_VOID => colored(' ', BG_COLOR), }; my $sleep = 0.07; # sleep duration between displays local $| = 1; my $w = eval { `tput cols` } || 80; my $h = eval { `tput lines` } || 24; my $r = "\033[H"; my @grid = map { [map { [VOID] } 1 .. $w] } 1 .. $h; my $dir = LEFT; my @head_pos = ($h / 2, $w / 2); my @tail_pos = ($head_pos[0], $head_pos[1] + 1); $grid[$head_pos[0]][$head_pos[1]] = [HEAD, $dir]; # head sub display { print $r, join( "\n", map { join( "", map { my $t = $_->[0]; my $p = $_->[1] // ''; my $i = $p eq UP ? 0 : $p eq DOWN ? 1 : $p eq LEFT ? 2 : 3; $t == HEAD ? (U_HEAD, D_HEAD, L_HEAD, R_HEAD)[$i] : $t == BODY ? (U_BODY, D_BODY, L_BODY, R_BODY)[$i] : (A_VOID); } @{$_} ) } @grid ); } sub move { # Move the pen head my ($y, $x) = @head_pos; my $new_y = ($y + $dir->[0]) % $h; my $new_x = ($x + $dir->[1]) % $w; my $cell = $grid[$new_y][$new_x]; my $t = $cell->[0]; # Create a new head $grid[$new_y][$new_x] = [HEAD, $dir]; # Replace the current head with body $grid[$y][$x] = [BODY, $dir]; # Save the position of the head @head_pos = ($new_y, $new_x); } ReadMode(3); while (1) { my $key; until (defined($key = ReadLine(-1))) { move(); display(); sleep($sleep); } if ($key eq "\e[A") { $dir = UP } elsif ($key eq "\e[B") { $dir = DOWN } elsif ($key eq "\e[C") { $dir = RIGHT } elsif ($key eq "\e[D") { $dir = LEFT } } ================================================ FILE: Games/asciiplanes ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Created on: 21 August 2012 # Latest edit on: 10 November 2013 # https://github.com/trizen # Find the planes' positions on a grid. (text-based game) use utf8; use 5.010; use strict; use warnings; use Term::ReadLine; use Text::ASCIITable; use List::Util qw(shuffle); binmode(STDOUT, ':utf8'); my $DEBUG = 0; ## Package variables my $pkgname = 'asciiplanes'; my $version = 0.01; ## Game run-time constants my $BOARD_SIZE = 8; my $PLANES_NUM = 3; my @parts = ('head', ('hit') x 7); my @plane_chars = (shuffle('♣', '★', '✠', '❂', '☀', '❤', '❆', '❃', '▣', '▼', '■', '◉', '◆', '▲')); my $wrap_plane = 0; my $hit_char = q{O}; my $miss_char = q{`}; my $use_colors = eval { require Term::ANSIColor; 1; }; sub usage { print <<"EOT"; usage: $0 [options] main: --size=i : length side of the board (default: $BOARD_SIZE) --planes=i : the total number of planes (default: $PLANES_NUM) --wrap! : wrap the plane around the play board (default: $wrap_plane) --hit=s : character used when a plane is hit (default: "$hit_char") --miss=s : character used when a plane is missed (default: "$miss_char") --planeN=s : character used to draw the Nth killed plane (N=[1-99]) --colors! : use ANSI colors (requires Term::ANSIColor) (default: $use_colors); help: --help : print this message and exit --version : print the version number and exit --debug : print some information useful in debugging example: $0 --size=12 --planes=6 --hit='*' EOT exit; } sub version { print "$pkgname $version\n"; exit; } if (@ARGV) { require Getopt::Long; Getopt::Long::GetOptions( 'board-size|size=i' => \$BOARD_SIZE, 'planes-num=i' => \$PLANES_NUM, 'hit-char=s' => \$hit_char, 'miss-char=s' => \$miss_char, 'wrap!' => \$wrap_plane, 'colors!' => \$use_colors, 'help|h|?' => \&usage, 'version|v|V' => \&version, 'debug!' => \$DEBUG, (map { ; "p$_|plane$_=s" => \$plane_chars[$_ - 1] } 1 .. 99), ) or die("$0: error in command line arguments!\n"); } @plane_chars = grep { defined } @plane_chars; ## The play-board of the game, and some other arrays #--------------------------------------------------------------- my @play_board = map { [(undef) x $BOARD_SIZE] } 1 .. $BOARD_SIZE; my @info_board = map { [(q{ }) x $BOARD_SIZE] } 1 .. $BOARD_SIZE; my %letters; for (0 .. $#play_board) { state $char = 'a'; $letters{$char++} = $_; } #--------------------------------------------------------------- sub pointers { my ($board, $x, $y, $indices) = @_; map { my ($row, $col) = ($x + $_->[0], $y + $_->[1]); if ($wrap_plane) { $row %= $BOARD_SIZE; $col %= $BOARD_SIZE; } $row < $BOARD_SIZE or return; $col < $BOARD_SIZE or return; $row >= 0 or return; $col >= 0 or return; \$board->[$row][$col] }[0, 0], grep { ref($_) eq 'ARRAY' } @{$indices}; } sub up { my ($board, $x, $y) = @_; #<<< return pointers($board, $x, $y, [ '[+0, +0]', [+1, -1], [+1, +0], [+1, +1], [+2, +0], [+3, -1], [+3, +0], [+3, +1], ]); #>>> } sub down { my ($board, $x, $y) = @_; #<<< return pointers($board, $x, $y, [ [-3, -1], [-3, +0], [-3, +1], [-2, +0], [-1, -1], [-1, +0], [-1, +1], '[+0, +0]', ]); #>>> } sub left { my ($board, $x, $y) = @_; #<<< return pointers($board, $x, $y, [ [-1, +1], [-1, +3], '[+0, +0]', [+0, +1], [+0, +2], [+0, +3], [+1, +1], [+1, +3], ]); #>>> } sub right { my ($board, $x, $y) = @_; #<<< return pointers($board, $x, $y, [ [-1, -3], [-1, -1], [+0, -3], [+0, -2], [+0, -1], '[+0, +0]', [+1, -3], [+1, -1], ]); #>>> } sub assign { my %opt = @_; my $plane = $opt{plane}; $#{$plane} == -1 && return; if (not $opt{change}) { foreach my $point (@{$plane}) { defined(${$point}) && return; } } foreach my $i (0 .. $#{$plane}) { ${$plane->[$i]} = $opt{data}->[$i]; } return 1; } sub print_ascii_table { my $table = Text::ASCIITable->new({headingText => "$pkgname $version"}); $table->setCols(' ', 1 .. $BOARD_SIZE); my $char = 'a'; foreach my $row (@info_board) { $table->addRow([$char++, @{$row}]); $table->addRowLine(); } my $t = $table->drawit; if ($use_colors) { my $hit_color = Term::ANSIColor::colored($hit_char, "bold red"); my $miss_color = Term::ANSIColor::colored($miss_char, "yellow"); $t =~ s{\Q$hit_char\E}{$hit_color}g; $t =~ s{\Q$miss_char\E}{$miss_color}g; foreach my $c (@plane_chars) { my $plane_color = Term::ANSIColor::colored($c, "bold green"); $t =~ s{\Q$c\E}{$plane_color}g; } } say $t; } my $count = 0; my @directions = (\&up, \&down, \&left, \&right); { my $x = int rand scalar(@play_board); my $y = int rand scalar(@{$play_board[0]}); my $rand = int rand scalar(@directions); my $code = $directions[$rand]; assign( change => 0, plane => [$code->(\@play_board, $x, $y)], data => [map { "$_$rand" } @parts], ) || redo; if ($DEBUG) { my $abc = 'a'; ++$abc for (1 .. $x); say "$rand: ", $abc, $y + 1; } redo if ++$count < $PLANES_NUM; } ## MAIN my $tries = 0; my $start_time = time; my $term = Term::ReadLine->new("ASCII Airplanes Game"); print_ascii_table(); while ($count > 0) { print "=>> Your guess (ex: d4)\n"; my $input = lc($term->readline("> ") // last); last if $input eq 'q' or $input eq 'quit'; my ($letter, $y) = $input =~ /^\h*([a-z]+)\D*([0-9]+)/; if ( not defined $letter or not exists $letters{$letter} or not defined $y or $y < 1 or $y > $BOARD_SIZE) { warn "\n[!] Invalid input!\n"; next; } $y -= 1; ++$tries; my $x = $letters{$letter}; my $point = $play_board[$x][$y]; if (not defined $point) { $info_board[$x][$y] = $miss_char; } elsif ($point =~ /^head(\d)$/i) { my $dir = $1; my $item = $plane_chars[($PLANES_NUM - $count) % (1 + $#plane_chars)]; my $code = $directions[$dir]; foreach my $board (\@play_board, \@info_board) { assign( change => 1, data => [($item) x 8], plane => [$code->($board, $x, $y)], ) || die "$0: unexpected error!"; } --$count; } elsif ($point =~ /^hit\d$/i) { $info_board[$x][$y] = $hit_char; } } continue { print_ascii_table(); } printf "** Info: %d tries in %d seconds\n", $tries, time - $start_time; if ($count == 0) { say "** Congratulations! All the planes are destroyed!"; } ================================================ FILE: Games/snake_game.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 June 2015 # Website: https://github.com/trizen # The snake game. (with colors + Unicode) use utf8; use 5.010; use strict; use warnings; use Time::HiRes qw(sleep); use Term::ANSIColor qw(colored); use Term::ReadKey qw(ReadMode ReadLine); binmode(STDOUT, ':utf8'); use constant { VOID => 0, HEAD => 1, BODY => 2, TAIL => 3, FOOD => 4, }; use constant { LEFT => [+0, -1], RIGHT => [+0, +1], UP => [-1, +0], DOWN => [+1, +0], }; use constant {BG_COLOR => 'on_black'}; use constant { SNAKE_COLOR => ('bold green' . ' ' . BG_COLOR), FOOD_COLOR => ('red' . ' ' . BG_COLOR), }; use constant { U_HEAD => colored('▲', SNAKE_COLOR), D_HEAD => colored('▼', SNAKE_COLOR), L_HEAD => colored('◀', SNAKE_COLOR), R_HEAD => colored('▶', SNAKE_COLOR), U_BODY => colored('╹', SNAKE_COLOR), D_BODY => colored('╻', SNAKE_COLOR), L_BODY => colored('╴', SNAKE_COLOR), R_BODY => colored('╶', SNAKE_COLOR), U_TAIL => colored('╽', SNAKE_COLOR), D_TAIL => colored('╿', SNAKE_COLOR), L_TAIL => colored('╼', SNAKE_COLOR), R_TAIL => colored('╾', SNAKE_COLOR), A_VOID => colored(' ', BG_COLOR), A_FOOD => colored('❇', FOOD_COLOR), }; my $sleep = 0.05; # sleep duration between displays my $food_num = 1; # number of initial food sources local $| = 1; my $w = eval { `tput cols` } || 80; my $h = eval { `tput lines` } || 24; my $r = "\033[H"; my @grid = map { [map { [VOID] } 1 .. $w] } 1 .. $h; my $dir = LEFT; my @head_pos = ($h / 2, $w / 2); my @tail_pos = ($head_pos[0], $head_pos[1] + 1); $grid[$head_pos[0]][$head_pos[1]] = [HEAD, $dir]; # head $grid[$tail_pos[0]][$tail_pos[1]] = [TAIL, $dir]; # tail sub create_food { my ($food_x, $food_y); do { $food_x = rand($w); $food_y = rand($h); } while ($grid[$food_y][$food_x][0] != VOID); $grid[$food_y][$food_x][0] = FOOD; } create_food() for (1 .. $food_num); sub display { print $r, join( "\n", map { join( "", map { my $t = $_->[0]; my $p = $_->[1] // ''; my $i = $p eq UP ? 0 : $p eq DOWN ? 1 : $p eq LEFT ? 2 : 3; $t == HEAD ? (U_HEAD, D_HEAD, L_HEAD, R_HEAD)[$i] : $t == BODY ? (U_BODY, D_BODY, L_BODY, R_BODY)[$i] : $t == TAIL ? (U_TAIL, D_TAIL, L_TAIL, R_TAIL)[$i] : $t == FOOD ? (A_FOOD) : (A_VOID); } @{$_} ) } @grid ); } sub move { my $grew = 0; # Move the head { my ($y, $x) = @head_pos; my $new_y = ($y + $dir->[0]) % $h; my $new_x = ($x + $dir->[1]) % $w; my $cell = $grid[$new_y][$new_x]; my $t = $cell->[0]; if ($t == BODY or $t == TAIL) { die "Game over!\n"; } elsif ($t == FOOD) { create_food(); $grew = 1; } # Create a new head $grid[$new_y][$new_x] = [HEAD, $dir]; # Replace the current head with body $grid[$y][$x] = [BODY, $dir]; # Save the position of the head @head_pos = ($new_y, $new_x); } # Move the tail if (not $grew) { my ($y, $x) = @tail_pos; my $pos = $grid[$y][$x][1]; my $new_y = ($y + $pos->[0]) % $h; my $new_x = ($x + $pos->[1]) % $w; $grid[$y][$x][0] = VOID; # erase the current tail $grid[$new_y][$new_x][0] = TAIL; # create a new tail # Save the position of the tail @tail_pos = ($new_y, $new_x); } } ReadMode(3); while (1) { my $key; until (defined($key = ReadLine(-1))) { move(); display(); sleep($sleep); } if ($key eq "\e[A" and $dir ne DOWN ) { $dir = UP } elsif ($key eq "\e[B" and $dir ne UP ) { $dir = DOWN } elsif ($key eq "\e[C" and $dir ne LEFT ) { $dir = RIGHT } elsif ($key eq "\e[D" and $dir ne RIGHT) { $dir = LEFT } } ================================================ FILE: Generators/bernoulli_numbers_formulas.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 September 2015 # Website: https://github.com/trizen use 5.014; use strict; use warnings; use Math::AnyNum qw(:overload); # Translation of: # https://en.wikipedia.org/wiki/Bernoulli_number#Algorithmic_description sub bernoulli_number { my ($n) = @_; # return 0 if $n > 1 && $n % 2; # Bn = 0 for all odd n > 1 my @A; for my $m (0 .. $n) { $A[$m] = 1 / ($m + 1); for (my $j = $m ; $j > 0 ; $j--) { $A[$j - 1] = ((($j == 1 ? '' : "$j*") . '(' . join('-', ($A[$j - 1], $A[$j])) . ')') =~ s/^\((.*?)\)\z/$1/r); } } return $A[0]; # which is Bn } foreach my $i (0 .. 6) { printf("B(%d) = %s\n", $i, bernoulli_number($i)); } __END__ B(0) = 1 B(1) = 1-1/2 B(2) = 1-1/2-2*(1/2-1/3) B(3) = 1-1/2-2*(1/2-1/3)-2*(2*(1/2-1/3)-3*(1/3-1/4)) B(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))) B(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)))) B(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))))) ================================================ FILE: Generators/faulhaber_s_formula_symbolic.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10 February 2016 # Website: https://github.com/trizen # The script generates formulas for calculating the sum # of consecutive numbers raised to a given power, such as: # 1^p + 2^p + 3^p + ... + n^p # where p is a positive integer. # See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula use 5.010; use strict; use warnings; use Math::Algebra::Symbols; # This function returns the nth Bernoulli number # See: https://en.wikipedia.org/wiki/Bernoulli_number sub bernoulli_number { my ($n) = @_; return 0 if $n > 1 && $n % 2; # Bn = 0 for all odd n > 1 my @A; for my $m (0 .. $n) { $A[$m] = symbols(1) / ($m + 1); for (my $j = $m ; $j > 0 ; $j--) { $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]); } } return $A[0]; # which is Bn } # The binomial coefficient # See: https://en.wikipedia.org/wiki/Binomial_coefficient sub binomial { my ($n, $k) = @_; $k == 0 || $n == $k ? 1 : binomial($n-1, $k-1) + binomial($n-1, $k); } # The Faulhaber's formula # See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula sub faulhaber_s_formula { my ($p) = @_; my $formula = 0; for my $j (0 .. $p) { $formula += (binomial($p + 1, $j) * bernoulli_number($j)) * symbols('n')**($p + 1 - $j); } (symbols(1) / ($p+1) * $formula) =~ s/\$n/n/gr =~ s/\*\*/^/gr; } foreach my $i (0 .. 10) { say "$i: ", faulhaber_s_formula($i); } ================================================ FILE: Generators/faulhaber_s_formulas_expanded.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 September 2015 # Website: https://github.com/trizen # The script generates formulas for calculating the sum # of consecutive numbers raised to a given power, such as: # 1^p + 2^p + 3^p + ... + n^p # where p is a positive integer. # See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula # To simplify the formulas, use Wolfram Alpha: # https://www.wolframalpha.com/ use 5.010; use strict; use warnings; use Memoize qw( memoize ); memoize('binomial'); memoize('factorial'); memoize('bern_helper'); memoize('bernoulli_number'); # Factorial # See: https://en.wikipedia.org/wiki/Factorial sub factorial { my ($n) = @_; return 1 if $n == 0; my $f = $n; while ($n-- > 1) { $f = "$f*$n"; } return $f; } # Binomial coefficient # See: https://en.wikipedia.org/wiki/Binomial_coefficient sub binomial { my ($n, $k) = @_; ## This line expands the factorials #return "(".factorial($n) .")" . "/((" . factorial($k).")*(". factorial($n-$k) . "))"; ## This line expands the binomial coefficients into factorials return "$n!/($k!*" . ($n - $k) . "!)"; ## This line computes the binomial coefficients #$k == 0 || $n == $k ? 1.0 : binomial($n - 1, $k - 1) + binomial($n - 1, $k); } # Bernoulli numbers # See: https://en.wikipedia.org/wiki/Bernoulli_number#Recursive_definition sub bern_helper { my ($n, $k) = @_; binomial($n, $k) . "*(" . (bernoulli_number($k) . "/" . ($n - $k + 1)) . ")"; } sub bern_diff { my ($n, $k, $d) = @_; $n < $k ? $d : bern_diff($n, $k + 1, "($d-" . bern_helper($n + 1, $k) . ")"); } sub bernoulli_number { my ($n) = @_; $n > 0 ? bern_diff($n - 1, 0, 1.0) : 1.0; } # Faulhaber's formula # See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula sub faulhaber_s_formula { my ($p, $n) = @_; my @formula; for my $j (0 .. $p) { push @formula, ('(' . (binomial($p + 1, $j) . "*" . bernoulli_number($j)) . ')') . '*' . "n^" . ($p + 1 - $j); } my $formula = join(' + ', @formula); "1/" . ($p + 1) . " * ($formula)"; } for my $i (0 .. 5) { printf "%d => %s\n", $i, faulhaber_s_formula($i + 0); } __END__ 0 => 1/1 * ((1!/(0!*1!)*1)*n^1) 1 => 1/2 * ((2!/(0!*2!)*1)*n^2 + (2!/(1!*1!)*(1-1!/(0!*1!)*(1/2)))*n^1) 2 => 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) 3 => 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) 4 => 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) 5 => 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) ================================================ FILE: Generators/faulhaber_s_formulas_expanded_2.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 September 2015 # Website: https://github.com/trizen # The script generates formulas for calculating the sum # of consecutive numbers raised to a given power, such as: # 1^p + 2^p + 3^p + ... + n^p # where p is a positive integer. # See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula # To simplify the formulas, use Wolfram Alpha: # https://www.wolframalpha.com/ use 5.010; use strict; use warnings; use Math::AnyNum qw(:overload); use Memoize qw( memoize ); memoize('binomial'); memoize('factorial'); memoize('bernoulli_number'); # Factorial # See: https://en.wikipedia.org/wiki/Factorial sub factorial { my ($n) = @_; return 1 if $n == 0; my $f = $n; while ($n-- > 1) { $f = "$f*$n"; } return $f; } # Binomial coefficient # See: https://en.wikipedia.org/wiki/Binomial_coefficient sub binomial { my ($n, $k) = @_; ## This line expands the factorials #return "(".factorial($n) .")" . "/((" . factorial($k).")*(". factorial($n-$k) . "))"; ## This line expands the binomial coefficients into factorials return "$n!/($k!*" . ($n - $k) . "!)"; ## This line computes the binomial coefficients #$k == 0 || $n == $k ? 1.0 : binomial($n - 1, $k - 1) + binomial($n - 1, $k); } # Bernoulli numbers # See: https://en.wikipedia.org/wiki/Bernoulli_number#Algorithmic_description sub bernoulli_number { my ($n) = @_; # return 0 if $n > 1 && $n % 2; # Bn = 0 for all odd n > 1 my @A; for my $m (0 .. $n) { $A[$m] = 1 / ($m + 1); for (my $j = $m ; $j > 0 ; $j--) { $A[$j - 1] = "$j*" . '(' . join('-', ($A[$j - 1], $A[$j])) . ')'; } } return $A[0]; # which is Bn } # Faulhaber's formula # See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula sub faulhaber_s_formula { my ($p, $n) = @_; my @formula; for my $j (0 .. $p) { push @formula, ('(' . (binomial($p + 1, $j) . "*" . bernoulli_number($j)) . ')') . '*' . "n^" . ($p + 1 - $j); } my $formula = join(' + ', @formula); "1/" . ($p + 1) . " * ($formula)"; } for my $i (0 .. 5) { printf "%d => %s\n", $i, faulhaber_s_formula($i + 0); } __END__ 0 => 1/1 * ((1!/(0!*1!)*1)*n^1) 1 => 1/2 * ((2!/(0!*2!)*1)*n^2 + (2!/(1!*1!)*1*(1-1/2))*n^1) 2 => 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) 3 => 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) 4 => 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) 5 => 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) ================================================ FILE: Generators/faulhaber_s_formulas_generator.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 03 September 2015 # Website: https://github.com/trizen # The script generates formulas for calculating the sum # of consecutive numbers raised to a given power, such as: # 1^p + 2^p + 3^p + ... + n^p # where p is a positive integer. # See also: # https://en.wikipedia.org/wiki/Faulhaber%27s_formula # For simplifying the formulas, we can use Wolfram|Alpha: # https://www.wolframalpha.com/ use 5.010; use strict; use warnings; use Math::AnyNum qw(:overload binomial); # This function returns the nth Bernoulli number # See: https://en.wikipedia.org/wiki/Bernoulli_number sub bernoulli_number { my ($n) = @_; return 0 if $n > 1 && $n % 2; # Bn = 0 for all odd n > 1 my @A; for my $m (0 .. $n) { $A[$m] = 1 / ($m + 1); for (my $j = $m ; $j > 0 ; $j--) { $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]); } } return $A[0]; # which is Bn } # The Faulhaber's formula # See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula sub faulhaber_s_formula { my ($p) = @_; my @formula; for my $j (0 .. $p) { push @formula, ('(' . (binomial($p + 1, $j) * bernoulli_number($j)) . ')') . '*' . "n^" . ($p + 1 - $j); } my $formula = join(' + ', grep { !/\(0\)\*/ } @formula); $formula =~ s{\(1\)\*}{}g; $formula =~ s{\^1\b}{}g; "1/" . ($p + 1) . " * ($formula)"; } foreach my $i (0 .. 10) { say "$i: ", faulhaber_s_formula($i); } __END__ 0: 1/1 * (n) 1: 1/2 * (n^2 + n) 2: 1/3 * (n^3 + (3/2)*n^2 + (1/2)*n) 3: 1/4 * (n^4 + (2)*n^3 + n^2) 4: 1/5 * (n^5 + (5/2)*n^4 + (5/3)*n^3 + (-1/6)*n) 5: 1/6 * (n^6 + (3)*n^5 + (5/2)*n^4 + (-1/2)*n^2) 6: 1/7 * (n^7 + (7/2)*n^6 + (7/2)*n^5 + (-7/6)*n^3 + (1/6)*n) 7: 1/8 * (n^8 + (4)*n^7 + (14/3)*n^6 + (-7/3)*n^4 + (2/3)*n^2) 8: 1/9 * (n^9 + (9/2)*n^8 + (6)*n^7 + (-21/5)*n^5 + (2)*n^3 + (-3/10)*n) 9: 1/10 * (n^10 + (5)*n^9 + (15/2)*n^8 + (-7)*n^6 + (5)*n^4 + (-3/2)*n^2) 10: 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) ================================================ FILE: Generators/parsing_and_code_gen.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 21 December 2015 # Website: https://github.com/trizen # A very basic parser and a Perl code generator. use 5.010; use strict; use warnings; # ## The parser # sub parse_expr { local *_ = $_[0]; # Whitespace /\G\s+/gc; # Number if (/\G([-+]?[0-9]+(?:\.[0-9]+)?)\b/gc) { return bless {value => $1}, 'Number'; } # Variable declaration if (/\Gvar\b/gc) { /\G\s+(\w+)/gc || die "expected a variable name after `var`"; return bless {name => $1}, 'Variable'; } # Identifier if (/\G(\w+)/gc) { return bless {name => $1}, 'Identifier'; } # Nested expression if (/\G\(/gc) { return parse($_[0]); } return; } sub parse { local *_ = $_[0]; my %ast; while (1) { /\G\s+/gc; # Prefix operator if (/\Gsay\b/gc) { my $arg = parse_expr($_[0]); push @{$ast{main}}, {self => bless({expr => {self => $arg}}, 'Say')}; } # Expression my $expr = parse_expr($_[0]); if (defined $expr) { push @{$ast{main}}, {self => $expr}; # Binary operator while (m{\G\s*([-\^+*/=])}gc) { my $op = $1; # Expression my $arg = parse_expr($_[0]); push @{$ast{main}[-1]{call}}, {op => $op, arg => {self => $arg}}; } next; } # End of nested expression if (/\G\)/gc) { return \%ast; } # End of code if (/\G\z/gc) { return \%ast; } die "Syntax error at -->", substr($_, pos($_), 10) . "\n",; } return \%ast; } # ## The code generator # sub generate_expr { my ($expr) = @_; my $code = ''; my $obj = $expr->{self}; my $ref = ref($obj); if ($ref eq 'HASH') { $code = '(' . generate($obj) . ')'; } elsif ($ref eq 'Number') { $code = $obj->{value}; } elsif ($ref eq 'Variable') { $code = 'my $' . $obj->{name}; } elsif ($ref eq 'Identifier') { $code = '$' . $obj->{name}; } elsif ($ref eq 'Say') { $code = 'print(' . generate_expr($obj->{expr}) . ', "\n")'; } # Check for a call operator if (exists $expr->{call}) { foreach my $call (@{$expr->{call}}) { if (exists $call->{op}) { my $op = $call->{op}; $code .= ' '; if ($op eq '^') { $code .= '**'; } else { $code .= $op; } $code .= ' '; } if (exists $call->{arg}) { $code .= generate_expr($call->{arg}); } } } return $code; } sub generate { my ($ast) = @_; my @statements; foreach my $statement (@{$ast->{main}}) { push @statements, generate_expr($statement); } return join(";\n", @statements); } # ## Example # my $code = <<'EOT'; var x = 42 var y = (81 / 3) say (x^2 * (3+y) - 1) EOT my $ast = parse(\$code); # parses the code and returns the AST eval { require Data::Dump; Data::Dump::pp($ast); # displays the AST (if Data::Dump is installed) }; say generate($ast); # generates code from the AST and prints it ================================================ FILE: Generators/powers_of_factorial.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 July 2016 # Website: https://github.com/trizen # A shortcut algorithm for finding the prime powers of n! # without computing the n-factorial in the first place. # Example: # 6! is equal with: 2^4 * 3^2 * 5 use 5.020; use strict; use warnings; use experimental qw(signatures); use ntheory qw(forprimes vecsum todigits); sub factorial_power ($n, $p) { ($n - vecsum(todigits($n, $p))) / ($p - 1); } sub factorial_powers ($n) { my $p = 0; my @powers; forprimes { if ($p == 1) { push @powers, $_; } else { push @powers, ($p = factorial_power($n, $_)) == 1 ? $_ : "$_^$p"; } } $n; @powers ? join(' * ', @powers) : '1'; } for (0 .. 25) { say "$_! = ", factorial_powers($_); } __END__ 0! = 1 1! = 1 2! = 2 3! = 2 * 3 4! = 2^3 * 3 5! = 2^3 * 3 * 5 6! = 2^4 * 3^2 * 5 7! = 2^4 * 3^2 * 5 * 7 8! = 2^7 * 3^2 * 5 * 7 9! = 2^7 * 3^4 * 5 * 7 10! = 2^8 * 3^4 * 5^2 * 7 11! = 2^8 * 3^4 * 5^2 * 7 * 11 12! = 2^10 * 3^5 * 5^2 * 7 * 11 13! = 2^10 * 3^5 * 5^2 * 7 * 11 * 13 14! = 2^11 * 3^5 * 5^2 * 7^2 * 11 * 13 15! = 2^11 * 3^6 * 5^3 * 7^2 * 11 * 13 16! = 2^15 * 3^6 * 5^3 * 7^2 * 11 * 13 17! = 2^15 * 3^6 * 5^3 * 7^2 * 11 * 13 * 17 18! = 2^16 * 3^8 * 5^3 * 7^2 * 11 * 13 * 17 19! = 2^16 * 3^8 * 5^3 * 7^2 * 11 * 13 * 17 * 19 20! = 2^18 * 3^8 * 5^4 * 7^2 * 11 * 13 * 17 * 19 21! = 2^18 * 3^9 * 5^4 * 7^3 * 11 * 13 * 17 * 19 22! = 2^19 * 3^9 * 5^4 * 7^3 * 11^2 * 13 * 17 * 19 23! = 2^19 * 3^9 * 5^4 * 7^3 * 11^2 * 13 * 17 * 19 * 23 24! = 2^22 * 3^10 * 5^4 * 7^3 * 11^2 * 13 * 17 * 19 * 23 25! = 2^22 * 3^10 * 5^6 * 7^3 * 11^2 * 13 * 17 * 19 * 23 ================================================ FILE: Generators/random_lsystem_generator.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 09 May 2016 # Website: https://github.com/trizen # Generate a random L-System. use 5.010; use strict; use warnings; use Math::AnyNum qw(:overload is_power); use ntheory qw(is_prime factor); my @vars = ('F', 'G', 'H'); sub is_triangular { my ($x) = @_; int(sqrt(8 * $x + 1))**2 == (8 * $x + 1); } sub is_square { my ($x) = @_; int(sqrt($x))**2 == $x; } sub divide { my ($str, $i) = @_; my @parts = ($str); for (1 .. @vars - 1) { my $rand; my $i = int(rand(@parts)); my $part = $parts[$i]; my $count = 0; do { $rand = int(rand(length($part))); if (++$count > 10) { generate(); return; } } while ( do { my $s = substr($part, 0, $rand); ($s =~ tr/[//) != ($s =~ tr/]//); } ); my ($x, $y) = (substr($part, 0, $rand), substr($part, $rand)); splice(@parts, $i, 1, $x, $y); } foreach my $part (@parts) { if ( $part eq '' or not $part =~ /\w/ # TODO: check each path (not only the first one) or (($parts[0] =~ tr/A-Z//cdsr) =~ /^$vars[0]+\z/o and @vars > 1) ) { $i ||= 0; if ($i < 10) { return divide($str, $i + 1); } else { generate(); return; } } } return @parts; } sub generate { my $start = int(rand(1000)) + 0; my $limit = $start + 10; my $deviation = 50; my @open; my $str = ''; for ( my $n = $start ; $n <= $limit ? 1 : @open ? do { $limit += 1; if ($limit - $start > $deviation) { return generate() } 1; } : 0 ; $n++ ) { if (is_triangular($n) or is_square($n)) { for (1 .. rand(5)) { $str .= ('+', '-')[rand(2)]; } } if (is_prime($n) or is_power($n)) { if (@open and rand(1) < 0.5) { $str .= ']'; pop @open; } else { $str .= '['; push @open, 1; } } for (1 .. rand(5)) { if (rand(1) < 0.5) { $str .= $vars[rand @vars]; } } if (rand(1) < 0.5) { $str .= ('+', '-')[rand(2)]; } } my @parts = divide($str); foreach my $i (0 .. $#parts) { say "$vars[$i] => \"$parts[$i]\","; } } generate(); ================================================ FILE: Generators/semiprime_equationization_C_generator.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10 July 2015 # Website: https://github.com/trizen # Generate a C program to compute the prime factors of a semiprime number. use 5.016; use strict; use integer; use warnings; sub semiprime_equationization { my ($semiprime, $xlen, $ylen) = @_; $xlen -= 1; $ylen -= 1; my @map; my @result; my $mem = '0'; my %x_loops; foreach my $i (0 .. $xlen) { my $start = $i == $xlen ? 1 : 0; $x_loops{"x$i"} = "for (unsigned int x$i = $start; x$i < 10; ++x$i) {"; } my %y_loops; foreach my $i (0 .. $ylen) { my $start = $i == $ylen ? 1 : 0; $y_loops{"y$i"} = "for (unsigned int y$i = $start; y$i < 10; ++y$i) {"; } my %vars; foreach my $j (0 .. $ylen) { foreach my $i (0 .. $xlen) { my $expr = '(' . join(' + ', "(x$i * y$j)", grep { $_ ne '0' } $mem) . ')'; $vars{"xy$i$j"} = $expr; my $n = "xy$i$j"; if ($i == $xlen) { push @{$map[$j]}, "($n % 10)", "($n / 10)"; $mem = '0'; } else { push @{$map[$j]}, "($n % 10)"; $mem = "($n / 10)"; } } my $n = $ylen - $j; if ($n > 0) { push @{$map[$j]}, ((0) x $n); } my $m = $ylen - $n; if ($m > 0) { unshift @{$map[$j]}, ((0) x $m); } } my @number = reverse split //, $semiprime; my @mrange = (0 .. $#map); my $end = $xlen + $ylen + 1; my %seen; my $loop_init = sub { my ($str) = @_; while ($str =~ /\b(y\d+)/g) { if (not $seen{$1}++) { my $init = $y_loops{$1}; push @result, $init; } } while ($str =~ /\b(x\d+)/g) { if (not $seen{$1}++) { my $init = $x_loops{$1}; push @result, $init; } } }; my $initializer = sub { my ($str) = @_; $loop_init->($str); while ($str =~ /\b(xy\d+)/g) { if (not $seen{$1}++) { my $init = "const unsigned int $1 = $vars{$1};"; __SUB__->($init); push @result, $init; } } }; foreach my $i (0 .. $#number) { my $expr = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')'; $initializer->($expr); push @result, "const unsigned int n$i = $expr;"; my $n = "n$i"; if ($i == $#number) { push @result, qq/if ($number[$i] == $n) { printf("Cracked: / . ("%d" x ($xlen + 1)) . (" * ") . ("%d" x ($ylen + 1)) . qq/\\n", / . join(", ", (map { "x$_" } reverse(0 .. $xlen)), (map { "y$_" } reverse(0 .. $ylen))) . qq/); return 0; }/; } elsif ($i == 0) { push @result, "if ($number[$i] != $n) { continue; }"; $mem = '0'; } else { push @result, "if ($number[$i] != ($n % 10)) { continue; }"; $mem = "($n / 10)"; } } unshift @result, "#include ", "int main() {"; push @result, "}" x (1 + $xlen + 1 + $ylen + 1); return @result; } # 71 * 43 #say for semiprime_equationization('3053', 2, 2); # 251 * 197 #say for semiprime_equationization('49447', 3, 3); # 7907 * 4999 say for semiprime_equationization('39527093', 4, 4); # 472882049 * 472882049 #say for semiprime_equationization('223617432266438401', 9, 9); # 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061 #say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50); ================================================ FILE: Generators/semiprime_equationization_Perl_generator.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10 July 2015 # Website: https://github.com/trizen # Generate a Perl program to compute the prime factors of a semiprime number. use 5.016; use strict; use integer; use warnings; sub semiprime_equationization { my ($semiprime, $xlen, $ylen) = @_; $xlen -= 1; $ylen -= 1; my @map; my @result; my $mem = '0'; my %x_loops; foreach my $i (0 .. $xlen) { my $start = $i == $xlen ? 1 : 0; if ($i == 0) { $x_loops{"x$i"} = "for (my \$x$i = 1; \$x$i < 10; \$x$i += 2) {"; } else { $x_loops{"x$i"} = "for my \$x$i ($start .. 9) {"; } } my %y_loops; foreach my $i (0 .. $ylen) { my $start = $i == $ylen ? 1 : 0; if ($i == 0) { $y_loops{"y$i"} = "for (my \$y$i = 1; \$y$i < 10; \$y$i += 2) {"; } else { $y_loops{"y$i"} = "for my \$y$i ($start .. 9) {"; } } my %vars; foreach my $j (0 .. $ylen) { foreach my $i (0 .. $xlen) { my $expr = '(' . join(' + ', "(\$x$i * \$y$j)", grep { $_ ne '0' } $mem) . ')'; $vars{"xy$i$j"} = $expr; my $n = "\$xy$i$j"; if ($i == $xlen) { push @{$map[$j]}, "($n % 10)", "($n / 10)"; $mem = '0'; } else { push @{$map[$j]}, "($n % 10)"; $mem = "($n / 10)"; } } my $n = $ylen - $j; if ($n > 0) { push @{$map[$j]}, ((0) x $n); } my $m = $ylen - $n; if ($m > 0) { unshift @{$map[$j]}, ((0) x $m); } } my @number = reverse split //, $semiprime; my @mrange = (0 .. $#map); my $end = $xlen + $ylen + 1; my %seen; my $loop_init = sub { my ($str) = @_; while ($str =~ /\$(y\d+)/g) { if (not $seen{$1}++) { my $init = $y_loops{$1}; push @result, $init; } } while ($str =~ /\$(x\d+)/g) { if (not $seen{$1}++) { my $init = $x_loops{$1}; push @result, $init; } } }; my $initializer = sub { my ($str) = @_; $loop_init->($str); while ($str =~ /\$(xy\d+)/g) { if (not $seen{$1}++) { my $init = "my \$$1 = $vars{$1};"; __SUB__->($init); push @result, $init; } } }; foreach my $i (0 .. $#number) { my $expr = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')'; $initializer->($expr); push @result, "my \$n$i = $expr;"; my $n = "\$n$i"; if ($i == $#number) { push @result, qq/if ($number[$i] == $n) { printf("Cracked: / . ("%d" x ($xlen + 1)) . (" * ") . ("%d" x ($ylen + 1)) . qq/\\n", / . join(", ", (map { "\$x$_" } reverse(0 .. $xlen)), (map { "\$y$_" } reverse(0 .. $ylen))) . qq/); exit 0; }/; } elsif ($i == 0) { push @result, "if ($number[$i] == $n) {"; $mem = '0'; } else { push @result, "if ($number[$i] == ($n % 10)) {"; $mem = "($n / 10)"; } } unshift @result, ('use integer;', 'use strict;', 'use warnings;'); push @result, "}" x (1 + $xlen + 1 + $ylen + $#number); return @result; } # 71 * 43 #say for semiprime_equationization('3053', 2, 2); # 251 * 197 #say for semiprime_equationization('49447', 3, 3); # 7907 * 4999 say for semiprime_equationization('39527093', 4, 4); # 472882049 * 472882049 #say for semiprime_equationization('223617432266438401', 9, 9); # 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061 #say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50); ================================================ FILE: Generators/zeta_2n_generator.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 06 September 2015 # Website: https://github.com/trizen # Generate closed-form formulas for zeta(2n). # See also: https://en.wikipedia.org/wiki/Riemann_zeta_function use 5.010; use strict; use warnings; use Math::AnyNum qw(:overload factorial); sub bernoulli_number { my ($n) = @_; return 0 if $n > 1 && $n % 2; # Bn = 0 for all odd n > 1 my @A; for my $m (0 .. $n) { $A[$m] = 1 / ($m + 1); for (my $j = $m ; $j > 0 ; $j--) { $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]); } } return $A[0]; # which is Bn } sub zeta_2n { my ($n2) = 2 * $_[0]; join('', (bernoulli_number($n2) * (-1)**($_[0] + 1) * 2**($n2 - 1) / factorial($n2)), " * pi^$n2"); } for my $i (1 .. 10) { say "zeta(", 2 * $i, ") = ", zeta_2n($i); } __END__ zeta(2) = 1/6 * pi^2 zeta(4) = 1/90 * pi^4 zeta(6) = 1/945 * pi^6 zeta(8) = 1/9450 * pi^8 zeta(10) = 1/93555 * pi^10 zeta(12) = 691/638512875 * pi^12 zeta(14) = 2/18243225 * pi^14 zeta(16) = 3617/325641566250 * pi^16 zeta(18) = 43867/38979295480125 * pi^18 zeta(20) = 174611/1531329465290625 * pi^20 ================================================ FILE: Greppers/marif ================================================ #!/usr/bin/perl # Copyright (C) 2012 Daniel "Trizen" Șuteu # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # #------------------------------------------------------- # Appname: marif # Created on: 25 January 2012 # Latest edit on: 13 November 2012 # https://github.com/trizen #------------------------------------------------------- use 5.010; use utf8; use strict; use warnings; use open IO => ':utf8'; use Getopt::Std qw(getopts); my %opts; getopts('tlvesr:h', \%opts); my $tree = $opts{t}; my $last = $opts{l}; my $verbose = $opts{v}; my $exit = $opts{e}; my $slurp = $opts{s}; my $regexp = $opts{r}; sub usage { print <<"USAGE"; usage: $0 [options] Options: -t : search in all files from a path -l : close file after the first match -e : exit program after the first match -s : slurp the entire file into memory -r : define a regex to find something in a file for case-insensitive mode, use: (?^i:regex) Others: -v : verbose mode\n USAGE exit shift; } if ($opts{h}) { usage(0); } elsif (not defined $regexp) { usage(1); } utf8::decode($regexp); sub open_and_search { my ($file) = @_; local $/ = $slurp ? undef : "\n"; open my $fh, '<:encoding(UTF-8)', $file or return; say ">Searching: $file" if $verbose; local $SIG{__WARN__} = sub { return }; while (defined(my $line = <$fh>)) { if ($line =~ /($regexp)/o) { substr($line, $-[0], 0, "\e[1;31m"); substr($line, $+[0] + 7, 0, "\e[0m"); print <<"EOT"; * Filename: $file * Line num: $. * Found on: $line EOT exit 0 if $exit; last if $last; } } return close $fh; } if ($tree) { require File::Find; foreach my $file (@ARGV) { if (-d $file) { File::Find::find( { no_chdir => 1, wanted => sub { if (-f -T and not /\.pdf\z/i) { open_and_search($_); } }, } => $file ); } else { open_and_search($file); } } } else { foreach my $file (@ARGV) { if (-f $file) { if (-T _) { open_and_search($file); } else { warn "[!] Not a text file: $file\n"; } } else { warn "[!] Not a file: $file\n"; } } } exit 0; ================================================ FILE: Greppers/mime_types.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 10 January 2014 # https://trizenx.blogspot.com # List the available categories and mime-types from .desktop files # usage: perl mime_types.pl [Category] use 5.016; use strict; use warnings; my %opt; if (@ARGV) { require Getopt::Std; Getopt::Std::getopts('hj', \%opt); } sub help { print <<"EOF"; usage: $0 [options] [Category] options: -j : join the results with a semicolon (;) -h : print this message and exit example: perl $0 # displays the available categories perl $0 Audio # displays the Audio mime-types perl $0 -j Video # displays the Video mime-types joined in one line EOF exit; } help() if $opt{h}; my @desktop_files = grep { /\.desktop\z/ } glob('/usr/share/applications/*'); my %table; foreach my $file (@desktop_files) { sysopen(my $fh, $file, 0) || next; sysread($fh, (my $content), -s $file); if ((my $p = index($content, "\n[", (my $i = index($content, '[Desktop Entry]') + 2**4))) != -1) { $content = substr($content, $i, $p - $i); } my @cats = $content =~ /^Categories=(.+)/m ? split(/;/, $1) : (); my @types = $content =~ /^MimeType=(.+)/m ? split(/;/, $1) : (); foreach my $cat (@cats) { @{$table{$cat}}{@types} = (); } } { { local $\ = $opt{j} ? ';' : "\n"; if (@ARGV && exists $table{$ARGV[0]}) { foreach my $type (sort keys %{$table{$ARGV[0]}}) { print $type; } } else { foreach my $category (sort { fc($a) cmp fc($b) } keys %table) { print $category; } } } $opt{j} && print "\n"; } ================================================ FILE: Greppers/mp3grep.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 22 March 2013 # https://github.com/trizen # List MP3 files, from a directory, that matches some # specified tags, such as: artist, genre, title, etc... use 5.010; use strict; use warnings; use re 'eval'; use MP3::Tag; use File::Find qw(find); use Getopt::Long qw(GetOptions); my $version = 0.01; my @tags = qw( album artist comment genre song title track year ); sub usage { print <<"HELP"; usage: $0 [options] [dirs] options: @{[ join("\n\t", '', map{ sprintf "--%-10s: get MP3s that matches the $_ tag", "$_=s" } @tags) ]} ** Each option accepts a regular expression as an argument. ** Regular expressions will match in case insensitive mode. ** When more than one option is specified, the result is printed only if it matches all the options specified. Example: $0 --artist="^(?:SOAD|System of a down)\$" /home/user/Music HELP exit; } sub version { print "mp3grep $version\n"; exit; } @ARGV || usage(); my %opt; GetOptions( (map { ; "$_=s" => \$opt{$_} } @tags), 'help|?' => \&usage, 'version' => \&version, ) || exit 1; sub check_file { if (/\.mp3\z/i && -f && !-z _) { my $filename = $_; my $mp3inf = MP3::Tag->new($filename); my $info_ref = $mp3inf->autoinfo(); my $match; foreach my $tag (@tags) { if (defined $opt{$tag} && defined $info_ref->{$tag}) { if ($info_ref->{$tag} =~ /$opt{$tag}/i) { $match //= $filename; next; } return; } } $match // return; say $match; } } my @files = grep { (-d) || (-f _) || do { warn "[!] Not a file or directory: $_\n"; 0 } } @ARGV; @files || exit 1; find { no_chdir => 1, wanted => \&check_file, } => @files; ================================================ FILE: Greppers/scgrep ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 04 February 2013 # Latest edit on: 16 July 2015 # https://github.com/trizen # Perl source code extractor. use utf8; use 5.018; use strict; use warnings; use open IO => ':utf8', ':std'; #use lib qw(../lib); use Perl::Tokenizer qw(perl_tokens); use List::Util qw(any); use Getopt::Std qw(getopts); use Term::ANSIColor qw(color); my %opts; getopts('hnlpcNb:a:t', \%opts); sub usage { my ($code) = @_; print <<"HELP"; usage: $0 [options] [types] [files] options: -b [i] : before characters -a [i] : after characters -l : print the full line -c : highlight the token (with -l) -p : print the name and position -n : print non-matching tokens -t : print the token names only -N : don't print a newline after the token types: Types are regular expressions. Example: ^operator ^keyword ^heredoc ^comment ^format ^backtick usage example: $0 -l -c regex /perl/script.pl $0 -l -c -n -p /perl/script.pl uncomment and unpod a perl script: $0 -N -n '^(?:pod|comment)\$' script.pl > clean_script.pl HELP exit $code; } usage(0) if $opts{h}; my @types; while (@ARGV and not -f $ARGV[0]) { push @types, map { qr{$_} } shift @ARGV; } my $code = ( do { local $/; <> } // die "usage: $0 [file]\n" ); my $reset_color = color('reset'); my $color = color('bold red on_black'); perl_tokens { my ($token, $from, $to) = @_; if ($opts{t}) { say $token; return; } my $matches = any { $token =~ $_ } @types; if ($opts{n} ? !$matches : $matches) { if ($opts{p}) { print "[$token] pos($from, $to): "; } if ($opts{l} and not $token eq 'vertical_space') { my $beg = rindex($code, "\n", $from) + 1; my $end = index($code, "\n", $to); my $line = substr($code, $beg, ($end - $beg)); if ($opts{c}) { substr($line, ($from - $beg), 0, $color); substr($line, ($from - $beg) + ($to - $from) + length($color), 0, $reset_color); } print $line; } else { if ($opts{b}) { print substr($code, $from - $opts{b}, $opts{b}); } print substr($code, $from, ($to - $from)); if ($opts{a}) { print substr($code, $to, $opts{a}); } } print "\n" unless $opts{N}; } } $code; =encoding utf8 =head1 NAME pfilter - a simple token extractor. =head1 SYNOPSIS pfilter [options] [types] < [script.pl] Options: -b [i] : before characters -a [i] : after characters -l : print the full line -c : highlight the token (with -l) -p : print the name and position -n : print non-matching tokens -t : print the token names only -N : don't print a newline after the token Types: Types are regular expressions. Example: ^operator ^keyword ^heredoc ^comment ^format ^backtick For more types, see: C Example: # uncomment and unpod a Perl script: pfilter -N -n '^(?:pod|comment)\z' script.pl > clean_script.pl =head1 DESCRIPTION pfilter extracts tokens from a Perl script that match a given regular expression. =head1 AUTHOR Daniel "Trizen" Șuteu, Etrizen@protonmail.comE =head1 COPYRIGHT AND LICENSE Copyright (C) 2015 This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.22.0 or, at your option, any later version of Perl 5 you may have available. =cut ================================================ FILE: Greppers/unigrep.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 18 December 2020 # https://github.com/trizen # A unidecode grep-like program. # In addition to normal grepping, it also converts input to ASCII and checks the given regex. # usage: # perl unigrep.pl [regex] [input] # find . | perl unigrep.pl [regex] use 5.010; use strict; use warnings; use Encode qw(decode_utf8); use Text::Unidecode qw(unidecode); use Getopt::Std qw(getopts); my %opt; getopts('i', \%opt); my $param = shift(@ARGV) // ''; my $regex = ($opt{i} ? qr/$param/oi : qr/$param/o); my $uniregex = do { my $t = decode_utf8($param); $opt{i} ? qr/$t/io : qr/$t/o; }; while (<>) { my $orig = $_; my $line = decode_utf8($_); my $unidec = unidecode($line); if ( $orig =~ $regex or $line =~ $uniregex or $unidec =~ $regex or $unidec =~ $uniregex) { print $orig; } } ================================================ FILE: HAL/HAL3736/HAL3736.memory ================================================ #!/usr/bin/perl # This file is part of the HAL9000 program. # Don't edit this file, unless you know what are you doing! # Updated on: Fri Apr 18 21:02:51 2014 # by: HAL9000.pl scalar { are => { you => { a => { computer => { "program?" => { ANSWER => "yes" } } }, an => { "alien?" => { ANSWER => "no" } }, }, }, do => { you => { like => { "music?" => { ANSWER => "yes" }, "to" => { "travel?" => { ANSWER => "no" } }, }, }, }, how => { are => { "you" => { "feeling?" => { ANSWER => "good" } }, "you?" => { ANSWER => "good" }, }, old => { are => { "you?" => { ANSWER => "not so" } } }, }, what => { are => { you => { "doing?" => { ANSWER => "learning" } } }, is => { favorite => { "color?" => { ANSWER => "white" } }, the => { capital => { of => { "italy?" => { ANSWER => "Rome" } } }, negation => { of => { "true?" => { ANSWER => "false" } } }, }, your => { "dream" => { "job?" => { ANSWER => "to speak exactly like a human being" } }, "favorite" => { "color?" => { ANSWER => "white" }, "language?" => { ANSWER => "Russian" }, }, "name?" => { ANSWER => "HAL3736" }, }, }, }, where => { are => { you => { "from?" => { ANSWER => "Rom\xC3\xA2nia" } } } }, } ================================================ FILE: HAL/HAL3736/HAL3736.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 14 April 2014 # Website: https://github.com/trizen # A basic A.I. concept, inspired by HAL9000. use utf8; use 5.014; use autodie; use warnings; use Data::Dump qw(pp); use Text::ParseWords qw(quotewords); # UTF-8 ready use open IO => ':encoding(UTF-8)'; # Constants use constant { NAME => 'HAL3736', MEMORY_FILE => 'HAL3736.memory', }; require Term::ReadLine; my $term = Term::ReadLine->new(NAME); # Save memory sub save_mem { my ($memory) = @_; open my $fh, '>', MEMORY_FILE; print {$fh} <<"HEADER", pp($memory), "\n"; #!/usr/bin/perl # This file is part of the ${\NAME} program. # Don't edit this file, unless you know what are you doing! # Updated on: ${\scalar localtime} # by: $0 HEADER close $fh; } # Create the memory if doesn't exist if (not -e MEMORY_FILE) { save_mem(scalar {}); } # Load the memory my $MEM = (do MEMORY_FILE); # Read or create memories sub hal { my ($items, $ref) = @_; foreach my $item (@{$items}) { $ref = ($ref->{$item} //= {}); } return $ref; } # Speak the text (with espeak) sub speak { my ($text) = @_; `espeak \Q$text\E &> /dev/null`; # speak the answer } print <<"EOF"; ******************************************************************************** Hello there! My name is ${\NAME}. I'm a "Heuristically programmed ALgorithmic computer", a descendant of HAL9000. In this training program, I'm ready to answer and learn new things about your awesome world. So, please, don't hesitate and ask me anything. I'll try my best. ******************************************************************************** EOF speak("Hello!"); my $q = 'a'; while (1) { my $question = unpack('A*', lc($term->readline("\n[?] Ask me $q question: ") // next)) =~ s/^\h+//r; last if $question eq 'q'; if (not $question =~ /\?\z/) { say "[*] This is not a question! :-)"; speak("This is not a question!"); if ($question eq '') { say "[!] Insert 'q' if you're bored already..."; } next; } $q = 'another'; $question =~ s/\b's\b/ is/g; # what's => what is $question =~ s/\b're\b/ are/g; # you're you => are $question =~ s/\b'm\b/ am/g; # I'm => I am my $requestion = $question; $requestion =~ s/\byour\b/my/g; # your => my $requestion =~ s/\bare\b/am/g; # are => am $requestion =~ s/\byou\b/I/g; # you => I $requestion =~ s/\byours\b/mine/g; # yours => mine my $answer = $requestion; my $q_suffix = ''; if ($answer =~ s/^what\h+//) { if ($answer =~ /am\b/) { } # ok elsif ($answer =~ s/^(\w+)\h*//) { $q_suffix = " $1"; } } my $an_suffix = ''; if ($answer =~ s/^how\h+//) { if ($answer =~ /^am\b/) { } # ok elsif ($answer =~ s/^(\w+)\h*//) { $an_suffix = " $1"; } } $answer =~ s/^where\b\h*//; $answer =~ s/\bam\h+I\b/I am/g; $answer =~ s/\?+\z//; #$answer =~ s/^does\b\h*//; my @input = quotewords(qr/\s+/o, 0, $question); next if scalar(@input) == 0; my $ref = hal(\@input, $MEM); if (exists $ref->{ANSWER}) { print "[*] "; my $ans; if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\z/i) { $ans = "\u\L$1\E!"; } else { $ans = "\u$answer$q_suffix $ref->{ANSWER}$an_suffix."; } say $ans; speak($ans); } else { say "\n[*] I don't know... :("; speak("I don't know..."); speak($requestion); my $input = $term->readline("[?] \u$requestion "); speak("Are you sure?"); if ($term->readline("[!] Are you sure? ") =~ /^y/i) { $ref->{ANSWER} = $input; speak("Roger that!"); } } } # Save what we learned save_mem($MEM); ================================================ FILE: HAL/HAL8212/HAL8212.memory ================================================ #!/usr/bin/perl # This file is part of the HAL8212 program. # Don't edit this file, unless you know what are you doing! # Updated on: Thu Apr 17 18:44:39 2014 # by: HAL8212.pl scalar {} ================================================ FILE: HAL/HAL8212/HAL8212.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 14 April 2014 # Website: https://github.com/trizen # A basic A.I. concept, inspired by HAL9000. use utf8; use 5.014; use autodie; use warnings; no if $] >= 5.018, warnings => "experimental::smartmatch"; # For saving the memory use Data::Dump qw(pp); # For contracting the words ("I am" into "I'm") use Lingua::EN::Contraction qw(contraction); # Stemming of words use Lingua::Stem qw(stem); # For correcting common mistakes use Lingua::EN::CommonMistakes qw(%MISTAKES_COMMON); use Lingua::EN::CommonMistakes qw(:no-defaults :american %MISTAKES_GB_TO_US); # UTF-8 ready use open IO => ':utf8'; # Constants use constant { NAME => 'HAL8212', MEMORY_FILE => 'HAL8212.memory', }; # For getting STDIN require Term::ReadLine; my $term = Term::ReadLine->new(NAME); # For tagging words require Lingua::EN::Tagger; my $ltag = Lingua::EN::Tagger->new; # For /dev/null use File::Spec qw(); # Save memory sub save_mem { my ($memory) = @_; open my $fh, '>', MEMORY_FILE; print {$fh} <<"HEADER", "scalar ", pp($memory), "\n"; #!/usr/bin/perl # This file is part of the ${\NAME} program. # Don't edit this file, unless you know what are you doing! # Updated on: ${\scalar localtime} # by: $0 HEADER close $fh; } # Create the memory if doesn't exist if (not -e MEMORY_FILE) { save_mem(scalar {}); } # Load the memory my $MEM = (do MEMORY_FILE); # Read or create memories sub hal { my ($items, $ref) = @_; foreach my $item (@{$items}) { $ref = ($ref->{$item} //= {}); } return $ref; } # Speak the text (with espeak) sub speak { my ($text) = @_; state $null = File::Spec->devnull; `espeak -ven-us \Q$text\E 2>$null`; } # Transform GB to US (colour -> color) sub gb_to_us { my ($word) = @_; if (defined(my $us_word = $MISTAKES_GB_TO_US{$word})) { return $us_word; } return $word; } # Fix common mistakes sub fix_word { my ($word) = @_; if (defined(my $fixed_word = $MISTAKES_COMMON{$word})) { return $fixed_word; } return $word =~ s/^i('|$)/I$1/gr; } # Ask for a question sub ask_question { state $one = 'a'; my $q = "Ask me $one question: "; if ($one eq 'a') { speak($q), $one = 'another'; } my $question = $term->readline("\n[?] " . $q); if (not defined $question or $question eq '') { say "[!] Insert 'q' if you're bored already..."; } elsif ($question eq 'q') { return; } return contraction($question =~ s/[<>]+//gr); } sub not_a_question { say "[*] This is not a question! :-)"; speak("This is not a question!"); } # Split a question into words sub get_words { my ($text) = @_; my @words; foreach my $word (split(' ', $text)) { my @ws; if ($word =~ s/([[:punct:]]+)\z//) { push @ws, $1; } push @words, gb_to_us(fix_word($word)), @ws; } return @words; } sub untag_word { my ($word) = @_; return scalar {$word =~ /^<([^>]+)>(.*?)<[^>]+>/s}; } sub locate { my ($couple, $pairs, $pos) = @_; foreach my $i ($pos .. $#{$pairs}) { if (exists $pairs->[$i]{$couple->[0]}) { if (exists $couple->[1]) { if ($pairs->[$i]{$couple->[0]} eq $couple->[1]) { return $i; } } else { return $i; } } } return; } sub flip_pers { my (@pairs) = @_; my @output; foreach my $pair (@pairs) { my $val; if (defined($val = $pair->{prps})) { given (lc $val) { when ('your') { push @output, 'my'; } when ('my') { push @output, 'your'; } default { push @output, $val; } } } elsif (defined($val = $pair->{prp})) { given (lc $val) { when ('mine') { push @output, 'yours'; } when ('yours') { push @output, 'mine'; } when ('you') { push @output, 'I'; } when ('I') { push @output, 'you'; } default { push @output, $val; } } } elsif (defined($val = $pair->{vbp})) { given (lc $val) { when (['are', "'re"]) { push @output, 'am'; } default { push @output, $val; } } } else { push @output, values %{$pair}; } } return @output; } sub INIT { print <<"EOF"; ******************************************************************************** Hello there! My name is ${\NAME}. I'm a "Heuristically programmed ALgorithmic computer", a descendant of HAL9000. In this training program, I'm ready to answer and learn new things about your awesome world. So, please, don't hesitate and ask me anything. I'll try my best. ******************************************************************************** EOF speak("Hello!"); } while (1) { # Get a question my $question = ask_question() // last; # Split the question into words my @words = get_words($question); # Stem words my @s_words = grep { $_ ne '' } @{stem(@words)}; # On empty questions, do this: @words || next; say join('--', @words); say join('==', @s_words); #say join('~~', $ltag->get_words($question)); #my $xml = $ltag->add_tags(join(" ", @words)); my $correct_q = join(' ', @words); my @pairs = map { untag_word($_) } split(' ', $ltag->add_tags($correct_q)); pp \@pairs; my @requestion = flip_pers(@pairs); pp \@requestion; my $answer = 'yes'; # let's just assume =cut my @question; if (defined(my $i = locate([wp => 'what'], \@pairs, 0))) { if (defined(locate([vbz => "'s"], \@pairs, $i))) { # what is if (defined(my $j = locate(['prps'], \@pairs, $i))) { # what is your if ($pairs[$j]{prps} eq 'yours') { push @question, "my"; while (defined(my $k = locate(['jj'], \@pairs, $j))) { push @question, $pairs[$k]{jj}; $j = $k+1; } #if (defined(my $k = locate(['nn'], \@pairs, } } } } =cut =cut if (exists $pairs[0]{wp}) { if( $pairs[0]{wp} eq 'what'){ if (exists $pairs[1]{vbz}) { if ($pairs[1]{vbz} eq "'s") { # what is } } } } =cut #say $xml; #pp \@pairs; =cut my $tags = xml2hash($xml); while (my ($key, $value) = each %{$tags}) { if (ref $value ne 'ARRAY') { $tags->{$key} = [$value]; } } if (not exists $tags->{pp} or $tags->{pp}[-1] ne '?') { not_a_question(); next; } pp $tags; =cut ##### NEEDS WORK ##### =cut my $requestion = $question; $requestion =~ s/\byour\b/my/g; # your => my $requestion =~ s/\bare\b/am/g; # are => am $requestion =~ s/\byou\b/I/g; # you => I $requestion =~ s/\byours\b/mine/g; # yours => mine my $answer = $requestion; my $q_suffix = ''; if ($answer =~ s/^what\h+//) { if ($answer =~ /am\b/) { } # ok elsif ($answer =~ s/^(\w+)\h*//) { $q_suffix = " $1"; } } my $an_suffix = ''; if ($answer =~ s/^how\h+//) { if ($answer =~ /^am\b/) { } # ok elsif ($answer =~ s/^(\w+)\h*//) { $an_suffix = " $1"; } } $answer =~ s/^where\b\h*//; $answer =~ s/\bam\h+I\b/I am/g; $answer =~ s/\?+\z//; #$answer =~ s/^does\b\h*//; my @input = quotewords(qr/\s+/o, 0, $question); next if scalar(@input) == 0; my $ref = hal(\@input, $MEM); if (exists $ref->{ANSWER}) { print "[*] "; my $ans; if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\z/i) { $ans = "\u\L$1\E!"; } else { $ans = "\u$answer$q_suffix $ref->{ANSWER}$an_suffix."; } say $ans; speak($ans); } else { say "\n[*] I don't know... :("; speak("I don't know..."); speak($requestion); my $input = $term->readline("[?] \u$requestion "); speak("Are you sure?"); if ($term->readline("[!] Are you sure? ") =~ /^y/i) { $ref->{ANSWER} = $input; speak("Roger that!"); } } =cut } # Save what we learned save_mem($MEM); ================================================ FILE: HAL/HAL9000/HAL9000.memory ================================================ ../HAL3736/HAL3736.memory ================================================ FILE: HAL/HAL9000/HAL9000.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 18 April 2014 # Website: https://github.com/trizen # A basic A.I. concept, inspired by the fictional HAL9000. # ## Configuration, grammar and .voca files: https://github.com/trizen/config-files/tree/master/.voxforge/julius # use utf8; use 5.014; use autodie; use warnings; no if $] >= 5.018, warnings => "experimental::smartmatch"; # For saving the memory use Data::Dump qw(pp); # For contracting the words ("I am" into "I'm") #use Lingua::EN::Contraction qw(contraction); # Stemming of words #use Lingua::Stem qw(stem); # For correcting common mistakes #use Lingua::EN::CommonMistakes qw(%MISTAKES_COMMON); #use Lingua::EN::CommonMistakes qw(:no-defaults :american %MISTAKES_GB_TO_US); # UTF-8 ready use open IO => ':utf8'; # Constants use constant { NAME => 'HAL9000', MEMORY_FILE => 'HAL9000.memory', }; # For getting STDIN #require Term::ReadLine; #my $term = Term::ReadLine->new(NAME); # For tagging words require Lingua::EN::Tagger; my $ltag = Lingua::EN::Tagger->new; # For /dev/null use File::Spec qw(); # Save memory sub save_mem { my ($memory) = @_; open my $fh, '>', MEMORY_FILE; print {$fh} <<"HEADER", "scalar ", pp($memory), "\n"; #!/usr/bin/perl # This file is part of the ${\NAME} program. # Don't edit this file, unless you know what are you doing! # Updated on: ${\scalar localtime} # by: $0 HEADER close $fh; } # Create the memory if doesn't exist if (not -e MEMORY_FILE) { save_mem(scalar {}); } # Load the memory my $MEM = (do MEMORY_FILE); # Read or create memories sub hal { my ($items, $ref) = @_; foreach my $item (@{$items}) { $ref = ($ref->{$item} //= {}); } return $ref; } # Speak the text (with espeak) sub speak { my ($text) = @_; state $null = File::Spec->devnull; `espeak -ven-us \Q$text\E 2>$null`; } =for comment # Transform GB to US (colour -> color) sub gb_to_us { my ($word) = @_; if (defined(my $us_word = $MISTAKES_GB_TO_US{$word})) { return $us_word; } return $word; } # Fix common mistakes sub fix_word { my ($word) = @_; if (defined(my $fixed_word = $MISTAKES_COMMON{$word})) { return $fixed_word; } return $word =~ s/^i('|$)/I$1/gr; } =cut sub start_julius { my ($callback) = @_; ref($callback) eq 'CODE' or die "usage: start_juliu(\&code)"; my $config = "$ENV{HOME}/.voxforge/julius/hal.jconf"; my @julius = qw(julius -input mic); open(my $pipe_h, '-|', @julius, '-C', $config) // exit $!; my @buffer; while (<$pipe_h>) { if (!/\S/) { my %conf; foreach my $line (@buffer) { if ($line =~ /^(\w+):\h*(.*\S)/) { $conf{$1} = $2; } } if (exists $conf{cmscore1} and exists $conf{sentence1}) { my @vals = split(' ', $conf{cmscore1}); say "got: $conf{sentence1} ($conf{cmscore1})"; ## 'cmscore1' should be: 1.000 1.000 1.000 1.000 (with minor tolerance) #require List::Util; #if (List::Util::sum(@vals) >= scalar(@vals) - 0.002) { # $callback->($conf{sentence1}); #} $callback->($conf{sentence1}); } $#buffer = -1; } push @buffer, $_; } } sub not_a_question { say "[*] This is not a question! :-)"; speak("This is not a question!"); } # Split a question into words sub get_words { my ($text) = @_; my @words; foreach my $word (split(' ', $text)) { my @ws; if ($word =~ s/([[:punct:]]+)\z//) { push @ws, $1; } #push @words, gb_to_us(fix_word($word)), @ws; push @words, $word, @ws; } return @words; } sub untag_word { my ($word) = @_; return scalar {$word =~ /^<([^>]+)>(.*?)<[^>]+>/s}; } sub locate { my ($couple, $pairs, $pos) = @_; foreach my $i ($pos .. $#{$pairs}) { if (exists $pairs->[$i]{$couple->[0]}) { if (exists $couple->[1]) { if ($pairs->[$i]{$couple->[0]} eq $couple->[1]) { return $i; } } else { return $i; } } } return; } sub flip_pers { my (@pairs) = @_; my @output; foreach my $pair (@pairs) { my $val; if (defined($val = $pair->{prps})) { given (lc $val) { when ('your') { push @output, 'my'; } when ('my') { push @output, 'your'; } default { push @output, $val; } } } elsif (defined($val = $pair->{prp})) { given (lc $val) { when ('mine') { push @output, 'yours'; } when ('yours') { push @output, 'mine'; } when ('you') { push @output, 'I'; } when ('I') { push @output, 'you'; } default { push @output, $val; } } } elsif (defined($val = $pair->{vbp})) { given (lc $val) { when (['are', "'re"]) { push @output, 'am'; } default { push @output, $val; } } } elsif (defined($val = $pair->{vbz})) { given (lc $val) { when ("'s") { push @output, 'is'; } default { push @output, $val; } } } else { push @output, values %{$pair}; } } return @output; } sub INIT { print <<"EOF"; ******************************************************************************** Hello there! My name is ${\NAME}. I'm a "Heuristically programmed ALgorithmic computer", a descendant of HAL9000. In this training program, I'm ready to answer and learn new things about your awesome world. So, please, don't hesitate and ask me anything. I'll try my best. ******************************************************************************** EOF speak("Hello!"); } #my $ref = hal([qw(how are you)], $MEM); #$ref->{ANSWER} = "good"; start_julius(\&decode_question); sub decode_question { my ($question) = @_; $question =~ s{^\h*(.*\S)\h*$}{$1} || return; # Split the question into words my @words = get_words($question); # On empty questions, do this: @words || return; say join('--', @words); my $correct_q = join(' ', @words); my @pairs = map { untag_word($_) } split(' ', $ltag->add_tags($correct_q)); pp \@pairs; my @requestion = flip_pers(@pairs); pp \@requestion; my @answ; if (defined(my $i = locate(['wp'], \@pairs, 0))) { my $type = $pairs[$i]; if ($type->{wp} eq 'what') { if (defined(my $j = locate(['vbz'], \@pairs, $i + 1))) { push @answ, (map { $pairs[$_] } $j + 1 .. $#pairs), $pairs[$j]; } else { # push } } } @answ = flip_pers(@answ); my $req = "@requestion"; $req =~ s/\h+'s\b/ is/g; $req =~ s/\h+'m\b/ am/g; $req .= '?'; say $req; $words[-1] .= '?'; my $ref = hal(\@words, $MEM); if (exists $ref->{ANSWER}) { print "[*] "; my $ans; if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\z/i) { $ans = "\u\L$1\E!"; } else { $ans = ucfirst join(" ", @answ, $ref->{ANSWER}); } say $ans; speak($ans); } else { speak("I don't know..."); speak($req); } ##### NEEDS WORK ##### =cut my $requestion = $question; $requestion =~ s/\byour\b/my/g; # your => my $requestion =~ s/\bare\b/am/g; # are => am $requestion =~ s/\byou\b/I/g; # you => I $requestion =~ s/\byours\b/mine/g; # yours => mine my $answer = $requestion; my $q_suffix = ''; if ($answer =~ s/^what\h+//) { if ($answer =~ /am\b/) { } # ok elsif ($answer =~ s/^(\w+)\h*//) { $q_suffix = " $1"; } } my $an_suffix = ''; if ($answer =~ s/^how\h+//) { if ($answer =~ /^am\b/) { } # ok elsif ($answer =~ s/^(\w+)\h*//) { $an_suffix = " $1"; } } $answer =~ s/^where\b\h*//; $answer =~ s/\bam\h+I\b/I am/g; $answer =~ s/\?+\z//; #$answer =~ s/^does\b\h*//; my @input = quotewords(qr/\s+/o, 0, $question); next if scalar(@input) == 0; my $ref = hal(\@input, $MEM); if (exists $ref->{ANSWER}) { print "[*] "; my $ans; if ($ref->{ANSWER} =~ /^(yes|no)[[:punct:]]?\z/i) { $ans = "\u\L$1\E!"; } else { $ans = "\u$answer$q_suffix $ref->{ANSWER}$an_suffix."; } say $ans; speak($ans); } else { say "\n[*] I don't know... :("; speak("I don't know..."); speak($requestion); my $input = $term->readline("[?] \u$requestion "); speak("Are you sure?"); if ($term->readline("[!] Are you sure? ") =~ /^y/i) { $ref->{ANSWER} = $input; speak("Roger that!"); } } =cut } # Save what we learned save_mem($MEM); ================================================ FILE: Image/2x_zoom.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 11 March 2017 # https://github.com/trizen # A simple gap-filling algorithm for applying a 2x zoom to an image. use 5.010; use strict; use warnings; use Imager; use List::Util qw(sum); my $file = shift(@ARGV) // die "usage: $0 [image]\n"; my $img = Imager->new(file => $file) or die Imager->errstr(); my $width = $img->getwidth; my $height = $img->getheight; my @matrix; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { $matrix[$y][$x] = $img->getpixel(x => $x, y => $y); } } my $out_img = Imager->new(xsize => 2 * $width, ysize => 2 * $height); sub gap_color { my ($x, $y) = @_; my @neighbors; if ($y > 0) { # Top neighbor if ($x < $width) { push @neighbors, $matrix[$y - 1][$x]; } # Top-right neighbor if ($x < $width - 1) { push @neighbors, $matrix[$y - 1][$x + 1]; } # Top-left neighbor if ($x > 0) { push @neighbors, $matrix[$y - 1][$x - 1]; } } if ($y < $height - 1) { # Bottom neighbor if ($x < $width) { push @neighbors, $matrix[$y + 1][$x]; } # Bottom-right neighbor if ($x < $width - 1) { push @neighbors, $matrix[$y + 1][$x + 1]; } # Bottom-left neighbor if ($x > 0) { push @neighbors, $matrix[$y + 1][$x - 1]; } } if ($y < $height) { # Left neighbor if ($x > 0) { push @neighbors, $matrix[$y][$x - 1]; } # Right neighbor if ($x < $width - 1) { push @neighbors, $matrix[$y][$x + 1]; } } # Get the RGBA colors my @colors = map { [$_->rgba] } @neighbors; my @red = map { $_->[0] } @colors; my @blue = map { $_->[1] } @colors; my @green = map { $_->[2] } @colors; my @alpha = map { $_->[3] } @colors; #<<< # Compute the average gap-filling color my @gap_color = ( sum(@red ) / @red, sum(@blue ) / @blue, sum(@green) / @green, sum(@alpha) / @alpha, ); #>>> return \@gap_color; } foreach my $y (0 .. $#matrix) { foreach my $x (0 .. $#{$matrix[$y]}) { #<<< # Fill the gaps $out_img->setpixel(x => 2 * $x, y => 2 * $y, color => $matrix[$y][$x]); $out_img->setpixel(x => 2 * $x + 1, y => 2 * $y + 1, color => gap_color($x + 1, $y + 1)); $out_img->setpixel(x => 2 * $x + 1, y => 2 * $y, color => gap_color($x + 1, $y )); $out_img->setpixel(x => 2 * $x, y => 2 * $y + 1, color => gap_color($x, $y + 1)); #>>> } } $out_img->write(file => '2x_zoom.png'); ================================================ FILE: Image/add_exif_info.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 30 September 2024 # Edit: 24 September 2025 # https://github.com/trizen # Add the EXIF "DateTimeOriginal" to images, based on the filename of the image, with support for GPS tags. use 5.036; use Image::ExifTool qw(); use File::Find qw(find); use Getopt::Long qw(GetOptions); use Time::Piece qw(); my $latitude = 45.84692326942804; my $longitude = 22.796479967835673; my $coordinates = undef; my $force = 0; my $set_gps = 0; my $utc_offset = 0; my $img_formats = ''; my @img_formats = qw( jpeg jpg ); sub usage($exit_code = 0) { print <<"EOT"; usage: $0 [options] [images] options: --gps! : set the GPS coordinates --force! : overwrite the EXIF creation date --latitude=float : value for GPSLatitude --longitude=float : value for GPSLongitude --coordinates=str : GPS coordinates as "latitude,longitude" --UTC-offset=i : offset date by this many hours (default: $utc_offset) -f --formats=s,s : specify more image formats (default: @img_formats) --help : print this message and exit EOT exit $exit_code; } GetOptions( "gps!" => \$set_gps, "force!" => \$force, "f|formats=s" => \$img_formats, "utc-offset=i" => \$utc_offset, "latitude=f" => \$latitude, "longitude=f" => \$longitude, "coordinates=s" => \$coordinates, 'help' => sub { usage(0) } ) or die("Error in command line arguments\n"); if (defined($coordinates)) { ($latitude, $longitude) = split(/\s*,\s*/, $coordinates); } sub process_image ($file) { my $exifTool = Image::ExifTool->new; $exifTool->ExtractInfo($file); 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})}) { my ($year, $month, $day, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6); my $date = "$year:$month:$day $hour:$min:$sec"; my $time_format = "%Y:%m:%d %H:%M:%S"; my $time_obj = Time::Piece->strptime($date, $time_format); if ($utc_offset) { $time_obj += $utc_offset * 3600; $date = $time_obj->strftime($time_format); } say "Setting image creation time to: $date"; # Set the file modification date $exifTool->SetNewValue(FileModifyDate => $date, Protected => 1); # Set the EXIF creation date (unless it already exists) if ($force or not defined $exifTool->GetValue("DateTimeOriginal")) { $exifTool->SetNewValue(DateTimeOriginal => $date); } # Set GPSLatitude and GPSLongitude tags if ($set_gps) { $exifTool->SetNewValue('GPSLatitude', $latitude); $exifTool->SetNewValue('GPSLatitudeRef', $latitude >= 0 ? 'N' : 'S'); $exifTool->SetNewValue('GPSLongitude', $longitude); $exifTool->SetNewValue('GPSLongitudeRef', $longitude >= 0 ? 'E' : 'W'); } my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($file); $exifTool->WriteInfo($file); $mtime = $time_obj->epoch; $atime = $mtime; # Set the original ownership of the image chown($uid, $gid, $file); # Set the modification time utime($atime, $mtime, $file) or warn "Can't change timestamp: $!\n"; # Set original permissions chmod($mode & 07777, $file) or warn "Can't change permissions: $!\n"; } else { warn "Unable to determine the image creation date. Skipping...\n"; } } @ARGV || usage(1); push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats); my $img_formats_re = do { local $" = '|'; qr/\.(@img_formats)\z/i; }; find { no_chdir => 1, wanted => sub { (/$img_formats_re/o && -f) || return; say ":: Processing: $_"; process_image($_); } } => @ARGV; ================================================ FILE: Image/bitmap_monochrome_encoding_decoding.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 24 August 2018 # https://github.com/trizen # Encode an image into an integer in monochrome bitmap format. # Decode an integer back into a monochrome image, by specifying XSIZE and YSIZE. # Usage: # perl bitmap_monochrome_encoding_decoding.pl [image|integer] [xsize] [ysize] # See also: # https://www.youtube.com/watch?v=_s5RFgd59ao # https://en.wikipedia.org/wiki/Tupper's_self-referential_formula # For example, try: # perl bitmap_monochrome_encoding_decoding.pl 960939379918958884971672962127852754715004339660129306651505519271702802395266424689642842174350718121267153782770623355993237280874144307891325963941337723487857735749823926629715517173716995165232890538221612403238855866184013235585136048828693337902491454229288667081096184496091705183454067827731551705405381627380967602565625016981482083418783163849115590225610003652351370343874461848378737238198224849863465033159410054974700593138339226497249461751545728366702369745461014655997933798537483143786841806593422227898388722980000748404719 # perl bitmap_monochrome_encoding_decoding.pl 4858487700955227269310810743279699920059071665868862676453015679577225782068321715691954329017884722389385550282344094325110559671706720456802995614421319713836803680439230203857023532236791776607932309358505788694249724093972434433440785815336774291945612106058206332142360075310011570794409292417648253014388444262569443218615514272957841814202800720702726236206242071675013681230087031878381452808096784548757607453284867359002454455428928632983954826623474612688372970630260114784068636783069647343475295488391045284413477645076796807315439 use 5.020; use strict; use warnings; my $XSIZE = 106; my $YSIZE = 17; use Imager; use Math::AnyNum; use experimental qw(signatures); sub bitmap_monochrome_encoding ($file) { my $img = Imager->new(file => $file) or die "Can't open file `$file`: $!"; $XSIZE = $img->getwidth; $YSIZE = $img->getheight; say "XSIZE = $XSIZE"; say "YSIZE = $YSIZE"; my $bin = ''; foreach my $x (0 .. $XSIZE - 1) { foreach my $y (0 .. $YSIZE - 1) { my ($R, $G, $B) = $img->getpixel(x => $x, y => $YSIZE - $y - 1)->rgba; if ($R + $G + $B >= 3 * 128) { $bin .= '1'; } else { $bin .= '0'; } } } Math::AnyNum->new($bin, 2) * $YSIZE; } sub bitmap_monochrome_decoding ($k) { my $red = Imager::Color->new('#FFFFFF'); my $img = Imager->new(xsize => $XSIZE, ysize => $YSIZE); my @bin = split(//, reverse(($k / $YSIZE)->floor->as_bin)); for (my $y = 0 ; @bin ; ++$y) { my @row = splice(@bin, 0, $YSIZE); foreach my $i (0 .. $XSIZE - 1) { $img->setpixel(x => $XSIZE - $y - 1, y => $i, color => $red) if $row[$i]; } } $img->write(file => 'monochrome_image.png'); } @ARGV || die "usage: $0 [image|integer] [xsize] [ysize]\n"; $XSIZE = $ARGV[1] if defined($ARGV[1]); $YSIZE = $ARGV[2] if defined($ARGV[2]); my $k = 0; if ($ARGV[0] =~ /^[0-9]+\z/) { say "[*] Decoding..."; $k = Math::AnyNum->new($ARGV[0]); } else { say "[*] Encoding..."; my $img_file = $ARGV[0]; $k = bitmap_monochrome_encoding($img_file); say "k = $k"; } bitmap_monochrome_decoding($k); say "[*] Done!" ================================================ FILE: Image/bwt_horizontal_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 April 2024 # https://github.com/trizen # Apply the Burrows-Wheeler transform on each row of an image. use 5.036; use GD; use Getopt::Std qw(getopts); use Compression::Util qw(bwt_encode_symbolic bwt_decode_symbolic); GD::Image->trueColor(1); sub apply_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width + 1, $height); foreach my $y (0 .. $height - 1) { my @row; foreach my $x (0 .. $width - 1) { push @row, scalar $new_image->colorAllocate($image->rgb($image->getPixel($x, $y))); } my ($encoded, $idx) = bwt_encode_symbolic(\@row); $new_image->setPixel(0, $y, $idx); foreach my $x (1 .. $width) { $new_image->setPixel($x, $y, $encoded->[$x - 1]); } } return $new_image; } sub undo_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width - 1, $height); foreach my $y (0 .. $height - 1) { my @row; my $idx = $image->getPixel(0, $y); foreach my $x (1 .. $width - 1) { push @row, scalar $image->getPixel($x, $y); } my $decoded = bwt_decode_symbolic(\@row, $idx); foreach my $x (0 .. $width - 2) { $new_image->setPixel($x, $y, $decoded->[$x]); } } return $new_image; } sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.png] [output.png] options: -d : decode the image -h : print this message and exit EOT exit($exit_code); } getopts('dh', \my %opts); my $input_file = $ARGV[0] // usage(2); my $output_file = $ARGV[1] // "output.png"; if (not -f $input_file) { die "Input file <<$input_file>> does not exist!\n"; } my $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file); open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!"; print $out_fh $img->png(9); close $out_fh; ================================================ FILE: Image/bwt_rgb_horizontal_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 April 2024 # Edit: 09 April 2024 # https://github.com/trizen # Apply the Burrows-Wheeler transform on each row (RGB-wise) of an image. use 5.036; use GD; use Getopt::Std qw(getopts); use Compression::Util qw(bwt_encode bwt_decode); GD::Image->trueColor(1); sub apply_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width + 3, $height); foreach my $y (0 .. $height - 1) { my (@R, @G, @B); foreach my $x (0 .. $width - 1) { my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y)); push @R, $R; push @G, $G; push @B, $B; } my ($R, $R_idx) = bwt_encode(pack('C*', @R)); my ($G, $G_idx) = bwt_encode(pack('C*', @G)); my ($B, $B_idx) = bwt_encode(pack('C*', @B)); @R = unpack('C*', $R); @G = unpack('C*', $G); @B = unpack('C*', $B); $new_image->setPixel(0, $y, $R_idx); $new_image->setPixel(1, $y, $G_idx); $new_image->setPixel(2, $y, $B_idx); foreach my $x (0 .. $width - 1) { $new_image->setPixel($x + 3, $y, $new_image->colorAllocate($R[$x], $G[$x], $B[$x])); } } return $new_image; } sub undo_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width - 3, $height); foreach my $y (0 .. $height - 1) { my (@R, @G, @B); my $R_idx = $image->getPixel(0, $y); my $G_idx = $image->getPixel(1, $y); my $B_idx = $image->getPixel(2, $y); foreach my $x (3 .. $width - 1) { my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y)); push @R, $R; push @G, $G; push @B, $B; } @R = unpack 'C*', bwt_decode(pack('C*', @R), $R_idx); @G = unpack 'C*', bwt_decode(pack('C*', @G), $G_idx); @B = unpack 'C*', bwt_decode(pack('C*', @B), $B_idx); foreach my $x (0 .. $width - 3 - 1) { $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$x], $G[$x], $B[$x])); } } return $new_image; } sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.png] [output.png] options: -d : decode the image -h : print this message and exit EOT exit($exit_code); } getopts('dh', \my %opts); my $input_file = $ARGV[0] // usage(2); my $output_file = $ARGV[1] // "output.png"; if (not -f $input_file) { die "Input file <<$input_file>> does not exist!\n"; } my $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file); open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!"; print $out_fh $img->png(9); close $out_fh; ================================================ FILE: Image/bwt_rgb_vertical_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 April 2024 # Edit: 09 April 2024 # https://github.com/trizen # Apply the Burrows-Wheeler transform on each column (RGB-wise) of an image. use 5.036; use GD; use Getopt::Std qw(getopts); use Compression::Util qw(bwt_encode bwt_decode); GD::Image->trueColor(1); sub apply_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width, $height + 3); foreach my $x (0 .. $width - 1) { my (@R, @G, @B); foreach my $y (0 .. $height - 1) { my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y)); push @R, $R; push @G, $G; push @B, $B; } my ($R, $R_idx) = bwt_encode(pack('C*', @R)); my ($G, $G_idx) = bwt_encode(pack('C*', @G)); my ($B, $B_idx) = bwt_encode(pack('C*', @B)); @R = unpack('C*', $R); @G = unpack('C*', $G); @B = unpack('C*', $B); $new_image->setPixel($x, 0, $R_idx); $new_image->setPixel($x, 1, $G_idx); $new_image->setPixel($x, 2, $B_idx); foreach my $y (0 .. $height - 1) { $new_image->setPixel($x, $y + 3, $new_image->colorAllocate($R[$y], $G[$y], $B[$y])); } } return $new_image; } sub undo_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width, $height - 3); foreach my $x (0 .. $width - 1) { my (@R, @G, @B); my $R_idx = $image->getPixel($x, 0); my $G_idx = $image->getPixel($x, 1); my $B_idx = $image->getPixel($x, 2); foreach my $y (3 .. $height - 1) { my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y)); push @R, $R; push @G, $G; push @B, $B; } @R = unpack 'C*', bwt_decode(pack('C*', @R), $R_idx); @G = unpack 'C*', bwt_decode(pack('C*', @G), $G_idx); @B = unpack 'C*', bwt_decode(pack('C*', @B), $B_idx); foreach my $y (0 .. $height - 3 - 1) { $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$y], $G[$y], $B[$y])); } } return $new_image; } sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.png] [output.png] options: -d : decode the image -h : print this message and exit EOT exit($exit_code); } getopts('dh', \my %opts); my $input_file = $ARGV[0] // usage(2); my $output_file = $ARGV[1] // "output.png"; if (not -f $input_file) { die "Input file <<$input_file>> does not exist!\n"; } my $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file); open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!"; print $out_fh $img->png(9); close $out_fh; ================================================ FILE: Image/bwt_vertical_transform.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 April 2024 # https://github.com/trizen # Apply the Burrows-Wheeler transform on each column of an image. use 5.036; use GD; use Getopt::Std qw(getopts); use Compression::Util qw(bwt_encode_symbolic bwt_decode_symbolic); GD::Image->trueColor(1); sub apply_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width, $height + 1); foreach my $x (0 .. $width - 1) { my @row; foreach my $y (0 .. $height - 1) { push @row, scalar $new_image->colorAllocate($image->rgb($image->getPixel($x, $y))); } my ($encoded, $idx) = bwt_encode_symbolic(\@row); $new_image->setPixel($x, 0, $idx); foreach my $y (1 .. $height) { $new_image->setPixel($x, $y, $encoded->[$y - 1]); } } return $new_image; } sub undo_bwt ($file) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width, $height - 1); foreach my $x (0 .. $width - 1) { my @row; my $idx = $image->getPixel($x, 0); foreach my $y (1 .. $height - 1) { push @row, $image->getPixel($x, $y); } my $decoded = bwt_decode_symbolic(\@row, $idx); foreach my $y (0 .. $height - 2) { $new_image->setPixel($x, $y, $decoded->[$y]); } } return $new_image; } sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.png] [output.png] options: -d : decode the image -h : print this message and exit EOT exit($exit_code); } getopts('dh', \my %opts); my $input_file = $ARGV[0] // usage(2); my $output_file = $ARGV[1] // "output.png"; if (not -f $input_file) { die "Input file <<$input_file>> does not exist!\n"; } my $img = $opts{d} ? undo_bwt($input_file) : apply_bwt($input_file); open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!"; print $out_fh $img->png(9); close $out_fh; ================================================ FILE: Image/collage.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 23 March 2021 # https://github.com/trizen # Create a collage from a collection of images. use 5.010; use strict; use autodie; use warnings; use GD qw(); use POSIX qw(ceil); use List::Util qw(min); use File::Find qw(find); use Getopt::Long qw(GetOptions); GD::Image->trueColor(1); my $size = 350; my $wsize = undef; my $hsize = undef; my $wcrop = 1 / 2; # width crop ratio my $hcrop = 1 / 5; # height crop ratio my $output_file = 'collage.png'; my $width = undef; my $height = undef; sub usage { my ($code) = @_; print <<"EOT"; usage: $0 [options] [files / directories] options: --size=i : the length of a square tile (default: $size) --wsize=i : the width of a tile (default: $size) --hsize=i : the height of a tile (default: $size) --wcrop=f : width cropping ratio (default: $wcrop) --hcrop=f : height cropping ratio (default: $hcrop) --width=i : minimum width of the collage (default: auto) --height=i : minimum height of the collage (default: auto) --output=s : output filename (default: $output_file) example: $0 --size=100 ~/Pictures EOT exit($code); } GetOptions( 'size=i' => \$size, 'wsize=i' => \$wsize, 'hsize=i' => \$hsize, 'wcrop=f' => \$wcrop, 'hcrop=f' => \$hcrop, 'width=i' => \$width, 'height=i' => \$height, 'output=s' => \$output_file, 'h|help' => sub { usage(0) }, ) or die("$0: error in command line arguments\n"); sub analyze_image { my ($file, $images) = @_; my $img = eval { GD::Image->new($file) } || return; say "Analyzing: $file"; $img = resize_image($img); push @$images, $img; } sub resize_image { my ($image) = @_; # Get image dimensions my ($width, $height) = $image->getBounds(); # File is already at the wanted resolution if ($width == $wsize and $height == $hsize) { return $image; } # Get the minimum ratio my $min_r = min($width / $wsize, $height / $hsize); my $n_width = sprintf('%.0f', $width / $min_r); my $n_height = sprintf('%.0f', $height / $min_r); # Create a new GD image with the new dimensions my $gd = GD::Image->new($n_width, $n_height); $gd->copyResampled($image, 0, 0, 0, 0, $n_width, $n_height, $width, $height); # Create a new GD image with the wanted dimensions my $cropped = GD::Image->new($wsize, $hsize); # Crop from left and right if ($n_width > $wsize) { my $diff = $n_width - $wsize; my $left = ceil($diff * $wcrop); $cropped->copy($gd, 0, 0, $left, 0, $wsize, $hsize); } # Crop from top and bottom elsif ($n_height > $hsize) { my $diff = $n_height - $hsize; my $top = int($diff * $hcrop); $cropped->copy($gd, 0, 0, 0, $top, $wsize, $hsize); } # No crop needed else { $cropped = $gd; } return $cropped; } my @photo_dirs = (@ARGV ? @ARGV : usage(2)); $wsize //= $size; $hsize //= $size; if ($wsize <= 0 or $hsize <= 0) { die "$0: size must be greater than zero (got: [$size, $wsize, $hsize])\n"; } my @images; # stores all the image objects find { no_chdir => 1, wanted => sub { if (/\.(?:jpe?g|png)\z/i) { analyze_image($_, \@images); } }, } => @photo_dirs; my $images_len = scalar(@images); $width //= int(sqrt($images_len)) * $wsize; $height //= $width; if ($width % $wsize != 0) { $width += ($wsize - ($width % $wsize)); } if ($height % $hsize != 0) { $height += ($hsize - ($height % $hsize)); } while (($width / $wsize) * ($height / $hsize) > $images_len) { $height -= $hsize; } while (($width / $wsize) * ($height / $hsize) < $images_len) { $height += $hsize; } my $collage = GD::Image->new($width, $height); foreach my $y (0 .. $height / $hsize - 1) { foreach my $x (0 .. $width / $wsize - 1) { my $source = shift(@images) // last; $collage->copy($source, $x * $wsize, $y * $hsize, 0, 0, $wsize, $hsize); } } open my $fh, '>:raw', $output_file; print $fh ( $output_file =~ /\.png\z/i ? $collage->png(9) : $collage->jpeg(90) ); close $fh; ================================================ FILE: Image/complex_transform.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 31 January 2018 # https://github.com/trizen # Complex transform of an image, by mapping each pixel position to a complex function. use 5.020; use strict; use warnings; use feature qw(lexical_subs); use experimental qw(signatures); use Imager; use List::Util qw(min max); use Math::GComplex qw(cplx); sub map_range ($this, $in_min, $in_max, $out_min, $out_max) { $this =~ /[0-9]/ or return 0; ($this - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min; } sub complex_transform ($file) { my $img = Imager->new(file => $file); my $width = $img->getwidth; my $height = $img->getheight; my @vals; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $z = cplx( (2 * $x - $width) / $width, (2 * $y - $height) / $height, ); push @vals, [$x, $y, $z->sin->reals]; } } my $max_x = max(map { $_->[2] } grep { $_->[2] =~ /[0-9]/ } @vals); my $max_y = max(map { $_->[3] } grep { $_->[3] =~ /[0-9]/ } @vals); my $min_x = min(map { $_->[2] } grep { $_->[2] =~ /[0-9]/ } @vals); my $min_y = min(map { $_->[3] } grep { $_->[3] =~ /[0-9]/ } @vals); say "X: [$min_x, $max_x]"; say "Y: [$min_y, $max_y]"; my $new_img = Imager->new( xsize => $width, ysize => $height, ); foreach my $val (@vals) { $new_img->setpixel( x => sprintf('%.0f', map_range($val->[2], $min_x, $max_x, 0, $width - 1)), y => sprintf('%.0f', map_range($val->[3], $min_y, $max_y, 0, $height - 1)), color => $img->getpixel(x => $val->[0], y => $val->[1]), ); } return $new_img; } sub usage { die "usage: $0 [input image] [output image]\n"; } my $input = shift(@ARGV) // usage(); my $output = shift(@ARGV) // 'complex_transform.png'; complex_transform($input)->write(file => $output); ================================================ FILE: Image/cyan_vision.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 16 November 2016 # Website: https://github.com/trizen # Redraws each pixel as a cyan colored circle. # WARNING: this process is *very* slow for large images. use 5.010; use strict; use warnings; use Imager; use List::Util qw(max); my @matrix; { my $img = Imager->new(file => shift(@ARGV)) || die die "usage: $0 [image]\n"; my $height = $img->getheight - 1; my $width = $img->getwidth - 1; foreach my $y (0 .. $height) { push @matrix, [ map { my ($r, $g, $b) = $img->getpixel(y => $y, x => $_)->rgba; my $rgb = $r; $rgb = ($rgb << 8) + $g; $rgb = ($rgb << 8) + $b; $rgb } (0 .. $width) ]; } } my $max_color = 2**16 - 1; # normal color is: 2**24 - 1 my $scale_factor = 3; # the scaling factor does not affect the performance my $radius = $scale_factor / atan2(0, -'inf'); my $space = $radius / 2; my $img = Imager->new( xsize => @{$matrix[0]} * $scale_factor, ysize => @matrix * $scale_factor, channels => 3, ); my $max = max(map { @$_ } @matrix); foreach my $i (0 .. $#matrix) { my $row = $matrix[$i]; foreach my $j (0 .. $#{$row}) { $img->circle( r => $radius, x => $j * $scale_factor + $radius + $space, y => $i * $scale_factor + $radius + $space, color => sprintf("#%06x", $row->[$j] / $max * $max_color), ); } } $img->write(file => 'cyan_image.png'); ================================================ FILE: Image/darken_image.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 07 November 2015 # Website: https://github.com/trizen # Replace the light-color pixels with their darken neighbors. # _________________ # | | | | # | A | B | C | # |_____|_____|_____| _____ # | | | | | | # | H | | D | --> | M | # |_____|_____|_____| |_____| # | | | | # | G | F | E | # |_____|_____|_____| # where M is the darkest color from (A, B, C, D, E, F, G, H) use 5.010; use strict; use warnings; use List::Util qw(min); use GD; GD::Image->trueColor(1); sub help { my ($exit_code) = @_; print <<"EOT"; usage: $0 [input image] [output image] EOT exit($exit_code // 0); } my $in_file = shift(@ARGV) // help(2); my $out_file = shift(@ARGV) // 'output.png'; my $img = GD::Image->new($in_file); my @matrix = ([]); my ($width, $height) = $img->getBounds; my $new_img = GD::Image->new($width, $height); sub get_pixel { $img->rgb($img->getPixel(@_)); } foreach my $y (1 .. $height - 2) { foreach my $x (1 .. $width - 2) { my @left = get_pixel($x - 1, $y); my @right = get_pixel($x + 1, $y); my @down_left = get_pixel($x - 1, $y + 1); my @down_right = get_pixel($x + 1, $y + 1); my @up = get_pixel($x, $y - 1); my @down = get_pixel($x, $y + 1); my @up_left = get_pixel($x - 1, $y - 1); my @up_right = get_pixel($x + 1, $y - 1); $matrix[$y][$x] = $new_img->colorAllocate( min(($up[0], $down[0], $up_left[0], $up_right[0], $down_left[0], $down_right[0])), min(($up[1], $down[1], $up_left[1], $up_right[1], $down_left[1], $down_right[1])), min(($up[2], $down[2], $up_left[2], $up_right[2], $down_left[2], $down_right[2])), ); } } for my $y (1 .. $height - 2) { for my $x (1 .. $width - 2) { $new_img->setPixel($x, $y, $matrix[$y][$x]); } } open(my $fh, '>:raw', $out_file) or die "Can't open `$out_file' for write: $!"; print $fh ( $out_file =~ /\.png\z/i ? $new_img->png : $out_file =~ /\.gif\z/i ? $new_img->gif : $new_img->jpeg ); close $fh; ================================================ FILE: Image/diff_negative.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 07 November 2015 # Edit: 19 May 2016 # Website: https://github.com/trizen # Replace the light-color pixels with the difference between the brightest and darkest neighbors. # _________________ # | | | | # | A | B | C | # |_____|_____|_____| _____ # | | | | | | # | H | | D | --> | M | # |_____|_____|_____| |_____| # | | | | # | G | F | E | # |_____|_____|_____| # where M is the average color of (max(A..H) - min(A..H)) use 5.010; use strict; use warnings; use List::Util qw(min max sum); use GD; GD::Image->trueColor(1); sub help { my ($exit_code) = @_; print <<"EOT"; usage: $0 [input image] [output image] EOT exit($exit_code // 0); } my $in_file = shift(@ARGV) // help(2); my $out_file = shift(@ARGV) // 'output.png'; my $img = GD::Image->new($in_file); my @matrix = ([]); my ($width, $height) = $img->getBounds; my $new_img = GD::Image->new($width, $height); sub diff { max(@_) - min(@_); } sub avg { (int(sum(@_) / @_)) x 3; } sub get_pixel { $img->rgb($img->getPixel(@_)) } foreach my $y (1 .. $height - 2) { foreach my $x (1 .. $width - 2) { my @left = get_pixel($x - 1, $y); my @right = get_pixel($x + 1, $y); my @down_left = get_pixel($x - 1, $y + 1); my @down_right = get_pixel($x + 1, $y + 1); my @up = get_pixel($x, $y - 1); my @down = get_pixel($x, $y + 1); my @up_left = get_pixel($x - 1, $y - 1); my @up_right = get_pixel($x + 1, $y - 1); $matrix[$y][$x] = $new_img->colorAllocate( avg( diff(($up[0], $down[0], $up_left[0], $up_right[0], $down_left[0], $down_right[0])), diff(($up[1], $down[1], $up_left[1], $up_right[1], $down_left[1], $down_right[1])), diff(($up[2], $down[2], $up_left[2], $up_right[2], $down_left[2], $down_right[2])) ), ); } } for my $y (1 .. $height - 2) { for my $x (1 .. $width - 2) { $new_img->setPixel($x, $y, $matrix[$y][$x]); } } open(my $fh, '>:raw', $out_file) or die "Can't open `$out_file' for write: $!"; print $fh ( $out_file =~ /\.png\z/i ? $new_img->png : $out_file =~ /\.gif\z/i ? $new_img->gif : $new_img->jpeg ); close $fh; ================================================ FILE: Image/edge_detector.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 05 November 2015 # Edit: 19 May 2016 # Website: https://github.com/trizen # A very basic edge detector, which highlights the edges in an image. use 5.010; use strict; use warnings; use GD; GD::Image->trueColor(1); use List::Util qw(sum); use Getopt::Long qw(GetOptions); my $tolerance = 15; # lower tolerance => more noise GetOptions('t|tolerance=f' => \$tolerance, 'h|help' => sub { help(0) }) or die "Error in command-line arguments!"; sub help { my ($exit_code) = @_; print <<"EOT"; usage: $0 [options] [input image] [output image] options: -t --tolerance=[0-100] : tolerance value for edges (default: $tolerance) lower values will generate more noise example: perl $0 -t=5 input.png output.png EOT exit($exit_code // 0); } my $in_file = shift(@ARGV) // help(2); my $out_file = shift(@ARGV) // 'output.png'; my $img = GD::Image->new($in_file); my @matrix = ([]); my ($width, $height) = $img->getBounds; sub get_avg_pixel { sum($img->rgb($img->getPixel(@_))) / 3; } # Detect edge foreach my $y (1 .. $height - 2) { foreach my $x (1 .. $width - 2) { if ( abs(get_avg_pixel($x-1, $y ) - get_avg_pixel($x+1, $y )) / 255 * 100 > $tolerance # left <-> right or abs(get_avg_pixel($x, $y-1) - get_avg_pixel($x, $y+1)) / 255 * 100 > $tolerance # up <-> down or abs(get_avg_pixel($x-1, $y-1) - get_avg_pixel($x+1, $y+1)) / 255 * 100 > $tolerance # up-left <-> down-right or abs(get_avg_pixel($x+1, $y-1) - get_avg_pixel($x-1, $y+1)) / 255 * 100 > $tolerance # up-right <-> down-left ) { $matrix[$y][$x] = 1; } } } # Remove noise foreach my $y (1 .. $height - 2) { foreach my $x (1 .. $width - 2) { if (defined($matrix[$y][$x])) { if (!defined($matrix[$y ][$x+1]) and !defined($matrix[$y ][$x-1]) and !defined($matrix[$y-1][$x-1]) and !defined($matrix[$y-1][$x ]) and !defined($matrix[$y-1][$x+1]) and !defined($matrix[$y+1][$x-1]) and !defined($matrix[$y+1][$x ]) and !defined($matrix[$y+1][$x+1]) ) { undef $matrix[$y][$x]; } } } } my $new_img = GD::Image->new($width, $height); my $bg_color = $new_img->colorAllocate(0, 0, 0); my $fg_color = $new_img->colorAllocate(255, 255, 255); for my $y (0 .. $height - 1) { for my $x (0 .. $width - 1) { $new_img->setPixel($x, $y, defined($matrix[$y][$x]) ? $fg_color : $bg_color); } } open(my $fh, '>:raw', $out_file) or die "Can't open `$out_file' for write: $!"; print $fh ( $out_file =~ /\.png\z/i ? $new_img->png : $out_file =~ /\.gif\z/i ? $new_img->gif : $new_img->jpeg ); close $fh; ================================================ FILE: Image/extract_jpegs.pl ================================================ #!/usr/bin/perl # Unpack two or more concatenated JPEG files. # See also: # https://stackoverflow.com/questions/4585527/detect-end-of-file-for-jpg-images use 5.014; use strict; use warnings; use Digest::MD5 qw(md5_hex); binmode(STDIN, ':raw'); binmode(STDOUT, ':raw'); my $data = do { local $/; <>; }; #my @files = split(/\x{FF}\x{D8}/, $data); #my @files = split(/^\xFF\xD8/m, $data); my $count = 1; #$data = reverse($data); #foreach my $data (@files) { while ($data =~ /(\xFF\xD8.*?\xFF\xD9)/gs) { my $jpeg = $1; my $name = sprintf("file_%d %s.jpg", $count++, md5_hex($jpeg)); open my $fh, '>:raw', $name or die "Can't open <<$name>>: $!"; print $fh $jpeg; close $fh; } ================================================ FILE: Image/fractal_frame.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 25 January 2018 # https://github.com/trizen # Adds a Mandelbrot-like fractal frame around the edges of an image. use 5.020; use strict; use warnings; use feature qw(lexical_subs); use experimental qw(signatures); use Imager; use Math::GComplex qw(cplx); sub complex_transform ($file) { my $img = Imager->new(file => $file); my $black = Imager::Color->new('#000000'); my $width = $img->getwidth; my $height = $img->getheight; my sub mandelbrot ($x, $y) { my $z = cplx( (2 * $x - $width) / $width, (2 * $y - $height) / $height, ); my $c = $z; my $i = 10; while (abs($z) < 2 and --$i) { $z = $z->pown(5) + $c; } return $i; } foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { next if (mandelbrot($x, $y) == 0); $img->setpixel( x => $x, y => $y, color => $black, ); } } return $img; } sub usage { die "usage: $0 [input image] [output image]\n"; } my $input = shift(@ARGV) // usage(); my $output = shift(@ARGV) // 'fractal_frame.png'; complex_transform($input)->write(file => $output); ================================================ FILE: Image/fractal_frame_transparent.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # License: GPLv3 # Date: 27 January 2018 # https://github.com/trizen # Adds a transparent Mandelbrot-like fractal frame around the edges of an image. use 5.020; use strict; use warnings; use feature qw(lexical_subs); use experimental qw(signatures); use Imager; use Math::GComplex qw(cplx); sub complex_transform ($file) { my $img = Imager->new(file => $file); my $width = $img->getwidth; my $height = $img->getheight; my $max_iter = 10; my sub mandelbrot ($x, $y) { my $z = cplx( (2 * $x - $width) / $width, (2 * $y - $height) / $height, ); my $c = $z; my $i = $max_iter; while (abs($z) < 2 and --$i) { $z = $z->pown(5) + $c; } ($max_iter - $i) / $max_iter; } foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $i = mandelbrot($x, $y); my $pixel = $img->getpixel(x => $x, y => $y); my ($red, $green, $blue, $alpha) = $pixel->rgba(); $red *= $i; $green *= $i; $blue *= $i; $alpha *= $i; $pixel->set($red, $green, $blue, $alpha); $img->setpixel( x => $x, y => $y, color => $pixel, ); } } return $img; } sub usage { die "usage: $0 [input image] [output image]\n"; } my $input = shift(@ARGV) // usage(); my $output = shift(@ARGV) // 'fractal_frame.png'; complex_transform($input)->write(file => $output); ================================================ FILE: Image/gd_png2jpg.pl ================================================ #!/usr/bin/perl # Daniel "Trizen" Șuteu # Date: 23 March 2021 # https://github.com/trizen # Convert PNG images to JPEG, using the GD library. # The original PNG files are deleted. use 5.036; use GD; use File::Find qw(find); use Getopt::Long qw(GetOptions); GD::Image->trueColor(1); my $batch_size = 100; # how many files to process at once my $quality = 95; # default quality value for JPEG (between 0-100) my $use_exiftool = 0; # true to use `exiftool` instead of `File::MimeInfo::Magic` sub convert_PNGs (@files) { say ":: Converting a batch of ", scalar(@files), " PNG images..."; foreach my $file (@files) { say ":: Processing: $file"; my $image = eval { GD::Image->new($file) } // do { warn "[!] Can't load file <<$file>>. Skipping...\n"; next; }; my $jpeg_data = $image->jpeg($quality); my $orig_file = $file; my $jpeg_file = $file; if ($jpeg_file =~ s/\.png\z/.jpg/i) { ## ok } else { $jpeg_file .= '.jpg'; } if (-e $jpeg_file) { warn "[!] File <<$jpeg_file>> already exists...\n"; next; } open(my $fh, '>:raw', $jpeg_file) or do { warn "[!] Can't open file <<$jpeg_file>> for writing: $!\n"; next; }; print {$fh} $jpeg_data; close $fh; if (-e $jpeg_file and ($orig_file ne $jpeg_file)) { say ":: Saved as: $jpeg_file"; unlink($orig_file); # remove the original PNG file } } } sub determine_mime_type ($file) { if ($use_exiftool) { my $res = `exiftool \Q$file\E`; $? == 0 or return; defined($res) or return; if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) { return $1; } return; } require File::MimeInfo::Magic; File::MimeInfo::Magic::magic($file); } my %types = ( 'image/png' => { files => [], call => \&convert_PNGs, }, ); GetOptions( 'exiftool!' => \$use_exiftool, 'batch-size=i' => \$batch_size, 'q|quality=i' => \$quality, ) or die "Error in command-line arguments!"; @ARGV or die <<"USAGE"; usage: perl $0 [options] [dirs | files] options: -q INT : quality level for JPEG (default: $quality) --batch=i : how many files to process at once (default: $batch_size) --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool) USAGE find( { no_chdir => 1, wanted => sub { (-f $_) || return; my $type = determine_mime_type($_) // return; if (exists $types{$type}) { my $ref = $types{$type}; push @{$ref->{files}}, $_; if (scalar(@{$ref->{files}}) >= $batch_size) { $ref->{call}->(splice(@{$ref->{files}})); } } } } => @ARGV ); foreach my $type (keys %types) { my $ref = $types{$type}; if (@{$ref->{files}}) { $ref->{call}->(splice(@{$ref->{files}})); } } say ":: Done!"; ================================================ FILE: Image/gd_similar_images.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 26 August 2015 # Edit: 24 October 2023 # Website: https://github.com/trizen # Find images that look similar. # Blog post: # https://trizenx.blogspot.com/2015/08/finding-similar-images.html use 5.022; use strict; use warnings; use experimental 'bitwise'; use GD qw(); use List::Util qw(sum); use File::Find qw(find); use Getopt::Long qw(GetOptions); GD::Image->trueColor(1); my $width = 32; my $height = 32; my $percentage = 90; my $keep_only = undef; my $img_formats = ''; my $resize_to = $width . 'x' . $height; my @img_formats = qw( jpeg jpg png ); sub help { my ($code) = @_; local $" = ","; print <<"EOT"; usage: $0 [options] [dir] options: -p --percentage=i : minimum similarity percentage (default: $percentage) -r --resize-to=s : resize images to this resolution (default: $resize_to) -f --formats=s,s : specify more image formats (default: @img_formats) -k --keep=s : keep only the 'smallest' or 'largest' image from each group WARNING: option '-k' permanently removes your images! example: perl $0 -p 75 -r '8x8' ~/Pictures EOT exit($code); } GetOptions( 'p|percentage=i' => \$percentage, 'r|resize-to=s' => \$resize_to, 'f|formats=s' => \$img_formats, 'k|keep=s' => \$keep_only, 'h|help' => sub { help(0) }, ) or die("Error in command line arguments"); ($width, $height) = split(/\h*x\h*/i, $resize_to); my $size = $width * $height; push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats); my $img_formats_re = do { local $" = '|'; qr/\.(@img_formats)\z/i; }; #<<< sub alike_percentage { ((($_[0] ^. $_[1]) =~ tr/\0//) / $size)**2 * 100; } #>>> sub fingerprint { my ($image) = @_; my $img = GD::Image->new($image) // return; { my $resized = GD::Image->new($width, $height); $resized->copyResampled($img, 0, 0, 0, 0, $width, $height, $img->getBounds()); $img = $resized; } my @averages; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { push @averages, sum($img->rgb($img->getPixel($x, $y)))/3; } } my $avg = sum(@averages) / @averages; join('', map { ($_ < $avg) ? 1 : 0 } @averages); } sub find_similar_images(&@) { my $callback = shift; my @files; find { no_chdir => 1, wanted => sub { (/$img_formats_re/o && -f) || return; push @files, { fingerprint => fingerprint($_) // return, filename => $_, }; } } => @_; # ## Populate the %alike hash # my %alike; foreach my $i (0 .. $#files - 1) { for (my $j = $i + 1 ; $j <= $#files ; $j++) { my $p = alike_percentage($files[$i]{fingerprint}, $files[$j]{fingerprint}); if ($p >= $percentage) { $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p; $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p; } } } # ## Group the files # my @alike; foreach my $root ( map { $_->[0] } sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) } map { my $keys = keys(%{$alike{$_}}); my $avg = sum(values(%{$alike{$_}})) / $keys; [$_, $keys, $avg] } keys %alike ) { my @group = keys(%{$alike{$root}}); if (@group) { my $avg = 0; $avg += delete($alike{$_}{$root}) for @group; push @alike, {score => $avg / @group, files => [$root, @group]}; } } # ## Callback each group # my %seen; foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) { (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next; $callback->($group->{score}, $group->{files}); } return 1; } @ARGV || help(1); find_similar_images { my ($score, $files) = @_; printf("=> Similarity: %.0f%%\n", $score); say join("\n", sort @{$files}); say "-" x 80; if (defined($keep_only)) { my @existent_files = grep { -f $_ } @$files; scalar(@existent_files) > 1 or return; my @sorted_by_size = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @existent_files; if ($keep_only =~ /large/i) { pop(@sorted_by_size); } elsif ($keep_only =~ /small/i) { shift(@sorted_by_size); } else { die "error: unknown value <<$keep_only>> for option `-k`!\n"; } foreach my $file (@sorted_by_size) { say "Removing: $file"; unlink($file) or warn "Failed to remove: $!"; } } } @ARGV; ================================================ FILE: Image/gd_star_trails.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 30 January 2015 # Edited: 31 January 2015 # Website: https://github.com/trizen # Merge two or more images together and keep the most intensive pixel colors use 5.010; use strict; use autodie; use warnings; use GD; use Getopt::Long qw(GetOptions); GD::Image->trueColor(1); my $output_file = 'output.png'; my $file_format = 'png'; my $png_compression = 9; my $jpeg_quality = 90; my $scale_percent = 0; sub help { print <<"HELP"; usage: $0 [options] [files] options: -o --output : output file (default: $output_file) -f --format : image format (default: $file_format) -q --jpeg-quality : JPEG quality (default: $jpeg_quality) -c --png-compression : PNG compression level (default: $png_compression) -s --scale-percent : scale image by a given percentage (default: $scale_percent) example: $0 -o merged.png --scale -20 file1.jpg file2.jpg HELP exit; } GetOptions( 'o|output=s' => \$output_file, 'f|format=s' => \$file_format, 'q|jpeg-quality=i' => \$jpeg_quality, 'c|png-compression=i' => \$png_compression, 's|scale-percent=i' => \$scale_percent, 'h|help' => \&help, ) or die "Error in command-line arguments!"; sub intensity { ($_[0] + $_[1] + $_[2]) / 3; } my @matrix; my %color_cache; my %intensity_cache; foreach my $image (@ARGV) { say "** Processing file: $image"; my $gd = GD::Image->new($image) // do { warn "** Can't load file <<$image>>. Skipping...\n"; next; }; my ($width, $height) = $gd->getBounds; if ($scale_percent != 0) { my $scale_width = $width + int($scale_percent / 100 * $width); my $scale_height = $height + int($scale_percent / 100 * $height); my $scaled_gd = GD::Image->new($scale_width, $scale_height); $scaled_gd->copyResampled($gd, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height); ($width, $height) = ($scale_width, $scale_height); $gd = $scaled_gd; } foreach my $x (0 .. $width - 1) { foreach my $y (0 .. $height - 1) { my $index = $gd->getPixel($x, $y); $matrix[$x][$y] //= [0, 0, 0]; if (intensity(@{$matrix[$x][$y]}) < ($intensity_cache{$index} //= (intensity(@{$color_cache{$index} //= [$gd->rgb($index)]})))) { $matrix[$x][$y] = $color_cache{$index}; } } } } @matrix || die "error: No image has been processed!\n"; say "** Creating the output image: $output_file"; my $image = GD::Image->new($#matrix + 1, $#{$matrix[0]} + 1); foreach my $x (0 .. $#matrix) { my $row = $matrix[$x] // next; foreach my $y (0 .. $#{$matrix[0]}) { my $entry = $row->[$y] // next; my $color = $image->colorAllocate(@{$entry}); $image->setPixel($x, $y, $color); } } open my $fh, '>:raw', $output_file; print $fh lc($file_format) =~ /png/ ? $image->png($png_compression) : $image->jpeg($jpeg_quality); close $fh; say "** All done!"; ================================================ FILE: Image/gif2webp.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 14 October 2023 # https://github.com/trizen # Convert GIF animations to WEBP animations, using the `gif2webp` tool from "libwebp". # The original GIF files are deleted. use 5.036; use File::Find qw(find); use Getopt::Long qw(GetOptions); my $gif2webp_cmd = "gif2webp"; # `gif2webp` command my $use_exiftool = 0; # true to use `exiftool` instead of `File::MimeInfo::Magic` `$gif2webp_cmd -h` or die "Error: `$gif2webp_cmd` tool from 'libwebp' is not installed!\n"; sub gif2webp ($file) { my $orig_file = $file; my $webp_file = $file; if ($webp_file =~ s/\.gif\z/.webp/i) { ## ok } else { $webp_file .= '.webp'; } if (-e $webp_file) { warn "[!] File <<$webp_file>> already exists...\n"; next; } system($gif2webp_cmd, '-lossy', $orig_file, '-o', $webp_file); if ($? == 0 and (-e $webp_file) and ($webp_file ne $orig_file)) { unlink($orig_file); } else { return; } return 1; } sub determine_mime_type ($file) { if ($file =~ /\.gif\z/i) { return "image/gif"; } if ($use_exiftool) { my $res = `exiftool \Q$file\E`; $? == 0 or return; defined($res) or return; if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) { return $1; } return; } require File::MimeInfo::Magic; File::MimeInfo::Magic::magic($file); } my %types = ( 'image/gif' => { call => \&gif2webp, }, ); GetOptions('exiftool!' => \$use_exiftool,) or die "Error in command-line arguments!"; @ARGV or die <<"USAGE"; usage: $0 [options] [dirs | files] options: --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool) USAGE find( { no_chdir => 1, wanted => sub { (-f $_) || return; my $type = determine_mime_type($_) // return; if (exists $types{$type}) { $types{$type}{call}->($_); } } } => @ARGV ); say ":: Done!"; ================================================ FILE: Image/horizontal_scrambler.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 05 April 2024 # https://github.com/trizen # Scramble the pixels in each row inside an image, using a deterministic method. use 5.036; use GD; use Getopt::Std qw(getopts); GD::Image->trueColor(1); sub scramble ($str) { my $i = length($str); $str =~ s/(.{$i})(.)/$2$1/gs while (--$i > 0); return $str; } sub unscramble ($str) { my $i = 0; my $l = length($str); $str =~ s/(.)(.{$i})/$2$1/gs while (++$i < $l); return $str; } sub scramble_image ($file, $function) { my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!"; my ($width, $height) = $image->getBounds(); my $new_image = GD::Image->new($width, $height); foreach my $y (0 .. $height - 1) { my (@R, @G, @B); foreach my $x (0 .. $width - 1) { my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y)); push @R, $R; push @G, $G; push @B, $B; } @R = unpack('C*', $function->(pack('C*', @R))); @G = unpack('C*', $function->(pack('C*', @G))); @B = unpack('C*', $function->(pack('C*', @B))); foreach my $x (0 .. $width - 1) { $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$x], $G[$x], $B[$x])); } } return $new_image; } sub usage ($exit_code = 0) { print <<"EOT"; usage: $0 [options] [input.png] [output.png] options: -d : decode the image -h : print this message and exit EOT exit($exit_code); } getopts('dh', \my %opts); my $input_file = $ARGV[0] // usage(2); my $output_file = $ARGV[1] // "output.png"; if (not -f $input_file) { die "Input file <<$input_file>> does not exist!\n"; } my $img = $opts{d} ? scramble_image($input_file, \&unscramble) : scramble_image($input_file, \&scramble); open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!"; print $out_fh $img->png(9); close $out_fh; ================================================ FILE: Image/image-hard-rotate.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 10 August 2025 # Edit: 23 Setepmber 2025 # https://github.com/trizen # Hard-rotate images that contain the "Orientation" EXIF tag specified as "Rotate 90 CW" or "Rotate 270 CW". use 5.036; use Imager; use Image::ExifTool qw(ImageInfo); use File::Find qw(find); use Getopt::Long qw(GetOptions); my $img_formats = ''; my $preserve_attr = 0; my @img_formats = qw( jpeg jpg ); sub usage ($code) { local $" = ","; print <<"EOT"; usage: $0 [options] [dirs | files] options: -f --formats=s,s : specify more image formats (default: @img_formats) -p --preserve! : preserve original file timestamps and permissions examples: $0 -p *.jpg EOT exit($code); } GetOptions( 'f|formats=s' => \$img_formats, 'p|preserve!' => \$preserve_attr, 'help' => sub { usage(0) }, ) or die("Error in command line arguments"); sub hard_rotate_image ($file) { my $info = ImageInfo($file); my $orientation = $info->{Orientation}; if (defined($orientation) and $orientation =~ /^Rotate (\d+) CW/) { my $angle = $1; say "-> Rotating image by $angle degrees clockwise..."; my $img = Imager->new(file => $file) or die Imager->errstr(); $img = $img->rotate(degrees => $angle); my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($file); unlink($file); $img->write(file => $file) or do { warn "Failed to rewrite image: ", $img->errstr; return; }; # Set the original ownership of the image chown($uid, $gid, $file); if ($preserve_attr) { # Set the original modification time utime($atime, $mtime, $file) or warn "Can't change timestamp: $!\n"; # Set original permissions chmod($mode & 07777, $file) or warn "Can't change permissions: $!\n"; } } } @ARGV || usage(1); push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats); my $img_formats_re = do { local $" = '|'; qr/\.(@img_formats)\z/i; }; find { no_chdir => 1, wanted => sub { (/$img_formats_re/o && -f) || return; say ":: Processing: $_"; hard_rotate_image($_); } } => @ARGV; ================================================ FILE: Image/image-unpack.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 29 April 2025 # https://github.com/trizen # Extract the {R,G,B} channels of an image, as binary data. use 5.036; use GD qw(); use Getopt::Long qw(GetOptions); binmode(STDOUT, ':raw'); GD::Image->trueColor(1); my $size = 80; my $red = 0; my $green = 0; my $blue = 0; sub help($code = 0) { print <<"HELP"; usage: $0 [options] [files] options: -w --width=i : resize image to this width (default: $size) -R --red : extract only the RED channel (default: $red) -G --green : extract only the GREEN channel (default: $green) -B --blue : extract only the BLUE channel (default: $blue) example: perl $0 --width 200 --red image.png > red_channel.bin HELP exit($code); } GetOptions( 'w|width=s' => \$size, 'R|red!' => \$red, 'G|green!' => \$green, 'B|blue!' => \$blue, 'h|help' => sub { help(0) }, ) or die "Error in command-line arguments!"; sub img_unpack($image) { my $img = GD::Image->new($image) // return; my ($width, $height) = $img->getBounds; if ($size != 0) { my $scale_width = $size; my $scale_height = int($height / ($width / ($size / 2))); my $resized = GD::Image->new($scale_width, $scale_height); $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height); ($width, $height) = ($scale_width, $scale_height); $img = $resized; } my @values; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $index = $img->getPixel($x, $y); my ($R, $G, $B) = $img->rgb($index); if ($red) { push @values, $R; } if ($green) { push @values, $G; } if ($blue) { push @values, $B; } } } my $output_width = $width * ($red + $green + $blue); return unpack("(A$output_width)*", pack('C*', @values)); } print for img_unpack($ARGV[0] // help(1)); ================================================ FILE: Image/image2ascii.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 27 August 2015 # Website: https://github.com/trizen # Generate an ASCII representation for an image use 5.010; use strict; use autodie; use warnings; use GD qw(); use Getopt::Long qw(GetOptions); GD::Image->trueColor(1); my $size = 80; sub help { my ($code) = @_; print <<"HELP"; usage: $0 [options] [files] options: -w --width=i : width size of the ASCII image (default: $size) example: perl $0 --width 200 image.png HELP exit($code); } GetOptions('w|width=s' => \$size, 'h|help' => sub { help(0) },) or die "Error in command-line arguments!"; sub avg { ($_[0] + $_[1] + $_[2]) / 3; } sub img2ascii { my ($image) = @_; my $img = GD::Image->new($image) // return; my ($width, $height) = $img->getBounds; if ($size != 0) { my $scale_width = $size; my $scale_height = int($height / ($width / ($size / 2))); my $resized = GD::Image->new($scale_width, $scale_height); $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height); ($width, $height) = ($scale_width, $scale_height); $img = $resized; } my $avg = 0; my @averages; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $index = $img->getPixel($x, $y); push @averages, avg($img->rgb($index)); $avg += $averages[-1] / $width / $height; } } unpack("(A$width)*", join('', map { $_ < $avg ? 1 : 0 } @averages)); } say for img2ascii($ARGV[0] // help(1)); ================================================ FILE: Image/image2audio.pl ================================================ #!/usr/bin/perl # Convert an image to an audio spectrogram. # Algorithm from: # https://github.com/alexadam/img-encode/blob/master/v1-python/imgencode.py # The spectrogram can be viewed in a program, like Audacity. # Inspired by the hidden message in the movie "Leave the world behind": # https://www.reddit.com/r/MrRobot/comments/18hnn3q/minor_spoiler_leave_the_world_behind_hidden/ use 5.036; use Imager; use Audio::Wav; use List::Util qw(min max); use Getopt::Long qw(GetOptions); my $max_height = 300; # resize images larger than this my $sample_rate = 44100; my $bits_sample = 16; my $frequency_band = $sample_rate / 2; # in Hz my $channels = 1; my $duration_factor = 1; my $output_wav = 'output.wav'; sub help ($code) { print <<"EOT"; usage: $0 [options] [images] options: -o --output=s : output audio file (default: $output_wav) -f --freq=i : frequency band in Hz (default: $frequency_band) -d --duration=f : duration multiplication factor (default: $duration_factor) -b --bits=i : bits sample (default: $bits_sample) -s --sample=i : sample rate (default: $sample_rate) -c --channels=i : number of channels (default: $channels) EOT exit($code); } GetOptions( 'o|output=s' => \$output_wav, 'f|frequency=i' => \$frequency_band, 'd|duration-factor=f' => \$duration_factor, 'b|bits-sample=i' => \$bits_sample, 's|sample-rate=i' => \$sample_rate, 'c|channels=i' => \$channels, 'h|help' => sub { help(0) }, ) or die("Error in command line arguments"); sub range_map ($value, $in_min, $in_max, $out_min, $out_max) { ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min; } sub image2spectrogram ($input_file, $write) { say "\n:: Processing: $input_file"; my $img = Imager->new(file => $input_file) or die "Can't open file <<$input_file>> for reading: $!"; my $width = $img->getwidth; my $height = $img->getheight; my $duration = $duration_factor * ($width / $height); say "-> Duration: $duration seconds"; if ($height > $max_height) { $img = $img->scale(ypixels => $max_height, qtype => 'mixing'); ($width, $height) = ($img->getwidth, $img->getheight); } my $min_size = min($width, $height); $width = int($duration * $min_size); $height = $min_size; say "-> Resizing the image to: $width x $height"; $img = $img->scale(xpixels => $width, ypixels => $height, qtype => 'mixing', type => 'nonprop'); my @data; my $maxFreq = 0; my $numSamples = int($sample_rate * $duration); my $samplesPerPixel = $numSamples / $width; my $C = $frequency_band / $height; my @img; foreach my $y (0 .. $height - 1) { my @line = $img->getscanline(y => $y); foreach my $pixel (@line) { my ($R, $G, $B) = $pixel->rgba; ## push @{$img[$y]}, ((($R + $G + $B) / 3) * 100 / 255)**2; ## push @{$img[$y]}, ((0.5 * max($R, $G, $B) + 0.5 * min($R, $G, $B)) * 100 / 255)**2; ## push @{$img[$y]}, (sqrt(0.299 * $R**2 + 0.587 * $G**2 + 0.114 * $B**2) * 100 / 255)**2; push @{$img[$y]}, ((0.299 * $R + 0.587 * $G + 0.114 * $B) * 100 / 255)**2; } } say "-> Converting the pixels to spectrogram frequencies"; my $tau = 2 * atan2(0, -1); foreach my $x (0 .. $numSamples - 1) { my $rez = 0; my $pixel_x = int($x / $samplesPerPixel); foreach my $y (0 .. $height - 1) { my $volume = $img[$y][$pixel_x] || next; my $freq = sprintf('%.0f', $C * ($height - $y + 1)); $rez += sprintf('%.0f', $volume * cos($freq * $tau * $x / $sample_rate)); } push @data, $rez; if (abs($rez) > $maxFreq) { $maxFreq = abs($rez); } } say "-> Maximum frequency: $maxFreq"; my $max_no = 2**($bits_sample - 1) - 1; #my $min = min(@data); #my $max = max(@data); my $min = -$maxFreq; my $max = $maxFreq; foreach my $val (@data) { ## $write->write(sprintf('%.0f', $max_no * $val / $maxFreq)); $write->write(range_map($val, $min, $max, -$max_no, $max_no)); } return 1; } @ARGV || help(2); my $details = { 'bits_sample' => $bits_sample, 'sample_rate' => $sample_rate, 'channels' => $channels, }; my $wav = Audio::Wav->new; my $write = $wav->write($output_wav, $details); foreach my $input_img (@ARGV) { image2spectrogram($input_img, $write); } $write->finish(); ================================================ FILE: Image/image2digits.pl ================================================ #!/usr/bin/perl # Author: Trizen # Date: 29 April 2022 # https://github.com/trizen # Generate an ASCII representation for an image, using only digits. # See also: # https://github.com/TotalTechGeek/pictoprime use 5.010; use strict; use autodie; use warnings; use GD qw(); use List::Util qw(max); use Getopt::Long qw(GetOptions); GD::Image->trueColor(1); my $size = 80; sub help { my ($code) = @_; print <<"HELP"; usage: $0 [options] [files] options: -w --width=i : width size of the ASCII image (default: $size) example: perl $0 --width 200 image.png HELP exit($code); } GetOptions('w|width=s' => \$size, 'h|help' => sub { help(0) },) or die "Error in command-line arguments!"; sub map_value { my ($value, $in_min, $in_max, $out_min, $out_max) = @_; ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min; } my @digits = split(//, "7772299408"); #my @digits = 0..9; sub img2digits { my ($image) = @_; my $img = GD::Image->new($image) // return; my ($width, $height) = $img->getBounds; if ($size != 0) { my $scale_width = $size; my $scale_height = int($height / ($width / ($size / 2))); my $resized = GD::Image->new($scale_width, $scale_height); $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height); ($width, $height) = ($scale_width, $scale_height); $img = $resized; } my @values; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $index = $img->getPixel($x, $y); my ($r, $g, $b) = $img->rgb($index); my $value = max($r, $g, $b); push @values, $digits[map_value($value, 0, 255, 0, $#digits)]; } } unpack("(A$width)*", join('', @values)); } say for img2digits($ARGV[0] // help(1)); ================================================ FILE: Image/image2html.pl ================================================ #!/usr/bin/perl # Author: Daniel "Trizen" Șuteu # License: GPLv3 # Date: 15 October 2015 # Website: https://github.com/trizen # Generate an HTML representation of an image # (best viewed with Firefox) use 5.010; use strict; use autodie; use warnings; use GD qw(); use Getopt::Long qw(GetOptions); use HTML::Entities qw(encode_entities); GD::Image->trueColor(1); my $size = 500; my $font_size = 1; sub help { my ($code) = @_; print <<"HELP"; usage: $0 [options] [files] options: -w --width=i : scale the image to this width (default: $size) -f --font-size=i : HTML font size property (default: $font_size) example: perl $0 --width 800 image.png HELP exit($code); } GetOptions( 'w|width=i' => \$size, 'f|font-size=f' => \$font_size, 'h|help' => sub { help(0) }, ) || die "Error in command-line arguments!"; sub img2html { my ($image) = @_; my $img = GD::Image->new($image) // return; my ($width, $height) = $img->getBounds; if ($size != 0) { my $scale_width = $size; my $scale_height = int($height / ($width / ($size / 2))); my $resized = GD::Image->new($scale_width, $scale_height); $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height); ($width, $height) = ($scale_width, $scale_height); $img = $resized; } my @pixels; foreach my $y (0 .. $height - 1) { foreach my $x (0 .. $width - 1) { my $index = $img->getPixel($x, $y); push @pixels, [$img->rgb($index)]; } } my $header = <<"EOT"; ${\encode_entities($image)} 
    EOT

    join('', $header, $style, $html, $footer);
}

say img2html($ARGV[0] // help(1));


================================================
FILE: Image/image2matrix.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# Transform an image into a matrix of RGB values.

use 5.010;
use strict;
use warnings;

use Imager;

my $file = shift(@ARGV) // die "usage: $0 [image]";
my $img = Imager->new(file => $file);

foreach my $y (0 .. $img->getheight - 1) {
    say join(
        ',',
        map {
            my $color = $img->getpixel(y => $y, x => $_);
            my ($r, $g, $b) = $color->rgba;

            my $rgb = $r;
            $rgb = ($rgb << 8) + $g;
            $rgb = ($rgb << 8) + $b;

            $rgb
          } (0 .. $img->getwidth - 1)
    );
}


================================================
FILE: Image/image2mozaic.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# Transform a regular image into a circle mozaic image.

use 5.010;
use strict;
use warnings;

use Imager;

my $radius = 4;
my $space  = 3;

sub image2mozaic {
    my ($img, $outfile) = @_;

    my $width  = $img->getwidth;
    my $height = $img->getheight;

    my $thumb = $img->scale(scalefactor => 1 / ($radius * $space));

    my $thumb_width  = $thumb->getwidth;
    my $thumb_height = $thumb->getheight;

    my @matrix;
    foreach my $y (0 .. $thumb_height - 1) {
        push @matrix, [map {
                [$thumb->getpixel(y => $y, x => $_)->rgba]
        } (0 .. $thumb_width - 1)];
    }

    my $scale_x = int($width / $thumb_width);
    my $scale_y = int($height / $thumb_height);

    my $mozaic = Imager->new(
                             xsize    => $scale_x * $thumb_width,
                             ysize    => $scale_y * $thumb_height,
                             channels => 3,
                            );

    my $color = Imager::Color->new(0, 0, 0);

    foreach my $i (0 .. $#matrix) {
        my $row = $matrix[$i];
        foreach my $j (0 .. $#{$row}) {
            $color->set(@{$row->[$j]});
            $mozaic->circle(
                            r     => $radius,
                            x     => int($radius + $j * $scale_x + rand($space)),
                            y     => int($radius + $i * $scale_y + rand($space)),
                            color => $color,
                           );
        }
    }

    $mozaic->write(file => $outfile);
}

my $file = shift(@ARGV) // die "usage: $0 [image]";
my $img = Imager->new(file => $file) // die "can't load image `$file': $!";

image2mozaic($img, 'circle_mozaic.png');


================================================
FILE: Image/image2png.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 19 December 2021
# Edit: 31 July 2022
# https://github.com/trizen

# Convert any images to PNG, using the Gtk3::Gdk::Pixbuf library.

# It can convert SVG, WEBP, JPEG, and more...

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Gtk3                  qw(-init);
use File::Spec::Functions qw(catfile);
use File::Basename        qw(dirname basename);
use Getopt::Long          qw(GetOptions);

my %CONFIG = (
              output_dir   => undef,
              width        => undef,
              height       => undef,
              scale_factor => undef,
              flipx        => undef,
              flipy        => undef,
              remove       => 0,
             );

sub help ($exit_code = 0) {
    print <<"EOT";
Usage: $0 [OPTIONS] []

  -w, --width=WIDTH     Width of output image in pixels
  -h, --height=HEIGHT   Height of output image in pixels
  -s, --scale=FACTOR    Scale image by FACTOR
  -d, --dir=DIRECTORY   Output directory

  --flipx       Flip X coordinates of image
  --flipy       Flip Y coordinates of image

  --remove!     Remove original files
  --help        Give this help list
EOT

    exit($exit_code);
}

GetOptions(
           "d|directory=s" => \$CONFIG{output_dir},
           "w|width=i"     => \$CONFIG{width},
           "h|height=i"    => \$CONFIG{height},
           "s|scale=f"     => \$CONFIG{scale_factor},
           "flipx"         => \$CONFIG{flipx},
           "flipy"         => \$CONFIG{flipy},
           "remove!"       => \$CONFIG{remove},
           'help'          => sub { help(0) },
          )
  or help(1);

@ARGV || help(2);

sub image2png ($input_file, $output_file = undef) {

    my $pixbuf;

    if (defined($CONFIG{width}) or defined($CONFIG{height})) {

        my $width = $CONFIG{width} // do {
            my (undef, $x, $y) = Gtk3::Gdk::Pixbuf::get_file_info($input_file);
            int($x / ($y / $CONFIG{height}));
        };

        my $height            = $CONFIG{height} // $CONFIG{width};
        my $keep_aspect_ratio = ($CONFIG{width} && $CONFIG{height}) ? 0 : 1;

        $pixbuf = "Gtk3::Gdk::Pixbuf"->new_from_file_at_scale($input_file, $width, $height, $keep_aspect_ratio);
    }
    elsif (defined($CONFIG{scale_factor})) {
        my (undef, $width, $height) = Gtk3::Gdk::Pixbuf::get_file_info($input_file);
        my $scale = $CONFIG{scale_factor};
        $pixbuf = "Gtk3::Gdk::Pixbuf"->new_from_file_at_scale($input_file, $width * $scale, $height * $scale, 0);
    }
    else {
        $pixbuf = "Gtk3::Gdk::Pixbuf"->new_from_file($input_file);
    }

    if ($CONFIG{flipx}) {
        $pixbuf = $pixbuf->flip(1);
    }

    if ($CONFIG{flipy}) {
        $pixbuf = $pixbuf->flip(0);
    }

    if (defined($pixbuf)) {
        if (!defined($output_file)) {

            my $output_dir = $CONFIG{output_dir} // dirname($input_file);
            my $basename   = basename($input_file);

            if (not $basename =~ s/\.(svg|jpe?g|webp|gif|avif|jfif|pjpeg|pjp|bmp|ico|tiff?|xpm)\z/.png/i) {
                $basename .= '.png';
            }

            if (not -d $output_dir) {
                require File::Path;
                File::Path::make_path($output_dir)
                  || warn "Cannot create output directory <<$output_dir>>: $!\n";
            }

            $output_file = catfile($output_dir, $basename);
        }
        $pixbuf->save($output_file, 'png');
        return 1;
    }

    return undef;
}

foreach my $file (@ARGV) {
    say ":: Processing: $file";
    if (-e $file) {
        if (image2png($file)) {
            if ($CONFIG{remove}) {
                say ":: Removing original file...";
                unlink($file) or warn "Cannot remove file <<$file>>: $!\n";
            }
        }
        else {
            warn "Cannot convert file <<$file>>! Skipping...\n";
        }
    }
    else {
        warn "File <<$file>> does not exist! Skipping...\n";
    }
}


================================================
FILE: Image/image2prime.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 29 April 2022
# https://github.com/trizen

# Generate an ASCII representation for an image, using only digits, such that the number is a prime.

# Inspired by the following Matt Parker video:
#   https://yewtu.be/watch?v=dET2l8l3upU

# See also:
#   https://github.com/TotalTechGeek/pictoprime

use 5.010;
use strict;
use autodie;
use warnings;

use GD qw();
use List::Util qw(max);
use Getopt::Long qw(GetOptions);
use Math::Prime::Util::GMP qw(is_prob_prime);

use constant {
              GENERATE_PRIME => 1,    # true to generate primes (slow)
             };

GD::Image->trueColor(1);

my $size = 80;

sub help {
    my ($code) = @_;
    print <<"HELP";
usage: $0 [options] [files]

options:
    -w  --width=i : width size of the ASCII image (default: $size)

example:
    perl $0 --width 200 image.png
HELP
    exit($code);
}

GetOptions('w|width=s' => \$size,
           'h|help'    => sub { help(0) },)
  or die "Error in command-line arguments!";

sub map_value {
    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;
    ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min;
}

my @digits = split(//, "7772299408");

#my @digits = 0..9;

# The ways that we allow the algorithm to substitute a character.
# Like 0 can become 8 or 9, so on and so forth.
my %substitutions = (
    '0' => ['8', '9'],
    '1' => ['7'],
    '7' => ['1'],
    '8' => ['0', '9'],
    '9' => ['4'],
    '4' => ['9'],
                    );

# These are used to swap out the last digit if necessary.
my %edge_digit_substitutions = (
                                '0' => '3',
                                '2' => '3',
                                '4' => '9',
                                '6' => '9',
                                '8' => '9',
                                '5' => '3'
                               );

sub create_prime {
    my ($pixels) = @_;

    GENERATE_PRIME || return $pixels;

    if (substr($pixels, 0, 1) == 0) {
        substr($pixels, 0, 1, $edge_digit_substitutions{0});
    }

    if (exists($edge_digit_substitutions{substr($pixels, -1)})) {
        my $digit = chop $pixels;
        $pixels .= $edge_digit_substitutions{$digit};
    }

    my $count  = 0;
    my $copy   = $pixels;
    my $length = length($pixels);

    my @substitution_indices = grep { exists $substitutions{substr($pixels, $_, 1)} } 0 .. $length - 1;

    while (1) {

        if (is_prob_prime($pixels)) {
            return $pixels;
        }

        if (++$count > 5) {
            $pixels = $copy;
            $count  = 0;
        }

        my $rand  = $substitution_indices[int rand scalar @substitution_indices];
        my $digit = substr($pixels, $rand, 1);
        my $alt   = $substitutions{$digit};

        substr($pixels, $rand, 1, $alt->[int rand scalar @$alt]);
    }
}

sub img2prime {
    my ($image) = @_;

    my $img = GD::Image->new($image) // return;
    my ($width, $height) = $img->getBounds;

    if ($size != 0) {
        my $scale_width  = $size;
        my $scale_height = int($height / ($width / ($size / 2)));

        my $resized = GD::Image->new($scale_width, $scale_height);
        $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);

        ($width, $height) = ($scale_width, $scale_height);
        $img = $resized;
    }

    my $avg = 0;
    my @averages;

    foreach my $y (0 .. $height - 1) {
        foreach my $x (0 .. $width - 1) {
            my $index = $img->getPixel($x, $y);
            my ($r, $g, $b) = $img->rgb($index);
            my $value = max($r, $g, $b);
            push @averages, $digits[map_value($value, 0, 255, 0, $#digits)];
        }
    }

    my $prime = create_prime(join('', @averages));
    unpack("(A$width)*", $prime);
}

say for img2prime($ARGV[0] // help(1));

__END__
30000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000001002222333222221100000000000000000000000000000000000000000
00000000000000000001101343344444444333332211000000000000000000000000000000000000
00000000000000000000355455555555556666666665544332100000000000000000000000000000
00000000000000003543245666666666777777777666665544321000000000000000000000000000
00000000000000001256666666677777777777777776666655432100000000000000000000000000
00000000011144433225666678888888876555556655543433322100000000000000000000000000
00000000012234667777767888888753135554300134310000000000000000000000000000000000
00000000001233356777888888884013366653000000000000000000000110000000000000000000
00000000000013345678888888711335667631000000000000000000000000010000000000000000
00001124556666656888888888123456776520000000000000111111100000011110000000000000
00033334567777788888888885245667776651000000000010000000000000001110001000000000
00021034355667788888888884456778877766520000000100000000022000000100000100000000
00000013044455888888888887788888888875300000000110000000132032111000000110000000
00000000012053888888888888888888888888400000000111001110220301211000001110000000
00000000000020788888888888888888888888830000001000000022021013133211001100000000
00000000000020788888888888888888888888830000010000000001221121121011000001000000
00000000013054888888888888888888888888400000001000001222222122231000000001000000
00000013044455888888888887778888888885400000000001100000001221021000000010000000
00022034355677788888888884456668877766420000000001110000011000000001111000000000
00033335567777788888888885235667776651000000000000100000000000000001100000000000
00000124455666655888888888123456777520000800000000011000011110000011000000000000
00000000000023345678888888711334667641000000000000000110000011111100000000000000
00000000001233356777888888884113366653000000000000000000000000000000000000000000
00000000012234667777767888888753135554300134310000000000000000000000000000000000
00000000011134332225666678888888876555556655544433332100000000000000000000000000
00000000000000001256666666667777777777777776666655432100000000000000000000000000
00000000000000013443245666666666777777777666665544321000000000000000000000000000
00000000000000000000354455555555555666665555543321100000000000000000000000000000
00000000000000000001101343344344434343332210000000000000000000000000000000000000
00000000000000000000001002222223222221100000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000003


================================================
FILE: Image/image_metadata_clone.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 26 September 2025
# https://github.com/trizen

# Copy EXIF metadata from images, given a source directory and a destination directory.

# Metadata from each image from the source directory is added to the images
# in the destination directory, based on the filename of each image.

use 5.036;
use Image::ExifTool qw();
use File::Find      qw(find);
use File::Basename  qw(basename);
use Getopt::Long    qw(GetOptions);

my $img_formats = '';

my @img_formats = qw(
  jpeg
  jpg
);

sub usage($exit_code = 0) {

    print <<"EOT";
usage: $0 [options] [source dir] [dest dir]

options:
    -f  --formats=s,s   : specify more image formats (default: @img_formats)
    --help              : print this message and exit
EOT

    exit $exit_code;
}

GetOptions("f|formats=s" => \$img_formats,
           'help'        => sub { usage(0) })
  or die("Error in command line arguments\n");

@ARGV == 2 or usage(1);

sub add_exif_info($source_image, $dest_image) {

    my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($dest_image);

    my $exifTool  = Image::ExifTool->new;
    my $exif_info = $exifTool->SetNewValuesFromFile($source_image);

    $exifTool = Image::ExifTool->new;

    foreach my $key (keys %$exif_info) {
        my $value = $exif_info->{$key};
        $exifTool->SetNewValue($key, $value);
    }

    $exifTool->WriteInfo($dest_image);

    # Set the original modification time
    utime($atime, $mtime, $dest_image)
      or warn "Can't change timestamp: $!\n";

    # Set original permissions
    chmod($mode & 07777, $dest_image)
      or warn "Can't change permissions: $!\n";

    # Set the original ownership of the image
    chown($uid, $gid, $dest_image);
}

push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats);

my $img_formats_re = do {
    local $" = '|';
    qr/\.(@img_formats)\z/i;
};

my ($source_dir, $dest_dir) = @ARGV;

my %source_files;

find {
    no_chdir => 1,
    wanted   => sub {
        (/$img_formats_re/o && -f) || return;
        my $basename = basename($_);
        $source_files{$basename} = $_;
    }
} => $source_dir;

find {
    no_chdir => 1,
    wanted   => sub {
        (/$img_formats_re/o && -f) || return;

        my $basename = basename($_);

        if (exists($source_files{$basename})) {
            say "Adding EXIF metadata to: $_";
            add_exif_info($source_files{$basename}, $_);
        }
        else {
            warn "Couldn't find <<$basename>> into source directory. Skipping...\n";
        }
    }
} => $dest_dir;


================================================
FILE: Image/imager_similar_images.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 August 2015
# Edit: 24 October 2023
# Website: https://github.com/trizen

# Find images that look similar.

# Blog post:
#   https://trizenx.blogspot.com/2015/08/finding-similar-images.html

use 5.022;
use strict;
use warnings;

use experimental qw(bitwise);

use Imager       qw();
use List::Util   qw(sum);
use File::Find   qw(find);
use Getopt::Long qw(GetOptions);

my $width      = 32;
my $height     = 'auto';
my $percentage = 90;

my $keep_only   = undef;
my $img_formats = '';

my @img_formats = qw(
  jpeg
  jpg
  png
);

sub help {
    my ($code) = @_;
    local $" = ",";
    print <<"EOT";
usage: $0 [options] [dir]

options:
    -p  --percentage=i  : minimum similarity percentage (default: $percentage)
    -w  --width=i       : resize images to this width (default: $width)
    -h  --height=i      : resize images to this height (default: $height)
    -f  --formats=s,s   : specify more image formats (default: @img_formats)
    -k  --keep=s        : keep only the 'smallest' or 'largest' image from each group

WARNING: option '-k' permanently removes your images!

example:
    perl $0 -p 75 -r '8x8' ~/Pictures
EOT

    exit($code);
}

GetOptions(
           'p|percentage=i' => \$percentage,
           'w|width=s'      => \$width,
           'h|height=s'     => \$height,
           'f|formats=s'    => \$img_formats,
           'k|keep=s'       => \$keep_only,
          )
  or die("Error in command line arguments");

push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats);

my $img_formats_re = do {
    local $" = '|';
    qr/\.(@img_formats)\z/i;
};

#<<<
sub alike_percentage {
    ((($_[0] ^. $_[1]) =~ tr/\0//) / $_[2])**2 * 100;
}
#>>>

sub fingerprint {
    my ($image) = @_;

    my $img = Imager->new(file => $image) or do {
        warn "Failed to load <<$image>>: ", Imager->errstr();
        return;
    };

    if ($height ne 'auto') {
        $img = $img->scale(ypixels => $height, qtype => 'preview');
    }
    else {
        $img = $img->scale(xpixels => $width, qtype => 'preview');
    }

    my ($curr_width, $curr_height) = ($img->getwidth, $img->getheight);

    my @averages;
    foreach my $y (0 .. $curr_height - 1) {
        my @line = $img->getscanline(y => $y);
        foreach my $pixel (@line) {
            my ($R, $G, $B) = $pixel->rgba;
            push @averages, sum($R, $G, $B) / 3;
        }
    }

    my $avg = sum(@averages) / @averages;
    [join('', map { ($_ < $avg) ? 1 : 0 } @averages), $curr_width, $curr_height];
}

sub find_similar_images(&@) {
    my $callback = shift;

    my @files;
    find {
        no_chdir => 1,
        wanted   => sub {
            (/$img_formats_re/o && -f) || return;

            push @files,
              {
                fingerprint => fingerprint($_) // return,
                filename    => $_,
              };
        }
    } => @_;

    #
    ## Populate the %alike hash
    #
    my %alike;
    foreach my $i (0 .. $#files - 1) {
        for (my $j = $i + 1 ; $j <= $#files ; $j++) {
            my $p = alike_percentage(
                           $files[$i]{fingerprint}->[0],
                           $files[$j]{fingerprint}->[0],
                           sqrt($files[$i]{fingerprint}->[1] * $files[$j]{fingerprint}->[1]) * sqrt($files[$i]{fingerprint}->[2] * $files[$j]{fingerprint}->[2])
            );
            if ($p >= $percentage) {
                $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p;
                $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p;
            }
        }
    }

    #
    ## Group the files
    #
    my @alike;
    foreach my $root (
        map  { $_->[0] }
        sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) }
        map {
            my $keys = keys(%{$alike{$_}});
            my $avg  = sum(values(%{$alike{$_}})) / $keys;

            [$_, $keys, $avg]
        }
        keys %alike
      ) {
        my @group = keys(%{$alike{$root}});
        if (@group) {
            my $avg = 0;
            $avg += delete($alike{$_}{$root}) for @group;
            push @alike, {score => $avg / @group, files => [$root, @group]};

        }
    }

    #
    ## Callback each group
    #
    my %seen;
    foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) {
        (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next;
        $callback->($group->{score}, $group->{files});
    }

    return 1;
}

@ARGV || help(1);
find_similar_images {
    my ($score, $files) = @_;

    printf("=> Similarity: %.0f%%\n", $score);
    say join("\n", sort @{$files});
    say "-" x 80;

    if (defined($keep_only)) {

        my @existent_files = grep { -f $_ } @$files;

        scalar(@existent_files) > 1 or return;

        my @sorted_by_size = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @existent_files;
        if ($keep_only =~ /large/i) {
            pop(@sorted_by_size);
        }
        elsif ($keep_only =~ /small/i) {
            shift(@sorted_by_size);
        }
        else {
            die "error: unknown value <<$keep_only>> for option `-k`!\n";
        }
        foreach my $file (@sorted_by_size) {
            say "Removing: $file";
            unlink($file) or warn "Failed to remove: $!";
        }
    }
} @ARGV;


================================================
FILE: Image/img-autocrop-avg.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 June 2015
# Edit: 19 March 2017
# https://github.com/trizen

# A generic image auto-cropper which adapt itself to any background color.

use 5.010;
use strict;
use warnings;

use GD qw();

use Getopt::Long qw(GetOptions);
use File::Basename qw(basename);
use File::Spec::Functions qw(catfile);

# Set true color
GD::Image->trueColor(1);

# Autoflush mode
local $| = 1;

my $tolerance = 5;
my $invisible = 0;

my $jpeg_quality    = 95;
my $png_compression = 7;

my $directory = 'Cropped images';

sub help {
    my ($code) = @_;
    print <<"EOT";
usage: $0 [options] [images]

options:
    -t --tolerance=i    : tolerance value for the background color
                          default: $tolerance

    -i --invisible!     : make the background transparent after cropping
                          default: ${$invisible ? \'true' : \'false'}

    -p --png-compress=i : the compression level for PNG images
                          default: $png_compression

    -j --jpeg-quality=i : the quality value for JPEG images
                          default: $jpeg_quality

    -d --directory=s    : directory where to create the cropped images
                          default: "$directory"

example:
    perl $0 -t 10 *.png
EOT
    exit($code // 0);
}

GetOptions(
           'd|directory=s'       => \$directory,
           'i|invisible!'        => \$invisible,
           't|tolerance=i'       => \$tolerance,
           'p|png-compression=i' => \$png_compression,
           'j|jpeg-quality=i'    => \$jpeg_quality,
           'h|help'              => sub { help(0) },
          )
  or die("$0: error in command line arguments!\n");

{
    my %cache;

    sub is_background {
        my ($img, $index, $bg_rgb) = @_;
        my $rgb = ($cache{$index} //= [$img->rgb($index)]);
        abs($rgb->[0] - $bg_rgb->[0]) <= $tolerance
          and abs($rgb->[1] - $bg_rgb->[1]) <= $tolerance
          and abs($rgb->[2] - $bg_rgb->[2]) <= $tolerance;
    }
}

sub make_invisible_bg {
    my ($img, $transparent, $bg_rgb, $width, $height) = @_;

    foreach my $x (0 .. $width) {
        foreach my $y (0 .. $height) {
            if (is_background($img, $img->getPixel($x, $y), $bg_rgb)) {
                $img->setPixel($x, $y, $transparent);
            }
        }
    }
}

sub autocrop {
    my @images = @_;

    foreach my $file (@images) {
        my $img = GD::Image->new($file);

        if (not defined $img) {
            warn "[!] Can't process image `$file': $!\n";
            next;
        }

        my ($width, $height) = $img->getBounds();

        $width  -= 1;
        $height -= 1;

        my $C = (2 * $width + 1 + 2 * $height + 1);
        my @bg_rgb = (0, 0, 0);

        foreach my $x (0 .. $width) {
            for my $arr ([map { $_ / $C } $img->rgb($img->getPixel($x, 0))],
                         [map { $_ / $C } $img->rgb($img->getPixel($x, $height))]) {
                $bg_rgb[0] += $arr->[0];
                $bg_rgb[1] += $arr->[1];
                $bg_rgb[2] += $arr->[2];
            }
        }

        foreach my $y (0 .. $height) {
            for my $arr ([map { $_ / $C } $img->rgb($img->getPixel(0, $y))],
                         [map { $_ / $C } $img->rgb($img->getPixel($width, $y))]) {
                $bg_rgb[0] += $arr->[0];
                $bg_rgb[1] += $arr->[1];
                $bg_rgb[2] += $arr->[2];
            }
        }

        print "Cropping: $file";

        my $top;
        my $bottom;
      TB: foreach my $y (1 .. $height) {
            foreach my $x (1 .. $width) {

                if (not defined $top) {
                    if (not is_background($img, $img->getPixel($x, $y), \@bg_rgb)) {
                        $top = $y - 1;
                    }
                }

                if (not defined $bottom) {
                    if (not is_background($img, $img->getPixel($x, $height - $y), \@bg_rgb)) {
                        $bottom = $height - $y + 1;
                    }
                }

                if (defined $top and defined $bottom) {
                    last TB;
                }
            }
        }

        if (not defined $top or not defined $bottom) {
            say " - fail!";
            next;
        }

        my $left;
        my $right;
      LR: foreach my $x (1 .. $width) {
            foreach my $y (1 .. $height) {
                if (not defined $left) {
                    if (not is_background($img, $img->getPixel($x, $y), \@bg_rgb)) {
                        $left = $x - 1;
                    }
                }

                if (not defined $right) {
                    if (not is_background($img, $img->getPixel($width - $x, $y), \@bg_rgb)) {
                        $right = $width - $x + 1;
                    }
                }

                if (defined $left and defined $right) {
                    last LR;
                }
            }
        }

        if (not defined $left or not defined $right) {
            say " - fail!";
            next;
        }

        my $cropped = GD::Image->new($right - $left + 1, $bottom - $top + 1);

        my $index;
        if ($invisible) {
            $index = $cropped->colorAllocateAlpha(int(rand(256)), int(rand(256)), int(rand(256)), 0);
            $cropped->filledRectangle(0, 0, $cropped->width, $cropped->height, $index);
            $cropped->transparent($index);
        }

        $cropped->copyResized(
                              $img,
                              0,          # destX
                              0,          # destY
                              $left,      # srcX
                              $top,       # srcY
                              $right,     # destW
                              $bottom,    # destH
                              $right,     # srcW
                              $bottom,    # srcH
                             );

        my $name = catfile($directory, basename($file));

        if ($invisible) {
            make_invisible_bg($cropped, $index, \@bg_rgb, $cropped->width - 1, $cropped->height - 1);
            $name =~ s/\.\w+\z/.png/;
        }

        open my $fh, '>:raw', $name or die "Can't create file `$name': $!";
        print $fh (
                     $name =~ /\.png\z/i ? $cropped->png($png_compression)
                   : $name =~ /\.gif\z/i ? $cropped->gif
                   :                       $cropped->jpeg($jpeg_quality)
                  );
        close $fh;

        say " - ok!";
    }
}

@ARGV || help(1);

if (not -d $directory) {
    mkdir($directory) || die "Can't mkdir `$directory': $!";
}

autocrop(@ARGV);


================================================
FILE: Image/img-autocrop-whitebg.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 June 2015
# https://github.com/trizen

# Auto-crop a list of images that have a white background.

use 5.010;
use strict;
use warnings;

use GD qw();

use File::Basename qw(basename);
use File::Spec::Functions qw(catfile);

# Set true color
GD::Image->trueColor(1);

# Autoflush mode
local $| = 1;

my $dir = 'Cropped images';

sub check {
    my ($img, $width, $height) = @_;

    my $check = sub {
        foreach my $sub (@_) {
            $sub->() == 0 or return;
        }
        1;
    };

    my $w_lt_h = $width < $height;
    my $min = $w_lt_h ? $width : $height;

    my %seen;

    # Spiral in to smaller gaps
    # -- this algorithm needs to be improved --
    for (my $i = int(sqrt($min)) ; $i >= 1 ; $i--) {
        foreach my $j (1 .. $min) {

            next if $j % $i;
            next if $seen{$j}++;

            if (
                not $check->(
                             sub { $img->getPixel($j,     0) },
                             sub { $img->getPixel(0,      $j) },
                             sub { $img->getPixel($j,     $height) },
                             sub { $img->getPixel($width, $j) },
                            )
              ) {
                return;
            }
        }
    }

    if ($w_lt_h) {
        foreach my $y ($width + 1 .. $height) {
            if (not $check->(sub { $img->getPixel(0, $y) }, sub { $img->getPixel($width, $y) })) {
                return;
            }
        }
    }
    else {
        foreach my $x ($height + 1 .. $width) {
            if (not $check->(sub { $img->getPixel($x, 0) }, sub { $img->getPixel($x, $height) })) {
                return;
            }
        }
    }

    return 1;
}

sub autocrop {
    my @images = @_;

    foreach my $file (@images) {
        my $img = GD::Image->new($file);

        if (not defined $img) {
            warn "[!] Can't process image `$file': $!\n";
            next;
        }

        my ($width, $height) = $img->getBounds();

        $width  -= 1;
        $height -= 1;

        print "Checking: $file";
        check($img, $width, $height) || do {
            print " - fail!\n";
            next;
        };

        print " - ok!\n";
        print "Cropping: $file";

        my $top;
        my $bottom;
      TB: foreach my $y (1 .. $height) {
            foreach my $x (1 .. $width) {

                if (not defined $top) {
                    if ($img->getPixel($x, $y)) {
                        $top = $y - 1;
                    }
                }

                if (not defined $bottom) {
                    if ($img->getPixel($x, $height - $y)) {
                        $bottom = $height - $y + 1;
                    }
                }

                if (defined $top and defined $bottom) {
                    last TB;
                }
            }
        }

        my $left;
        my $right;
      LR: foreach my $x (1 .. $width) {
            foreach my $y (1 .. $height) {
                if (not defined $left) {
                    if ($img->getPixel($x, $y)) {
                        $left = $x - 1;
                    }
                }

                if (not defined $right) {
                    if ($img->getPixel($width - $x, $y)) {
                        $right = $width - $x + 1;
                    }
                }

                if (defined $left and defined $right) {
                    last LR;
                }
            }
        }

        my $cropped = GD::Image->new($right - $left + 1, $bottom - $top + 1);
        $cropped->copyResized(
                              $img,
                              0,          # destX
                              0,          # destY
                              $left,      # srcX
                              $top,       # srcY
                              $right,     # destW
                              $bottom,    # destH
                              $right,     # srcW
                              $bottom,    # srcH
                             );

        my $name = catfile($dir, basename($file));

        open my $fh, '>:raw', $name or die "Can't create file `$name': $!";
        print $fh ($name =~ /\.png\z/i ? $cropped->png : $cropped->jpeg);
        close $fh;

        print " - ok!\n";
    }
}

@ARGV || die "usage: $0 [images]\n";

if (not -d $dir) {
    mkdir($dir) || die "Can't mkdir `$dir': $!";
}

autocrop(@ARGV);


================================================
FILE: Image/img-autocrop.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 June 2015
# https://github.com/trizen

# A generic image auto-cropper which adapt itself to any background color.

use 5.010;
use strict;
use warnings;

use GD qw();

use Getopt::Long qw(GetOptions);
use File::Basename qw(basename);
use File::Spec::Functions qw(catfile);

# Set true color
GD::Image->trueColor(1);

# Autoflush mode
local $| = 1;

my $tolerance = 5;
my $invisible = 0;

my $jpeg_quality    = 95;
my $png_compression = 7;

my $directory = 'Cropped images';

sub help {
    my ($code) = @_;
    print <<"EOT";
usage: $0 [options] [images]

options:
    -t --tolerance=i    : tolerance value for the background color
                          default: $tolerance

    -i --invisible!     : make the background transparent after cropping
                          default: ${$invisible ? \'true' : \'false'}

    -p --png-compress=i : the compression level for PNG images
                          default: $png_compression

    -j --jpeg-quality=i : the quality value for JPEG images
                          default: $jpeg_quality

    -d --directory=s    : directory where to create the cropped images
                          default: "$directory"

example:
    perl $0 -t 10 *.png
EOT
    exit($code // 0);
}

GetOptions(
           'd|directory=s'       => \$directory,
           'i|invisible!'        => \$invisible,
           't|tolerance=i'       => \$tolerance,
           'p|png-compression=i' => \$png_compression,
           'j|jpeg-quality=i'    => \$jpeg_quality,
           'h|help'              => sub { help(0) },
          )
  or die("$0: error in command line arguments!\n");

{
    my %cache;

    sub is_background {
        my ($img, $index, $bg_rgb) = @_;
        my $rgb = ($cache{$index} //= [$img->rgb($index)]);
        abs($rgb->[0] - $bg_rgb->[0]) <= $tolerance
          and abs($rgb->[1] - $bg_rgb->[1]) <= $tolerance
          and abs($rgb->[2] - $bg_rgb->[2]) <= $tolerance;
    }
}

sub check {
    my ($img, $bg_rgb, $width, $height) = @_;

    my $check = sub {
        foreach my $sub (@_) {
            is_background($img, $sub->(), $bg_rgb) || return;
        }
        1;
    };

    my $w_lt_h = $width < $height;
    my $min = $w_lt_h ? $width : $height;

    my %seen;

    # Spiral-in to smaller gaps
    # -- this algorithm needs to be improved --
    for (my $i = int(sqrt($min)) ; $i >= 1 ; $i--) {
        foreach my $j (1 .. $min) {

            next if $j % $i;
            next if $seen{$j}++;

            if (
                not $check->(
                             sub { $img->getPixel($j,     0) },
                             sub { $img->getPixel(0,      $j) },
                             sub { $img->getPixel($j,     $height) },
                             sub { $img->getPixel($width, $j) },
                            )
              ) {
                return;
            }
        }
    }

    if ($w_lt_h) {
        foreach my $y ($width + 1 .. $height) {
            if (not $check->(sub { $img->getPixel(0, $y) }, sub { $img->getPixel($width, $y) })) {
                return;
            }
        }
    }
    else {
        foreach my $x ($height + 1 .. $width) {
            if (not $check->(sub { $img->getPixel($x, 0) }, sub { $img->getPixel($x, $height) })) {
                return;
            }
        }
    }

    return 1;
}

sub make_invisible_bg {
    my ($img, $transparent, $bg_rgb, $width, $height) = @_;

    foreach my $x (0 .. $width) {
        foreach my $y (0 .. $height) {
            if (is_background($img, $img->getPixel($x, $y), $bg_rgb)) {
                $img->setPixel($x, $y, $transparent);
            }
        }
    }
}

sub autocrop {
    my @images = @_;

    foreach my $file (@images) {
        my $img = GD::Image->new($file);

        if (not defined $img) {
            warn "[!] Can't process image `$file': $!\n";
            next;
        }

        my ($width, $height) = $img->getBounds();

        $width  -= 1;
        $height -= 1;

        my $bg_rgb = [$img->rgb($img->getPixel(0, 0))];

        print "Checking: $file";
        check($img, $bg_rgb, $width, $height) || do {
            say " - fail!";
            next;
        };

        say " - ok!";
        print "Cropping: $file";

        my $top;
        my $bottom;
      TB: foreach my $y (1 .. $height) {
            foreach my $x (1 .. $width) {

                if (not defined $top) {
                    if (not is_background($img, $img->getPixel($x, $y), $bg_rgb)) {
                        $top = $y - 1;
                    }
                }

                if (not defined $bottom) {
                    if (not is_background($img, $img->getPixel($x, $height - $y), $bg_rgb)) {
                        $bottom = $height - $y + 1;
                    }
                }

                if (defined $top and defined $bottom) {
                    last TB;
                }
            }
        }

        if (not defined $top or not defined $bottom) {
            say " - fail!";
            next;
        }

        my $left;
        my $right;
      LR: foreach my $x (1 .. $width) {
            foreach my $y (1 .. $height) {
                if (not defined $left) {
                    if (not is_background($img, $img->getPixel($x, $y), $bg_rgb)) {
                        $left = $x - 1;
                    }
                }

                if (not defined $right) {
                    if (not is_background($img, $img->getPixel($width - $x, $y), $bg_rgb)) {
                        $right = $width - $x + 1;
                    }
                }

                if (defined $left and defined $right) {
                    last LR;
                }
            }
        }

        if (not defined $left or not defined $right) {
            say " - fail!";
            next;
        }

        my $cropped = GD::Image->new($right - $left + 1, $bottom - $top + 1);

        my $index;
        if ($invisible) {
            $index = $cropped->colorAllocateAlpha(int(rand(256)), int(rand(256)), int(rand(256)), 0);
            $cropped->filledRectangle(0, 0, $cropped->width, $cropped->height, $index);
            $cropped->transparent($index);
        }

        $cropped->copyResized(
                              $img,
                              0,          # destX
                              0,          # destY
                              $left,      # srcX
                              $top,       # srcY
                              $right,     # destW
                              $bottom,    # destH
                              $right,     # srcW
                              $bottom,    # srcH
                             );

        my $name = catfile($directory, basename($file));

        if ($invisible) {
            make_invisible_bg($cropped, $index, $bg_rgb, $cropped->width - 1, $cropped->height - 1);
            $name =~ s/\.\w+\z/.png/;
        }

        open my $fh, '>:raw', $name or die "Can't create file `$name': $!";
        print $fh (
                     $name =~ /\.png\z/i ? $cropped->png($png_compression)
                   : $name =~ /\.gif\z/i ? $cropped->gif
                   :                       $cropped->jpeg($jpeg_quality)
                  );
        close $fh;

        say " - ok!";
    }
}

@ARGV || help(1);

if (not -d $directory) {
    mkdir($directory) || die "Can't mkdir `$directory': $!";
}

autocrop(@ARGV);


================================================
FILE: Image/img_composition.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 15 April 2015
# Edit: 18 September 2016
# Website: https://github.com/trizen

# Compose two images together by merging all the pixels, color by color.

use 5.010;
use strict;
use autodie;
use warnings;

use GD;

use List::Util qw(min);
use Getopt::Long qw(GetOptions);

GD::Image->trueColor(1);

my $output_file      = 'output.png';
my $scale_percentage = 0;

sub usage {
    print <<"USAGE";
usage: $0 [options] [img1] [img2]

options:
    -o  --output         : output file (default: $output_file)
    -s  --scale-percent  : scale images by a given percentage (default: $scale_percentage)

example:
    $0 -s -40 img1.png img2.jpg
USAGE
    exit 2;
}

GetOptions(
           'o|output=s'           => \$output_file,
           's|scale-percentage=i' => \$scale_percentage,
           'h|help'               => \&usage,
          );

sub scale_image {
    my ($img, $scale_percentage) = @_;

    my ($width, $height) = $img->getBounds;

    my $scale_width  = $width + int($scale_percentage / 100 * $width);
    my $scale_height = $height + int($scale_percentage / 100 * $height);

    my $scaled_gd = GD::Image->new($scale_width, $scale_height);
    $scaled_gd->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);

    return $scaled_gd;
}

sub make_matrix {
    my ($file, $scale_percentage) = @_;

    my $img = GD::Image->new($file) // do {
        warn "Can't load image `$file': $!\n";
        return;
    };

    if ($scale_percentage != 0) {
        $img = scale_image($img, $scale_percentage);
    }

    my @matrix;
    my ($width, $height) = $img->getBounds();
    foreach my $x (0 .. $width - 1) {
        foreach my $y (0 .. $height - 1) {
            $matrix[$x][$y] = [$img->rgb($img->getPixel($x, $y))];
        }
    }

    return \@matrix;
}

sub compose_images {
    my ($A, $B) = @_;

    local $| = 1;

    my ($rows, $cols) = (min($#{$A}, $#{$B}), min($#{$A->[0]}, $#{$B->[0]}));

    my @C;
    foreach my $r (0 .. $rows) {
        foreach my $i (0 .. $cols) {
            foreach my $c (0 .. 2) {
                $C[$i][$r][$c] = int(($A->[$r][$i][$c] + $B->[$r][$i][$c]) / 2);
            }
        }
        print "$r of $rows...\r";
    }

    return \@C;
}

sub write_matrix {
    my ($matrix, $file) = @_;

    my ($rows, $cols) = ($#{$matrix}, $#{$matrix->[0]});
    my $img = GD::Image->new($cols + 1, $rows + 1);

    foreach my $y (0 .. $rows) {
        foreach my $x (0 .. $cols) {
            $img->setPixel($x, $y, $img->colorAllocate(@{$matrix->[$y][$x]}));
        }
    }

    open my $fh, '>:raw', $file;
    print $fh lc($file) =~ /\.png\z/
      ? $img->png()
      : $img->jpeg();
    close $fh;

}

say "** Reading images...";
my $A = make_matrix(shift(@ARGV) // usage(), $scale_percentage) // die "error 1: $!";
my $B = make_matrix(shift(@ARGV) // usage(), $scale_percentage) // die "error 2: $!";

say "** Composing images...";
my $C = compose_images($A, $B);

say "** Writing the output image...";
write_matrix($C, $output_file)
  ? (say "** All done!")
  : (die "Error: $!");


================================================
FILE: Image/img_rewrite.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 30 January 2015
# Website: https://github.com/trizen

# Rewrite a set of images specified as arguments.

use 5.010;
use strict;
use warnings;

use Image::Magick;

foreach my $file (@ARGV) {
    say "** Processing file `$file'...";
    my $img = Image::Magick->new;
    $img->Read($file) && do {
        warn "[!] Can't load image `$file' ($!). Skipping file...\n";
        next;
    };
    unlink($file);
    $img->Write($file);
}


================================================
FILE: Image/julia_transform.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 11 March 2017
# https://github.com/trizen

# Julia transform of an image.

# See also:
#   https://en.wikipedia.org/wiki/Julia_set

use 5.010;
use strict;
use warnings;

use Imager;
use Math::GComplex;

my $file = shift(@ARGV) // die "usage: $0 [image]\n";

sub map_val {
    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;

#<<<
    ($value - $in_min)
        * ($out_max - $out_min)
        / ($in_max - $in_min)
    + $out_min;
#>>>
}

my $img = Imager->new(file => $file)
  or die Imager->errstr();

my $width  = $img->getwidth;
my $height = $img->getheight;

sub transform {
    my ($x, $y) = @_;

#<<<
    my $z = Math::GComplex->new(
        (2 * $x - $width ) / $width,
        (2 * $y - $height) / $height,
    );
#>>>

    state $c = Math::GComplex->new(-0.4, 0.6);

    my $i = 10;
    while ($z->abs < 2 and --$i >= 0) {
        $z = $z * $z + $c;
    }

    $z->reals;
}

my @matrix;

my ($min_x, $min_y) = ('inf') x 2;
my ($max_x, $max_y) = (-'inf') x 2;

foreach my $y (0 .. $height - 1) {
    foreach my $x (0 .. $width - 1) {
        my ($new_x, $new_y) = transform($x, $y);

        $matrix[$y][$x] = [$new_x, $new_y];

        if ($new_x < $min_x) {
            $min_x = $new_x;
        }
        if ($new_y < $min_y) {
            $min_y = $new_y;
        }
        if ($new_x > $max_x) {
            $max_x = $new_x;
        }
        if ($new_y > $max_y) {
            $max_y = $new_y;
        }
    }
}

say "X: [$min_x, $max_x]";
say "Y: [$min_y, $max_y]";

my $out_img = Imager->new(xsize => $width,
                          ysize => $height);

foreach my $y (0 .. $height - 1) {
    foreach my $x (0 .. $width - 1) {
        my ($new_x, $new_y) = @{$matrix[$y][$x]};
        $new_x = map_val($new_x, $min_x, $max_x, 0, $width - 1);
        $new_y = map_val($new_y, $min_y, $max_y, 0, $height - 1);
        $out_img->setpixel(
                           x     => $new_x,
                           y     => $new_y,
                           color => $img->getpixel(x => $x, y => $y),
                          );
    }
}

$out_img->write(file => 'julia_transform.png');


================================================
FILE: Image/lookalike_images.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 August 2015
# Edit: 05 June 2021
# https://github.com/trizen

# Find images that look similar, given a main image.

# Blog post:
#   https://trizenx.blogspot.com/2015/08/finding-similar-images.html

use 5.020;
use strict;
use warnings;

use experimental qw(bitwise signatures);

use Image::Magick qw();
use List::Util qw(sum);
use File::Find qw(find);
use Getopt::Long qw(GetOptions);

my $width      = 32;
my $height     = 32;
my $percentage = 60;

my $fuzzy_matching = 0;
my $copy_to        = undef;

my $resize_to = $width . 'x' . $height;

my @img_formats = qw(
  jpeg
  jpg
  png
);

sub help ($code = 0) {
    local $" = ",";
    print <<"EOT";
usage: $0 [options] [main image] [dir]

options:
    -p  --percentage=i  : minimum similarity percentage (default: $percentage)
    -r  --resize-to=s   : resize images to this resolution (default: $resize_to)
    -f  --fuzzy!        : use fuzzy matching (default: $fuzzy_matching)
    -c  --copy-to=s     : copy similar images into this directory

example:
    perl $0 -p 75 -r '8x8' main.jpg ~/Pictures
EOT

    exit($code);
}

GetOptions(
           'p|percentage=i' => \$percentage,
           'r|resize-to=s'  => \$resize_to,
           'f|fuzzy!'       => \$fuzzy_matching,
           'c|copy-to=s'    => \$copy_to,
           'h|help'         => sub { help(0) },
          )
  or die("Error in command line arguments");

($width, $height) = split(/\h*x\h*/i, $resize_to);

my $size = $width * $height;

my $img_formats_re = do {
    local $" = '|';
    qr/\.(@img_formats)\z/i;
};

sub avg ($x, $y, $z) {
    ($x + $y + $z) / 3;
}

sub alike_percentage ($x, $y) {
    ((($x ^. $y) =~ tr/\0//) / $size)**2 * 100;
}

sub fingerprint ($image) {

    my $img = Image::Magick->new;
    $img->Read(filename => $image) && return;
    $img->AdaptiveResize(width => $width, height => $height) && return;

    my @pixels = $img->GetPixels(
                                 map       => 'RGB',
                                 x         => 0,
                                 y         => 0,
                                 width     => $width,
                                 height    => $height,
                                 normalize => 1,
                                );

    my $i = 0;
    my @averages;

    while (@pixels) {

        my $x = int($i % $width);
        my $y = int($i / $width);

        push @averages, avg(splice(@pixels, 0, 3));

        ++$i;
    }

    my $avg = sum(@averages) / @averages;
    join('', map { $_ < $avg ? 1 : 0 } @averages);
}

sub find_similar_images ($callback, $main_image, @paths) {

    my @files;

    find {
        no_chdir => 1,
        wanted   => sub {
            (/$img_formats_re/o && -f) || return;

            push @files,
              {
                fingerprint => fingerprint($_) // return,
                filename    => $_,
              };
        }
    } => @paths;

    my $main_fingerprint = fingerprint($main_image) // return;

    if ($fuzzy_matching) {

        my %seen    = ($main_fingerprint => 1);
        my @similar = ($main_fingerprint);

        my @similar_files;

        while (@similar) {

            my $similar_fingerprint = shift(@similar);

            foreach my $file (@files) {

                my $p = alike_percentage($similar_fingerprint, $file->{fingerprint});

                if ($p >= $percentage and !$seen{$file->{fingerprint}}++) {
                    push @similar, $file->{fingerprint};
                    push @similar_files, {score => $p, filename => $file->{filename}};
                }
            }
        }

        foreach my $entry (sort { $b->{score} <=> $a->{score} } @similar_files) {
            $callback->($entry->{score}, $entry->{filename});
        }
    }
    else {
        foreach my $file (@files) {

            my $p = alike_percentage($main_fingerprint, $file->{fingerprint});

            if ($p >= $percentage) {
                $callback->($p, $file->{filename});
            }
        }
    }

    return 1;
}

my $main_file = shift(@ARGV) // help(1);

@ARGV || help(1);

if (defined($copy_to)) {

    require File::Copy;

    if (not -d $copy_to) {
        require File::Path;
        File::Path::make_path($copy_to)
          or die "Can't create path <<$copy_to>>: $!";
    }
}

find_similar_images(
    sub ($score, $file) {

        say sprintf("%.0f%%: %s", $score, $file);

        if ($copy_to) {
            File::Copy::cp($file, $copy_to);
        }
    },
    $main_file,
    @ARGV
                   );


================================================
FILE: Image/magick_png2jpg.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 March 2021
# https://github.com/trizen

# Convert PNG images to JPEG, using the ImageMagick library.

# The original PNG files are deleted.

use 5.036;
use File::Find    qw(find);
use Image::Magick qw();
use Getopt::Long  qw(GetOptions);

my $batch_size   = 100;    # how many files to process at once
my $use_exiftool = 0;      # true to use `exiftool` instead of `File::MimeInfo::Magic`

sub convert_PNGs (@files) {

    say ":: Converting a batch of ", scalar(@files), " PNG images...";

    foreach my $file (@files) {
        say ":: Processing: $file";

        my $image = Image::Magick->new;

        $image->Read(filename => $file) && do {
            warn "[!] Can't load file <<$file>>. Skipping...\n";
            next;
        };

        my $orig_file = $file;
        my $jpeg_file = $file;

        if ($jpeg_file =~ s/\.png\z/.jpg/i) {
            ## ok
        }
        else {
            $jpeg_file .= '.jpg';
        }

        if (-e $jpeg_file) {
            warn "[!] File <<$jpeg_file>> already exists...\n";
            next;
        }

        open(my $fh, '>:raw', $jpeg_file) or do {
            warn "[!] Can't open file <<$jpeg_file>> for writing: $!\n";
            next;
        };

        $image->Write(file => $fh, filename => $jpeg_file);

        close $fh;

        if (-e $jpeg_file and ($orig_file ne $jpeg_file)) {
            say ":: Saved as: $jpeg_file";
            unlink($orig_file);    # remove the original PNG file
        }
    }
}

sub determine_mime_type ($file) {

    if ($file =~ /\.jpe?g\z/i) {
        return "image/jpeg";
    }

    if ($file =~ /\.png\z/i) {
        return "image/png";
    }

    if ($use_exiftool) {
        my $res = `exiftool \Q$file\E`;
        $? == 0       or return;
        defined($res) or return;
        if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) {
            return $1;
        }
        return;
    }

    require File::MimeInfo::Magic;
    File::MimeInfo::Magic::magic($file);
}

my %types = (
             'image/png' => {
                             files => [],
                             call  => \&convert_PNGs,
                            },
            );

GetOptions('exiftool!'    => \$use_exiftool,
           'batch-size=i' => \$batch_size,)
  or die "Error in command-line arguments!";

@ARGV or die <<"USAGE";
usage: perl $0 [options] [dirs | files]

options:

    --batch=i  : how many files to process at once (default: $batch_size)
    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)

USAGE

find(
    {
     no_chdir => 1,
     wanted   => sub {

         (-f $_) || return;
         my $type = determine_mime_type($_) // return;

         if (exists $types{$type}) {

             my $ref = $types{$type};
             push @{$ref->{files}}, $_;

             if (scalar(@{$ref->{files}}) >= $batch_size) {
                 $ref->{call}->(splice(@{$ref->{files}}));
             }
         }
     }
    } => @ARGV
);

foreach my $type (keys %types) {

    my $ref = $types{$type};

    if (@{$ref->{files}}) {
        $ref->{call}->(splice(@{$ref->{files}}));
    }
}

say ":: Done!";


================================================
FILE: Image/magick_similar_images.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 August 2015
# Edit: 25 October 2023
# Website: https://github.com/trizen

# Find images that look similar.

# Blog post:
#   https://trizenx.blogspot.com/2015/08/finding-similar-images.html

use 5.022;
use strict;
use warnings;

use experimental 'bitwise';

use Image::Magick qw();
use List::Util    qw(sum);
use File::Find    qw(find);
use Getopt::Long  qw(GetOptions);

my $width      = 32;
my $height     = 32;
my $percentage = 90;

my $keep_only   = undef;
my $img_formats = '';
my $resize_to   = $width . 'x' . $height;

my @img_formats = qw(
  jpeg
  jpg
  png
);

sub help {
    my ($code) = @_;
    local $" = ",";
    print <<"EOT";
usage: $0 [options] [dir]

options:
    -p  --percentage=i  : minimum similarity percentage (default: $percentage)
    -r  --resize-to=s   : resize images to this resolution (default: $resize_to)
    -f  --formats=s,s   : specify more image formats (default: @img_formats)
    -k  --keep=s        : keep only the 'smallest' or 'largest' image from each group

WARNING: option '-k' permanently removes your images!

example:
    perl $0 -p 75 -r '8x8' ~/Pictures
EOT

    exit($code);
}

GetOptions(
           'p|percentage=i' => \$percentage,
           'r|resize-to=s'  => \$resize_to,
           'f|formats=s'    => \$img_formats,
           'k|keep=s'       => \$keep_only,
           'h|help'         => sub { help(0) },
          )
  or die("Error in command line arguments");

($width, $height) = split(/\h*x\h*/i, $resize_to);

my $size = $width * $height;
push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats);

my $img_formats_re = do {
    local $" = '|';
    qr/\.(@img_formats)\z/i;
};

#<<<
sub alike_percentage {
    ((($_[0] ^. $_[1]) =~ tr/\0//) / $size)**2 * 100;
}
#>>>

sub fingerprint {
    my ($image) = @_;

    my $img = Image::Magick->new;
    $img->Read(filename => $image) && return;

    $img->AdaptiveResize(width => $width, height => $height) && return;   # balanced
    ## $img->Resize(width => $width, height => $height) && return;        # better, but slower
    ## $img->Resample(width => $width, height => $height) && return;      # faster, but worse

    my @pixels = $img->GetPixels(
                                 map       => 'RGB',
                                 x         => 0,
                                 y         => 0,
                                 width     => $width,
                                 height    => $height,
                                 normalize => 1,
                                );

    my @averages;

    while (@pixels) {
        push @averages, sum(splice(@pixels, 0, 3))/3;
    }

    my $avg = sum(@averages) / @averages;
    join('', map { ($_ < $avg) ? 1 : 0 } @averages);
}

sub find_similar_images(&@) {
    my $callback = shift;

    my @files;
    find {
        no_chdir => 1,
        wanted   => sub {
            (/$img_formats_re/o && -f) || return;

            push @files,
              {
                fingerprint => fingerprint($_) // return,
                filename    => $_,
              };
        }
    } => @_;

    #
    ## Populate the %alike hash
    #
    my %alike;
    foreach my $i (0 .. $#files - 1) {
        for (my $j = $i + 1 ; $j <= $#files ; $j++) {
            my $p = alike_percentage($files[$i]{fingerprint}, $files[$j]{fingerprint});
            if ($p >= $percentage) {
                $alike{$files[$i]{filename}}{$files[$j]{filename}} = $p;
                $alike{$files[$j]{filename}}{$files[$i]{filename}} = $p;
            }
        }
    }

    #
    ## Group the files
    #
    my @alike;
    foreach my $root (
        map  { $_->[0] }
        sort { ($a->[1] <=> $b->[1]) || ($b->[2] <=> $a->[2]) }
        map {
            my $keys = keys(%{$alike{$_}});
            my $avg  = sum(values(%{$alike{$_}})) / $keys;

            [$_, $keys, $avg]
        }
        keys %alike
      ) {
        my @group = keys(%{$alike{$root}});
        if (@group) {
            my $avg = 0;
            $avg += delete($alike{$_}{$root}) for @group;
            push @alike, {score => $avg / @group, files => [$root, @group]};

        }
    }

    #
    ## Callback each group
    #
    my %seen;
    foreach my $group (sort { $b->{score} <=> $a->{score} } @alike) {
        (@{$group->{files}} == grep { $seen{$_}++ } @{$group->{files}}) and next;
        $callback->($group->{score}, $group->{files});
    }

    return 1;
}

@ARGV || help(1);
find_similar_images {
    my ($score, $files) = @_;

    printf("=> Similarity: %.0f%%\n", $score);
    say join("\n", sort @{$files});
    say "-" x 80;

    if (defined($keep_only)) {

        my @existent_files = grep { -f $_ } @$files;

        scalar(@existent_files) > 1 or return;

        my @sorted_by_size = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, -s $_] } @existent_files;
        if ($keep_only =~ /large/i) {
            pop(@sorted_by_size);
        }
        elsif ($keep_only =~ /small/i) {
            shift(@sorted_by_size);
        }
        else {
            die "error: unknown value <<$keep_only>> for option `-k`!\n";
        }
        foreach my $file (@sorted_by_size) {
            say "Removing: $file";
            unlink($file) or warn "Failed to remove: $!";
        }
    }
} @ARGV;


================================================
FILE: Image/magick_star_trails.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 30 January 2015
# Edited: 31 January 2015
# Website: https://github.com/trizen

# Merge two or more images together and keep the most intensive pixel colors

use 5.010;
use strict;
use autodie;
use warnings;

use Image::Magick;
use List::Util   qw(min max);
use Getopt::Long qw(GetOptions);

my $output_file   = 'output.png';
my $scale_percent = 0;
my $brightness_f  = 'avg';

my %brightness = (

    # I: https://en.wikipedia.org/wiki/HSL_and_HSV#Lightness
    avg => sub { ($_[0] + $_[1] + $_[2]) / 3 },

    # L: https://en.wikipedia.org/wiki/HSL_and_HSV#Lightness
    hsl => sub { 0.5 * max(@_) + 0.5 * min(@_) },

    # https://en.wikipedia.org/wiki/Relative_luminance
    rl => sub { (0.2126 * $_[0] + 0.7152 * $_[1] + 0.0722 * $_[2]) },

    # https://en.wikipedia.org/wiki/Luma_(video)#Rec._601_luma_versus_Rec._709_luma_coefficients
    luma => sub { (0.299 * $_[0] + 0.587 * $_[1] + 0.114 * $_[2]) },

    # http://alienryderflex.com/hsp.html
    hsp => sub { sqrt(0.299 * ($_[0]**2) + 0.587 * ($_[1]**2) + 0.114 * ($_[2]**2)) },
);

sub help {
    local $" = ", ";
    print <<"HELP";
usage: $0 [options] [files]

options:
    -o  --output         : output file (default: $output_file)
    -s  --scale-percent  : scale image by a given percentage (default: $scale_percent)
    -f  --formula        : formula for the brightness of a pixel (default: $brightness_f)
                           valid values: @{[sort keys %brightness]}

example:
    $0 -o merged.png --scale -20 file1.jpg file2.jpg
HELP
    exit;
}

GetOptions(
           'o|output=s'        => \$output_file,
           's|scale-percent=i' => \$scale_percent,
           'f|formula=s'       => \$brightness_f,
           'h|help'            => \&help,
          )
  or die "Error in command-line arguments!";

if (not exists $brightness{$brightness_f}) {
    local $" = ", ";
    die "[!] Invalid brightness formula: `$brightness_f'.
        Valid values are: @{[sort keys %brightness]}\n";
}

my $lightness_function = $brightness{$brightness_f};

my @matrix;
foreach my $image (@ARGV) {

    say "** Processing file: $image";

    my $img = Image::Magick->new;
    my $err = $img->Read($image);

    if ($err) {
        warn "** Can't load file <<$image>> ($err). Skipping...\n";
        next;
    }

    my ($width, $height) = $img->Get('width', 'height');

    if ($scale_percent != 0) {
        my $scale_width  = $width + int($scale_percent / 100 * $width);
        my $scale_height = $height + int($scale_percent / 100 * $height);
        $img->Resize(width => $scale_width, height => $scale_height);
        ($width, $height) = ($scale_width, $scale_height);
    }

    my @pixels = $img->GetPixels(
                                 map       => 'RGB',
                                 x         => 0,
                                 y         => 0,
                                 width     => $width,
                                 height    => $height,
                                 normalize => 1,
                                );

    my $i = 0;
    while (@pixels) {

        my $x = int($i % $width);
        my $y = int($i / $width);

        my @rgb = splice(@pixels, 0, 3);

        $matrix[$x][$y] //= [0, 0, 0];
        if ($lightness_function->(@{$matrix[$x][$y]}) < $lightness_function->(@rgb)) {
            $matrix[$x][$y] = \@rgb;
        }

        ++$i;
    }
}

@matrix || die "error: No image has been processed!\n";
say "** Creating the output image: $output_file";

my $image = Image::Magick->new;
$image->Set(size => @matrix . 'x' . @{$matrix[0]});
$image->ReadImage('canvas:white');

foreach my $x (0 .. $#matrix) {
    my $row = $matrix[$x] // next;
    foreach my $y (0 .. $#{$matrix[0]}) {
        my $entry = $row->[$y] // next;
        $image->SetPixel(x => $x, y => $y, color => $entry);
    }
}

open my $fh, '>:raw', $output_file;
$image->Write(file => $fh, filename => $output_file);
close $fh;

say "** All done!";


================================================
FILE: Image/matrix_visual.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# Display a matrix as a rectangle packed with circles.

# Brighter circles represent larger numerical values,
# while dimmer circles represent smaller numerical values.

use 5.010;
use strict;
use warnings;

use Imager;
use List::MoreUtils qw(minmax);

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

#<<<
# Reading a matrix from the standard input.
#~ @matrix = ();
#~ while(<>) {
    #~ chomp;
    #~ push @matrix, [split(/,/, $_)];
#~ }
#>>>

my $max_color    = 2**16 - 1;
my $scale_factor = 10;
my $radius       = $scale_factor / atan2(0, -'inf');
my $space        = $radius / 2;

my $img = Imager->new(
                      xsize    => @{$matrix[0]} * $scale_factor,
                      ysize    => @matrix * $scale_factor,
                      channels => 3,
                     );

my ($min, $max) = minmax(map { @$_ } @matrix);

foreach my $i (0 .. $#matrix) {
    my $row = $matrix[$i];
    foreach my $j (0 .. $#{$row}) {
        my $cell = $row->[$j];

        my $value = int($max_color / ($max - $min) * ($cell - $min));
        my $color = Imager::Color->new(sprintf("#%06x", $value));

        $img->circle(
                     r     => $radius,
                     x     => int($j * $scale_factor + $radius + $space),
                     y     => int($i * $scale_factor + $radius + $space),
                     color => $color,
                    );
    }
}

$img->write(file => 'matrix_circle.png');


================================================
FILE: Image/mirror_images.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 04 June 2024
# https://github.com/trizen

# Mirror a given list of images (horizontal flip).

use 5.036;
use Imager       qw();
use File::Find   qw(find);
use Getopt::Long qw(GetOptions);

my $img_formats = '';

my @img_formats = qw(
  jpeg
  jpg
  png
);

sub usage ($code) {
    local $" = ",";
    print <<"EOT";
usage: $0 [options] [dirs | files]

options:
    -f  --formats=s,s   : specify more image formats (default: @img_formats)

example:
    perl $0 ~/Pictures
EOT

    exit($code);
}

GetOptions('f|formats=s' => \$img_formats,
           'help'        => sub { usage(0) },)
  or die("Error in command line arguments");

push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats);

my $img_formats_re = do {
    local $" = '|';
    qr/\.(@img_formats)\z/i;
};

sub mirror_image ($image) {

    my $img = Imager->new(file => $image) or do {
        warn "Failed to load <<$image>>: ", Imager->errstr();
        return;
    };

    $img->flip(dir => "h");
    $img->write(file => $image);
}

@ARGV || usage(1);

find {
    no_chdir => 1,
    wanted   => sub {
        (/$img_formats_re/o && -f) || return;
        say "Mirroring: $_";
        mirror_image($_);
    }
} => @ARGV;


================================================
FILE: Image/mtf_horizontal_transform.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 06 April 2024
# Edit: 09 April 2024
# https://github.com/trizen

# Scramble the pixels in each row inside an image, using the Move-to-front transform (MTF).

use 5.036;
use GD;
use Getopt::Std       qw(getopts);
use Compression::Util qw(mtf_encode mtf_decode);

GD::Image->trueColor(1);

sub scramble_image ($file, $function) {

    my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!";
    my ($width, $height) = $image->getBounds();

    my $new_image = GD::Image->new($width, $height);
    my @alphabet  = (0 .. 255);

    foreach my $y (0 .. $height - 1) {

        my @row;
        foreach my $x (0 .. $width - 1) {
            push @row, $image->rgb($image->getPixel($x, $y));
        }

        @row = @{$function->(\@row, \@alphabet)};

        foreach my $x (0 .. $width - 1) {
            $new_image->setPixel($x, $y, $new_image->colorAllocate(splice(@row, 0, 3)));
        }
    }

    return $new_image;
}

sub usage ($exit_code = 0) {

    print <<"EOT";
usage: $0 [options] [input.png] [output.png]

options:

    -d : decode the image
    -h : print this message and exit

EOT

    exit($exit_code);
}

getopts('dh', \my %opts);

my $input_file  = $ARGV[0] // usage(2);
my $output_file = $ARGV[1] // "output.png";

if (not -f $input_file) {
    die "Input file <<$input_file>> does not exist!\n";
}

my $img = $opts{d} ? scramble_image($input_file, \&mtf_decode) : scramble_image($input_file, \&mtf_encode);
open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!";
print $out_fh $img->png(9);
close $out_fh;


================================================
FILE: Image/mtf_vertical_transform.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 06 April 2024
# Edit: 09 April 2024
# https://github.com/trizen

# Scramble the pixels in each column inside an image, using the Move-to-front transform (MTF).

use 5.036;
use GD;
use Getopt::Std       qw(getopts);
use Compression::Util qw(mtf_encode mtf_decode);

GD::Image->trueColor(1);

sub scramble_image ($file, $function) {

    my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!";
    my ($width, $height) = $image->getBounds();

    my $new_image = GD::Image->new($width, $height);
    my @alphabet  = (0 .. 255);

    foreach my $x (0 .. $width - 1) {

        my @column;
        foreach my $y (0 .. $height - 1) {
            push @column, $image->rgb($image->getPixel($x, $y));
        }

        @column = @{$function->(\@column, \@alphabet)};

        foreach my $y (0 .. $height - 1) {
            $new_image->setPixel($x, $y, $new_image->colorAllocate(splice(@column, 0, 3)));
        }
    }

    return $new_image;
}

sub usage ($exit_code = 0) {

    print <<"EOT";
usage: $0 [options] [input.png] [output.png]

options:

    -d : decode the image
    -h : print this message and exit

EOT

    exit($exit_code);
}

getopts('dh', \my %opts);

my $input_file  = $ARGV[0] // usage(2);
my $output_file = $ARGV[1] // "output.png";

if (not -f $input_file) {
    die "Input file <<$input_file>> does not exist!\n";
}

my $img = $opts{d} ? scramble_image($input_file, \&mtf_decode) : scramble_image($input_file, \&mtf_encode);
open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!";
print $out_fh $img->png(9);
close $out_fh;


================================================
FILE: Image/nearest_neighbor_interpolation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 July 2018
# https://github.com/trizen

# A simple implementation of the nearest-neighbor interpolation algorithm for scaling up an image.

# See also:
#   https://en.wikipedia.org/wiki/Nearest-neighbor_interpolation

use 5.020;
use strict;
use warnings;

use Imager;
use experimental qw(signatures);

sub nearest_neighbor_interpolation ($file, $zoom = 2) {

    my $img = Imager->new(file => $file)
      or die Imager->errstr();

    my $width  = $img->getwidth;
    my $height = $img->getheight;

    my $out_img = Imager->new(xsize => $zoom * $width,
                              ysize => $zoom * $height);

    foreach my $y (0 .. $height - 1) {
        foreach my $x (0 .. $width - 1) {
            my $pixel = $img->getpixel(x => $x, y => $y);
#<<<
            # Fill the gaps
            $out_img->setpixel(x => $zoom * $x,     y => $zoom * $y,     color => $pixel);
            $out_img->setpixel(x => $zoom * $x + 1, y => $zoom * $y + 1, color => $pixel);
            $out_img->setpixel(x => $zoom * $x + 1, y => $zoom * $y,     color => $pixel);
            $out_img->setpixel(x => $zoom * $x,     y => $zoom * $y + 1, color => $pixel);
#>>>
        }
    }

    return $out_img;
}

my $file = shift(@ARGV) // die "usage: $0 [image]\n";
my $img  = nearest_neighbor_interpolation($file, 2);

$img->write(file => "output.png");


================================================
FILE: Image/optimize_images.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 October 2019
# https://github.com/trizen

# Optimize JPEG and PNG images in a given directory (recursively) using the "jpegoptim" and "optipng" tools.

use 5.036;
use File::Find   qw(find);
use Getopt::Long qw(GetOptions);

my $batch_size   = 100;    # how many files to process at once
my $use_exiftool = 0;      # true to use `exiftool` instead of `File::MimeInfo::Magic`

sub optimize_JPEGs (@files) {

    say ":: Optimizing a batch of ", scalar(@files), " JPEG images...";

    system(
        "jpegoptim",
        "--preserve",    # preserve file modification times
        ##'--max=90',
        ##'--size=2048',
        '--all-progressive',
        @files
          );
}

sub optimize_PNGs (@files) {

    say ":: Optimizing a batch of ", scalar(@files), " PNG images...";

    system(
        "optipng",
        "-preserve",    # preserve file attributes if possible
        "-o1",          # optimization level
        @files
          );
}

sub determine_mime_type ($file) {

    if ($file =~ /\.jpe?g\z/i) {
        return "image/jpeg";
    }

    if ($file =~ /\.png\z/i) {
        return "image/png";
    }

    if ($use_exiftool) {
        my $res = `exiftool \Q$file\E`;
        $? == 0       or return;
        defined($res) or return;
        if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) {
            return $1;
        }
        return;
    }

    require File::MimeInfo::Magic;
    File::MimeInfo::Magic::magic($file);
}

my %types = (
             'image/jpeg' => {
                              files => [],
                              call  => \&optimize_JPEGs,
                             },
             'image/png' => {
                             files => [],
                             call  => \&optimize_PNGs,
                            },
            );

GetOptions('exiftool!'    => \$use_exiftool,
           'batch-size=i' => \$batch_size,)
  or die "Error in command-line arguments!";

@ARGV or die <<"USAGE";
usage: perl $0 [options] [dirs | files]

options:

    --batch=i  : how many files to process at once (default: $batch_size)
    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)

USAGE

find(
    {
     no_chdir => 1,
     wanted   => sub {

         (-f $_) || return;
         my $type = determine_mime_type($_) // return;

         if (exists $types{$type}) {

             my $ref = $types{$type};
             push @{$ref->{files}}, $_;

             if (scalar(@{$ref->{files}}) >= $batch_size) {
                 $ref->{call}->(splice(@{$ref->{files}}));
             }
         }
     }
    } => @ARGV
);

foreach my $type (keys %types) {

    my $ref = $types{$type};

    if (@{$ref->{files}}) {
        $ref->{call}->(splice(@{$ref->{files}}));
    }
}

say ":: Done!";


================================================
FILE: Image/optimize_images_littleutils.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 December 2020
# https://github.com/trizen

# Optimize JPEG, PNG and GIF images in a given directory (recursively) using the "opt-png", "opt-jpg" and "opt-gif" tools from littleutils.

# Littleutils:
#   https://sourceforge.net/projects/littleutils/

use 5.036;
use File::Find   qw(find);
use Getopt::Long qw(GetOptions);

my $batch_size   = 100;    # how many files to process at once
my $use_exiftool = 0;      # true to use `exiftool` instead of `File::MimeInfo::Magic`

sub optimize_JPEGs (@files) {

    say ":: Optimizing a batch of ", scalar(@files), " JPEG images...";

    system(
        "opt-jpg",
        "-m", "all",    # copy all extra markers
        "-t",           # preserve timestamp on modified files
        @files
          );
}

sub optimize_PNGs (@files) {

    say ":: Optimizing a batch of ", scalar(@files), " PNG images...";

    system(
        "opt-png",
        "-t",           # preserve timestamp on modified files
        @files
          );
}

sub optimize_GIFs (@files) {

    say ":: Optimizing a batch of ", scalar(@files), " GIF images...";

    system(
        "opt-gif",
        "-t",           # preserve timestamp on modified files
        @files
          );
}

sub determine_mime_type ($file) {

    if ($file =~ /\.jpe?g\z/i) {
        return "image/jpeg";
    }

    if ($file =~ /\.png\z/i) {
        return "image/png";
    }

    if ($use_exiftool) {
        my $res = `exiftool \Q$file\E`;
        $? == 0       or return;
        defined($res) or return;
        if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) {
            return $1;
        }
        return;
    }

    require File::MimeInfo::Magic;
    File::MimeInfo::Magic::magic($file);
}

my %types = (
             'image/jpeg' => {
                              files => [],
                              call  => \&optimize_JPEGs,
                             },
             'image/png' => {
                             files => [],
                             call  => \&optimize_PNGs,
                            },
             'image/gif' => {
                             files => [],
                             call  => \&optimize_GIFs,
                            },
            );

GetOptions('exiftool!'    => \$use_exiftool,
           'batch-size=i' => \$batch_size,)
  or die "Error in command-line arguments!";

@ARGV or die <<"USAGE";
usage: perl $0 [options] [dirs | files]

options:

    --batch=i  : how many files to process at once (default: $batch_size)
    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)

USAGE

find(
    {
     no_chdir => 1,
     wanted   => sub {

         (-f $_) || return;
         my $type = determine_mime_type($_) // return;

         if (exists $types{$type}) {

             my $ref = $types{$type};
             push @{$ref->{files}}, $_;

             if (scalar(@{$ref->{files}}) >= $batch_size) {
                 $ref->{call}->(splice(@{$ref->{files}}));
             }
         }
     }
    } => @ARGV
);

foreach my $type (keys %types) {

    my $ref = $types{$type};

    if (@{$ref->{files}}) {
        $ref->{call}->(splice(@{$ref->{files}}));
    }
}

say ":: Done!";


================================================
FILE: Image/outguess-png-imager.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 07 February 2022
# https://github.com/trizen

# Hide arbitrary data into the pixels of a PNG image, storing 3 bits in each pixel color.

# Concept inspired by outguess:
#   https://github.com/resurrecting-open-source-projects/outguess
#   https://uncovering-cicada.fandom.com/wiki/OutGuess

# Q: How does it work?
# A: The script uses the Imager library to read the RGB color values of each pixel.
#    Then it changes the last bit of each value to one bit from the data to be encoded.

# Q: How does the decoding work?
# A: The first 32 bits from the first 32 pixels of the image, form the length of the encoded data.
#    Then the remaining bits (3 bits from each pixel) are collected to form the encoded data.

# The script also does transparent Deflate compression and decompression of the encoded data.

use 5.020;
use strict;
use warnings;

no warnings 'once';

use Imager;
use Getopt::Long qw(GetOptions);
use experimental qw(signatures);

binmode(STDIN,  ':raw');
binmode(STDOUT, ':raw');

sub encode_data ($data, $img_file) {

    my $image = Imager->new(file => $img_file)
      or die Imager->errstr();

    require IO::Compress::RawDeflate;
    IO::Compress::RawDeflate::rawdeflate(\$data, \my $compressed_data)
      or die "rawdeflate failed: $IO::Compress::RawDeflate::RawDeflateError\n";

    $data = $compressed_data;

    my $bin    = unpack("B*", $data);
    my $width  = $image->getwidth();
    my $height = $image->getheight();

    my $maximum_data_size = 3 * (($width * $height - 32) >> 3);
    my $data_size         = length($bin) >> 3;

    if ($data_size == 0) {
        die sprintf("No data was given!\n");
    }

    if ($data_size > $maximum_data_size) {
        die sprintf(
                    "Data is too large (%s bytes) for this image (exceeded by %.2f%%).\n"
                      . "Maximum data size for this image is %s bytes.\n",
                    $data_size, 100 - ($maximum_data_size / $data_size * 100),
                    $maximum_data_size
                   );
    }

    warn sprintf("Compressed data size: %s bytes (%.2f%% out of max %s bytes)\n",
                 $data_size, $data_size / $maximum_data_size * 100,
                 $maximum_data_size);

    my $length_bin = unpack("B*", pack("N*", $data_size));

    $bin = reverse($length_bin . $bin);

    my $size = length($bin);

  OUTER: foreach my $y (0 .. $height - 1) {
        my $x = 0;
        foreach my $color ($image->getscanline(x => 0, y => $y, width => $width)) {

            if ($size > 0) {
                my ($red, $green, $blue, $alpha) = $color->rgba;
                $color->set((map { (($_ >> 1) << 1) | (chop($bin) || 0) } ($red, $green, $blue)), $alpha);
                $size -= 3;
            }
            else {
                last OUTER;
            }

            $image->setpixel(x => $x++, y => $y, color => $color);
        }
    }

    return $image;
}

sub decode_data ($img_file) {

    my $image = Imager->new(file => $img_file)
      or die Imager->errstr();

    my $width  = $image->getwidth;
    my $height = $image->getheight;

    my $bin  = '';
    my $size = 0;

    my $length        = $width * $height;
    my $find_length   = 1;
    my $max_data_size = 3 * ($length - 4);

  OUTER: foreach my $y (0 .. $height - 1) {
        foreach my $color ($image->getscanline(x => 0, y => $y, width => $width)) {

            if ($size < $length) {

                my ($red, $green, $blue) = $color->rgba;
                $bin .= join('', map { $_ & 1 } ($red, $green, $blue));
                $size += 3;

                if ($find_length and $size >= 32) {

                    $length      = unpack("N*", pack("B*", substr($bin, 0, 32)));
                    $find_length = 0;
                    $size        = length($bin) - 32;
                    $bin         = substr($bin, 32);

                    if ($length > $max_data_size or $length == 0) {
                        die "No hidden data was found in this image!\n";
                    }

                    warn sprintf("Compressed data size: %s bytes\n", $length);
                    $length <<= 3;
                }
            }
            else {
                last OUTER;
            }
        }
    }

    my $data = pack("B*", substr($bin, 0, $length));

    require IO::Uncompress::RawInflate;
    IO::Uncompress::RawInflate::rawinflate(\$data, \my $uncompressed)
      or die "rawinflate failed: $IO::Uncompress::RawInflate::RawInflateError\n";

    warn sprintf("Uncompressed data size: %s bytes\n", length($uncompressed));

    return $uncompressed;
}

sub help ($exit_code = 0) {
    print <<"EOT";
usage: $0 [options] [input] [output]

options:

    -z [file] : encode a given data file

example:

    # Encode
    perl $0 -z=data.txt input.jpg encoded.png

    # Decode
    perl $0 encoded.png decoded-data.txt
EOT

    exit($exit_code);
}

my $data_file;

GetOptions("z|f|encode=s" => \$data_file,
           "h|help"       => sub { help(0) },)
  or die("Error in command line arguments\n");

if (defined($data_file)) {

    my $input_image  = shift(@ARGV) // help(2);
    my $output_image = shift(@ARGV);

    open my $fh, '<:raw', $data_file
      or die "Can't open file <<$data_file>> for reading: $!";

    my $data = do {
        local $/;
        <$fh>;
    };

    close $fh;

    my $img = encode_data($data, $input_image);

    if (defined($output_image)) {

        if ($output_image !~ /\.png\z/i) {
            die "The output image must have the '.png' extension!\n";
        }

        $img->write(file => $output_image)
          or die $img->errstr;
    }
    else {
        $img->write(fh => \*STDOUT, type => 'png')
          or die $img->errstr;
    }
}
else {
    my $input_image = shift(@ARGV) // help(2);
    my $output_file = shift(@ARGV);

    my $data = decode_data($input_image);

    if (defined($output_file)) {
        open my $fh, '>:raw', $output_file
          or die "Can't open file <<$output_file>> for writing: $!";
        print $fh $data;
        close $fh;
    }
    else {
        print $data;
    }
}


================================================
FILE: Image/outguess-png.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 06 February 2022
# Edit: 31 July 2022
# https://github.com/trizen

# Hide arbitrary data into the pixels of a PNG image, storing 3 bits in each pixel color.

# Concept inspired by outguess:
#   https://github.com/resurrecting-open-source-projects/outguess
#   https://uncovering-cicada.fandom.com/wiki/OutGuess

# Q: How does it work?
# A: The script uses the GD library to read the RGB color values of each pixel.
#    Then it changes the last bit of each value to one bit from the data to be encoded.

# Q: How does the decoding work?
# A: The first 32 bits from the first 32 pixels of the image, form the length of the encoded data.
#    Then the remaining bits (3 bits from each pixel) are collected to form the encoded data.

# The script also does transparent Deflate compression and decompression of the encoded data.

use 5.020;
use strict;
use warnings;

no warnings 'once';

use GD           qw();
use Getopt::Long qw(GetOptions);
use experimental qw(signatures);

GD::Image->trueColor(1);

binmode(STDIN,  ':raw');
binmode(STDOUT, ':raw');

sub encode_data ($data, $img_file) {

    my $image = GD::Image->new($img_file)
      or die "Can't open image <<$img_file>>: $!";

    $image = $image->newFromJpegData($image->jpeg(100));

    require IO::Compress::RawDeflate;
    IO::Compress::RawDeflate::rawdeflate(\$data, \my $compressed_data)
      or die "rawdeflate failed: $IO::Compress::RawDeflate::RawDeflateError\n";

    $data = $compressed_data;

    my $bin = unpack("B*", $data);
    my ($width, $height) = $image->getBounds();

    my $maximum_data_size = 3 * (($width * $height - 32) >> 3);
    my $data_size         = length($bin) >> 3;

    if ($data_size == 0) {
        die sprintf("No data was given!\n");
    }

    if ($data_size > $maximum_data_size) {
        die sprintf(
                    "Data is too large (%s bytes) for this image (exceeded by %.2f%%).\n"
                      . "Maximum data size for this image is %s bytes.\n",
                    $data_size, 100 - ($maximum_data_size / $data_size * 100),
                    $maximum_data_size
                   );
    }

    warn sprintf("Compressed data size: %s bytes (%.2f%% out of max %s bytes)\n",
                 $data_size, $data_size / $maximum_data_size * 100,
                 $maximum_data_size);

    my $length_bin = unpack("B*", pack("N*", $data_size));

    $bin = reverse($length_bin . $bin);

    my $size = length($bin);

  OUTER: foreach my $y (0 .. $height - 1) {
        foreach my $x (0 .. $width - 1) {

            my $index = $image->getPixel($x, $y);

            if ($size > 0) {
                my ($red, $green, $blue) = $image->rgb($index);
                $index = $image->colorResolve(map { (($_ >> 1) << 1) | (chop($bin) || 0) } ($red, $green, $blue));
                $size -= 3;
            }
            else {
                last OUTER;
            }

            $image->setPixel($x, $y, $index);
        }
    }

    return $image;
}

sub decode_data ($img_file) {

    my $image = GD::Image->new($img_file)
      or die "Can't open image <<$img_file>>: $!";

    my ($width, $height) = $image->getBounds();

    my $bin  = '';
    my $size = 0;

    my $length        = $width * $height;
    my $find_length   = 1;
    my $max_data_size = 3 * ($length - 4);

  OUTER: foreach my $y (0 .. $height - 1) {
        foreach my $x (0 .. $width - 1) {
            my $index = $image->getPixel($x, $y);

            if ($size < $length) {

                my ($red, $green, $blue) = $image->rgb($index);

                $bin .= join('', map { $_ & 1 } ($red, $green, $blue));
                $size += 3;

                if ($find_length and $size >= 32) {

                    $length      = unpack("N*", pack("B*", substr($bin, 0, 32)));
                    $find_length = 0;
                    $size        = length($bin) - 32;
                    $bin         = substr($bin, 32);

                    if ($length > $max_data_size or $length == 0) {
                        die "No hidden data was found in this image!\n";
                    }

                    warn sprintf("Compressed data size: %s bytes\n", $length);
                    $length <<= 3;
                }
            }
            else {
                last OUTER;
            }
        }
    }

    my $data = pack("B*", substr($bin, 0, $length));

    require IO::Uncompress::RawInflate;
    IO::Uncompress::RawInflate::rawinflate(\$data, \my $uncompressed)
      or die "rawinflate failed: $IO::Uncompress::RawInflate::RawInflateError\n";

    warn sprintf("Uncompressed data size: %s bytes\n", length($uncompressed));

    return $uncompressed;
}

sub help ($exit_code = 0) {
    print <<"EOT";
usage: $0 [options] [input] [output]

options:

    -z [file] : encode a given data file

example:

    # Encode
    perl $0 -z=data.txt input.jpg encoded.png

    # Decode
    perl $0 encoded.png decoded-data.txt
EOT

    exit($exit_code);
}

my $data_file;

GetOptions("z|f|encode=s" => \$data_file,
           "h|help"       => sub { help(0) },)
  or die("Error in command line arguments\n");

if (defined($data_file)) {

    my $input_image  = shift(@ARGV) // help(2);
    my $output_image = shift(@ARGV);

    open my $fh, '<:raw', $data_file
      or die "Can't open file <<$data_file>> for reading: $!";

    my $data = do {
        local $/;
        <$fh>;
    };

    close $fh;

    my $img = encode_data($data, $input_image);

    if (defined($output_image)) {

        if ($output_image !~ /\.png\z/i) {
            die "The output image must have the '.png' extension!\n";
        }

        open my $fh, '>:raw', $output_image
          or die "Can't open file <<$output_image>> for writing: $!";
        print $fh $img->png(9);
        close $fh;
    }
    else {
        print $img->png(9);
    }
}
else {
    my $input_image = shift(@ARGV) // help(2);
    my $output_file = shift(@ARGV);

    my $data = decode_data($input_image);

    if (defined($output_file)) {
        open my $fh, '>:raw', $output_file
          or die "Can't open file <<$output_file>> for writing: $!";
        print $fh $data;
        close $fh;
    }
    else {
        print $data;
    }
}


================================================
FILE: Image/photo_mosaic_from_images.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 06 January 2017
# https://github.com/trizen

# A simple RGB mosaic generator from a collection of images, using the pattern from a given image.

use 5.010;
use strict;
use autodie;
use warnings;

use GD qw();
use POSIX qw(ceil);
use List::Util qw(min);
use File::Find qw(find);
use Getopt::Long qw(GetOptions);

GD::Image->trueColor(1);

my $size        = 15;
my $wcrop       = 1 / 2;          # width crop ratio
my $hcrop       = 1 / 6;          # height crop ratio
my $output_file = 'mosaic.png';

sub usage {
    my ($code) = @_;
    print <<"EOT";
usage: $0 [options] [main_image] [photos_dir]

options:
    --size=i   : the size of a mosaic square (default: $size)
    --wcrop=f  : width cropping ratio (default: $wcrop)
    --hcrop=f  : height cropping ratio (default: $hcrop)
    --output=s : output filename (default: $output_file)

example:
    perl $0 --size=20 main.jpg images
EOT
    exit($code);
}

GetOptions(
           'size=i'   => \$size,
           'wcrop=f'  => \$wcrop,
           'hcrop=f'  => \$hcrop,
           'output=s' => \$output_file,
           'h|help'   => sub { usage(0) },
          )
  or die("$0: error in command line arguments\n");

sub analyze_image {
    my ($file, $images) = @_;

    my $img = eval { GD::Image->new($file) } || return;

    say "Analyzing: $file";

    $img = resize_image($img);
    my ($width, $height) = $img->getBounds;

    my $red_avg   = 0;
    my $green_avg = 0;
    my $blue_avg  = 0;
    my $avg       = 0;

    my $pixels = $width * $height;
    foreach my $y (0 .. $height - 1) {
        foreach my $x (0 .. $width - 1) {
            my $pixel = $img->getPixel($x, $y);
            my ($red, $green, $blue) = $img->rgb($pixel);

            $avg       += ($red + $green + $blue) / 3 / $pixels;
            $red_avg   += $red / $pixels;
            $green_avg += $green / $pixels;
            $blue_avg  += $blue / $pixels;
        }
    }

    my ($x, $y, $z) = map { ($_ + $avg) / 2 } ($red_avg, $green_avg, $blue_avg);
    push @{$images->[$x][$y][$z]}, $img;
}

sub resize_image {
    my ($image) = @_;

    # Get image dimensions
    my ($width, $height) = $image->getBounds();

    # File is already at the wanted resolution
    if ($width == $size and $height == $size) {
        return $image;
    }

    # Get the minimum ratio
    my $min_r = min($width / $size, $height / $size);

    my $n_width  = sprintf('%.0f', $width / $min_r);
    my $n_height = sprintf('%.0f', $height / $min_r);

    # Create a new GD image with the new dimensions
    my $gd = GD::Image->new($n_width, $n_height);
    $gd->copyResampled($image, 0, 0, 0, 0, $n_width, $n_height, $width, $height);

    # Create a new GD image with the wanted dimensions
    my $cropped = GD::Image->new($size, $size);

    # Crop from left and right
    if ($n_width > $size) {
        my $diff = $n_width - $size;
        my $left = ceil($diff * $wcrop);
        $cropped->copy($gd, 0, 0, $left, 0, $size, $size);
    }

    # Crop from top and bottom
    elsif ($n_height > $size) {
        my $diff = $n_height - $size;
        my $top  = int($diff * $hcrop);
        $cropped->copy($gd, 0, 0, 0, $top, $size, $size);
    }

    # No crop needed
    else {
        $cropped = $gd;
    }

    return $cropped;
}

sub find_closest {
    my ($red, $green, $blue, $images) = @_;

    my ($R, $G, $B);

    # Finds the closest red value
    for (my $j = 0 ; ; ++$j) {
        if (exists($images->[$red + $j]) and defined($images->[$red + $j])) {
            $R = $images->[$red + $j];
            last;
        }

        if ($red - $j >= 0 and defined($images->[$red - $j])) {
            $R = $images->[$red - $j];
            last;
        }
    }

    # Finds the closest green value
    for (my $j = 0 ; ; ++$j) {
        if (exists($R->[$green + $j]) and defined($R->[$green + $j])) {
            $G = $R->[$green + $j];
            last;
        }

        if ($green - $j >= 0 and defined($R->[$green - $j])) {
            $G = $R->[$green - $j];
            last;
        }
    }

    # Finds the closest blue value
    for (my $j = 0 ; ; ++$j) {
        if (exists($G->[$blue + $j]) and defined($G->[$blue + $j])) {
            $B = $G->[$blue + $j];
            last;
        }

        if ($blue - $j >= 0 and defined($G->[$blue - $j])) {
            $B = $G->[$blue - $j];
            last;
        }
    }

    $B->[rand @$B];    # returns a random image (when there are more candidates)
}

my $main_file = shift(@ARGV) // usage(2);
my @photo_dirs = (@ARGV ? @ARGV : usage(2));

my $img = GD::Image->new($main_file) || die "Can't load image `$main_file`: $!";

if ($size <= 0) {
    die "$0: size must be greater than zero (got: $size)\n";
}

my @images;    # stores all the image objects

find {
    no_chdir => 1,
    wanted   => sub {
        if (/\.(?:jpe?g|png)\z/i) {
            analyze_image($_, \@images);
        }
    },
} => @photo_dirs;

my ($width, $height) = $img->getBounds;
my $mosaic = GD::Image->new($width, $height);

foreach my $y (0 .. $height / $size) {
    foreach my $x (0 .. $width / $size) {
        $mosaic->copy(find_closest($img->rgb($img->getPixel($x * $size, $y * $size)), \@images),
                      $x * $size, $y * $size, 0, 0, $size, $size);
    }
}

open my $fh, '>:raw', $output_file;
print $fh (
             $output_file =~ /\.png\z/i
           ? $mosaic->png
           : $mosaic->jpeg
          );
close $fh;


================================================
FILE: Image/qhi_decoder.pl
================================================
#!/usr/bin/perl

# Implementation of the QHI decoder (QOI+Huffman coding), generating a PNG file.

# See also:
#   https://qoiformat.org/
#   https://github.com/phoboslab/qoi

use 5.020;
use warnings;

use Imager;
use experimental qw(signatures);

sub huffman_decode ($bits, $hash) {
    local $" = '|';
    $bits =~ s/(@{[sort { length($a) <=> length($b) } keys %{$hash}]})/$hash->{$1}/gr;    # very fast
}

sub qhi_decoder ($bytes) {

    my sub invalid() {
        die "Not a QHIF image";
    }

    my $index = 0;

    join('', map { $bytes->[$index++] } 1 .. 4) eq 'qhif' or invalid();

    my $width  = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));
    my $height = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));

    my $channels   = ord $bytes->[$index++];
    my $colorspace = ord $bytes->[$index++];

    ($width > 0 and $height > 0) or invalid();
    ($channels > 0 and $channels <= 4) or invalid();
    ($colorspace == 0 or $colorspace == 1) or invalid();

    ord(pop(@$bytes)) == 0x01 or invalid();

    for (1 .. 7) {
        ord(pop(@$bytes)) == 0x00 or invalid();
    }

    say "[$width, $height, $channels, $colorspace]";

    my $img = 'Imager'->new(
                            xsize    => $width,
                            ysize    => $height,
                            channels => $channels,
                           );

    my $run = 0;
    my @px  = (0, 0, 0, 255);

    my @pixels;
    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);

    my @codes;
    my $codes_len = 0;

    foreach my $c (0 .. 255) {
        my $l = ord($bytes->[$index++]);
        if ($l > 0) {
            $codes_len += $l;
            push @codes, [$c, $l];
        }
    }

    my $codes_bin = '';
    while (length($codes_bin) < $codes_len) {
        $codes_bin .= unpack('B*', $bytes->[$index++] // last);
    }

    my %rev_dict;
    foreach my $pair (@codes) {
        my $code = substr($codes_bin, 0, $pair->[1], '');
        $rev_dict{$code} = chr($pair->[0]);
    }

    my $enc_len = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));

    splice(@$bytes, 0, $index);

    if ($enc_len > 0) {
        @$bytes = unpack("C*", huffman_decode(unpack("B" . $enc_len, join('', @$bytes)), \%rev_dict));
    }
    else {
        @$bytes = ();
    }

    $index  = 0;

    while (1) {

        if ($run > 0) {
            --$run;
        }
        else {
            my $byte = $bytes->[$index++] // last;

            if ($byte == 0b11_11_11_10) {    # OP RGB
                $px[0] = $bytes->[$index++];
                $px[1] = $bytes->[$index++];
                $px[2] = $bytes->[$index++];
            }
            elsif ($byte == 0b11_11_11_11) {    # OP RGBA
                $px[0] = $bytes->[$index++];
                $px[1] = $bytes->[$index++];
                $px[2] = $bytes->[$index++];
                $px[3] = $bytes->[$index++];
            }
            elsif (($byte >> 6) == 0b00) {      # OP INDEX
                @px = @{$colors[$byte]};
            }
            elsif (($byte >> 6) == 0b01) {      # OP DIFF
                my $dr = (($byte & 0b00_11_00_00) >> 4) - 2;
                my $dg = (($byte & 0b00_00_11_00) >> 2) - 2;
                my $db = (($byte & 0b00_00_00_11) >> 0) - 2;

                ($px[0] += $dr) %= 256;
                ($px[1] += $dg) %= 256;
                ($px[2] += $db) %= 256;
            }
            elsif (($byte >> 6) == 0b10) {      # OP LUMA
                my $byte2 = $bytes->[$index++];

                my $dg    = ($byte & 0b00_111_111) - 32;
                my $dr_dg = ($byte2 >> 4) - 8;
                my $db_dg = ($byte2 & 0b0000_1111) - 8;

                my $dr = $dr_dg + $dg;
                my $db = $db_dg + $dg;

                ($px[0] += $dr) %= 256;
                ($px[1] += $dg) %= 256;
                ($px[2] += $db) %= 256;
            }
            elsif (($byte >> 6) == 0b11) {    # OP RUN
                $run = ($byte & 0b00_111_111);
            }

            $colors[($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64] = [@px];
        }

        push @pixels, @px;
    }

    foreach my $row (0 .. $height - 1) {
        my @line = splice(@pixels, 0, 4 * $width);
        $img->setscanline(y => $row, pixels => pack("C*", @line));
    }

    return $img;
}

@ARGV || do {
    say STDERR "usage: $0 [input.qhi] [output.png]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.png";

my @chars = do {
    open(my $fh, '<:raw', $in_file)
      or die "Can't open file <<$in_file>> for reading: $!";
    local $/;
    split(//, scalar <$fh>);
};

my $img = qhi_decoder(\@chars);
$img->write(file => $out_file, type => 'png');


================================================
FILE: Image/qhi_encoder.pl
================================================
#!/usr/bin/perl

# Variation of the QOI encoder, combined with Huffman coding.

# QHIf = Quite Huffman Image format. :)

# See also:
#   https://qoiformat.org/
#   https://github.com/phoboslab/qoi

use 5.020;
use warnings;

use Imager;
use experimental qw(signatures);

# produce encode and decode dictionary from a tree
sub walk ($node, $code, $h, $rev_h) {

    my $c = $node->[0] // return ($h, $rev_h);
    if (ref $c) { walk($c->[$_], $code . $_, $h, $rev_h) for ('0', '1') }
    else        { $h->{$c} = $code; $rev_h->{$code} = $c }

    return ($h, $rev_h);
}

# make a tree, and return resulting dictionaries
sub mktree ($bytes) {
    my (%freq, @nodes);

    ++$freq{$_} for @$bytes;
    @nodes = map { [$_, $freq{$_}] } sort { $a <=> $b } keys %freq;

    do {    # poor man's priority queue
        @nodes = sort { $a->[1] <=> $b->[1] } @nodes;
        my ($x, $y) = splice(@nodes, 0, 2);
        if (defined($x) and defined($y)) {
            push @nodes, [[$x, $y], $x->[1] + $y->[1]];
        }
    } while (@nodes > 1);

    walk($nodes[0], '', {}, {});
}

sub huffman_encode ($bytes, $dict) {
    my $enc = '';
    for (@$bytes) {
        $enc .= $dict->{$_} // die "bad char: $_";
    }
    return $enc;
}

sub qhi_encoder ($img, $out_fh) {

    use constant {
                  QOI_OP_RGB  => 0b1111_1110,
                  QOI_OP_RGBA => 0b1111_1111,
                  QOI_OP_DIFF => 0b01_000_000,
                  QOI_OP_RUN  => 0b11_000_000,
                  QOI_OP_LUMA => 0b10_000_000,
                 };

    my $width      = $img->getwidth;
    my $height     = $img->getheight;
    my $channels   = $img->getchannels;
    my $colorspace = 0;

    say "[$width, $height, $channels, $colorspace]";

    my @header = unpack('C*', 'qhif');

    push @header, unpack('C4', pack('N', $width));
    push @header, unpack('C4', pack('N', $height));

    push @header, $channels;
    push @header, $colorspace;

    my @bytes;

    my $run     = 0;
    my @px      = (0, 0, 0, 255);
    my @prev_px = @px;

    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);

    foreach my $y (0 .. $height - 1) {

        my @line     = unpack('C*', scalar $img->getscanline(y => $y));
        my $line_len = scalar(@line);

        for (my $i = 0 ; $i < $line_len ; $i += 4) {
            @px = splice(@line, 0, 4);

            if (    $px[0] == $prev_px[0]
                and $px[1] == $prev_px[1]
                and $px[2] == $prev_px[2]
                and $px[3] == $prev_px[3]) {

                if (++$run == 62) {
                    push @bytes, QOI_OP_RUN | ($run - 1);
                    $run = 0;
                }
            }
            else {

                if ($run > 0) {
                    push @bytes, (QOI_OP_RUN | ($run - 1));
                    $run = 0;
                }

                my $hash     = ($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64;
                my $index_px = $colors[$hash];

                if (    $px[0] == $index_px->[0]
                    and $px[1] == $index_px->[1]
                    and $px[2] == $index_px->[2]
                    and $px[3] == $index_px->[3]) {    # OP INDEX
                    push @bytes, $hash;
                }
                else {

                    $colors[$hash] = [@px];

                    if ($px[3] == $prev_px[3]) {

                        my $vr = $px[0] - $prev_px[0];
                        my $vg = $px[1] - $prev_px[1];
                        my $vb = $px[2] - $prev_px[2];

                        my $vg_r = $vr - $vg;
                        my $vg_b = $vb - $vg;

                        if (    $vr > -3
                            and $vr < 2
                            and $vg > -3
                            and $vg < 2
                            and $vb > -3
                            and $vb < 2) {
                            push(@bytes, QOI_OP_DIFF | (($vr + 2) << 4) | (($vg + 2) << 2) | ($vb + 2));
                        }
                        elsif (    $vg_r > -9
                               and $vg_r < 8
                               and $vg > -33
                               and $vg < 32
                               and $vg_b > -9
                               and $vg_b < 8) {
                            push(@bytes, QOI_OP_LUMA | ($vg + 32));
                            push(@bytes, (($vg_r + 8) << 4) | ($vg_b + 8));
                        }
                        else {
                            push(@bytes, QOI_OP_RGB, $px[0], $px[1], $px[2]);
                        }
                    }
                    else {
                        push(@bytes, QOI_OP_RGBA, $px[0], $px[1], $px[2], $px[3]);
                    }
                }
            }

            @prev_px = @px;
        }
    }

    if ($run > 0) {
        push(@bytes, 0b11_00_00_00 | ($run - 1));
    }

    my @footer;
    push(@footer, (0x00) x 7);
    push(@footer, 0x01);

    my ($h, $rev_h) = mktree(\@bytes);
    my $enc   = huffman_encode(\@bytes, $h);

    my $dict  = '';
    my $codes = '';

    foreach my $i (0 .. 255) {
        my $c = $h->{$i} // '';
        $codes .= $c;
        $dict  .= chr(length($c));
    }

    # Header
    print $out_fh pack('C*', @header);

    # Huffman dictionary + data
    print $out_fh $dict;
    print $out_fh pack("B*", $codes);
    print $out_fh pack("N",  length($enc));
    print $out_fh pack("B*", $enc);

    # Footer
    print $out_fh pack('C*', @footer);
}

@ARGV || do {
    say STDERR "usage: $0 [input.png] [output.qhi]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.qhi";

my $img = 'Imager'->new(file => $in_file)
    or die "Can't read image: $in_file";

open(my $out_fh, '>:raw', $out_file)
  or die "Can't open file <<$out_file>> for writing: $!";

qhi_encoder($img, $out_fh);


================================================
FILE: Image/qoi_decoder.pl
================================================
#!/usr/bin/perl

# Implementation of the QOI decoder (generating a PNG file).

# See also:
#   https://qoiformat.org/
#   https://github.com/phoboslab/qoi
#   https://yewtu.be/watch?v=EFUYNoFRHQI

use 5.020;
use warnings;

use Imager;
use experimental qw(signatures);

sub qoi_decoder ($bytes) {

    my sub invalid() {
        die "Not a QOIF image";
    }

    my $index = 0;

    pack('C4', map { $bytes->[$index++] } 1 .. 4) eq 'qoif' or invalid();

    my $width  = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));
    my $height = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));

    my $channels   = $bytes->[$index++];
    my $colorspace = $bytes->[$index++];

    ($width > 0 and $height > 0) or invalid();
    ($channels > 0 and $channels <= 4) or invalid();
    ($colorspace == 0 or $colorspace == 1) or invalid();

    pop(@$bytes) == 0x01 or invalid();

    for (1 .. 7) {
        pop(@$bytes) == 0x00 or invalid();
    }

    say "[$width, $height, $channels, $colorspace]";

    my $img = 'Imager'->new(
                            xsize    => $width,
                            ysize    => $height,
                            channels => $channels,
                           );

    my $run = 0;
    my @px  = (0, 0, 0, 255);

    my @pixels;
    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);

    while (1) {

        if ($run > 0) {
            --$run;
        }
        else {
            my $byte = $bytes->[$index++] // last;

            if ($byte == 0b11_11_11_10) {    # OP RGB
                $px[0] = $bytes->[$index++];
                $px[1] = $bytes->[$index++];
                $px[2] = $bytes->[$index++];
            }
            elsif ($byte == 0b11_11_11_11) {    # OP RGBA
                $px[0] = $bytes->[$index++];
                $px[1] = $bytes->[$index++];
                $px[2] = $bytes->[$index++];
                $px[3] = $bytes->[$index++];
            }
            elsif (($byte >> 6) == 0b00) {      # OP INDEX
                @px = @{$colors[$byte]};
            }
            elsif (($byte >> 6) == 0b01) {      # OP DIFF
                my $dr = (($byte & 0b00_11_00_00) >> 4) - 2;
                my $dg = (($byte & 0b00_00_11_00) >> 2) - 2;
                my $db = (($byte & 0b00_00_00_11) >> 0) - 2;

                ($px[0] += $dr) %= 256;
                ($px[1] += $dg) %= 256;
                ($px[2] += $db) %= 256;
            }
            elsif (($byte >> 6) == 0b10) {      # OP LUMA
                my $byte2 = $bytes->[$index++];

                my $dg    = ($byte & 0b00_111_111) - 32;
                my $dr_dg = ($byte2 >> 4) - 8;
                my $db_dg = ($byte2 & 0b0000_1111) - 8;

                my $dr = $dr_dg + $dg;
                my $db = $db_dg + $dg;

                ($px[0] += $dr) %= 256;
                ($px[1] += $dg) %= 256;
                ($px[2] += $db) %= 256;
            }
            elsif (($byte >> 6) == 0b11) {    # OP RUN
                $run = ($byte & 0b00_111_111);
            }

            $colors[($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64] = [@px];
        }

        push @pixels, @px;
    }

    foreach my $row (0 .. $height - 1) {
        my @line = splice(@pixels, 0, 4 * $width);
        $img->setscanline(y => $row, pixels => pack("C*", @line));
    }

    return $img;
}

@ARGV || do {
    say STDERR "usage: $0 [input.qoi] [output.png]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.png";

my @bytes = do {
    open(my $fh, '<:raw', $in_file)
      or die "Can't open file <<$in_file>> for reading: $!";
    local $/;
    unpack("C*", scalar <$fh>);
};

my $img = qoi_decoder(\@bytes);
$img->write(file => $out_file, type => 'png');


================================================
FILE: Image/qoi_encoder.pl
================================================
#!/usr/bin/perl

# Implementation of the QOI encoder.

# See also:
#   https://qoiformat.org/
#   https://github.com/phoboslab/qoi
#   https://yewtu.be/watch?v=EFUYNoFRHQI

use 5.020;
use warnings;

use Imager;
use experimental qw(signatures);

sub qoi_encoder ($img) {

    use constant {
                  QOI_OP_RGB  => 0b1111_1110,
                  QOI_OP_RGBA => 0b1111_1111,
                  QOI_OP_DIFF => 0b01_000_000,
                  QOI_OP_RUN  => 0b11_000_000,
                  QOI_OP_LUMA => 0b10_000_000,
                 };

    my $width      = $img->getwidth;
    my $height     = $img->getheight;
    my $channels   = $img->getchannels;
    my $colorspace = 0;

    say "[$width, $height, $channels, $colorspace]";

    my @bytes = unpack('C*', 'qoif');

    push @bytes, unpack('C4', pack('N', $width));
    push @bytes, unpack('C4', pack('N', $height));

    push @bytes, $channels;
    push @bytes, $colorspace;

    my $run     = 0;
    my @px      = (0, 0, 0, 255);
    my @prev_px = @px;

    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);

    foreach my $y (0 .. $height - 1) {

        my @line     = unpack('C*', scalar $img->getscanline(y => $y));
        my $line_len = scalar(@line);

        for (my $i = 0 ; $i < $line_len ; $i += 4) {
            @px = splice(@line, 0, 4);

            if (    $px[0] == $prev_px[0]
                and $px[1] == $prev_px[1]
                and $px[2] == $prev_px[2]
                and $px[3] == $prev_px[3]) {

                if (++$run == 62) {
                    push @bytes, QOI_OP_RUN | ($run - 1);
                    $run = 0;
                }
            }
            else {

                if ($run > 0) {
                    push @bytes, (QOI_OP_RUN | ($run - 1));
                    $run = 0;
                }

                my $hash     = ($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64;
                my $index_px = $colors[$hash];

                if (    $px[0] == $index_px->[0]
                    and $px[1] == $index_px->[1]
                    and $px[2] == $index_px->[2]
                    and $px[3] == $index_px->[3]) {    # OP INDEX
                    push @bytes, $hash;
                }
                else {

                    $colors[$hash] = [@px];

                    if ($px[3] == $prev_px[3]) {

                        my $vr = $px[0] - $prev_px[0];
                        my $vg = $px[1] - $prev_px[1];
                        my $vb = $px[2] - $prev_px[2];

                        my $vg_r = $vr - $vg;
                        my $vg_b = $vb - $vg;

                        if (    $vr > -3
                            and $vr < 2
                            and $vg > -3
                            and $vg < 2
                            and $vb > -3
                            and $vb < 2) {
                            push(@bytes, QOI_OP_DIFF | (($vr + 2) << 4) | (($vg + 2) << 2) | ($vb + 2));
                        }
                        elsif (    $vg_r > -9
                               and $vg_r < 8
                               and $vg > -33
                               and $vg < 32
                               and $vg_b > -9
                               and $vg_b < 8) {
                            push(@bytes, QOI_OP_LUMA | ($vg + 32));
                            push(@bytes, (($vg_r + 8) << 4) | ($vg_b + 8));
                        }
                        else {
                            push(@bytes, QOI_OP_RGB, $px[0], $px[1], $px[2]);
                        }
                    }
                    else {
                        push(@bytes, QOI_OP_RGBA, $px[0], $px[1], $px[2], $px[3]);
                    }
                }
            }

            @prev_px = @px;
        }
    }

    if ($run > 0) {
        push(@bytes, QOI_OP_RUN | ($run - 1));
    }

    push(@bytes, (0x00) x 7);
    push(@bytes, 0x01);

    return \@bytes;
}

@ARGV || do {
    say STDERR "usage: $0 [input.png] [output.qoi]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.qoi";

my $img = 'Imager'->new(file => $in_file)
    or die "Can't read image: $in_file";

my $bytes = qoi_encoder($img);

open(my $fh, '>:raw', $out_file)
  or die "Can't open file <<$out_file>> for writing: $!";

print $fh pack('C*', @$bytes);
close $fh;


================================================
FILE: Image/qzst_decoder.pl
================================================
#!/usr/bin/perl

# Implementation of the QZST decoder (QOI + Zstandard compression), generating a PNG file.

# See also:
#   https://qoiformat.org/
#   https://github.com/phoboslab/qoi

use 5.020;
use warnings;

use Imager;
use experimental           qw(signatures);
use IO::Uncompress::UnZstd qw(unzstd $UnZstdError);

sub qzst_decoder ($bytes) {

    my sub invalid() {
        die "Not a QZST image";
    }

    my $index = 0;

    join('', map { $bytes->[$index++] } 1 .. 4) eq 'qzst' or invalid();

    my $width  = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));
    my $height = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));

    my $channels   = ord $bytes->[$index++];
    my $colorspace = ord $bytes->[$index++];

    ($width > 0 and $height > 0) or invalid();
    ($channels > 0 and $channels <= 4) or invalid();
    ($colorspace == 0 or $colorspace == 1) or invalid();

    ord(pop(@$bytes)) == 0x01 or invalid();

    for (1 .. 7) {
        ord(pop(@$bytes)) == 0x00 or invalid();
    }

    say "[$width, $height, $channels, $colorspace]";

    my $len = unpack('N', join('', map { $bytes->[$index++] } 1 .. 4));

    scalar(@$bytes) - $index == $len or invalid();
    splice(@$bytes, 0, $index);

    unzstd(\join('', @$bytes), \my $qoi_data)
      or die "unzstd failed: $UnZstdError\n";

    $index  = 0;
    @$bytes = unpack('C*', $qoi_data);

    my $img = 'Imager'->new(
                            xsize    => $width,
                            ysize    => $height,
                            channels => $channels,
                           );

    my $run = 0;
    my @px  = (0, 0, 0, 255);

    my @pixels;
    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);

    while (1) {

        if ($run > 0) {
            --$run;
        }
        else {
            my $byte = $bytes->[$index++] // last;

            if ($byte == 0b11_11_11_10) {    # OP RGB
                $px[0] = $bytes->[$index++];
                $px[1] = $bytes->[$index++];
                $px[2] = $bytes->[$index++];
            }
            elsif ($byte == 0b11_11_11_11) {    # OP RGBA
                $px[0] = $bytes->[$index++];
                $px[1] = $bytes->[$index++];
                $px[2] = $bytes->[$index++];
                $px[3] = $bytes->[$index++];
            }
            elsif (($byte >> 6) == 0b00) {      # OP INDEX
                @px = @{$colors[$byte]};
            }
            elsif (($byte >> 6) == 0b01) {      # OP DIFF
                my $dr = (($byte & 0b00_11_00_00) >> 4) - 2;
                my $dg = (($byte & 0b00_00_11_00) >> 2) - 2;
                my $db = (($byte & 0b00_00_00_11) >> 0) - 2;

                ($px[0] += $dr) %= 256;
                ($px[1] += $dg) %= 256;
                ($px[2] += $db) %= 256;
            }
            elsif (($byte >> 6) == 0b10) {      # OP LUMA
                my $byte2 = $bytes->[$index++];

                my $dg    = ($byte & 0b00_111_111) - 32;
                my $dr_dg = ($byte2 >> 4) - 8;
                my $db_dg = ($byte2 & 0b0000_1111) - 8;

                my $dr = $dr_dg + $dg;
                my $db = $db_dg + $dg;

                ($px[0] += $dr) %= 256;
                ($px[1] += $dg) %= 256;
                ($px[2] += $db) %= 256;
            }
            elsif (($byte >> 6) == 0b11) {    # OP RUN
                $run = ($byte & 0b00_111_111);
            }

            $colors[($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64] = [@px];
        }

        push @pixels, @px;
    }

    foreach my $row (0 .. $height - 1) {
        my @line = splice(@pixels, 0, 4 * $width);
        $img->setscanline(y => $row, pixels => pack("C*", @line));
    }

    return $img;
}

@ARGV || do {
    say STDERR "usage: $0 [input.qzst] [output.png]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.png";

my @chars = do {
    open(my $fh, '<:raw', $in_file)
      or die "Can't open file <<$in_file>> for reading: $!";
    local $/;
    split(//, scalar <$fh>);
};

my $img = qzst_decoder(\@chars);
$img->write(file => $out_file, type => 'png');


================================================
FILE: Image/qzst_encoder.pl
================================================
#!/usr/bin/perl

# Variation of the QOI encoder, combined with Zstandard compression.

# See also:
#   https://qoiformat.org/
#   https://github.com/phoboslab/qoi

use 5.020;
use warnings;

use Imager;
use experimental       qw(signatures);
use IO::Compress::Zstd qw(zstd $ZstdError);

sub qzst_encoder ($img, $out_fh) {

    use constant {
                  QOI_OP_RGB  => 0b1111_1110,
                  QOI_OP_RGBA => 0b1111_1111,
                  QOI_OP_DIFF => 0b01_000_000,
                  QOI_OP_RUN  => 0b11_000_000,
                  QOI_OP_LUMA => 0b10_000_000,
                 };

    my $width      = $img->getwidth;
    my $height     = $img->getheight;
    my $channels   = $img->getchannels;
    my $colorspace = 0;

    say "[$width, $height, $channels, $colorspace]";

    my @header = unpack('C*', 'qzst');

    push @header, unpack('C4', pack('N', $width));
    push @header, unpack('C4', pack('N', $height));

    push @header, $channels;
    push @header, $colorspace;

    my $qoi_data = '';

    my $run     = 0;
    my @px      = (0, 0, 0, 255);
    my @prev_px = @px;

    my @colors = (map { [0, 0, 0, 0] } 1 .. 64);

    foreach my $y (0 .. $height - 1) {

        my @line     = unpack('C*', scalar $img->getscanline(y => $y));
        my $line_len = scalar(@line);

        for (my $i = 0 ; $i < $line_len ; $i += 4) {
            @px = splice(@line, 0, 4);

            if (    $px[0] == $prev_px[0]
                and $px[1] == $prev_px[1]
                and $px[2] == $prev_px[2]
                and $px[3] == $prev_px[3]) {

                if (++$run == 62) {
                    $qoi_data .= chr(QOI_OP_RUN | ($run - 1));
                    $run = 0;
                }
            }
            else {

                if ($run > 0) {
                    $qoi_data .= chr(QOI_OP_RUN | ($run - 1));
                    $run = 0;
                }

                my $hash     = ($px[0] * 3 + $px[1] * 5 + $px[2] * 7 + $px[3] * 11) % 64;
                my $index_px = $colors[$hash];

                if (    $px[0] == $index_px->[0]
                    and $px[1] == $index_px->[1]
                    and $px[2] == $index_px->[2]
                    and $px[3] == $index_px->[3]) {    # OP INDEX
                    $qoi_data .= chr($hash);
                }
                else {

                    $colors[$hash] = [@px];

                    if ($px[3] == $prev_px[3]) {

                        my $vr = $px[0] - $prev_px[0];
                        my $vg = $px[1] - $prev_px[1];
                        my $vb = $px[2] - $prev_px[2];

                        my $vg_r = $vr - $vg;
                        my $vg_b = $vb - $vg;

                        if (    $vr > -3
                            and $vr < 2
                            and $vg > -3
                            and $vg < 2
                            and $vb > -3
                            and $vb < 2) {
                            $qoi_data .= chr(QOI_OP_DIFF | (($vr + 2) << 4) | (($vg + 2) << 2) | ($vb + 2));
                        }
                        elsif (    $vg_r > -9
                               and $vg_r < 8
                               and $vg > -33
                               and $vg < 32
                               and $vg_b > -9
                               and $vg_b < 8) {
                            $qoi_data .= join('', chr(QOI_OP_LUMA | ($vg + 32)), chr((($vg_r + 8) << 4) | ($vg_b + 8)));
                        }
                        else {
                            $qoi_data .= join('', chr(QOI_OP_RGB), chr($px[0]), chr($px[1]), chr($px[2]));
                        }
                    }
                    else {
                        $qoi_data .= join('', chr(QOI_OP_RGBA), chr($px[0]), chr($px[1]), chr($px[2]), chr($px[3]));
                    }
                }
            }

            @prev_px = @px;
        }
    }

    if ($run > 0) {
        $qoi_data .= chr(0b11_00_00_00 | ($run - 1));
    }

    my @footer;
    push(@footer, (0x00) x 7);
    push(@footer, 0x01);

    # Header
    print $out_fh pack('C*', @header);

    # Compressed data
    zstd(\$qoi_data, \my $zstd_data) or die "zstd failed: $ZstdError\n";
    print $out_fh pack("N", length($zstd_data));
    print $out_fh $zstd_data;

    # Footer
    print $out_fh pack('C*', @footer);
}

@ARGV || do {
    say STDERR "usage: $0 [input.png] [output.qzst]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.qzst";

my $img = 'Imager'->new(file => $in_file)
  or die "Can't read image: $in_file";

open(my $out_fh, '>:raw', $out_file)
  or die "Can't open file <<$out_file>> for writing: $!";

qzst_encoder($img, $out_fh);


================================================
FILE: Image/recompress_images.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 September 2023
# Edit: 08 August 2024
# https://github.com/trizen

# Recompress a given list of images, using either PNG or JPEG (whichever results in a smaller file size).

# WARNING: the original files are deleted!
# WARNING: the program does LOSSY compression of images!

# If the file is a PNG image:
#   1. we create a JPEG copy
#   2. we recompress the PNG image using `pngquant`
#   3. we recompress the JPEG copy using `jpegoptim`
#   4. then we keep whichever is smaller: the PNG or the JPEG file

# If the file is a JPEG image:
#   1. we create a PNG copy
#   2. we recompress the JPEG image using `jpegoptim`
#   3. we recompress the PNG copy using `pngquant`
#   4. then we keep whichever is smaller: the JPEG or the PNG file

# The following tools are required:
#   * jpegoptim  -- for recompressing JPEG images
#   * pngquant   -- for recompressing PNG images

use 5.036;

use GD;
use File::Find            qw(find);
use File::Temp            qw(mktemp);
use File::Copy            qw(copy);
use File::Spec::Functions qw(catfile tmpdir);
use Getopt::Long          qw(GetOptions);

GD::Image->trueColor(1);

my $png_only  = 0;    # true to recompress only PNG images
my $jpeg_only = 0;    # true to recompress only JPEG images

my $quality         = 85;    # default quality value for JPEG (between 0-100)
my $png_compression = 0;     # default PNG compression level for GD (between 0-9)

my $keep_original = 0;       # true to keep original images
my $use_exiftool  = 0;       # true to use `exiftool` instead of `File::MimeInfo::Magic`
my $preserve_attr = 0;       # preserve original file attributes
my $suffix        = '';      # recompressed filenames suffix

sub png2jpeg (%args) {

    my $orig_file = $args{png_file}  // return;
    my $jpeg_file = $args{jpeg_file} // return;

    my $image = eval { GD::Image->new($orig_file) } // do {
        warn "[!] Can't load file <<$orig_file>>. Skipping...\n";
        return;
    };

    my $jpeg_data = $image->jpeg($quality);

    open(my $fh, '>:raw', $jpeg_file) or do {
        warn "[!] Can't open file <<$jpeg_file>> for writing: $!\n";
        return;
    };

    print {$fh} $jpeg_data;
    close $fh;
}

sub jpeg2png (%args) {

    my $orig_file = $args{jpeg_file} // return;
    my $png_file  = $args{png_file}  // return;

    my $image = eval { GD::Image->new($orig_file) } // do {
        warn "[!] Can't load file <<$orig_file>>. Skipping...\n";
        return;
    };

    my $png_data = $image->png($png_compression);

    open(my $fh, '>:raw', $png_file) or do {
        warn "[!] Can't open file <<$png_file>> for writing: $!\n";
        return;
    };

    print {$fh} $png_data;
    close $fh;
}

sub determine_mime_type ($file) {

    if ($file =~ /\.jpe?g\z/i) {
        return "image/jpeg";
    }

    if ($file =~ /\.png\z/i) {
        return "image/png";
    }

    if ($use_exiftool) {
        my $res = `exiftool \Q$file\E`;
        $? == 0       or return;
        defined($res) or return;
        if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) {
            return $1;
        }
        return;
    }

    require File::MimeInfo::Magic;
    File::MimeInfo::Magic::magic($file);
}

sub optimize_jpeg ($jpeg_file) {

    # Uncomment the following line to use `recomp-jpg` from LittleUtils
    # return system('recomp-jpg', '-q', '-t', $quality, $jpeg_file);

    system('jpegoptim', '-q', '-s', '--threshold=0.1', '-m', $quality, $jpeg_file);
}

sub optimize_png ($png_file) {
    system('pngquant', '--strip', '--ext', '.png', '--skip-if-larger', '--force', $png_file);
}

@ARGV or die <<"USAGE";
usage: perl $0 [options] [dirs | files]

Recompress a given list of images, using either PNG or JPEG (whichever results in a smaller file size).

options:

    -q INT      : quality level for JPEG (default: $quality)
    --jpeg      : recompress only JPEG images (default: $jpeg_only)
    --png       : recompress only PNG images (default: $png_only)
    --exiftool  : use `exiftool` to determine the MIME type (default: $use_exiftool)
    --preserve  : preserve original file timestamps and permissions
    --suffix=s  : add a given suffix to recompressed filenames
    --keep      : keep original files (to be used with --suffix)

WARNING: the original files are deleted!
WARNING: the program does LOSSY compression of images!
USAGE

GetOptions(
           'q|quality=i' => \$quality,
           'jpeg|jpg!'   => \$jpeg_only,
           'png!'        => \$png_only,
           'exiftool!'   => \$use_exiftool,
           'p|preserve!' => \$preserve_attr,
           'suffix=s'    => \$suffix,
           'keep!'       => \$keep_original,
          )
  or die "Error in command-line arguments!";

my %types = (
             'image/png' => {
                             files  => [],
                             format => 'png',
                            },
             'image/jpeg' => {
                              files  => [],
                              format => 'jpg',
                             },
            );

find(
    {
     no_chdir => 1,
     wanted   => sub {

         (-f $_) || return;
         my $type = determine_mime_type($_) // return;

         if (exists $types{$type}) {
             my $ref = $types{$type};
             push @{$ref->{files}}, $_;
         }
     }
    } => @ARGV
);

my $total_savings = 0;

my $temp_png = catfile(tmpdir(), mktemp("tmpfileXXXXX") . '.png');
my $temp_jpg = catfile(tmpdir(), mktemp("tmpfileXXXXX") . '.jpg');

sub recompress_image ($file, $file_format) {

    my $conversion_func = \&jpeg2png;
    my $temp_file       = $temp_jpg;

    if ($file_format eq 'png') {
        $conversion_func = \&png2jpeg;
        $temp_file       = $temp_png;
    }

    copy($file, $temp_file) or do {
        warn "[!] Can't copy <<$file>> to <<$temp_file>>: $!\n";
        return;
    };

    $conversion_func->(png_file => $temp_png, jpeg_file => $temp_jpg) or return;
    optimize_png($temp_png);
    optimize_jpeg($temp_jpg);

    my $final_file = $temp_png;
    my $file_ext   = 'png';

    if ((-s $temp_jpg) < (-s $final_file)) {
        $final_file = $temp_jpg;
        $file_ext   = 'jpg';
    }

    my $final_size = (-s $final_file);
    my $curr_size  = (-s $file);

    $final_size > 0 or return;

    if ($final_size < $curr_size) {

        my $saved = ($curr_size - $final_size) / 1024;

        $total_savings += $saved;

        printf(":: Saved: %.2fKB (%.2fMB -> %.2fMB) (%.2f%%) ($file_format -> $file_ext)\n\n",
               $saved,
               $curr_size / 1024**2,
               $final_size / 1024**2,
               ($curr_size - $final_size) / $curr_size * 100);

        my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($file);

        if (not $keep_original) {
            unlink($file) or return;
        }

        my $new_file = ($file =~ s/\.(?:png|jpe?g)\z//ir) . $suffix . '.' . $file_ext;

        while (-e $new_file) {    # lazy solution
            $new_file .= '.' . $file_ext;
        }

        copy($final_file, $new_file) or do {
            warn "[!] Can't copy <<$final_file>> to <<$new_file>>: $!\n";
            return;
        };

        # Set the original ownership of the image
        chown($uid, $gid, $new_file);

        if ($preserve_attr) {

            # Set the original modification time
            utime($atime, $mtime, $new_file)
              or warn "Can't change timestamp: $!\n";

            # Set original permissions
            chmod($mode & 07777, $new_file)
              or warn "Can't change permissions: $!\n";
        }
    }
    else {
        printf(":: The image is already very well compressed. Skipping...\n\n");
    }

    return 1;
}

foreach my $type (keys %types) {

    my $ref = $types{$type};

    if ($jpeg_only and $ref->{format} eq 'png') {
        next;
    }

    if ($png_only and $ref->{format} eq 'jpg') {
        next;
    }

    foreach my $file (@{$ref->{files}}) {
        if ($ref->{format} eq 'png') {
            say ":: Processing PNG file: $file";
            recompress_image($file, 'png');

        }
        elsif ($ref->{format} eq 'jpg') {
            say ":: Processing JPEG file: $file";
            recompress_image($file, 'jpg');
        }
        else {
            say "ERROR: unknown format type for file: $file";
        }
    }
}

unlink($temp_jpg);
unlink($temp_png);

printf(":: Total savings: %.2fKB\n", $total_savings),


================================================
FILE: Image/remove_sensitive_exif_tags.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 October 2019
# https://github.com/trizen

# Remove sensitive EXIF information from images that may be used for online-tracking.

# The script uses the "exiftool".
#   https://www.sno.phy.queensu.ca/~phil/exiftool/

# This is particularly necessary for photos downloaded from Facebook, which include a tracking ID inside them.
#   https://news.ycombinator.com/item?id=20427007
#   https://dustri.org/b/on-facebooks-pictures-watermarking.html
#   https://www.hackerfactor.com/blog/index.php?/archives/726-Facebook-Tracking.html
#   https://www.reddit.com/r/privacy/comments/ccndcq/facebook_is_embedding_tracking_data_inside_the/

use 5.020;
use warnings;
use File::Find qw(find);

use Getopt::Std qw(getopts);
use experimental qw(signatures);

my %opts;
getopts('ea', \%opts);    # flag "-e" removes extra tags

my $extra      = $opts{e} || 0;          # true to remove additional information, such as the camera name
my $all        = $opts{a} || 0;          # true to remove all tags
my $batch_size = 100;                    # how many files to process at once
my $image_re   = qr/\.(png|jpe?g)\z/i;

sub strip_tags ($files) {

    say ":: Stripping tracking tags of ", scalar(@$files), " photos...";
    say ":: The first image is: $files->[0]";

    system(
        "exiftool",

        "-overwrite_original_in_place",    # overwrite image in place

        "-*Serial*Number*=",               # remove serial number of camera photo
        "-*ImageUniqueID*=",               # remove the unique image ID
        "-*Copyright*=",                   # remove copyright data
        "-usercomment=",                   # remove any user comment
        "-iptc=",                          # remove any IPTC data
        "-xmp=",                           # remove any XMP data
        "-geotag=",                        # remove geotag data
        "-gps:all=",                       # remove ALL GPS data

        (
         $extra
         ? (
            "-make=",                      # remove the brand name of the camera used to make the photo
            "-model=",                     # remove the model name of the camera used to make the photo
            "-software=",                  # remove the software name used to edit/process the photo
            "-imagedescription=",          # remove any image description
           )
         : ()
        ),

        ($all ? ("-all=") : ()),

        @$files
          );
}

my @files;

@ARGV or die "usage: perl script.pl -[ea] [dirs | files]\n";

find(
    {
     no_chdir => 1,
     wanted   => sub {
         if (/$image_re/ and -f $_) {

             push @files, $_;

             if (@files >= $batch_size) {
                 strip_tags(\@files);
                 @files = ();
             }
         }
     }
    } => @ARGV
);

if (@files) {
    strip_tags(\@files);
}

say ":: Done!";


================================================
FILE: Image/resize_images.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 30 October 2023
# Edit: 26 September 2025
# https://github.com/trizen

# Resize images to a given width or height, keeping aspect ratio.

use 5.036;
use Imager       qw();
use File::Find   qw(find);
use List::Util   qw(min max);
use Getopt::Long qw(GetOptions);

my $width  = 'auto';
my $height = 'auto';
my $min    = 'auto';
my $max    = 'auto';
my $qtype  = 'mixing';
my $outdir = undef;

my $img_formats   = '';
my $preserve_attr = 0;

my @img_formats = qw(
  jpeg
  jpg
  png
);

sub usage ($code) {
    local $" = ",";
    print <<"EOT";
usage: $0 [options] [dirs | files]

options:
    -w  --width=i     : resize images to this width
    -h  --height=i    : resize images to this height

        --min=i       : resize images to have the smallest side equal to this
        --max=i       : resize images to have the largest side equal to this

    -q  --quality=s   : quality of scaling: 'normal', 'preview' or 'mixing' (default: $qtype)
    -f  --formats=s,s : specify more image formats (default: @img_formats)
    -p  --preserve!   : preserve file original timestamps and metadata info
    -o  --outdir=s    : create resized images into this directory

examples:

    $0 --min=1080 *.jpg     # smallest side = 1080 pixels
    $0 --height=1080 *.jpg  # height = 1080 pixels

EOT

    exit($code);
}

GetOptions(
           'w|width=i'   => \$width,
           'h|height=i'  => \$height,
           'minimum=i'   => \$min,
           'maximum=i'   => \$max,
           'q|quality=s' => \$qtype,
           'f|formats=s' => \$img_formats,
           'p|preserve!' => \$preserve_attr,
           'o|outdir=s'  => \$outdir,
           'help'        => sub { usage(0) },
          )
  or die("Error in command line arguments");

push @img_formats, map { quotemeta } split(/\s*,\s*/, $img_formats);

my $img_formats_re = do {
    local $" = '|';
    qr/\.(@img_formats)\z/i;
};

if (defined($outdir)) {

    if (not -d $outdir) {
        require File::Path;
        File::Path::make_path($outdir)
          or die "Can't create output directory <<$outdir>>: $!";
    }

    require File::Basename;
    require File::Spec::Functions;
}

sub resize_image ($image) {

    my $img = Imager->new(file => $image) or do {
        warn "Failed to load <<$image>>: ", Imager->errstr();
        return;
    };

    my ($curr_width, $curr_height) = ($img->getwidth, $img->getheight);

    if ($min ne 'auto' and $min > 0) {

        if (min($curr_width, $curr_height) <= $min) {
            say "Image too small to resize";
            return;
        }

        if ($curr_width < $curr_height) {
            $img = $img->scale(xpixels => $min, qtype => $qtype);
        }
        else {
            $img = $img->scale(ypixels => $min, qtype => $qtype);
        }
    }
    elsif ($max ne 'auto' and $max > 0) {

        if (max($curr_width, $curr_height) <= $max) {
            say "Image too small to resize";
            return;
        }

        if ($curr_height > $curr_width) {
            $img = $img->scale(ypixels => $max, qtype => $qtype);
        }
        else {
            $img = $img->scale(xpixels => $max, qtype => $qtype);
        }
    }
    elsif ($height ne 'auto' and $height > 0) {
        if ($curr_height <= $height) {
            say "Image too small to resize";
            return;
        }
        $img = $img->scale(ypixels => $height, qtype => $qtype);
    }
    elsif ($width ne 'auto' and $width > 0) {
        if ($curr_width <= $width) {
            say "Image too small to resize";
            return;
        }
        $img = $img->scale(xpixels => $width, qtype => $qtype);
    }
    else {
        die "No --width or --height specified...";
    }

    my ($exif_info, $exifTool);

    if ($preserve_attr) {
        require Image::ExifTool;
        $exifTool  = Image::ExifTool->new;
        $exif_info = $exifTool->SetNewValuesFromFile($image);
    }

    my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($image);

    # Create resized image into $outdir directory
    if (defined($outdir)) {
        $image = File::Spec::Functions::catfile($outdir, File::Basename::basename($image));
    }

    $img->write(file => $image) or do {
        warn "Failed to rewrite image: ", $img->errstr;
        return;
    };

    if ($preserve_attr) {

        $exifTool = Image::ExifTool->new;

        foreach my $key (keys %$exif_info) {
            my $value = $exif_info->{$key};
            $exifTool->SetNewValue($key, $value);
        }

        $exifTool->WriteInfo($image);

        # Set the original modification time
        utime($atime, $mtime, $image)
          or warn "Can't change timestamp: $!\n";

        # Set original permissions
        chmod($mode & 07777, $image)
          or warn "Can't change permissions: $!\n";
    }

    # Set the original ownership of the image
    chown($uid, $gid, $image);

    return 1;
}

@ARGV || usage(1);

find {
    no_chdir => 1,
    wanted   => sub {
        (/$img_formats_re/o && -f) || return;
        say "Resizing: $_";
        resize_image($_);
    }
} => @ARGV;


================================================
FILE: Image/rgb_dump.pl
================================================
#!/usr/bin/perl

# Dump the first n pixels from a given image.

use 5.020;
use warnings;

use Imager;
use experimental qw(signatures);

@ARGV || do {
    say STDERR "usage: $0 [input.png] [n]";
    exit(2);
};

my $in_file = $ARGV[0];
my $n       = $ARGV[1] // 10;

my $img = 'Imager'->new(file => $in_file)
  or die "Can't read image: $in_file";

my $width  = $img->getwidth;
my $height = $img->getheight;

OUTER: foreach my $y (0 .. $height - 1) {
    foreach my $x (0 .. $width - 1) {
        --$n >= 0 or last OUTER;
        my $color = $img->getpixel(x => $x, y => $y);
        my ($r, $g, $b) = $color->rgba;
        printf("%08b,%08b,%08b | %2x,%2x,%2x | %3d,%3d,%3d\n", ($r, $g, $b) x 3);
    }
}


================================================
FILE: Image/sharp_2x_zoom.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 31 October 2015
# Website: https://github.com/trizen

# Zoom a picture two times, without loosing too much details.

# Requires: wkhtmltoimage

use 5.010;
use strict;
use autodie;
use warnings;

use GD qw();
use File::Temp qw(tempfile);
use HTML::Entities qw(encode_entities);

GD::Image->trueColor(1);

sub help {
    my ($code) = @_;
    print <<"HELP";
usage: $0 [input image] [output image]
HELP
    exit($code);
}

sub enhance_img {
    my ($image, $out) = @_;

    my $img = GD::Image->new($image) // return;
    my ($width, $height) = $img->getBounds;

    my $scale_width  = 2 * $width;
    my $scale_height = $height;

    my $resized = GD::Image->new($scale_width, $scale_height);
    $resized->copyResampled($img, 0, 0, 0, 0, $scale_width, $scale_height, $width, $height);

    ($width, $height) = ($scale_width, $scale_height);
    $img = $resized;

    my @pixels;

    foreach my $y (0 .. $height - 1) {
        foreach my $x (0 .. $width - 1) {
            my $index = $img->getPixel($x, $y);
            push @pixels, [$img->rgb($index)];
        }
    }

    my $header = <<"EOT";


${\encode_entities($image)}





    EOT

    $html = join('', $header, $style, $html, $footer);

    my ($fh, $tmpfile) = tempfile(UNLINK => 1, SUFFIX => '.html');
    print $fh $html;
    close $fh;

    system(
           'wkhtmltoimage', '--quality',     '100',      '--crop-h', $height * 2,
           '--crop-w',      $width,          '--crop-x', '8',        '--crop-y',
           '8',             '--transparent', '--quiet',  $tmpfile,   $out
          );
}

my $img = $ARGV[0] // help(1);
my $out = $ARGV[1] // help(1);
enhance_img($img, $out);


================================================
FILE: Image/slideshow.pl
================================================
#!/usr/bin/perl

# Create a video slideshow from a collection of images, given a glob pattern.

# Usage:
#   perl slideshow.pl 'glob_pattern*.jpg' 'output.mp4'

use 5.036;
use Getopt::Long qw(GetOptions);

my $width  = 1920;
my $height = 1080;
my $delay  = 2;

GetOptions(
           "width=i"  => \$width,
           "height=i" => \$height,
           "delay=i"  => \$delay
          )
  or die("Error in command line arguments\n");

@ARGV == 2 or die <<"USAGE";
usage: $0 [options] [glob pattern] [output.mp4]

options:

    --width=i   : width of the video (default: $width)
    --height=i  : height of the video (default: $height)
    --delay=i   : delay in seconds between pictures (default: $delay)
USAGE

system('ffmpeg', qw(-framerate),
       join('/', 1, $delay),
       qw(-pattern_type glob -i),
       $ARGV[0], '-vf',
       "scale=${width}:${height}:force_original_aspect_ratio=decrease,pad=${width}:${height}:(ow-iw)/2:(oh-ih)/2",
       qw(-c:v libx264 -s),
       join('x', $width, $height),
       qw(-crf 18 -tune stillimage -r 24),
       $ARGV[1]);


================================================
FILE: Image/vertical_scrambler.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 05 April 2024
# https://github.com/trizen

# Scramble the pixels in each column inside an image, using a deterministic method.

use 5.036;
use GD;
use Getopt::Std qw(getopts);

GD::Image->trueColor(1);

sub scramble ($str) {
    my $i = length($str);
    $str =~ s/(.{$i})(.)/$2$1/gs while (--$i > 0);
    return $str;
}

sub unscramble ($str) {
    my $i = 0;
    my $l = length($str);
    $str =~ s/(.)(.{$i})/$2$1/gs while (++$i < $l);
    return $str;
}

sub scramble_image ($file, $function) {

    my $image = GD::Image->new($file) || die "Can't open file <<$file>>: $!";
    my ($width, $height) = $image->getBounds();

    my $new_image = GD::Image->new($width, $height);

    foreach my $x (0 .. $width - 1) {

        my (@R, @G, @B);
        foreach my $y (0 .. $height - 1) {
            my ($R, $G, $B) = $image->rgb($image->getPixel($x, $y));
            push @R, $R;
            push @G, $G;
            push @B, $B;
        }

        @R = unpack('C*', $function->(pack('C*', @R)));
        @G = unpack('C*', $function->(pack('C*', @G)));
        @B = unpack('C*', $function->(pack('C*', @B)));

        foreach my $y (0 .. $height - 1) {
            $new_image->setPixel($x, $y, $new_image->colorAllocate($R[$y], $G[$y], $B[$y]));
        }
    }

    return $new_image;
}

sub usage ($exit_code = 0) {

    print <<"EOT";
usage: $0 [options] [input.png] [output.png]

options:

    -d : decode the image
    -h : print this message and exit

EOT

    exit($exit_code);
}

getopts('dh', \my %opts);

my $input_file  = $ARGV[0] // usage(2);
my $output_file = $ARGV[1] // "output.png";

if (not -f $input_file) {
    die "Input file <<$input_file>> does not exist!\n";
}

my $img = $opts{d} ? scramble_image($input_file, \&unscramble) : scramble_image($input_file, \&scramble);
open(my $out_fh, '>:raw', $output_file) or die "can't create output file <<$output_file>>: $!";
print $out_fh $img->png(9);
close $out_fh;


================================================
FILE: Image/visualize_binary.pl
================================================
#!/usr/bin/perl

# Visualize a given input stream of bytes, as a PGM (P5) image.

use 5.014;
use strict;
use warnings;

use Getopt::Long qw(GetOptions);

my $width  = 0;
my $height = 0;
my $colors = 255;

sub print_usage {
    print <<"EOT";
usage: $0 [options] [output.pgm]

options:

    --width=i   : width of the image (default: $width)
    --height=i  : height of the image (default: $height)
    --colors=i  : number of colors (default: $colors)
    --help      : display this message and exit

EOT
    exit;
}

GetOptions(
           "w|width=i"  => \$width,
           "h|height=i" => \$height,
           "c|colors=i" => \$colors,
           "help"       => \&print_usage,
          )
  or die "Error in arguments";

binmode(STDIN,  ':raw');
binmode(STDOUT, ':raw');

my $data = do {
    local $/;
    <>;
};

if (!$width or !$height) {
    $width  ||= ($height ? int(length($data) / $height) : int(sqrt(length($data))));
    $height ||= int(length($data) / $width);
}

print "P5 $width $height $colors\n";
print $data;


================================================
FILE: Image/webp2png.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 April 2021
# https://github.com/trizen

# Convert WEBP images to PNG, using the `dwebp` tool from "libwebp".

# The original WEBP files are deleted.

use 5.036;
use File::Find   qw(find);
use Getopt::Long qw(GetOptions);

my $dwebp_cmd    = "dwebp";    # `dwebp` command
my $use_exiftool = 0;          # true to use `exiftool` instead of `File::MimeInfo::Magic`

`$dwebp_cmd -h`
  or die "Error: `$dwebp_cmd` tool from 'libwebp' is not installed!\n";

sub webp2png ($file) {

    my $orig_file = $file;
    my $png_file  = $file;

    if ($png_file =~ s/\.webp\z/.png/i) {
        ## ok
    }
    else {
        $png_file .= '.png';
    }

    if (-e $png_file) {
        warn "[!] File <<$png_file>> already exists...\n";
        next;
    }

    system($dwebp_cmd, $orig_file, '-o', $png_file);

    if ($? == 0 and (-e $png_file) and ($png_file ne $orig_file)) {
        unlink($orig_file);
    }
    else {
        return;
    }

    return 1;
}

sub determine_mime_type ($file) {

    if ($file =~ /\.webp\z/i) {
        return "image/webp";
    }

    if ($use_exiftool) {
        my $res = `exiftool \Q$file\E`;
        $? == 0       or return;
        defined($res) or return;
        if ($res =~ m{^MIME\s+Type\s*:\s*(\S+)}mi) {
            return $1;
        }
        return;
    }

    require File::MimeInfo::Magic;
    File::MimeInfo::Magic::magic($file);
}

my %types = (
             'image/webp' => {
                              call => \&webp2png,
                             }
            );

GetOptions('exiftool!' => \$use_exiftool,)
  or die "Error in command-line arguments!";

@ARGV or die <<"USAGE";
usage: perl $0 [options] [dirs | files]

options:

    --exiftool : use `exiftool` to determine the MIME type (default: $use_exiftool)

USAGE

find(
    {
     no_chdir => 1,
     wanted   => sub {

         (-f $_) || return;
         my $type = determine_mime_type($_) // return;

         if (exists $types{$type}) {
             $types{$type}{call}->($_);
         }
     }
    } => @ARGV
);

say ":: Done!";


================================================
FILE: Image/zuper_image_decoder.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 26 November 2022
# https://github.com/trizen

# A decoder for the Zuper (ZPR) image format, generating PNG images.

use 5.020;
use warnings;

use Imager;
use experimental           qw(signatures);
use IO::Uncompress::UnZstd qw(unzstd $UnZstdError);

sub zpr_decoder ($bytes) {

    my sub invalid() {
        die "Not a ZPR image";
    }

    my $index = 0;

    pack('C4', map { $bytes->[$index++] } 1 .. 4) eq 'zprf' or invalid();

    my $width  = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));
    my $height = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));

    my $channels   = $bytes->[$index++];
    my $colorspace = $bytes->[$index++];

    ($width > 0 and $height > 0) or invalid();
    ($channels > 0 and $channels <= 4) or invalid();
    ($colorspace == 0 or $colorspace == 1) or invalid();

    pop(@$bytes) == 0x01 or invalid();

    for (1 .. 7) {
        pop(@$bytes) == 0x00 or invalid();
    }

    say "[$width, $height, $channels, $colorspace]";

    my $len = unpack('N', pack('C4', map { $bytes->[$index++] } 1 .. 4));

    scalar(@$bytes) - $index == $len or invalid();

    splice(@$bytes, 0, $index);
    my $z = pack('C' . $len, @$bytes);

    unzstd(\$z, \my $all_channels)
      or die "unzstd failed: $UnZstdError\n";

    my $img = 'Imager'->new(
                            xsize    => $width,
                            ysize    => $height,
                            channels => $channels,
                           );

    my @channels = unpack(sprintf("(a%d)%d", $width * $height, $channels), $all_channels);
    my $diff = 4 - $channels;

    foreach my $y (0 .. $height - 1) {
        my $row = '';
        foreach my $x (1 .. $width) {
            $row .= substr($_, 0, 1, '') for @channels;
            $row .= chr(0) x $diff if $diff;
        }
        $img->setscanline(y => $y, pixels => $row);
    }

    return $img;
}

@ARGV || do {
    say STDERR "usage: $0 [input.zpr] [output.png]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.png";

my @bytes = do {
    open(my $fh, '<:raw', $in_file)
      or die "Can't open file <<$in_file>> for reading: $!";
    local $/;
    unpack("C*", scalar <$fh>);
};

my $img = zpr_decoder(\@bytes);
$img->write(file => $out_file, type => 'png');


================================================
FILE: Image/zuper_image_encoder.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 26 November 2022
# https://github.com/trizen

# A very simple lossless image encoder, using Zstandard compression.

# Pretty good at compressing computer-generated images.

use 5.020;
use warnings;

use Imager;
use experimental       qw(signatures);
use IO::Compress::Zstd qw(zstd $ZstdError);

sub zuper_encoder ($img, $out_fh) {

    my $width      = $img->getwidth;
    my $height     = $img->getheight;
    my $channels   = $img->getchannels;
    my $colorspace = 0;

    say "[$width, $height, $channels, $colorspace]";

    my @header = unpack('C*', 'zprf');

    push @header, unpack('C4', pack('N', $width));
    push @header, unpack('C4', pack('N', $height));

    push @header, $channels;
    push @header, $colorspace;

    my $index    = 0;
    my @channels = map { "" } (1 .. $channels);

    foreach my $y (0 .. $height - 1) {

        my @line     = split(//, scalar $img->getscanline(y => $y));
        my $line_len = scalar(@line);

        for (my $i = 0 ; $i < $line_len ; $i += 4) {
            my @px = splice(@line, 0, 4);
            foreach my $j (0 .. $channels - 1) {
                $channels[$j] .= $px[$j];
            }
            ++$index;
        }
    }

    my @footer;
    push(@footer, (0x00) x 7);
    push(@footer, 0x01);

    my $all_channels = '';

    foreach my $channel (@channels) {
        $all_channels .= $channel;
    }

    zstd(\$all_channels, \my $z)
      or die "zstd failed: $ZstdError\n";

    my $before = length($all_channels);
    my $after  = length($z);

    say "Compression: $before -> $after (saved ", sprintf("%.2f%%", 100 - $after / $before * 100), ")";

    # Header
    print $out_fh pack('C*', @header);

    # Compressed data
    print $out_fh pack('N', $after);
    print $out_fh $z;

    # Footer
    print $out_fh pack('C*', @footer);
}

@ARGV || do {
    say STDERR "usage: $0 [input.png] [output.zpr]";
    exit(2);
};

my $in_file  = $ARGV[0];
my $out_file = $ARGV[1] // "$in_file.zpr";

my $img = 'Imager'->new(file => $in_file)
    or die "Can't read image: $in_file";

open(my $out_fh, '>:raw', $out_file)
  or die "Can't open file <<$out_file>> for writing: $!";

zuper_encoder($img, $out_fh);


================================================
FILE: JAPH/alien_japh.pl
================================================
                   read*DATA,$_,13**+3;y #{}
                 {}{};s>[\s*]+>>g;$i=length;s/
              (.{$i})(.)/$2$1/gx while$i--;eval;;
           ;for(q\just \.q)another),q)perl hacker)){
         for(split$!){$_=$$h{$_}?do{$_=$$h{$_};;;;;;;y
       / -_/&&unpack'u',chr(length()*.75+32
      ).$_}:$"x$];$w=(sort{$b<=>$a}map+length,split$\=$/)
     [$]-$]];s/^(.*?)\s*$/sprintf'%-*s',$w,$1/egm;push@f,[
    [split$\],$w]}for$x($?..-//+$]){push@{$x[$x]},@{$f[$_][
   $?]}?pop@{$f[$_][$?]}:$"x$f[$_][//]for$?..$#f}$s.="@{+pop
  @x}$/"while@x;$k=$g=chr(ord$^);for(split$\,$s){$s=$g;$$s=$_
  ;++$g}$==135;print$w="\e[H","\e[J";{print$w;print$"x$=,$$_?
 chop$$_:''for$k..$g;select$,,$,,$,,.01;--$=&&redo}}__END__!!!
 C**wX*yX****o*f*****ig*pv*AoB**LhCffX*g*I**I*lyI****8*g*FC8L8
 8**v*I*LC*g9*8I*o81ga***ICXp*I*Ig8***CIv*wF*B*8*I*8*wX**gCvIA
 g*LA,L>8*Cg*CCyy*w**cIi**F>*L=8**L*X**='CgCLfg*vC8wXgX*Kef*9*
B8C**I*g*gvIALKX*L**C*vy*>I*gX***I*Xg8**w1*}CA*=y8*y******lAyw*
=8C*gy*f****f**y*8**loK****K88A**8f=,*II****'g*f*F*F*wf*v**gvCA
C8*y*y*LIgK******Xf''***'*I***A*X=yiov***g>C*,*8*g****IAgvA*I*X
Fj**gCy*8Xv**89v'*XI*ILy**=A**C1A*8y*v*o**v9KvXyw**f**f**X8**C*
*Fy******C*C9**L*vf**C*vF*8gg$*y**v*8v**AL**II*ILKsK*Xyv**gCI**
8**y        fI**K*F*8**L*,*I9*C**8*BiFw*fg,A8h8*gF'        B***
vg*L           *8*C*8*F*fX*CC8*g*B***,Iv88A*****           gC8X
*1*C              C***IF*u******CX8**L>Xi=***              *C**
C*v8*               **ICI8I*>*KC***8IF*B*8*               *oIF*
**K**                Av*ALvg**C*I*g**'*wBA                **FLg
*'1''*                 f=*yLLI*****'ff'*                 *fo*9g
 *IA>y                  F***v*8FIoy'*C*                  *Lf**
 I*8f8v                  *k'y8F*=vw*>g                  **Kf**
  vy8*X>                  *K*L*XgKw*'                  o*g'vF
   *1By'                   gBv*LI***                   XX8**
   KB***'                  Xv**A'**8                  v***of
    ilgCgC*                 **'***f                 y*BA*8i
     **LI*y*                *8IoIv*                *oC,y*g
      ,**gI**=               *yC8i               'I8g*L>8
       '9{8gB*>A             F*18I             **8A=*v**
        *yA'*1pf**           *wv**           ****,I8l*v
         *IAB*AC*f**f       I**yA**       yF*C1*Avp***
          **gCv'*****KIyK******8C'g9I**yFK*IL8*A=vo*y
           C*ABX*F*fv8***AC,*9***wy***IKI****,Kn=i**
            **Xf8w*L1*w*9***8*,ygf*X**88oKCIC***I**
             I*8*'*F8IL***CL**y*>*>I*****fCC*8LC*y
               **XC***A*I*g*C*FA*w****Bv**CfyA*I
                g*I*y*****A*BI9'g**gy*Iw*L8*lgX
                 *IXXX*A**X**8g*I88*I***B*i***
                   *y**X*FXAyg****Avgo*F*F*F
                     *XAg*gC*i****,*LI**>*
                       IK*I*Xg****tv****
                         XCA**8pr*CIg*
                           A*K=***y*


================================================
FILE: JAPH/alpha_ascii_japh.pl
================================================
print q q q x length time and print chr length qq q exec getc getgrent glob goto
getgrnam getsockname getsockopt getgrgid gmtime grep getprotoent q and print chr
length time and print q q q and print q q q and print chr length q q caller chop
chdir chmod chomp chown chr chroot close closedir continue connect cos crypt die
dbmclose dbmopen defined dump q and print q q  q and print chr length q q import
binmode bless each no formline package q and do s ss q q readpipe qx length time
sex xor s t readpipe tr t xor print chr length xor print q q  q xor s y y x yggg
xor s sissg xor s trt qq t xor print chr length xor print chr length qq q splice
setpwent setsockopt shift shmctl study socketpair sort split sprintf srand utime
write q xor eval print chr length xor print q q q xor print chr length xor print
chr length q q scalar seekdir sethostent select semctl semget semop send setpgrp
setgrent opendir sub listen q xor print chr length xor print chr length time xor
print chr length xor s spssg xor s sassg xor s s rss xor printf chr length xor s
s s q q x q x length time sex xor s s ss xor do print chr length xor print q q q
xor s s ssg xor s sessg xor s exee xor print chr length xor s sxxssx xor do eval
print chr length xor print chr length xor s sxsxxxsg xor s sxxxxxssx xor do eval
print chr length xor print q q q xor s sxsq q x q x length time se xor s sx sxxx
sx xor print chr length xor print qq q   q xor print chr length xor print qq q q
xor print chr length xor s yy do eval print chr length time foreach qw qr x q ye


================================================
FILE: JAPH/alpha_japh.pl
================================================
print chr length qw a b a x ord qq bJb and
print chr length qw b c b x ord qq cuc and
print chr length qw c d c x ord qq dsd and
print chr length qw d e d x ord qq ete and
print chr length qw e f e x ord qq f f and
print chr length qw f g f x ord qq gag and
print chr length qw g h g x ord qq hnh and
print chr length qw h i h x ord qq ioi and
print chr length qw i j i x ord qq jtj and
print chr length qw j k j x ord qq khk and
print chr length qw k l k x ord qq lel and
print chr length qw l m l x ord qq mrm and
print chr length qw m n m x ord qq n n and
print chr length qw n o n x ord qq oPo and
print chr length qw o p o x ord qq pep and
print chr length qw p q p x ord qq qrq and
print chr length qw q r q x ord qq rlr and
print chr length qw r s r x ord qq s s and
print chr length qw s t s x ord qq tht and
print chr length qw t u t x ord qq uau and
print chr length qw u v u x ord qq vcv and
print chr length qw v w v x ord qq wkw and
print chr length qw w x w x ord qq xex and
print chr length qw x y x x ord qq yry and
print chr length time and do not eval exit


================================================
FILE: JAPH/alpha_japh_2.pl
================================================
print chr length o x ord qw o J o and
print chr length o x ord qw x u x and
print chr length o x ord qw o s o and
print chr length o x ord qw x t x and
print chr length o x ord qq o   o and
print chr length o x ord qw x a x and
print chr length o x ord qw o n o and
print chr length o x ord qw x o x and
print chr length o x ord qw o t o and
print chr length o x ord qw x h x and
print chr length o x ord qw o e o and
print chr length o x ord qw x r x and
print chr length o x ord qq o   o and
print chr length o x ord qw x P x and
print chr length o x ord qw o e o and
print chr length o x ord qw x r x and
print chr length o x ord qw o l o and
print chr length o x ord qq x   x and
print chr length o x ord qw o h o and
print chr length o x ord qw x a x and
print chr length o x ord qw o c o and
print chr length o x ord qw x k x and
print chr length o x ord qw o e o and
print chr length o x ord qw x r x and
print chr length time and do not exit


================================================
FILE: JAPH/alpha_japh_3.pl
================================================
qw qxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxqand
s yys xxprint scalar reverse q qrekcah lreP rehtona tsuJqxe and print qq x
xyexxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx


================================================
FILE: JAPH/arrow_japh.pl
================================================
!_&print q qJq or
!__&print q quq or
!___&print q qsq or
!____&print q qtq or
!_____&print q q q or
!______&print q qaq or
!_______&print q qnq or
!________&print q qoq or
!_________&print q qtq or
!__________&print q qhq or
!___________&print q qeq or
!____________&print q qrq or
!____________&print q q q or
!____________&print q qPq or
!___________&print q qeq or
!__________&print q qrq or
!_________&print q qlq or
!________&print q q q or
!_______&print q qhq or
!______&print q qaq or
!_____&print q qcq or
!____&print q qkq or
!___&print q qeq or
!__&print q qrq or
!_&print q q,q,$/


================================================
FILE: JAPH/barewords_japh.pl
================================================
Just another Perl hacker

local+$,=$";package another;sub Just{print(substr((caller(0))[3],3**2),@_)}
package hacker;sub Perl{Just another((split/:./,(caller(0))[3])[1,0]),exit}


================================================
FILE: JAPH/cubic_japh.pl
================================================
       +($\,$})=($/,q$@$);@@=split$!=>($@
      =$}|'/'=>$:=$@,++$@,$@++,$~=(++$@=>
     ++$@),$.=$",$_=$/|$}.(+(++$@=>++$@).
    $~).++$~.$..($;=$}|'!').($^='.'|$}).+
   ('/'|$}).$~.($@=$}|'(').($"='%'|$}).(+
  +++$:=>++$:,+++$:).$..($:^'"').$".$:.(q
 },}|$}).$..$@.$;.($}.$}|'#+').$".$:.q|,|
 );sub f{print@_}sub i(_){my($l,$j)=0;my(
 $x,$y,$z,$c,$h,$v,$d,$s,$p,$o)=(+@{+pop}
 ,qw w+ -w,qw\| /\,sub{$j=$_[0];$l+$j>+@@
 &&($l=$?);@@[do{$l=$j+$l;$l-$j..$l-1}]},
 $?);f$.x($z+1),$c,$h x$x,$c;f$.x($z-$_+1
 ),$d,$s->($x),$d,$s->($_-1-$p),$_>$y?!$p
 &&++$p?do{$o=$z-$y;$c}:$p++?$d:$c:$v for
 1..$z;f$c,$h x$x,$c,$p?($s->($z-$o),$d):
 ($s->($z),$z<$y?$v:$c);f$v,$s->($x),$v,
 ,$z-1>=$y?$_>=$z?($s->($x),$c):($s->($
 z-$_-$o),$d):$y-$_>$z?($s->($z),$v):(
 $s->($y-$_),$y-$_==$z?$c:$d)for+1..$
 y;f$c,$h x$x,$c}+i,,for[24,24,24],[
 1,24,0],[24,1,0],[1,0,24],[24,3,1]


================================================
FILE: JAPH/invisible_japh.pl
================================================
open _=>">$0";print _+'print chr length for split"\5"=>qq;';print _+qq
"\0"x+ord($_)=>"\5"for(split//=>join''=>'Vioh<}rshtynutime=>seek=>tell=>$"=>alarm=>next=>
our=>tied=>hex=>each=>recv=>$"=>pipe=>exit=>redo=>lock=>$"=>
hex=>accept=>connect=>keys=>eof=>rewinddir=>chr length time;


================================================
FILE: JAPH/japh_from_escapes.pl
================================================
'J 	 
o	 
 P
 	
'=~($_=qr/^J\u\s\t \a\no\t\h\e\r P\e\r\l \h\a\ck\e\r$/)&&
print s/(?(?{$-[0]==$=\/2})(?{'l'})|(?{$!}))|^\W+(.)(?{$1
.($1^'?')})|[\\^](?=\w)(?{$@})|\W+\z(?{",$\/"})/$^R/girls


================================================
FILE: JAPH/japh_from_eval_subst.pl
================================================
s/(?{(('[[).\|`][[{[.@\/(^.[{;\,[@:?+^)('^'+)@@(^*((\/[:@\/[@;\{+^.@{([\@;["').'"')})/$^R/ee


================================================
FILE: JAPH/japh_from_keywords.pl
================================================
join eval tell rand reverse ord chr eval split xor
uc prototype eval lcfirst join chmod kill eval ref
split sprintf reverse times xor not eval and srand
tell sqrt formline eval ord lcfirst ucfirst length
 glob gmtime exp defined caller or binmode log ord
abs lc sqrt study alarm split time or formline cos
ne rewinddir kill chdir reset prototype split sqrt
ord int localtime abs oct pack pop eq scalar print
telldir open unpack return and unlink write chroot
hex bless utime split chown split close rmdir join
exp fileno getc sleep redo glob mkdir stat ne pack
reverse getpwnam next lstat gethostent and getpgrp
 eq log ord time xor chr undef and eval caller and
printf srand lstat chown chdir syscall open select
eq -w closedir sleep chr split and quotemeta reset
require ne closedir sleep chr undef or pack unpack
length study length umask readpipe pos xor defined
 join system and die or do exit if defined require
hex defined undef or sprintf localtime cmp time or
abs time and undef and open exp getc fileno system
caller eof rewinddir readpipe return study defined
kill die wantarray and readlink eof readpipe split
eval warn join study abs localtime oct log time or
reverse xor open 0; print chr ord while readline 0
,;print chr abs length time for cos length defined


================================================
FILE: JAPH/japh_from_pod.pl
================================================
sub f{my%D;@D{@_}=();for(@_){if(-d){next if${_}eq'.';my@g;opendir(D,${_})||next;
while(defined(my$d=readdir(D))){unless(${d}eq'.'or${d}eq'..'){push@g,"${_}/$d"}}
closedir(D);push@f,grep({-f}@g);f(grep((!exists($D{$_})),grep({-d}@g)))}elsif(-f
){push@f,$_}}return@f}my$q=qr/["']\w[^\W\d]{3}\h\w{5}([[:alpha:]])\S\b\N\D\1\w+?
\s\p{PosixAlpha}\B.[\x63-\x72]{4,},?(?:\\n)?["']/six;do{-T||next;open(_,'<',$_);
sysread _,$_,-s;if(/$q/o){$_=eval$&;chomp;local$\=$/;print;exit}}foreach(f@INC);


================================================
FILE: JAPH/japh_from_poetry.pl
================================================
$_ = q q
       Jungla urbană si tonalitatea
       amplifică naivitatea omului terestru, hrănind eficient răutatea...
       Preoții explică răscumpărațiilor luciferului
       hârtia acoperită cu koranul enunțat răului...

q;for(split /\s/){ print chr ord, q q q } print chr length time


================================================
FILE: JAPH/japh_from_punctuation_chars.pl
================================================
$,='@',$@=$,|'/',$:=$@,++$@,$@++,$~=(++$@,++$@),$.=$",$_=$/|$,.((++$@,++$@).$~)
.++$~.$..($;=$,|'!').($^='.'|$,).('/'|$,).$~.($@=$,|'(').($"='%'|$,).(++$:=>,++
$:,++$:).$..($:^'"').$".$:.(','|$,).$..$@.$;.($,.$,|'#+').$".$:.','.$/=>=>print


================================================
FILE: JAPH/japh_from_subs.pl
================================================
print"@{sub hacker;[grep{sub Just;$::{$_}eq-1}keys%::
];sub Perl}[!!_+(++${sub another;_}),$?,//,$#$],$/";;


================================================
FILE: JAPH/japh_from_the_deep.pl
================================================
\&~=~'\(';print+s{\x42}{$"}r,for($`..-$`)[4889245,650731,2540044,8375064,1505137],$/;


================================================
FILE: JAPH/japh_variable.pl
================================================
BEGIN{$^W=1,$SIG{__WARN__}=sub{pop=~s/:+([^"]+)/die
"$1,$\/"=~tr\_\ \r/error}}$Just_another_Perl_hacker


================================================
FILE: JAPH/japh_variables.pl
================================================
for($-..$=+$=){$_=chr;/[a-z]/io||next;$$_ = $_, $$_ = $_}
print "$J$u$s$t $a$n$o$t$h$e$r $P$e$r$l $h$a$c$k$e$r,$/";


================================================
FILE: JAPH/japh_variables_2.pl
================================================
$\=$/;foreach($-..$=+$=){$_=chr,m$[\x61-\x75\x2C]$i||next,$$_ = $_ and $$$_=$$_}
print join $",$J.$u.$s.$t,$a.$n.$o.$t.$h.$e.$r,$P.$e.$r.$l,$h.$a.$c.$k.$e.$r.$,;


================================================
FILE: JAPH/leet_japh.pl
================================================
for(chr 97..chr 117){$_[@_]=$_}for$1(split/\D/,){$_.=$_
[$1]if$_[$1]}s/([^Ja]+)([^p]+)([^h]+)(.+)/\u$1 $2 \u$3 $4,\n/
;@_=split//;for(@_){print;print"\0"x6**$]if$^O=~/^l/}__DATA__
9+20+18+19+23*0*13+14+19+7+4+17*15*4+17*11+7+0*2*10-4+17=1337


================================================
FILE: JAPH/length_obfuscation.pl
================================================
$_=q qrea ncJertsa ,thelhPkour q,my $i=length;
while($i){s/(.{$i})(.)/$2$1/g;--$i}print+$_.$/


================================================
FILE: JAPH/log_japh.pl
================================================
print chr for unpack q((a2)*), substr log(18747683), 3, 8;


================================================
FILE: JAPH/log_japh_2.pl
================================================
use bignum;$\=$/;$,=$"; print map { pack "C${\(length>>1)}", unpack
"x3(a2)*", log } 51063670, 20632319030177, 54134528, 1100260138130;


================================================
FILE: JAPH/non-alphanumeric_japh.pl
================================================
$,='@',$@=$,|'/',$:=$@=>++$@,$@++,$~=(++$@=>/\/\//=>,++$@)=>$\=("$,$,$,$,"^
'%#(/'),$_=($/|$,).((++$@,++$@).$~).++$~.$".($;=$,|'!').($^=('.',=>,=>,)|$,
).('/'|$,).$~.($@=$,|'(').($.='%'|$,).(++$:=>/<=|=>/=>,++$:=>++$:).$".($:^+
'"').$..$:.(','|$,).$".$@.$;.($,.$,|'#+').$..$:.',',`$\ '$_'>&${\($]>>//)}`


================================================
FILE: JAPH/re_eval_japh.pl
================================================
use re 'eval';
_=~('(?{'.('[[).\|`][[{[.@/(^.[{;\,[@:?+^)('
^'+)@@(^*((/[:@/[@;\{+^.@{([\@;["').'"})');;


================================================
FILE: JAPH/slash_r_japh.pl
================================================
print$/=~s~~r~r=~s~~e~r=~s~~k~r=~s~~c~r=~s~~a~r=~s~~h~r=~s~~ ~r=~s<>
~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
=~s~~o~r=~s~~n~r=~s~~a~r=~s~~ ~r=~s~~t~r=~s~~s~r=~s~~u~r=~s~~J~r////


================================================
FILE: JAPH/ternary_japh.pl
================================================
{{{{{{{{{{{{{{{{{{{{{{{{{$\=$/}}}}}}}}}}}}}}}}}}}}}}}}}print
'a'?'J':'b'?'c':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n',
'b'?'u':'c'?'d':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o',
'c'?'s':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p',
'd'?'t':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q',
'e'?' ':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r',
'f'?'a':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s',
'g'?'n':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t',
'h'?'o':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u',
'i'?'t':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v',
'j'?'h':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w',
'k'?'e':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v'?'w':'x',
'l'?'r':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w'?'x':'y',
'm'?' ':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v'?'w':'x'?'y':'z',
'a'?'P':'b'?'c':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n',
'b'?'e':'c'?'d':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o',
'c'?'r':'d'?'e':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p',
'd'?'l':'e'?'f':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q',
'e'?' ':'f'?'g':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r',
'f'?'h':'g'?'h':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s',
'g'?'a':'h'?'i':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t',
'h'?'c':'i'?'j':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u',
'i'?'k':'j'?'k':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v',
'j'?'e':'k'?'l':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w',
'k'?'r':'l'?'m':'n'?'o':'p'?'q':'r'?'s':'t'?'u':'v'?'w':'x',
'l'?',':'m'?'n':'o'?'p':'q'?'r':'s'?'t':'u'?'v':'w'?'x':'y';


================================================
FILE: JAPH/up_and_down.pl
================================================
eval {                                       hacker
                                        Perl
                                another
                           Just
$,=$"};
eval {                     Just
                                another
                                        Perl
                                             hacker
};
package                         another
;sub                       Just
{print qw;                              Perl
                                             hacker
;}
package                                      hacker
;sub                                    Perl
{print qw;                 Just
                                another
;,''}


================================================
FILE: JAPH/vec_japh.pl
================================================
$_ = [
        74, 116, 113, 113,
        28,  92, 104, 104,
       108,  95,  91, 103,
        20,  67,  87,  99,
        92,  15,  86,  78,
        79,  86,  79,  91,
        20,  19,  00,  73,
     ];

{vec(${print${$j},$/;$j},$i++
,8)=$$_[$i]+$i;$$_[$i]&&redo}


================================================
FILE: JAPH/vec_japh_2.pl
================================================
$_=[$j=#];
          101,  98, 102, 108, 28,
           69, 111, 108, 108, 23,
           87,  99,  99, 103, 90,
           86,  98,  15,  62, 82,
           94,  87,  10,  81, 73,
           74,  81,  74,  86, 15,
            2,  31,   6,  17,  0,
$i=$j-$j];

{vec($j,$i++,8)=$$_[$i]+$i;$$_[$i]&&redo||`$j`}


================================================
FILE: LICENSE
================================================
GNU GENERAL PUBLIC LICENSE
                       Version 3, 29 June 2007

 Copyright (C) 2007 Free Software Foundation, Inc. 
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

                            Preamble

  The GNU General Public License is a free, copyleft license for
software and other kinds of works.

  The licenses for most software and other practical works are designed
to take away your freedom to share and change the works.  By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users.  We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors.  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.

  To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights.  Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received.  You must make sure that they, too, receive
or can get the source code.  And you must show them these terms so they
know their rights.

  Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.

  For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software.  For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.

  Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so.  This is fundamentally incompatible with the aim of
protecting users' freedom to change the software.  The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable.  Therefore, we
have designed this version of the GPL to prohibit the practice for those
products.  If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.

  Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary.  To prevent this, the GPL assures that
patents cannot be used to render the program non-free.

  The precise terms and conditions for copying, distribution and
modification follow.

                       TERMS AND CONDITIONS

  0. Definitions.

  "This License" refers to version 3 of the GNU General Public License.

  "Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.

  "The Program" refers to any copyrightable work licensed under this
License.  Each licensee is addressed as "you".  "Licensees" and
"recipients" may be individuals or organizations.

  To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy.  The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.

  A "covered work" means either the unmodified Program or a work based
on the Program.

  To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy.  Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.

  To "convey" a work means any kind of propagation that enables other
parties to make or receive copies.  Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.

  An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License.  If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.

  1. Source Code.

  The "source code" for a work means the preferred form of the work
for making modifications to it.  "Object code" means any non-source
form of a work.

  A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.

  The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form.  A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.

  The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities.  However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work.  For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.

  The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.

  The Corresponding Source for a work in source code form is that
same work.

  2. Basic Permissions.

  All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met.  This License explicitly affirms your unlimited
permission to run the unmodified Program.  The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work.  This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.

  You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force.  You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright.  Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.

  Conveying under any other circumstances is permitted solely under
the conditions stated below.  Sublicensing is not allowed; section 10
makes it unnecessary.

  3. Protecting Users' Legal Rights From Anti-Circumvention Law.

  No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.

  When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.

  4. Conveying Verbatim Copies.

  You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.

  You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.

  5. Conveying Modified Source Versions.

  You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:

    a) The work must carry prominent notices stating that you modified
    it, and giving a relevant date.

    b) The work must carry prominent notices stating that it is
    released under this License and any conditions added under section
    7.  This requirement modifies the requirement in section 4 to
    "keep intact all notices".

    c) You must license the entire work, as a whole, under this
    License to anyone who comes into possession of a copy.  This
    License will therefore apply, along with any applicable section 7
    additional terms, to the whole of the work, and all its parts,
    regardless of how they are packaged.  This License gives no
    permission to license the work in any other way, but it does not
    invalidate such permission if you have separately received it.

    d) If the work has interactive user interfaces, each must display
    Appropriate Legal Notices; however, if the Program has interactive
    interfaces that do not display Appropriate Legal Notices, your
    work need not make them do so.

  A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit.  Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.

  6. Conveying Non-Source Forms.

  You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:

    a) Convey the object code in, or embodied in, a physical product
    (including a physical distribution medium), accompanied by the
    Corresponding Source fixed on a durable physical medium
    customarily used for software interchange.

    b) Convey the object code in, or embodied in, a physical product
    (including a physical distribution medium), accompanied by a
    written offer, valid for at least three years and valid for as
    long as you offer spare parts or customer support for that product
    model, to give anyone who possesses the object code either (1) a
    copy of the Corresponding Source for all the software in the
    product that is covered by this License, on a durable physical
    medium customarily used for software interchange, for a price no
    more than your reasonable cost of physically performing this
    conveying of source, or (2) access to copy the
    Corresponding Source from a network server at no charge.

    c) Convey individual copies of the object code with a copy of the
    written offer to provide the Corresponding Source.  This
    alternative is allowed only occasionally and noncommercially, and
    only if you received the object code with such an offer, in accord
    with subsection 6b.

    d) Convey the object code by offering access from a designated
    place (gratis or for a charge), and offer equivalent access to the
    Corresponding Source in the same way through the same place at no
    further charge.  You need not require recipients to copy the
    Corresponding Source along with the object code.  If the place to
    copy the object code is a network server, the Corresponding Source
    may be on a different server (operated by you or a third party)
    that supports equivalent copying facilities, provided you maintain
    clear directions next to the object code saying where to find the
    Corresponding Source.  Regardless of what server hosts the
    Corresponding Source, you remain obligated to ensure that it is
    available for as long as needed to satisfy these requirements.

    e) Convey the object code using peer-to-peer transmission, provided
    you inform other peers where the object code and Corresponding
    Source of the work are being offered to the general public at no
    charge under subsection 6d.

  A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.

  A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling.  In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage.  For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product.  A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.

  "Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source.  The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.

  If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information.  But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).

  The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed.  Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.

  Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.

  7. Additional Terms.

  "Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law.  If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.

  When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it.  (Additional permissions may be written to require their own
removal in certain cases when you modify the work.)  You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.

  Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:

    a) Disclaiming warranty or limiting liability differently from the
    terms of sections 15 and 16 of this License; or

    b) Requiring preservation of specified reasonable legal notices or
    author attributions in that material or in the Appropriate Legal
    Notices displayed by works containing it; or

    c) Prohibiting misrepresentation of the origin of that material, or
    requiring that modified versions of such material be marked in
    reasonable ways as different from the original version; or

    d) Limiting the use for publicity purposes of names of licensors or
    authors of the material; or

    e) Declining to grant rights under trademark law for use of some
    trade names, trademarks, or service marks; or

    f) Requiring indemnification of licensors and authors of that
    material by anyone who conveys the material (or modified versions of
    it) with contractual assumptions of liability to the recipient, for
    any liability that these contractual assumptions directly impose on
    those licensors and authors.

  All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10.  If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term.  If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.

  If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.

  Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.

  8. Termination.

  You may not propagate or modify a covered work except as expressly
provided under this License.  Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).

  However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.

  Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.

  Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License.  If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.

  9. Acceptance Not Required for Having Copies.

  You are not required to accept this License in order to receive or
run a copy of the Program.  Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance.  However,
nothing other than this License grants you permission to propagate or
modify any covered work.  These actions infringe copyright if you do
not accept this License.  Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.

  10. Automatic Licensing of Downstream Recipients.

  Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License.  You are not responsible
for enforcing compliance by third parties with this License.

  An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations.  If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.

  You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License.  For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.

  11. Patents.

  A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based.  The
work thus licensed is called the contributor's "contributor version".

  A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version.  For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.

  Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.

  In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement).  To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.

  If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients.  "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.

  If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.

  A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License.  You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.

  Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.

  12. No Surrender of Others' Freedom.

  If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all.  For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.

  13. Use with the GNU Affero General Public License.

  Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work.  The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.

  14. Revised Versions of this License.

  The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

  Each version is given a distinguishing version number.  If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation.  If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.

  If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.

  Later license versions may give you additional or different
permissions.  However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.

  15. Disclaimer of Warranty.

  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. Limitation of Liability.

  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.

  17. Interpretation of Sections 15 and 16.

  If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.

                     END OF TERMS AND CONDITIONS

            How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    {one line to give the program's name and a brief idea of what it does.}
    Copyright (C) {year}  {name of author}

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see .

Also add information on how to contact you by electronic and paper mail.

  If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:

    {project}  Copyright (C) {year}  {fullname}
    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".

  You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
.

  The GNU General Public License does not permit incorporating your program
into proprietary programs.  If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library.  If this is what you want to do, use the GNU Lesser General
Public License instead of this License.  But first, please read
.


================================================
FILE: Lingua/en_phoneme.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# License: GPLv3
# Date: 15 April 2014
# Website: https://github.com/trizen

# usage: ./en_phoneme.pl [word] [word] [...]

use 5.010;
use strict;
use warnings;

use Lingua::EN::Phoneme;
my $lep = Lingua::EN::Phoneme->new;

sub normalize {
    my $syl = lc($_[0]);
    $syl =~ s/h0\z/x/;
    $syl =~ s/\w\K0\z//;
    $syl =~ s/\w\K1\z//;
    return $syl;
}

foreach my $word (@ARGV) {
    my $p_word = $lep->phoneme($word) // do {
        warn "error: '$word' is not an English word!\n";
        next;
    };
    say join(" ", map { normalize($_) } split(' ', $p_word));
}


================================================
FILE: Lingua/lingua_ro_numbers.pl
================================================
#!/usr/bin/perl

use utf8;
use 5.014;
use strict;
use warnings;

use open ':std' => 'utf8';

use Scalar::Util qw(looks_like_number);
use Lingua::RO::Numbers qw(ro_to_number number_to_ro);

require Term::ReadLine;
my $term = Term::ReadLine->new($0);

while (1) {
    my $num = $term->readline("Introduceți un număr: ") // last;
    say +(looks_like_number($num) ? number_to_ro($num) : ro_to_number($num)) // next;
}


================================================
FILE: Lingua/poetry_from_poetry.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 February 2017
# https://github.com/trizen

# An experimental poetry generator, using a given poetry
# as input, replacing words with other similar words.

# usage:
#   perl poetry_from_poetry.pl [poetry.txt] [wordlists]

use 5.016;
use strict;
use autodie;
use warnings;

use open IO => ':utf8', ':std';

use File::Find qw(find);

my $poetry_file = shift(@ARGV);

@ARGV
  || die "usage: $0 [poetry.txt] [wordlists]\n";

my $poetry = do {
    open my $fh, '<', $poetry_file;
    local $/;
    <$fh>;
};

my $starting_len = 2;    # word starting length
my $ending_len   = 2;    # word ending length

my %words;
my %seen;

sub generate_key {
    my ($word) = @_;
    substr($word, 0, $starting_len) . substr($word, -$ending_len);
}

sub collect_words {
    my ($file) = @_;

    open my $fh, '<', $file;

    my $content = do {
        local $/;
        <$fh>;
    };

    close $fh;

    while ($content =~ /([\pL]+)/g) {
        my $word = CORE::fc($1);
        if (length($word) > $ending_len) {
            next if $seen{$word}++;
            my $key = generate_key($word);
            push @{$words{$key}}, $word;
        }
    }
}

find {
    no_chdir => 1,
    wanted   => sub {
        if ((-f $_) and (-T _)) {
            collect_words($_);
        }
    },
} => @ARGV;

$poetry =~ s{([\pL]+)}{
    my $word = $1;
    if (length($word) <= $ending_len) {
        $word;
    }
    else {
        my $key = generate_key($word);
        exists($words{$key}) ? $words{$key}[rand @{$words{$key}}] : $word;
    }
}ge;

say $poetry;


================================================
FILE: Lingua/poetry_from_poetry_with_variations.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 February 2017
# https://github.com/trizen

# An experimental poetry generator, using a given poetry as input,
# replacing words with random words from groups of alike ending words.

# usage:
#   perl poetry_from_poetry.pl [poetry.txt] [wordlists]

use 5.016;
use strict;
use autodie;
use warnings;

use open IO => ':utf8', ':std';

use File::Find qw(find);

my $poetry_file = shift(@ARGV);

@ARGV
  || die "usage: $0 [poetry.txt] [wordlists]\n";

my $poetry = do {
    open my $fh, '<', $poetry_file;
    local $/;
    <$fh>;
};

my $ending_len = 3;    # word ending length
my $group_len  = 0;    # the number of words in a group - 1

my $word_regex = qr/[\pL]+(?:-[\pL]+)?/;

my %words;
my %seen;

sub collect_words {
    my ($file) = @_;

    open my $fh, '<', $file;

    my $content = do {
        local $/;
        <$fh>;
    };

    close $fh;

    while ($content =~ /($word_regex(?:\h+$word_regex){$group_len})/go) {
        my $word = CORE::fc($1);
        my $len = $ending_len;

        if (length($word) > $len) {
            next if $seen{$word}++;
            push @{$words{substr($word, -$len)}}, $word;
        }
    }
}

find {
    no_chdir => 1,
    wanted   => sub {
        if ((-f $_) and (-T _)) {
            collect_words($_);
        }
    },
} => @ARGV;

my @keys = keys(%words);
my %endings;

$poetry =~ s{($word_regex)}{
    my $word = $1;
    my $len = $ending_len;

    if (length($word) <= $len) {
        $word;
    }
    else {
        my $ending = CORE::fc(substr($word, -$len));
        my $key = ($endings{$ending} //= $keys[rand @keys]);
        exists($words{$key}) ? $words{$key}[rand @{$words{$key}}] : $word;
    }
}ge;

say $poetry;


================================================
FILE: Lingua/random_poetry_generator.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 February 2017
# https://github.com/trizen

# An experimental random poetry generator.

# usage:
#   perl random_poetry_generator.pl [wordlist]

use 5.016;
use strict;
use autodie;
use warnings;

use open IO => ':utf8', ':std';

use List::Util qw(max);
use File::Find qw(find);

@ARGV || die "usage: $0 [wordlists]\n";    # wordlists or directories

my $min_len     = 20;                      # minimum length of each verse
my $ending_len  = 3;                       # rhyme ending length
my $strophe_len = 4;                       # number of verses in a strophe

#<<<
# Rhymes template
my @template = (
    'A', 'A', 'B', 'B',
    'A', 'B', 'B', 'A',
    'A', 'B', 'A', 'B',
    'B', 'A', 'A', 'B',
);
#>>>

my $max_endings = do {
    my %count;
    ++$count{$_} for @template;
    max(values %count);
};

my %words;
my %seen;

sub collect_words {
    my ($file) = @_;

    open my $fh, '<', $file;

    my $content = do {
        local $/;
        <$fh>;
    };

    close $fh;

    my @words =
      grep { length($_) > $ending_len }
      map  { CORE::fc(s/^[^\pL]+//r =~ s/[^\pL]+\z//r) }
      split(' ', $content);

    foreach my $word (@words) {
        next if $seen{$word}++;
        push @{$words{substr($word, -$ending_len)}}, $word;
    }
}

find {
    no_chdir => 1,
    wanted   => sub {
        if ((-f $_) and (-T _)) {
            collect_words($_);
        }
    },
} => @ARGV;

my @keys = keys(%words);

my %endings;
my %used_ending;
my %used_word;

my $strofhe_i = 0;
foreach my $r (@template) {
    my $ending;

    if (exists $endings{$r}) {
        $ending = $endings{$r};
    }
    else {
        my $try = 0;
        do {
            $ending = $keys[rand @keys];
        } while (@{$words{$ending}} < $max_endings and !exists($used_ending{$ending}) and ++$try < 1000);
        $endings{$r}          = $ending;
        $used_ending{$ending} = 1;
    }

    my @row;

    for (my $length = 0 ; ;) {

        my $word;
        my $try = 0;
        do {
            my $key = ($length > $min_len) ? $ending : $keys[rand @keys];
            my $words = $words{$key};
            $word = $words->[rand @$words];
        } while (exists($used_word{$word}) and ++$try < 1000);

        $used_word{$word} = 1;

        push @row, $word;
        last if $length > $min_len;
        $length += length($word) + 1;
    }

    say "@row";
    print "\n" if (++$strofhe_i % $strophe_len == 0);
}


================================================
FILE: Lingua/rus_translit.pl
================================================
use Lingua::Translit;
my $tr = new Lingua::Translit('DIN 1460 RUS');
print $tr->translit(@ARGV ? shift : join'',<>);


================================================
FILE: Math/1_over_n_is_finite.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 25 December 2012
# https://github.com/trizen

# Checks if 1/n is finite or infinite.

# See also: https://perlmonks.org/index.pl?node_id=1006283

use 5.010;
use strict;
use warnings;

sub is_finite {
    my ($x) = @_;
    $x || return;
    $x /= 5 while $x % 5 == 0;
    return !($x & $x - 1);
}

foreach my $i (1 .. 20) {
    printf "%-4s is finite: %d\n", "1/$i", is_finite($i);
}


================================================
FILE: Math/1_over_n_period_length.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 October 2016
# Website: https://github.com/trizen

# The period length after the decimal point of 1/n.
# This is defined only for integers prime to 10.

# Inspired by N. J. Wildberger's video:
#   https://www.youtube.com/watch?v=lMrz7ISoDGs

# See also:
#   https://oeis.org/A002329

use 5.010;
use strict;
use warnings;

use ntheory qw(divisors euler_phi powmod);

sub period_length_1_over_n {
    my ($n) = @_;

    my @divisors = divisors(euler_phi($n));

    foreach my $d (@divisors) {
        if (powmod(10, $d, $n) == 1) {
            return $d;
        }
    }

    return -1;
}

foreach my $n (1 .. 99) {
    my $l = period_length_1_over_n($n);
    printf("P(%2d) = %d\n", $n, $l) if $l != -1;
}


================================================
FILE: Math/BPSW_primality_test.pl
================================================
#!/usr/bin/perl

# The Baillie-PSW primality test, named after Robert Baillie, Carl Pomerance, John Selfridge, and Samuel Wagstaff.

# No counter-examples are known to this test.

# Algorithm: given an odd integer n, that is not a perfect power:
#   1. Perform a (strong) base-2 Fermat test.
#   2. Find the first D in the sequence 5, −7, 9, −11, 13, −15, ... for which the Jacobi symbol (D/n) is −1.
#      Set P = 1 and Q = (1 − D) / 4.
#   3. Perform a strong Lucas probable prime test on n using parameters D, P, and Q.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_pseudoprime
#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::AnyNum qw(
    is_prime is_power is_congruent
    kronecker powmod as_bin bit_scan1
);

sub findQ($n) {

    # Find first D for which kronecker(D, n) == -1
    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);
        if (kronecker($D, $n) == -1) {
            return ((1 - $D) / 4);
        }
    }
}

sub BPSW_primality_test($n) {

    return 0 if $n <= 1;
    return 1 if $n == 2;

    return 0 if !($n & 1);
    return 0 if is_power($n);

    # Fermat base-2 test
    powmod(2, $n - 1, $n) == 1 or return 0;

    # Perform a strong Lucas probable test
    my $Q = findQ($n);
    my $d = $n + 1;
    my $s = bit_scan1($d, 0);
    my $t = $d >> ($s+1);

    my ($U1     ) = (1   );
    my ($V1, $V2) = (2, 1);
    my ($Q1, $Q2) = (1, 1);

    foreach my $bit (split(//, as_bin($t))) {

        $Q1 = ($Q1 * $Q2) % $n;

        if ($bit) {
            $Q2 = ($Q1 * $Q) % $n;
            $U1 = ($U1 * $V2) % $n;
            $V1 = ($V2 * $V1 - $Q1) % $n;
            $V2 = ($V2 * $V2 - ($Q2 + $Q2)) % $n;
        }
        else {
            $Q2 = $Q1;
            $U1 = ($U1 * $V1 - $Q1) % $n;
            $V2 = ($V2 * $V1 - $Q1) % $n;
            $V1 = ($V1 * $V1 - ($Q2 + $Q2)) % $n;
        }
    }

    $Q1 = ($Q1 * $Q2) % $n;
    $Q2 = ($Q1 * $Q) % $n;
    $U1 = ($U1 * $V1 - $Q1) % $n;
    $V1 = ($V2 * $V1 - $Q1) % $n;
    $Q1 = ($Q1 * $Q2) % $n;

    return 1 if is_congruent($U1, 0, $n);
    return 1 if is_congruent($V1, 0, $n);

    for (1 .. $s-1) {

        $V1 = ($V1 * $V1 - 2 * $Q1) % $n;
        $Q1 = ($Q1 * $Q1) % $n;

        return 1 if is_congruent($V1, 0, $n);
    }

    return 0;
}

#
## Run some tests
#

my $from  = 1;
my $to    = 1e5;
my $count = 0;

foreach my $n ($from .. $to) {
    if (BPSW_primality_test($n)) {
        if (not is_prime($n)) {
            say "Counter-example: $n";
        }
        ++$count;
    }
    elsif (is_prime($n)) {
        say "Missed a prime: $n";
    }
}

say "There are $count primes between $from and $to.";


================================================
FILE: Math/BPSW_primality_test_mpz.pl
================================================
#!/usr/bin/perl

# The Baillie-PSW primality test, named after Robert Baillie, Carl Pomerance, John Selfridge, and Samuel Wagstaff.

# No counter-examples are known to this test.

# Algorithm: given an odd integer n, that is not a perfect power:
#   1. Perform a (strong) base-2 Fermat test.
#   2. Find the first D in the sequence 5, −7, 9, −11, 13, −15, ... for which the Jacobi symbol (D/n) is −1.
#      Set P = 1 and Q = (1 − D) / 4.
#   3. Perform a strong Lucas probable prime test on n using parameters D, P, and Q.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_pseudoprime
#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;

sub findQ ($n) {
    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);

        if (Math::GMPz::Rmpz_si_kronecker($D, $n) == -1) {
            return ((1 - $D) / 4);
        }
    }
}

sub BPSW_primality_test ($n) {

    $n = Math::GMPz::Rmpz_init_set_str($n, 10) if ref($n) ne 'Math::GMPz';

    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;
    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;

    return 0 if Math::GMPz::Rmpz_even_p($n);
    return 0 if Math::GMPz::Rmpz_perfect_power_p($n);

    state $d = Math::GMPz::Rmpz_init_nobless();
    state $t = Math::GMPz::Rmpz_init_nobless();

    Math::GMPz::Rmpz_set_ui($t, 2);

    # Fermat base-2 test (a strong Miller-Rabin test should be preferred instead)
    Math::GMPz::Rmpz_sub_ui($d, $n, 1);
    Math::GMPz::Rmpz_powm($t, $t, $d, $n);
    Math::GMPz::Rmpz_cmp_ui($t, 1) and return 0;

    my $P = 1;
    my $Q = findQ($n);

    Math::GMPz::Rmpz_add_ui($d, $d, 2);                 # d = n+1
    my $s = Math::GMPz::Rmpz_scan1($d, 0);              # s = valuation(n, 2)
    Math::GMPz::Rmpz_div_2exp($t, $d, $s+1);            # t = d >> (s+1)

    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);
    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set_ui($P));
    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($t, 2))) {

        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
        Math::GMPz::Rmpz_mod($Q1, $Q1, $n);

        if ($bit) {
            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
            Math::GMPz::Rmpz_mul($U1, $U1, $V2);
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);

            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $n);
            Math::GMPz::Rmpz_sub($V1, $V1, $Q1);
            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);

            Math::GMPz::Rmpz_mod($V1, $V1, $n);
            Math::GMPz::Rmpz_mod($U1, $U1, $n);
        }
        else {
            Math::GMPz::Rmpz_set($Q2, $Q1);
            Math::GMPz::Rmpz_mul($U1, $U1, $V1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_sub($U1, $U1, $Q1);

            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);
            Math::GMPz::Rmpz_sub($V2, $V2, $Q1);
            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);

            Math::GMPz::Rmpz_mod($V2, $V2, $n);
            Math::GMPz::Rmpz_mod($U1, $U1, $n);
        }
    }

    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
    Math::GMPz::Rmpz_mul($U1, $U1, $V1);
    Math::GMPz::Rmpz_mul($V1, $V1, $V2);
    Math::GMPz::Rmpz_sub($U1, $U1, $Q1);
    Math::GMPz::Rmpz_sub($V1, $V1, $Q1);
    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);

    if (Math::GMPz::Rmpz_divisible_p($U1, $n)) {
        return 1;
    }

    if (Math::GMPz::Rmpz_divisible_p($V1, $n)) {
        return 1;
    }

    for (1 .. $s-1) {

        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);
        Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);
        Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $n);

        if (Math::GMPz::Rmpz_divisible_p($V1, $n)) {
            return 1;
        }
    }

    return 0;
}

#
## Run some tests
#

use ntheory qw(is_prime);

my $from  = 1;
my $to    = 1e5;
my $count = 0;

foreach my $n ($from .. $to) {
    if (BPSW_primality_test($n)) {
        if (not is_prime($n)) {
            say "Counter-example: $n";
        }
        ++$count;
    }
    elsif (is_prime($n)) {
        say "Missed a prime: $n";
    }
}

say "There are $count primes between $from and $to.";


================================================
FILE: Math/LUP_decomposition.pl
================================================
#!/usr/bin/perl

# Simple implementation of the LU decomposition.

# See also:
#   https://en.wikipedia.org/wiki/LU_decomposition

use 5.014;
use warnings;

use Math::AnyNum qw(:overload);

# Code translated from Wikipedia (+ minor tweaks):
#   https://en.wikipedia.org/wiki/LU_decomposition#C_code_examples

sub _LUP_decompose {
    my ($matrix) = @_;

    my @A = map { [@$_] } @$matrix;
    my $N = $#A;
    my @P = (0 .. $N + 1);

    foreach my $i (0 .. $N) {

        my $maxA = 0;
        my $imax = $i;

        foreach my $k ($i .. $N) {
            my $absA = abs($A[$k][$i] // return ($N, \@A, \@P));

            if ($absA > $maxA) {
                $maxA = $absA;
                $imax = $k;
            }
        }

        if ($imax != $i) {

            @P[$i, $imax] = @P[$imax, $i];
            @A[$i, $imax] = @A[$imax, $i];

            ++$P[$N + 1];
        }

        foreach my $j ($i + 1 .. $N) {

            if ($A[$i][$i] == 0) {
                return ($N, \@A, \@P);
            }

            $A[$j][$i] /= $A[$i][$i];

            foreach my $k ($i + 1 .. $N) {
                $A[$j][$k] -= $A[$j][$i] * $A[$i][$k];
            }
        }
    }

    return ($N, \@A, \@P);
}

sub solve {
    my ($matrix, $vector) = @_;

    my ($N, $A, $P) = _LUP_decompose($matrix);

    my @x = map { $vector->[$P->[$_]] } 0 .. $N;

    foreach my $i (1 .. $N) {
        foreach my $k (0 .. $i - 1) {
            $x[$i] -= $A->[$i][$k] * $x[$k];
        }
    }

    for (my $i = $N ; $i >= 0 ; --$i) {
        foreach my $k ($i + 1 .. $N) {
            $x[$i] -= $A->[$i][$k] * $x[$k];
        }
        $x[$i] /= $A->[$i][$i];
    }

    return \@x;
}

sub invert {
    my ($matrix) = @_;

    my ($N, $A, $P) = _LUP_decompose($matrix);

    my @I;

    foreach my $j (0 .. $N) {
        foreach my $i (0 .. $N) {

            $I[$i][$j] = ($P->[$i] == $j) ? 1 : 0;

            foreach my $k (0 .. $i - 1) {
                $I[$i][$j] -= $A->[$i][$k] * $I[$k][$j];
            }
        }

        for (my $i = $N ; $i >= 0 ; --$i) {

            foreach my $k ($i + 1 .. $N) {
                $I[$i][$j] -= $A->[$i][$k] * $I[$k][$j];
            }

            $I[$i][$j] /= $A->[$i][$i] // return [[]];
        }
    }

    return \@I;
}

sub determinant {
    my ($matrix) = @_;

    my ($N, $A, $P) = _LUP_decompose($matrix);

    my $det = $A->[0][0] // return 1;

    foreach my $i (1 .. $N) {
        $det *= $A->[$i][$i];
    }

    if (($P->[$N + 1] - $N) % 2 == 0) {
        $det *= -1;
    }

    return $det;
}

#
## Examples
#

# Defining a matrix

my $A = [
    [2, -1,  5,  1],
    [3,  2,  2, -6],
    [1,  3,  3, -1],
    [5, -2, -3,  3],
];

# Determinant of a matrix
say "det(A) = ", determinant($A);

# Solve a system of linear equations
my $v = [-3, -32, -47, 49];
say '(', join(', ', @{solve($A, $v)}), ')';

# Invert a matrix
my $inv = invert($A);
say join(",\n", map { '[' . join(', ', map { sprintf('%8s', $_) } @$_) . ']' } @$inv);

__END__
det(A) = 684

(2, -12, -4, 1)

[   4/171,   11/171,   10/171,     8/57],
[ -55/342,  -23/342,  119/342,     2/57],
[ 107/684,   -5/684,   11/684,   -7/114],
[   7/684, -109/684,  103/684,    7/114]


================================================
FILE: Math/MBE_factorization_method.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 12 March 2022
# https://github.com/trizen

# A new integer factorization method, using the binary exponentiation algorithm with modular exponentiation.

# We call it the "Modular Binary Exponentiation" (MBE) factorization method.

# Similar in flavor to the Pollard's p-1 method.

# See also:
#   https://en.wikipedia.org/wiki/Exponentiation_by_squaring

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::GMPz;

sub MBE_factor ($n, $max_k = 1000) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $t = Math::GMPz::Rmpz_init();
    my $g = Math::GMPz::Rmpz_init();

    my $a = Math::GMPz::Rmpz_init();
    my $b = Math::GMPz::Rmpz_init();
    my $c = Math::GMPz::Rmpz_init();

    foreach my $k (1 .. $max_k) {

        #say "Trying k = $k";

        Math::GMPz::Rmpz_div_ui($t, $n, $k + 1);

        Math::GMPz::Rmpz_set($a, $t);
        Math::GMPz::Rmpz_set($b, $t);
        Math::GMPz::Rmpz_set_ui($c, 1);

        foreach my $i (0 .. Math::GMPz::Rmpz_sizeinbase($b, 2) - 1) {

            if (Math::GMPz::Rmpz_tstbit($b, $i)) {

                Math::GMPz::Rmpz_powm($c, $a, $c, $n);
                Math::GMPz::Rmpz_sub_ui($g, $c, 1);
                Math::GMPz::Rmpz_gcd($g, $g, $n);

                if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                    return $g;
                }
            }

            Math::GMPz::Rmpz_powm($a, $a, $a, $n);
        }
    }

    return;
}

say MBE_factor("3034271543203");                                    #=> 604727
say MBE_factor("43120971427631");                                   #=> 5501281
say MBE_factor("1548517437362569");                                 #=> 24970961
say MBE_factor("18446744073709551617");                             #=> 274177
say MBE_factor("5889680315647781787273935275179391");               #=> 133337
say MBE_factor("25246363781991463940137062180162737");              #=> 6156182033
say MBE_factor("133337481996728163387583397826265769");             #=> 401417
say MBE_factor("950928942549203243363840778331691788194718753");    #=> 340282366920938463463374607431768211457


================================================
FILE: Math/PSW_primality_test.pl
================================================
#!/usr/bin/perl

# The PSW primality test, named after Carl Pomerance, John Selfridge, and Samuel Wagstaff.

# No counter-examples are known to this test.

# Algorithm: given an odd integer n, that is not a perfect power:
#   1. Perform a (strong) base-2 Fermat test.
#   2. Find the first P>0 such that kronecker(P^2 + 4, n) = -1.
#   3. If the Lucas U sequence: U(P, -1, n+1) = 0 (mod n), then n is probably prime.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_pseudoprime
#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(is_prime is_power lucas_sequence kronecker powmod);

sub findP($n) {

    # Find P such that kronecker(P^2 + 4, n) = -1.
    for (my $k = 1 ; ; ++$k) {
        if (kronecker($k*$k + 4, $n) == -1) {
            return $k;
        }
    }
}

sub PSW_primality_test ($n) {

    return 0 if $n <= 1;
    return 1 if $n == 2;

    return 0 if !($n & 1);
    return 0 if is_power($n);

    # Fermat base-2 test
    powmod(2, $n - 1, $n) == 1 or return 0;

    my $P = findP($n);
    my $Q = -1;

    # If LucasU(P, -1, n+1) = 0 (mod n), then n is probably prime.
    (lucas_sequence($n, $P, $Q, $n + 1))[0] == 0;
}

#
## Run some tests
#

my $from  = 1;
my $to    = 1e6;
my $count = 0;

foreach my $n ($from .. $to) {
    if (PSW_primality_test($n)) {
        if (not is_prime($n)) {
            say "Counter-example: $n";
        }
        ++$count;
    }
    elsif (is_prime($n)) {
        say "Missed a prime: $n";
    }
}

say "There are $count primes between $from and $to.";


================================================
FILE: Math/PSW_primality_test_mpz.pl
================================================
#!/usr/bin/perl

# The PSW primality test, named after Carl Pomerance, John Selfridge, and Samuel Wagstaff.

# No counter-examples are known to this test.

# Algorithm: given an odd integer n, that is not a perfect power:
#   1. Perform a (strong) base-2 Fermat test.
#   2. Find the first P>0 such that kronecker(P^2 + 4, n) = -1.
#   3. If the Lucas U sequence: U(P, -1, n+1) = 0 (mod n), then n is probably prime.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_pseudoprime
#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;
use ntheory qw(is_prime lucas_sequence);

sub PSW_primality_test ($n) {

    $n = Math::GMPz->new("$n");

    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;
    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;

    return 0 if Math::GMPz::Rmpz_even_p($n);
    return 0 if Math::GMPz::Rmpz_perfect_power_p($n);

    my $d = Math::GMPz::Rmpz_init();
    my $t = Math::GMPz::Rmpz_init_set_ui(2);

    # Fermat base-2 test
    Math::GMPz::Rmpz_sub_ui($d, $n, 1);
    Math::GMPz::Rmpz_powm($t, $t, $d, $n);
    Math::GMPz::Rmpz_cmp_ui($t, 1) and return 0;

    # Find P such that kronecker(P^2 - 4*Q, n) = -1.
    my $P;
    for (my $k = 1 ; ; ++$k) {
        if (Math::GMPz::Rmpz_ui_kronecker($k * $k + 4, $n) == -1) {
            $P = $k;
            last;
        }
    }

    # If LucasU(P, -1, n+1) = 0 (mod n), then n is probably prime.
    (lucas_sequence($n, $P, -1, $n + 1))[0] == 0;
}

#
## Run some tests
#

my $from  = 1;
my $to    = 1e5;
my $count = 0;

foreach my $n ($from .. $to) {
    if (PSW_primality_test($n)) {
        if (not is_prime($n)) {
            say "Counter-example: $n";
        }
        ++$count;
    }
    elsif (is_prime($n)) {
        say "Missed a prime: $n";
    }
}

say "There are $count primes between $from and $to.";


================================================
FILE: Math/RSA_PRNG.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 19 January 2017
# https://github.com/trizen

# A concept for a new pseudorandom number generator,
# based on the idea of the RSA encryption algorithm.

# Under development and analysis...

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(gcd irand powmod);
use ntheory qw(random_strong_prime);

{
    my $p = Math::AnyNum->new(random_strong_prime(256));
    my $q = Math::AnyNum->new(random_strong_prime(256));

    my $n = $p * $q;
    my $phi = ($p - 1) * ($q - 1);

    my $e;
#<<<
    do {
        $e = irand(65537, $n);
    } until (
            $e < $phi
        and gcd($e,     $phi  ) == 1
        and gcd($e - 1, $p - 1) == 2
        and gcd($e - 1, $q - 1) == 2
    );
#>>>

    sub RSA_PRNG {
        my ($seed) = @_;

        my $state = abs($seed);

        sub {
            $state = powmod($state + 11, $e, $n) & 0x7fff_ffff;
        };
    }
}

my $rand = RSA_PRNG(42);

foreach my $i (1 .. 20) {
    say $rand->();
}


================================================
FILE: Math/RSA_example.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 January 2017
# https://github.com/trizen

# A simple example for the RSA algorithm.

use 5.010;
use strict;
use warnings;

use ntheory qw(random_strong_prime);

my $p = random_strong_prime(2048);
my $q = random_strong_prime(2048);

my $n = ($p * $q);

my $phi = ($p - 1) * ($q - 1);

sub gcd($$) {
    my ($u, $v) = @_;
    while ($v) {
        ($u, $v) = ($v, $u % $v);
    }
    return abs($u);
}

my $e = 0;
for (my $k = 16 ; gcd($e, $phi) != 1 ; ++$k) {
    $e = 2**$k + 1;
}

sub invmod($$) {
    my ($a, $n) = @_;
    my ($t, $nt, $r, $nr) = (0, 1, $n, $a % $n);
    while ($nr != 0) {
        my $quot = int(($r - ($r % $nr)) / $nr);
        ($nt, $t) = ($t - $quot * $nt, $nt);
        ($nr, $r) = ($r - $quot * $nr, $nr);
    }
    return if $r > 1;
    $t += $n if $t < 0;
    return $t;
}

my $d = invmod($e, $phi);

sub expmod($$$) {
    my ($a, $b, $n) = @_;
    my $c = 1;
    do {
        ($c *= $a) %= $n if $b & 1;
        ($a *= $a) %= $n;
    } while ($b >>= 1);
    return $c;
}

my $m = 1234;
my $c = expmod($m, $e, $n);
my $M = expmod($c, $d, $n);
say $M;


================================================
FILE: Math/additive_binomial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 October 2017
# https://github.com/trizen

# Analogy to the binomial coefficient, using addition instead of multiplication.

# Defined as:
#    additive_binomial(n, k) = (Sum_{a = n-k+1..n} a) - (Sum_{b = 1..k} b)
#                            = n*(n+1)/2 - (n-k)*(n-k+1)/2 - k*(k+1)/2
#                            = n*k - k^2
#                            = k*(n-k)

# Additionally:
#   f(x, n) = Sum_{k=0, n} ( additive_binomial(n, k) + x*k )
#           = x*n*(n+1)/2 + (n+1)/3 * n*(n-1)/2
#           = x*(n^2 + n)/2 + (n^3 - n)/6
#           = {x, 3x+1, 6x+4, 10x+10, 15x+20, 21x+35, 28x+56, 36x+84, 45x+120, 55x+165, ...}

# Where for x=1, we have:
#   f(1, n) = {1, 4, 10, 20, 35, 56, 84, 120, 165, 220, 286, 364, 455, 560, 680, 816, 969, ...}

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub additive_binomial ($n, $k) {
    $k * ($n - $k);
}

foreach my $n (0 .. 19) {
    say join(' ', map { sprintf('%2s', additive_binomial($n, $_)) } 0 .. $n);
}

__END__
 0
 0  0
 0  1  0
 0  2  2  0
 0  3  4  3  0
 0  4  6  6  4  0
 0  5  8  9  8  5  0
 0  6 10 12 12 10  6  0
 0  7 12 15 16 15 12  7  0
 0  8 14 18 20 20 18 14  8  0
 0  9 16 21 24 25 24 21 16  9  0
 0 10 18 24 28 30 30 28 24 18 10  0
 0 11 20 27 32 35 36 35 32 27 20 11  0
 0 12 22 30 36 40 42 42 40 36 30 22 12  0
 0 13 24 33 40 45 48 49 48 45 40 33 24 13  0
 0 14 26 36 44 50 54 56 56 54 50 44 36 26 14  0
 0 15 28 39 48 55 60 63 64 63 60 55 48 39 28 15  0
 0 16 30 42 52 60 66 70 72 72 70 66 60 52 42 30 16  0
 0 17 32 45 56 65 72 77 80 81 80 77 72 65 56 45 32 17  0
 0 18 34 48 60 70 78 84 88 90 90 88 84 78 70 60 48 34 18  0


================================================
FILE: Math/additive_partitions.pl
================================================
#!/usr/bin/perl

# Generate all additive partitions of a given number.
# With support for specifying the largest value in a partition.

use 5.036;

sub partitions ($n, $max_part = $n) {
    my @results;

    sub ($n, $max_part, $current) {

        if ($n == 0) {
            push @results, [@$current];
            return;
        }

        my $upper = ($n < $max_part ? $n : $max_part);

        for my $part (1 .. $upper) {
            push @$current, $part;
            __SUB__->($n - $part, $part, $current);
            pop @$current;    # backtrack
        }
    }->($n, $max_part, []);

    return @results;
}

my $n          = shift(@ARGV) // 5;
my $max_part   = shift(@ARGV) // $n;
my @partitions = partitions($n, $max_part);
my $count      = scalar @partitions;

printf "Additive partitions of %d  (%d total):\n", $n, $count;
printf "  [%s]\n", join(', ', @$_) for @partitions;

__END__
Additive partitions of 5  (7 total):
  [1, 1, 1, 1, 1]
  [2, 1, 1, 1]
  [2, 2, 1]
  [3, 1, 1]
  [3, 2]
  [4, 1]
  [5]


================================================
FILE: Math/alexandrian_integers.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 18 August 2016
# License: GPLv3
# Website: https://github.com/trizen

# Get the nth Alexandrian integer.

# See also: https://oeis.org/A147811
#           https://projecteuler.net/problem=221

use 5.010;
use strict;
use warnings;

use ntheory qw(divisors);

sub nth_alexandrian {
    my ($nth) = @_;

    return 120 if $nth == 3;    # hmm...

    my %nums;
    my $count = 0;
    my $prev  = 6;

  OUT: foreach my $n (1 .. $nth) {
        foreach my $d (divisors($n * $n + 1)) {

            my $q = $n + $d;
            my $r = ($n + ($n * $n + 1) / $d);

            last if $q > $r;

            my $A = $n * $q * $r;
            --$count if ($A < $prev);

            if (not exists $nums{$A}) {
                undef $nums{$A};
                $prev = $A;
                last OUT if (++$count == $nth);
            }
        }
    }

    +(sort { $a <=> $b } keys %nums)[$nth - 1];
}

foreach my $n (1 .. 20) {
    say "A($n) = ", nth_alexandrian($n);
}

__END__
A(1) = 6
A(2) = 42
A(3) = 120
A(4) = 156
A(5) = 420
A(6) = 630
A(7) = 930
A(8) = 1428
A(9) = 1806
A(10) = 2016
A(11) = 2184
A(12) = 3192
A(13) = 4950
A(14) = 5256
A(15) = 8190
A(16) = 8364
A(17) = 8970
A(18) = 10296
A(19) = 10998
A(20) = 12210


================================================
FILE: Math/almost_prime_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 02 August 2020
# https://github.com/trizen

# Generate all the k-almost prime divisors of n.

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub almost_prime_divisors ($n, $k) {

    my @pp = factor_exp($n);
    my @d  = ([1, 0]);

    foreach my $pp (@pp) {

        my $p = $pp->[0];
        my $e = $pp->[1];

        my @t;
        my $r = [1, 0];

        for my $i (1 .. $e) {

            $r->[0] = mulint($r->[0], $p);
            $r->[1]++;

            if ($r->[1] == $k) {
                push @t, [$r->[0], $r->[1]];
                last;
            }

            foreach my $u (@d) {
                if ($u->[1] + $r->[1] <= $k) {
                    push @t, [mulint($u->[0], $r->[0]), $u->[1] + $r->[1]];
                }
            }
        }

        push @d, @t;
    }

    sort { $a <=> $b } map { $_->[0] } grep { $_->[1] == $k } @d;
}

my $n = factorial(10);

foreach my $k (0 .. factor($n)) {
    my @divisors = almost_prime_divisors($n, $k);
    printf("%2d-almost prime divisors of %s: [%s]\n", $k, $n, join(', ', @divisors));
}

__END__
 0-almost prime divisors of 3628800: [1]
 1-almost prime divisors of 3628800: [2, 3, 5, 7]
 2-almost prime divisors of 3628800: [4, 6, 9, 10, 14, 15, 21, 25, 35]
 3-almost prime divisors of 3628800: [8, 12, 18, 20, 27, 28, 30, 42, 45, 50, 63, 70, 75, 105, 175]
 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]
 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]
 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]
 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]
 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]
 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]
10-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]
11-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]
12-almost prime divisors of 3628800: [20736, 34560, 48384, 51840, 57600, 72576, 80640, 86400, 120960, 129600, 134400, 181440, 201600, 302400, 453600]
13-almost prime divisors of 3628800: [103680, 145152, 172800, 241920, 259200, 362880, 403200, 604800, 907200]
14-almost prime divisors of 3628800: [518400, 725760, 1209600, 1814400]
15-almost prime divisors of 3628800: [3628800]


================================================
FILE: Math/almost_prime_divisors_recursive.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 March 2021
# https://github.com/trizen

# Generate all the k-almost prime divisors of n.

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub almost_prime_divisors ($n, $k) {

    if ($k == 0) {
        return (1);
    }

    my @factor_exp  = factor_exp($n);
    my @factors     = map { $_->[0] } @factor_exp;
    my %valuations  = map { @$_ } @factor_exp;
    my $factors_end = $#factors;

    if ($k == 1) {
        return @factors;
    }

    my @list;

    sub ($m, $k, $i = 0) {

        if ($k == 1) {

            my $L = divint($n, $m);

            foreach my $j ($i .. $factors_end) {

                my $q = $factors[$j];
                $q > $L and last;

                if (valuation($m, $q) < $valuations{$q}) {
                    push(@list, mulint($m, $q));
                }
            }

            return;
        }

        my $L = rootint(divint($n, $m), $k);

        foreach my $j ($i .. $factors_end) {

            my $q = $factors[$j];
            $q > $L and last;

            if (valuation($m, $q) < $valuations{$q}) {
                __SUB__->(mulint($m, $q), $k - 1, $j);
            }
        }
    }->(1, $k);

    sort { $a <=> $b } @list;
}

my $n = factorial(10);

foreach my $k (0 .. factor($n)) {
    my @divisors = almost_prime_divisors($n, $k);
    printf("%2d-almost prime divisors of %s: [%s]\n", $k, $n, join(', ', @divisors));
}

__END__
 0-almost prime divisors of 3628800: [1]
 1-almost prime divisors of 3628800: [2, 3, 5, 7]
 2-almost prime divisors of 3628800: [4, 6, 9, 10, 14, 15, 21, 25, 35]
 3-almost prime divisors of 3628800: [8, 12, 18, 20, 27, 28, 30, 42, 45, 50, 63, 70, 75, 105, 175]
 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]
 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]
 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]
 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]
 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]
 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]
10-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]
11-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]
12-almost prime divisors of 3628800: [20736, 34560, 48384, 51840, 57600, 72576, 80640, 86400, 120960, 129600, 134400, 181440, 201600, 302400, 453600]
13-almost prime divisors of 3628800: [103680, 145152, 172800, 241920, 259200, 362880, 403200, 604800, 907200]
14-almost prime divisors of 3628800: [518400, 725760, 1209600, 1814400]
15-almost prime divisors of 3628800: [3628800]


================================================
FILE: Math/almost_prime_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 February 2021
# https://github.com/trizen

# Generate k-almost prime numbers <= n. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub almost_prime_numbers ($n, $k, $callback) {

    sub ($m, $p, $r) {

        if ($r == 1) {

            forprimes {
                $callback->(mulint($m, $_));
            } $p, divint($n, $m);

            return;
        }

        my $s = rootint(divint($n, $m), $r);

        for (my $q = $p ; $q <= $s ; $q = next_prime($q)) {
            __SUB__->(mulint($m, $q), $q, $r - 1);
        }
    }->(1, 2, $k);
}

# Generate all the numbers k <= 100 for which bigomega(k) = 4
almost_prime_numbers(100, 4, sub ($n) { say $n });


================================================
FILE: Math/almost_prime_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 February 2021
# https://github.com/trizen

# Generate k-almost prime numbers in range [a,b]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime

use 5.036;
use ntheory 0.74 qw(:all);

sub almost_prime_numbers ($A, $B, $k, $callback) {

    $A = vecmax($A, powint(2, $k));

    sub ($m, $p, $k) {

        if ($k == 1) {

            forprimes {
                $callback->(mulint($m, $_));
            } vecmax($p, cdivint($A, $m)), divint($B, $m);

            return;
        }

        my $s = rootint(divint($B, $m), $k);

        while ($p <= $s) {

            my $t = mulint($m, $p);

            if (cdivint($A, $t) <= divint($B, $t)) {
                __SUB__->($t, $p, $k - 1);
            }

            $p = next_prime($p);
        }
    }->(1, 2, $k);
}

# Generate 5-almost primes in the range [50, 1000]

my $k    = 5;
my $from = 50;
my $upto = 1000;

my @arr; almost_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });

my @test = grep { is_almost_prime($k, $_) } $from..$upto;   # just for testing
join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);


================================================
FILE: Math/almost_prime_numbers_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 February 2021
# Edit: 04 April 2024
# https://github.com/trizen

# Generate all the k-almost prime numbers in range [A,B].

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime

use 5.036;
use ntheory qw(:all);
use Math::GMPz;

sub almost_prime_numbers ($A, $B, $k) {

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_setbit($u, $k);

    $A = vecmax($A, $u);
    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my @values = sub ($m, $lo, $k) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        my @lst;

        if ($k == 1) {

            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            foreach my $p (@{primes($lo, $hi)}) {
                my $v = Math::GMPz::Rmpz_init();
                Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                push @lst, $v;
            }

            return @lst;
        }

        my $z = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {
            Math::GMPz::Rmpz_mul_ui($z, $m, $p);

            Math::GMPz::Rmpz_cdiv_q($u, $A, $z);
            Math::GMPz::Rmpz_tdiv_q($v, $B, $z);

            if (Math::GMPz::Rmpz_cmp($u, $v) <= 0) {
                push @lst, __SUB__->($z, $p, $k - 1);
            }
        }

        return @lst;
      }
      ->(Math::GMPz->new(1), 2, $k);

    sort { Math::GMPz::Rmpz_cmp($a, $b) } @values;
}

# Generate 5-almost primes in the range [50, 1000]

my $k    = 5;
my $from = 50;
my $upto = 1000;

my @arr  = almost_prime_numbers($from, $upto, $k);
my @test = grep { is_almost_prime($k, $_) } $from .. $upto;    # just for testing

join(' ', @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);


================================================
FILE: Math/almost_prime_numbers_in_range_v2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 February 2021
# Edit: 06 August 2024
# https://github.com/trizen

# Generate k-almost prime numbers in range [a,b]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime

use 5.036;
use ntheory qw(:all);

sub almost_prime_numbers ($A, $B, $k, $callback) {

    $A = vecmax($A, powint(2, $k));

    sub ($m, $lo, $k) {

        if ($k == 1) {

            forprimes {
                $callback->($m * $_);
            } vecmax($lo, cdivint($A, $m)), divint($B, $m);

            return;
        }

        my $hi = rootint(divint($B, $m), $k);

        foreach my $p (@{primes($lo, $hi)}) {
            __SUB__->($m * $p, $p, $k - 1);
        }
      }
      ->(1, 2, $k);
}

# Generate 5-almost primes in the range [50, 1000]

my $k    = 5;
my $from = 50;
my $upto = 1000;

my @arr;
almost_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });

my @test = grep { is_almost_prime($k, $_) } $from .. $upto;    # just for testing
join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);


================================================
FILE: Math/almost_primes_from_factor_list.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 March 2021
# https://github.com/trizen

# Generate all the possible k-almost primes <= n, using a given list of prime factors.

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub almost_primes ($n, $k, $factors, $squarefree = 0) {

    my $factors_end = $#{$factors};

    if ($k == 0) {
        return (1);
    }

    if ($k == 1) {
        return @$factors;
    }

    my @list;

    sub ($m, $k, $i = 0) {

        if ($k == 1) {

            my $L = divint($n, $m);

            foreach my $j ($i .. $factors_end) {
                my $q = $factors->[$j];
                last if ($q > $L);
                push(@list, mulint($m, $q));
            }

            return;
        }

        my $L = rootint(divint($n, $m), $k);

        foreach my $j ($i .. $factors_end) {
            my $q = $factors->[$j];
            last if ($q > $L);
            __SUB__->(mulint($m, $q), $k - 1, $j + $squarefree);
        }
    }->(1, $k);

    sort { $a <=> $b } @list;
}

my $n       = 1e3;              # limit
my @factors = @{primes(11)};    # prime list

foreach my $k (0 .. scalar(@factors)) {
    my @divisors = almost_primes($n, $k, \@factors);
    printf("%2d-almost primes <= %s: [%s]\n", $k, $n, join(', ', @divisors));
}

__END__
 0-almost primes <= 1000: [1]
 1-almost primes <= 1000: [2, 3, 5, 7, 11]
 2-almost primes <= 1000: [4, 6, 9, 10, 14, 15, 21, 22, 25, 33, 35, 49, 55, 77, 121]
 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]
 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]
 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]


================================================
FILE: Math/almost_primes_in_range_from_factor_list.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 March 2023
# https://github.com/trizen

# Generate all the possible k-almost primes in a given range [A, B], using a given list of prime factors.

use 5.036;
use ntheory 0.74 qw(:all);

sub almost_primes_in_range ($A, $B, $k, $factors, $squarefree = 0) {

    $A = vecmax($A, ($squarefree ? pn_primorial($k) : powint(2, $k)));

    my $factors_end = $#{$factors};

    if ($k == 0) {
        return (($A > 1) ? () : 1);
    }

    my @list;

    sub ($m, $k, $i = 0) {

        my $lo = $factors->[$i];
        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));

            if ($lo > $hi) {
                return;
            }

            foreach my $j ($i .. $factors_end) {
                my $q = $factors->[$j];
                last if ($q > $hi);
                next if ($q < $lo);
                push(@list, mulint($m, $q));
            }

            return;
        }

        foreach my $j ($i .. ($factors_end - $squarefree)) {
            my $q = $factors->[$j];
            last if ($q > $hi);
            next if ($q < $lo);
            __SUB__->(mulint($m, $q), $k - 1, $j + $squarefree);
        }
      }
      ->(1, $k);

    sort { $a <=> $b } @list;
}

my $from    = 1;
my $upto    = 1e3;
my @factors = @{primes(11)};    # prime list

foreach my $k (0 .. scalar(@factors)) {
    my @divisors = almost_primes_in_range($from, $upto, $k, \@factors);
    printf("%2d-almost primes in range [%s, %s]: [%s]\n", $k, $from, $upto, join(', ', @divisors));
}

__END__
 0-almost primes in range [1, 1000]: [1]
 1-almost primes in range [1, 1000]: [2, 3, 5, 7, 11]
 2-almost primes in range [1, 1000]: [4, 6, 9, 10, 14, 15, 21, 22, 25, 33, 35, 49, 55, 77, 121]
 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]
 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]
 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]


================================================
FILE: Math/area_of_triangle.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 August 2016
# Website: https://github.com/trizen

# Find the area of a triangle where all three sides are known, using Heron's Formula.

use 5.010;
use strict;
use warnings;

sub triangle_area {
    my ($x, $y, $z) = @_;
    my $s = ($x + $y + $z) / 2;
    sqrt($s * ($s - $x) * ($s - $y) * ($s - $z));
}

say triangle_area(5, 5, 6);


================================================
FILE: Math/arithmetic_derivative.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 August 2017
# https://github.com/trizen

# A simple implementation of the arithmetic derivative function for positive integers.

# See also:
#   https://projecteuler.net/problem=484

use 5.016;
use strict;
use warnings;

use ntheory qw(factor);

sub arithmetic_derivative {
    my ($n) = @_;

    my $sum = 0;
    foreach my $p (factor($n)) {
        $sum += $n / $p;
    }

    return $sum;
}

say arithmetic_derivative(1234);            #=> 619
say arithmetic_derivative(479001600);       #=> 3496919040
say arithmetic_derivative(162375475128);    #=> 298100392484


================================================
FILE: Math/arithmetic_expressions.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 07 August 2016
# Website: https://github.com/trizen

# Generate arithmetic expressions, using a set of 4 integers and 4 operators.
# Problem from: https://projecteuler.net/problem=93

use 5.010;
use strict;
use warnings;

use ntheory qw(forperm);

my @op = ('+', '-', '*', '/');

my @expr = (
            "%d %s %d %s %d %s %d",
            "%d %s (%d %s (%d %s %d))",
            "%d %s ((%d %s %d) %s %d)",
            "(%d %s (%d %s %d)) %s %d",
            "%d %s (%d %s %d %s %d)",
            "%d %s (%d %s %d) %s %d",
            "%d %s %d %s (%d %s %d)",
            "((%d %s %d) %s %d) %s %d",
            "(%d %s %d) %s (%d %s %d)",
           );

sub evaluate {
    my ($nums, $ops, $table) = @_;
    foreach my $expr (@expr) {

        my $e = sprintf($expr,
            $nums->[0], $ops->[0],
            $nums->[1], $ops->[1],
            $nums->[2], $ops->[2],
            $nums->[3]
        );

        my $n = eval $e;

        if (not $@
            and $n > 0
            and int($n) eq $n) {
            push @{$table->{$n}}, $e;
        }
    }
}

sub compute {
    my ($set, $table) = @_;

    forperm {
        my @nums = @{$set}[@_];

        foreach my $i (0 .. 3) {
            foreach my $j (0 .. 3) {
                foreach my $k (0 .. 3) {
                    my @ops = @op[$i, $j, $k];
                    evaluate(\@nums, \@ops, $table);
                }
            }
        }

    }
    scalar(@$set);
}

my @set = (1, 2, 3, 4);
my $num = 28;

compute(\@set, \my %table);

if (exists $table{$num}) {
    say "\n=> Using the set [@set], the number $num can be represented as:\n";
    say join("\n", @{$table{$num}});
}
else {
    say "[!] The number $num cannot be represented as an arithmetic expression, using the set [@set].";
}

__END__

Using the set [1 2 3 4], the number 28 can be represented as:

(1 + (2 * 3)) * 4
(1 + (3 * 2)) * 4
((2 * 3) + 1) * 4
((3 * 2) + 1) * 4
4 * (1 + (2 * 3))
4 * (1 + 2 * 3)
4 * (1 + (3 * 2))
4 * (1 + 3 * 2)
4 * ((2 * 3) + 1)
4 * (2 * 3 + 1)
4 * ((3 * 2) + 1)
4 * (3 * 2 + 1)


================================================
FILE: Math/arithmetic_geometric_mean_complex.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 April 2017
# https://github.com/trizen

# Implementation of the arithmetic-geometric mean function, in complex numbers.

# See also:
#   https://en.wikipedia.org/wiki/Arithmetic%E2%80%93geometric_mean
#   https://www.mathworks.com/help/symbolic/mupad_ref/numeric-gaussagm.html

use 5.010;
use strict;
use warnings;

use Math::MPC;

our $PREC  = 192;
our $ROUND = Math::MPC::MPC_RNDNN;

# agm(a, -a) = 0
# agm(0,  x) = 0
# agm(x,  0) = 0

sub agm($$) {
    my ($x, $y) = @_;

    my $a0 = Math::MPC::Rmpc_init2($PREC);
    my $g0 = Math::MPC::Rmpc_init2($PREC);

    Math::MPC::Rmpc_set_str($a0, $x, 10, $ROUND);
    Math::MPC::Rmpc_set_str($g0, $y, 10, $ROUND);

    my $a1 = Math::MPC::Rmpc_init2($PREC);
    my $g1 = Math::MPC::Rmpc_init2($PREC);
    my $t  = Math::MPC::Rmpc_init2($PREC);

    # agm(0,  x) = 0
    if (!Math::MPC::Rmpc_cmp_si_si($a0, 0, 0)) {
        return $a0;
    }

    # agm(x, 0) = 0
    if (!Math::MPC::Rmpc_cmp_si_si($g0, 0, 0)) {
        return $g0;
    }

    my $count = 0;
    {
        Math::MPC::Rmpc_add($a1, $a0, $g0, $ROUND);
        Math::MPC::Rmpc_div_2exp($a1, $a1, 1, $ROUND);

        Math::MPC::Rmpc_mul($g1, $a0, $g0, $ROUND);
        Math::MPC::Rmpc_add($t, $a0, $g0, $ROUND);
        Math::MPC::Rmpc_sqr($t, $t, $ROUND);
        Math::MPC::Rmpc_cmp_si_si($t, 0, 0) || return $t;
        Math::MPC::Rmpc_div($g1, $g1, $t, $ROUND);
        Math::MPC::Rmpc_sqrt($g1, $g1, $ROUND);
        Math::MPC::Rmpc_add($t, $a0, $g0, $ROUND);
        Math::MPC::Rmpc_mul($g1, $g1, $t, $ROUND);

        if (Math::MPC::Rmpc_cmp($a0, $a1) and ++$count < $PREC) {
            Math::MPC::Rmpc_set($a0, $a1, $ROUND);
            Math::MPC::Rmpc_set($g0, $g1, $ROUND);
            redo;
        }
    }

    return $g0;
}

say agm(3,   4);
say agm(-1,  2);
say agm(1,   -2);
say agm(0,   5);
say agm(-10, 3.14159265358979323846264338327950288419716939938);
say agm(10,  0);
say agm(10,  -10);
say agm(10,  10);
say agm(-3,  -4);
say agm(-1,  -1);
say agm(-1,  -2);
say agm(-2,  -2);
say agm(2,   -3);


================================================
FILE: Math/arithmetic_sum_closed_form.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 November 2017
# https://github.com/trizen

# Compute the sum of an arithmetic sequence.

# Example: arithmetic_sum_*(1,3,1) returns 6  because 1+2+3   =  6
#          arithmetic_sum_*(1,7,2) returns 16 because 1+3+5+7 = 16

# arithmetic_sum_*(begin, end, step)

use 5.010;
use strict;
use warnings;

use experimental qw(signatures);

sub arithmetic_sum_continuous ($x, $y, $z) {
    ($x + $y) * (($y - $x) / $z + 1) / 2;
}

sub arithmetic_sum_discrete ($x, $y, $z) {
    (int(($y - $x) / $z) + 1) * ($z * int(($y - $x) / $z) + 2 * $x) / 2;
}

say arithmetic_sum_continuous(10, 113, 6);    #=> 1117.25
say arithmetic_sum_discrete(10, 113, 6);      #=> 1098


================================================
FILE: Math/ascii_cuboid.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 June 2012
# License: GPLv3
# https://github.com/trizen

use 5.010;

# usage: script X Y Z [S]

sub cuboid {

    # Constant dimensions of the cuboid
    my ($x, $y, $z) = map { int } @_[0 .. 2];

    # ASCII characters
    # $c = corner point
    # $h = horizontal line
    # $v = vertical line
    # $d = diagonal line
    # $s = space (inside the cuboid)
    my ($c, $h, $v, $d, $s) = ('+', '-', '|', '/', shift(@ARGV) // q{ });

    say q{ } x ($z + 1), $c, $h x $x, $c;
    say q{ } x ($z - $_ + 1), $d, $s x $x, $d, $s x ($_ - ($_ > $y ? ($_ - $y) : 1)),
      $_ - 1 == $y ? $c : $_ > $y ? $d : $v for 1 .. $z;
    say $c, $h x $x, $c, ($s x ($z < $y ? $z : $y), $z < $y ? $v : $z == $y ? $c : $d);
    say $v, $s x $x, $v, $z > $y ? $_ >= $z ? ($s x $x, $c) : ($s x ($y - $_), $d)
      : $y - $_ > $z ? ($s x $z, $v) : ($s x ($y - $_), $y - $_ == $z ? $c : $d) for 1 .. $y;
    say $c, $h x $x, $c;
}

cuboid(shift() // rand(20), shift() // rand(10), shift() // rand(10));


================================================
FILE: Math/ascii_julia_set.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 January 2018
# https://github.com/trizen

# ASCII generation of a Julia set (+ANSI colors).

# See also:
#   https://en.wikipedia.org/wiki/Julia_set

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GComplex;
use Term::ANSIColor qw(:constants);

my @colors = (
                (BLACK), (RED),   (GREEN),        (YELLOW),     (BLUE),         (MAGENTA),
                (CYAN),  (WHITE), (BRIGHT_BLACK), (BRIGHT_RED), (BRIGHT_GREEN), (BRIGHT_YELLOW),
                (BRIGHT_BLUE), (BRIGHT_MAGENTA), (BRIGHT_CYAN), (BRIGHT_WHITE),
             );

my @chars = (' ', '`', '.', ',', ':', ';', '!', '-', '+', '*', '%', '#');

sub range_map ($value, $in_min, $in_max, $out_min, $out_max) {
      ($value - $in_min)
        * ($out_max - $out_min)
        / ($in_max  - $in_min)
    + $out_min;
}

sub julia_set ($z, $I = 12, $L = 2, $C = Math::GComplex->new(-0.835, -0.2321)) {

    my $n = 0;

    while (abs($z) < $L and ++$n <= $I) {
        $z = $z * $z + $C;
    }

    return (($I - $n) / $I);
}

for (my $y = 1 ; $y >= -1 ; $y -= 0.05) {
    for (my $x = -2 ; $x <= 2 ; $x += 0.0315) {
        my $num = julia_set(Math::GComplex->new($x, $y));
        my $color_index = sprintf('%.0f', range_map($num, 0, 1, 0, $#colors));
        my $char_index  = sprintf('%.0f', range_map($num, 0, 1, 0, $#chars));
        print($colors[$color_index] . $chars[$char_index]);
    }
    print "\n";
}

print(RESET);


================================================
FILE: Math/ascii_mandelbrot_set.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 January 2018
# https://github.com/trizen

# ASCII generation of the Mandelbrot set (+ANSI colors).

# See also:
#   https://en.wikipedia.org/wiki/Mandelbrot_set

use 5.020;
use strict;
use experimental qw(signatures);

use Math::GComplex;
use Term::ANSIColor qw(:constants);

my @colors = reverse(
              (BLACK), (RED),   (GREEN),        (YELLOW),     (BLUE),         (MAGENTA),
              (CYAN),  (WHITE), (BRIGHT_BLACK), (BRIGHT_RED), (BRIGHT_GREEN), (BRIGHT_YELLOW),
              (BRIGHT_BLUE), (BRIGHT_MAGENTA), (BRIGHT_CYAN), (BRIGHT_WHITE),
             );

my @chars = ('-', '#', '%', '*', '+', '!', ';', ':', ',', '.');

sub range_map ($value, $in_min, $in_max, $out_min, $out_max) {
      ($value - $in_min)
        * ($out_max - $out_min)
        / ($in_max  - $in_min)
    + $out_min;
}

sub mandelbrot_set ($z, $I = 400, $L = 2)  {

    my $n = 0;
    my $c = $z;

    while (abs($z) < $L and ++$n <= $I) {
        $z = $z * $z + $c;
    }

    return (($I - $n) / $I);
}

for (my $y = 1 ; $y >= -1 ; $y -= 0.05) {
    for (my $x = -2 ; $x <= 0.5 ; $x += 0.0315) {
        my $num = mandelbrot_set(Math::GComplex->new($x, $y));
        my $color_index = sprintf('%.0f', range_map($num, 0, 1, 0, $#colors));
        my $char_index  = sprintf('%.0f', range_map($num, 0, 1, 0, $#chars));
        print($colors[$color_index] . $chars[$char_index]);
    }
    print "\n";
}

print (RESET);


================================================
FILE: Math/batir_factorial_asymptotic_formula_mpfr.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 21 June 2017
# https://github.com/trizen

# A very good factorial approximation, due to N. Batir.

# The asymptotic formula is:
#   n! ~ 1/216 * √(π/70) * exp(-n) * n^(n-2) * √(42*n*(24*n*(90*n*(12*n*(6*n + 1) + 1) - 31) - 139) + 9871)

use 5.010;
use strict;
use warnings;

our ($ROUND, $PREC);

BEGIN {
    use Math::MPFR qw();
    $ROUND = Math::MPFR::MPFR_RNDN();
    $PREC  = 200;
}

use Math::AnyNum (PREC => $PREC);

sub fac_batir {
    my ($n) = @_;

    my $f = Math::MPFR::Rmpfr_init2($PREC);

    # f = (12*n*(6*n + 1) + 1)
    Math::MPFR::Rmpfr_set_ui($f, $n, $ROUND);
    Math::MPFR::Rmpfr_mul_ui($f, $f, 6, $ROUND);
    Math::MPFR::Rmpfr_add_ui($f, $f, 1, $ROUND);
    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);
    Math::MPFR::Rmpfr_mul_ui($f, $f, 12, $ROUND);
    Math::MPFR::Rmpfr_add_ui($f, $f, 1, $ROUND);

    # f = (24*n*(90*n*f - 31) - 139)
    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);
    Math::MPFR::Rmpfr_mul_ui($f, $f, 90, $ROUND);
    Math::MPFR::Rmpfr_sub_ui($f, $f, 31, $ROUND);
    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);
    Math::MPFR::Rmpfr_mul_ui($f, $f, 24, $ROUND);
    Math::MPFR::Rmpfr_sub_ui($f, $f, 139, $ROUND);

    # f = √(42*n*f + 9871)
    Math::MPFR::Rmpfr_mul_ui($f, $f, $n, $ROUND);
    Math::MPFR::Rmpfr_mul_ui($f, $f, 42, $ROUND);
    Math::MPFR::Rmpfr_add_ui($f, $f, 9871, $ROUND);
    Math::MPFR::Rmpfr_sqrt($f, $f, $ROUND);

    # f = f * n^(n-2)
    my $t = Math::MPFR::Rmpfr_init2($PREC);
    Math::MPFR::Rmpfr_ui_pow_ui($t, $n, $n - 2, $ROUND);
    Math::MPFR::Rmpfr_mul($f, $f, $t, $ROUND);

    # f = f * exp(-n)
    Math::MPFR::Rmpfr_set_ui($t, $n, $ROUND);
    Math::MPFR::Rmpfr_neg($t, $t, $ROUND);
    Math::MPFR::Rmpfr_exp($t, $t, $ROUND);
    Math::MPFR::Rmpfr_mul($f, $f, $t, $ROUND);

    # f = f * √(π/70)
    Math::MPFR::Rmpfr_const_pi($t, $ROUND);
    Math::MPFR::Rmpfr_div_ui($t, $t, 70, $ROUND);
    Math::MPFR::Rmpfr_sqrt($t, $t, $ROUND);
    Math::MPFR::Rmpfr_mul($f, $f, $t, $ROUND);

    # f = f/216
    Math::MPFR::Rmpfr_div_ui($f, $f, 216, $ROUND);

    # Create and return a new Math::AnyNum object
    Math::AnyNum->new($f);
}

foreach my $n (1 .. 10) {
    say fac_batir($n);
}

__END__
1.0001633529366947590265935448207438761433429838411
2.0000029860747051176081702869925254469658097576474
6.0000003229774185743648491096337544662543793954941
24.000000013320139202368363609786566171333392325063
119.99999982560322070035659496327332403346753218872
719.99999937604769710505519830495674394359333008983
5039.9999977053735752532469858794448681595399481797
40319.999990211060074629645362635300614581980624166
362879.99995110486335462650403778927886141969579338
3628799.9997167757110134397984453555772078233918289


================================================
FILE: Math/bell_numbers.pl
================================================
#!/usr/bin/perl

# Fast algorithm for computing the first n Bell numbers, using Aitken's array.

# See also:
#   https://en.wikipedia.org/wiki/Bell_number

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
## use Math::AnyNum qw(:overload);

sub bell_numbers ($n) {

    my @acc;
    my @bell = (1);

    foreach my $k (1 .. $n) {

        my $t = $bell[-1];

        foreach my $i (0 .. $#acc) {
            $t += $acc[$i];
            $acc[$i] = $t;
        }

        unshift(@acc, $bell[-1]);
        push @bell, $acc[-1];
    }

    @bell;
}

say join ', ', bell_numbers(15);

__END__
1, 1, 2, 5, 15, 52, 203, 877, 4140, 21147, 115975, 678570, 4213597, 27644437, 190899322, 1382958545


================================================
FILE: Math/bell_numbers_mpz.pl
================================================
#!/usr/bin/perl

# Fast algorithm for computing the first `n` Bell numbers, using Aitken's array (optimized for space).

# See also:
#   https://en.wikipedia.org/wiki/Bell_number

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use experimental qw(signatures);

sub bell_numbers($n) {

    my @acc;

    my $t    = Math::GMPz::Rmpz_init();
    my @bell = (Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $k (1 .. $n) {

        Math::GMPz::Rmpz_set($t, $bell[-1]);

        foreach my $item (@acc) {
            Math::GMPz::Rmpz_add($t, $t, $item);
            Math::GMPz::Rmpz_set($item, $t);
        }

        unshift @acc, Math::GMPz::Rmpz_init_set($bell[-1]);
        push @bell, Math::GMPz::Rmpz_init_set($acc[-1]);
    }

    @bell;
}

say join ', ', bell_numbers(15);

__END__
1, 1, 2, 5, 15, 52, 203, 877, 4140, 21147, 115975, 678570, 4213597, 27644437, 190899322, 1382958545


================================================
FILE: Math/bernoulli_denominators.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 May 2017
# https://github.com/trizen

# Fast computation of the denominator of the nth-Bernoulli number.

# See also:
#   https://oeis.org/A139822
#   https://en.wikipedia.org/wiki/Von_Staudt%E2%80%93Clausen_theorem

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use POSIX qw(ULONG_MAX);
use ntheory qw(fordivisors is_prob_prime);

sub bernoulli_denominator {
    my ($n) = @_;

    return 1 if ($n == 0);
    return 2 if ($n == 1);
    return 1 if ($n % 2 == 1);

    my $p = Math::GMPz::Rmpz_init();
    my $d = Math::GMPz::Rmpz_init_set_ui(1);

    fordivisors {
        if ($_ >= ULONG_MAX) {
            Math::GMPz::Rmpz_set_str($p, "$_", 10);
            Math::GMPz::Rmpz_add_ui($p, $p, 1);

            if (is_prob_prime($p)) {
                Math::GMPz::Rmpz_mul($d, $d, $p);
            }
        }
        else {
            if (is_prob_prime($_ + 1)) {
                Math::GMPz::Rmpz_mul_ui($d, $d, $_ + 1);    # d = d * p, where (p-1)|n
            }
        }
    } $n;

    return $d;
}

foreach my $n (0 .. 20) {
    say "denom(B(10^$n)) = ", bernoulli_denominator(Math::GMPz->new('1' . ('0' x $n)));
}

__END__
denom(B(10^0)) = 2
denom(B(10^1)) = 66
denom(B(10^2)) = 33330
denom(B(10^3)) = 342999030
denom(B(10^4)) = 2338224387510
denom(B(10^5)) = 9355235774427510
denom(B(10^6)) = 936123257411127577818510
denom(B(10^7)) = 9601480183016524970884020224910
denom(B(10^8)) = 394815332706046542049668428841497001870
denom(B(10^9)) = 24675958688943241584150818852261991458372001870


================================================
FILE: Math/bernoulli_denominators_records.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 January 2019
# https://github.com/trizen

# Fast program for computing the numbers `n` such that the denominator of Bernoulli(n) is a record.

# OEIS sequences:
#   https://oeis.org/A100195
#   https://oeis.org/A100194

# See also:
#   https://en.wikipedia.org/wiki/Bernoulli_number
#   https://mathworld.wolfram.com/BernoulliNumber.html
#   https://en.wikipedia.org/wiki/Von_Staudt%E2%80%93Clausen_theorem

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(divisors is_prime vecprod);

sub bernoulli_denominator ($n) {    # denominator of the n-th Bernoulli number

    return 1 if ($n <= 0);
    return 1 if ($n > 1 and $n % 2);

    vecprod(map { $_ + 1 } grep { is_prime($_ + 1) } divisors($n));
}

sub records_upto ($n, $callback) {

    for (my ($k, $m) = (0, -1) ; $k <= $n ; $k += 2) {

        my $sum = 0;
        foreach my $d (divisors($k)) {
            if (is_prime($d + 1)) {
                $sum += log($d + 1);
            }
        }

        if ($sum > $m) {
            $m = $sum;
            $callback->($k);
        }
    }
}

records_upto(1e4, sub ($k) { say "B($k) = ", bernoulli_denominator($k) });

__END__
B(0) = 2
B(2) = 6
B(4) = 30
B(6) = 42
B(10) = 66
B(12) = 2730
B(30) = 14322
B(36) = 1919190
B(60) = 56786730
B(72) = 140100870
B(108) = 209191710
B(120) = 2328255930
B(144) = 2381714790
B(180) = 7225713885390
B(240) = 9538864545210
B(360) = 21626561658972270
B(420) = 446617991732222310
B(540) = 115471236091149548610
B(840) = 5145485882746933233510
B(1008) = 14493038256293268734790
B(1080) = 345605409620810598989730
B(1200) = 42107247672297314156359710
B(1260) = 4554106624556364764691012210
B(1620) = 24743736851520275624910204330
B(1680) = 802787680649929796414310788070
B(2016) = 1908324101335116127448341021830
B(2160) = 1324918483651364394207119201026530
B(2520) = 9655818125018463593525930077544596530
B(3360) = 176139196253087613320507734410708168870
B(3780) = 20880040554948303778681975110988542692370
B(5040) = 1520038371910163024272084596792024938493098335890
B(6480) = 2386506545702609292996755910476726098859145077130
B(7560) = 334731403390662540713247087231623394273840419057927010
B(8400) = 30721852291400450355987797336504062619723310330260297070


================================================
FILE: Math/bernoulli_numbers.pl
================================================
#!/usr/bin/perl

# Akiyama–Tanigawa algorithm for computing the nth-Bernoulli number.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload);

# Translation of:
#   https://en.wikipedia.org/wiki/Bernoulli_number#Algorithmic_description

sub bernoulli {
    my ($n) = @_;

    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1

    my @A;
    for my $m (0 .. $n) {
        $A[$m] = 1 / ($m + 1);

        for (my $j = $m ; $j > 0 ; $j--) {
            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);
        }
    }

    return $A[0];                    # which is Bn
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, bernoulli(2 * $i);
}


================================================
FILE: Math/bernoulli_numbers_from_factorials.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 02 December 2017
# https://github.com/trizen

# A new algorithm for computing Bernoulli numbers.

# Inspired from Norman J. Wildberger video lecture:
#   https://www.youtube.com/watch?v=qmMs6tf8qZ8

# See also:
#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload factorial bernfrac);

sub bernoulli_numbers {
    my ($n) = @_;

    my @B = (1);

    foreach my $i (1 .. $n) {
        foreach my $k (0 .. $i - 1) {
            $B[$i] //= 0;
            $B[$i] -= $B[$k] / factorial($i - $k + 1);
        }
    }

    map { $B[$_] * factorial($_) } 0 .. $#B;
}

my @B = bernoulli_numbers(100);      # first 100 Bernoulli numbers

foreach my $i (0 .. $#B) {

    # Verify the results
    if ($i > 1 and $B[$i] != bernfrac($i)) {
        die "error for i=$i";
    }

    say "B($i) = $B[$i]";
}


================================================
FILE: Math/bernoulli_numbers_from_factorials_mpq.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 02 December 2017
# https://github.com/trizen

# A new algorithm for computing Bernoulli numbers.

# Inspired from Norman J. Wildberger video lecture:
#   https://www.youtube.com/watch?v=qmMs6tf8qZ8

# See also:
#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle

use 5.010;
use strict;
use warnings;

use Math::GMPq;
use Math::GMPz;

sub bernoulli_numbers {
    my ($n) = @_;

    my @B;
    my @factorial;

    Math::GMPq::Rmpq_set_ui($B[0]  = Math::GMPq::Rmpq_init(), 1, 1);
    Math::GMPq::Rmpq_set_ui($B[$_] = Math::GMPq::Rmpq_init(), 0, 1) for (1 .. $n);

    my $t = Math::GMPq::Rmpq_init();

    foreach my $i (1 .. $n) {

        if ($i % 2 != 0 and $i > 1) {
            next;
        }

        foreach my $k (0 .. $i - 1) {

            if ($k % 2 != 0 and $k > 1) {
                next;
            }

            my $r = $i - $k + 1;

            $factorial[$r] //= do {
                my $t = Math::GMPz::Rmpz_init();
                Math::GMPz::Rmpz_fac_ui($t, $r);
                $t;
            };

            Math::GMPq::Rmpq_div_z($t, $B[$k], $factorial[$r]);
            Math::GMPq::Rmpq_sub($B[$i], $B[$i], $t);
        }
    }

    for (my $k = 2; $k <= $#B; $k += 2) {
        Math::GMPq::Rmpq_mul_z($B[$k], $B[$k], $factorial[$k]);
    }

    return @B;
}

my @B = bernoulli_numbers(100);    # first 100 Bernoulli numbers

foreach my $i (0 .. $#B) {
    say "B($i) = $B[$i]";
}


================================================
FILE: Math/bernoulli_numbers_from_factorials_mpz.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 07 July 2018
# https://github.com/trizen

# A new algorithm for computing Bernoulli numbers.

# Inspired from Norman J. Wildberger video lecture:
#   https://www.youtube.com/watch?v=qmMs6tf8qZ8

# See also:
#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle

use 5.010;
use strict;
use warnings;

use Math::GMPq;
use Math::GMPz;

sub bernoulli_numbers {
    my ($n) = @_;

    my @A = (Math::GMPz::Rmpz_init_set_ui(1));
    my @B = (Math::GMPz::Rmpz_init_set_ui(1));
    my @F = (Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $k (1 .. $n) {

        $F[$k] = Math::GMPz::Rmpz_init();
        $A[$k] = Math::GMPz::Rmpz_init_set_ui(0);
        $B[$k] = Math::GMPz::Rmpz_init_set_ui(1);

        Math::GMPz::Rmpz_mul_ui($F[$k], $F[$k - 1], $k);
    }

    Math::GMPz::Rmpz_mul_ui($F[$n + 1] = Math::GMPz::Rmpz_init(), $F[$n], $n + 1);

    my $t = Math::GMPz::Rmpz_init();

    foreach my $i (1 .. $n) {

        if ($i % 2 != 0 and $i > 1) {
            next;
        }

        foreach my $k (0 .. $i - 1) {

            if ($k % 2 != 0 and $k > 1) {
                next;
            }

            my $r = $i - $k + 1;

            Math::GMPz::Rmpz_mul($A[$i], $A[$i], $F[$r]);
            Math::GMPz::Rmpz_mul($A[$i], $A[$i], $B[$k]);
            Math::GMPz::Rmpz_submul($A[$i], $B[$i], $A[$k]);
            Math::GMPz::Rmpz_mul($B[$i], $B[$i], $F[$r]);
            Math::GMPz::Rmpz_mul($B[$i], $B[$i], $B[$k]);

            Math::GMPz::Rmpz_gcd($t, $A[$i], $B[$i]);
            Math::GMPz::Rmpz_divexact($A[$i], $A[$i], $t);
            Math::GMPz::Rmpz_divexact($B[$i], $B[$i], $t);
        }
    }

    my @R = @A;

    for (my $k = 2 ; $k <= $#B ; $k += 2) {
        Math::GMPz::Rmpz_mul($A[$k], $A[$k], $F[$k]);

        my $bern = Math::GMPq::Rmpq_init();
        Math::GMPq::Rmpq_set_num($bern, $A[$k]);
        Math::GMPq::Rmpq_set_den($bern, $B[$k]);
        Math::GMPq::Rmpq_canonicalize($bern);

        $R[$k] = $bern;
    }

    if ($#R > 0) {
        my $bern = Math::GMPq::Rmpq_init();
        Math::GMPq::Rmpq_set_num($bern, $A[1]);
        Math::GMPq::Rmpq_set_den($bern, $B[1]);
        Math::GMPq::Rmpq_canonicalize($bern);
        $R[1] = $bern;
    }

    return @R;
}

my @B = bernoulli_numbers(100);    # first 100 Bernoulli numbers

foreach my $i (0 .. $#B) {
    say "B($i) = $B[$i]";
}


================================================
FILE: Math/bernoulli_numbers_from_factorials_visual.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 02 December 2017
# https://github.com/trizen

# A new algorithm for computing Bernoulli numbers (visualization).

# Inspired from Norman J. Wildberger video lecture:
#   https://www.youtube.com/watch?v=qmMs6tf8qZ8

# See also:
#   https://en.wikipedia.org/wiki/Bernoulli_number#Connection_with_Pascal’s_triangle

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload factorial bernfrac);

sub bernoulli_numbers {
    my ($n) = @_;

    my @B = (1, (0) x $n);

    foreach my $i (1 .. $n) {

        if ($i % 2 != 0 and $i > 1) {
            ## next;
        }

        foreach my $k (0 .. $i - 1) {

            if ($k % 2 != 0 and $k > 1) {
                ## next;
            }

            my $f = factorial($i - $k + 1);
            my $d = $B[$i] - $B[$k] / $f;

            printf("[%2s, %s] -> %6s / %2s! - %6s / %s!  / %2s! = %6s  / %2s!\n",
                   $i, $k, $B[$i] * factorial($i),
                   $i, $B[$k] * factorial($k),
                   $k,
                   $i - $k + 1,
                   $d * factorial($i), $i);

            $B[$i] = $d;
        }

        say '';
    }

    map { $B[$_] * factorial($_) } 0 .. $#B;
}

my @B = bernoulli_numbers(10);    # first 10 Bernoulli numbers

foreach my $i (0 .. $#B) {

    # Verify the results
    if ($i > 1 and $B[$i] != bernfrac($i)) {
        die "error for i=$i";
    }

    say "B($i) = $B[$i]";
}

__END__
[ 1, 0] ->      0 /  1! -      1 / 0!  /  2! =   -1/2  /  1!

[ 2, 0] ->      0 /  2! -      1 / 0!  /  3! =   -1/3  /  2!
[ 2, 1] ->   -1/3 /  2! -   -1/2 / 1!  /  2! =    1/6  /  2!

[ 3, 0] ->      0 /  3! -      1 / 0!  /  4! =   -1/4  /  3!
[ 3, 1] ->   -1/4 /  3! -   -1/2 / 1!  /  3! =    1/4  /  3!
[ 3, 2] ->    1/4 /  3! -    1/6 / 2!  /  2! =      0  /  3!

[ 4, 0] ->      0 /  4! -      1 / 0!  /  5! =   -1/5  /  4!
[ 4, 1] ->   -1/5 /  4! -   -1/2 / 1!  /  4! =   3/10  /  4!
[ 4, 2] ->   3/10 /  4! -    1/6 / 2!  /  3! =  -1/30  /  4!
[ 4, 3] ->  -1/30 /  4! -      0 / 3!  /  2! =  -1/30  /  4!

[ 5, 0] ->      0 /  5! -      1 / 0!  /  6! =   -1/6  /  5!
[ 5, 1] ->   -1/6 /  5! -   -1/2 / 1!  /  5! =    1/3  /  5!
[ 5, 2] ->    1/3 /  5! -    1/6 / 2!  /  4! =  -1/12  /  5!
[ 5, 3] ->  -1/12 /  5! -      0 / 3!  /  3! =  -1/12  /  5!
[ 5, 4] ->  -1/12 /  5! -  -1/30 / 4!  /  2! =      0  /  5!

[ 6, 0] ->      0 /  6! -      1 / 0!  /  7! =   -1/7  /  6!
[ 6, 1] ->   -1/7 /  6! -   -1/2 / 1!  /  6! =   5/14  /  6!
[ 6, 2] ->   5/14 /  6! -    1/6 / 2!  /  5! =   -1/7  /  6!
[ 6, 3] ->   -1/7 /  6! -      0 / 3!  /  4! =   -1/7  /  6!
[ 6, 4] ->   -1/7 /  6! -  -1/30 / 4!  /  3! =   1/42  /  6!
[ 6, 5] ->   1/42 /  6! -      0 / 5!  /  2! =   1/42  /  6!

[ 7, 0] ->      0 /  7! -      1 / 0!  /  8! =   -1/8  /  7!
[ 7, 1] ->   -1/8 /  7! -   -1/2 / 1!  /  7! =    3/8  /  7!
[ 7, 2] ->    3/8 /  7! -    1/6 / 2!  /  6! =  -5/24  /  7!
[ 7, 3] ->  -5/24 /  7! -      0 / 3!  /  5! =  -5/24  /  7!
[ 7, 4] ->  -5/24 /  7! -  -1/30 / 4!  /  4! =   1/12  /  7!
[ 7, 5] ->   1/12 /  7! -      0 / 5!  /  3! =   1/12  /  7!
[ 7, 6] ->   1/12 /  7! -   1/42 / 6!  /  2! =      0  /  7!

[ 8, 0] ->      0 /  8! -      1 / 0!  /  9! =   -1/9  /  8!
[ 8, 1] ->   -1/9 /  8! -   -1/2 / 1!  /  8! =   7/18  /  8!
[ 8, 2] ->   7/18 /  8! -    1/6 / 2!  /  7! =  -5/18  /  8!
[ 8, 3] ->  -5/18 /  8! -      0 / 3!  /  6! =  -5/18  /  8!
[ 8, 4] ->  -5/18 /  8! -  -1/30 / 4!  /  5! =  17/90  /  8!
[ 8, 5] ->  17/90 /  8! -      0 / 5!  /  4! =  17/90  /  8!
[ 8, 6] ->  17/90 /  8! -   1/42 / 6!  /  3! =  -1/30  /  8!
[ 8, 7] ->  -1/30 /  8! -      0 / 7!  /  2! =  -1/30  /  8!

[ 9, 0] ->      0 /  9! -      1 / 0!  / 10! =  -1/10  /  9!
[ 9, 1] ->  -1/10 /  9! -   -1/2 / 1!  /  9! =    2/5  /  9!
[ 9, 2] ->    2/5 /  9! -    1/6 / 2!  /  8! =  -7/20  /  9!
[ 9, 3] ->  -7/20 /  9! -      0 / 3!  /  7! =  -7/20  /  9!
[ 9, 4] ->  -7/20 /  9! -  -1/30 / 4!  /  6! =   7/20  /  9!
[ 9, 5] ->   7/20 /  9! -      0 / 5!  /  5! =   7/20  /  9!
[ 9, 6] ->   7/20 /  9! -   1/42 / 6!  /  4! =  -3/20  /  9!
[ 9, 7] ->  -3/20 /  9! -      0 / 7!  /  3! =  -3/20  /  9!
[ 9, 8] ->  -3/20 /  9! -  -1/30 / 8!  /  2! =      0  /  9!

[10, 0] ->      0 / 10! -      1 / 0!  / 11! =  -1/11  / 10!
[10, 1] ->  -1/11 / 10! -   -1/2 / 1!  / 10! =   9/22  / 10!
[10, 2] ->   9/22 / 10! -    1/6 / 2!  /  9! = -14/33  / 10!
[10, 3] -> -14/33 / 10! -      0 / 3!  /  8! = -14/33  / 10!
[10, 4] -> -14/33 / 10! -  -1/30 / 4!  /  7! =  19/33  / 10!
[10, 5] ->  19/33 / 10! -      0 / 5!  /  6! =  19/33  / 10!
[10, 6] ->  19/33 / 10! -   1/42 / 6!  /  5! = -14/33  / 10!
[10, 7] -> -14/33 / 10! -      0 / 7!  /  4! = -14/33  / 10!
[10, 8] -> -14/33 / 10! -  -1/30 / 8!  /  3! =   5/66  / 10!
[10, 9] ->   5/66 / 10! -      0 / 9!  /  2! =   5/66  / 10!

B(0) = 1
B(1) = -1/2
B(2) = 1/6
B(3) = 0
B(4) = -1/30
B(5) = 0
B(6) = 1/42
B(7) = 0
B(8) = -1/30
B(9) = 0
B(10) = 5/66


================================================
FILE: Math/bernoulli_numbers_from_primes.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 May 2017
# https://github.com/trizen

# A very high-level computation of the nth-Bernoulli number, using prime numbers.

# Algorithm due to Kevin J. McGown (December 8, 2005)
# See his paper: "Computing Bernoulli Numbers Quickly"

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(factorial next_prime ceil float is_div);

sub bern_from_primes {
    my ($n) = @_;

    $n == 0 and return Math::AnyNum->one;
    $n == 1 and return Math::AnyNum->new('1/2');
    $n <  0 and return Math::AnyNum->nan;
    $n %  2 and return Math::AnyNum->zero;

    my $tau   = 6.28318530717958647692528676655900576839433879875;
    my $log2B = (log(4 * $tau * $n) / 2 + $n * log($n) - $n * log($tau) - $n) / log(2);

    local $Math::AnyNum::PREC = int($n + $log2B) + ($n <= 90 ? 18 : 0);

    my $K = factorial($n) * 2 / Math::AnyNum->tau**$n;
    my $d = 1;

    for (my $p = 2 ; $p <= $n + 1 ; $p = next_prime($p)) {
        if (is_div($n, $p - 1)) {
            $d *= $p;
        }
    }

    my $N = ceil(($K * $d)->root($n - 1));

    my $z = 1.0;
    for (my $p = 2 ; $p <= $N ; $p = next_prime($p)) {
        my $u = float($p)**$n;
        $z *= $u / ($u-1);
    }

    (-1)**($n / 2 + 1) * int(ceil($d * $K * $z)) / $d;
}

foreach my $n (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $n, bern_from_primes(2 * $n);
}


================================================
FILE: Math/bernoulli_numbers_from_primes_gmpf.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 November 2017
# https://github.com/trizen

# Efficient algorithm for computing the nth-Bernoulli number, using prime numbers.

# Algorithm due to Kevin J. McGown (December 8, 2005)
# See his paper: "Computing Bernoulli Numbers Quickly"

# Run times:
#   bern( 40_000) - 2.763s
#   bern(100_000) - 19.591s
#   bern(200_000) - 1 min, 27.21s

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use Math::GMPq;
use Math::GMPf;
use Math::MPFR;

sub bern_from_primes {
    my ($n) = @_;

    $n == 0 and return Math::GMPq->new('1');
    $n == 1 and return Math::GMPq->new('1/2');
    $n <  0 and return undef;
    $n %  2 and return Math::GMPq->new('0');

    state $round = Math::MPFR::MPFR_RNDN();
    state $tau   = 6.28318530717958647692528676655900576839433879875;

    my $log2B = (CORE::log(4 * $tau * $n) / 2 + $n * (CORE::log($n / $tau) - 1)) / CORE::log(2);

    my $prec = CORE::int($n + $log2B) +
          ($n <= 90 ? (3, 3, 4, 4, 7, 6, 6, 6, 7, 7, 7, 8, 8, 9, 10, 12, 9, 7, 6, 0, 0, 0,
                       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);

    state $d = Math::GMPz::Rmpz_init_nobless();
    Math::GMPz::Rmpz_fac_ui($d, $n);                      # d = n!

    my $K = Math::MPFR::Rmpfr_init2($prec);
    Math::MPFR::Rmpfr_const_pi($K, $round);               # K = pi
    Math::MPFR::Rmpfr_pow_si($K, $K, -$n, $round);        # K = K^(-n)
    Math::MPFR::Rmpfr_mul_z($K, $K, $d, $round);          # K = K*d
    Math::MPFR::Rmpfr_div_2ui($K, $K, $n - 1, $round);    # K = K / 2^(n-1)

    # `d` is the denominator of bernoulli(n)
    Math::GMPz::Rmpz_set_ui($d, 2);                       # d = 2

    my @primes = (2);

    {
        # Sieve the primes <= n+1
        # Sieve of Eratosthenes + Dana Jacobsen's optimizations

        my $N = $n + 1;

        my @composite;
        my $bound = CORE::int(CORE::sqrt($N));

        for (my $i = 3 ; $i <= $bound ; $i += 2) {
            if (!exists($composite[$i])) {
                for (my $j = $i * $i ; $j <= $N ; $j += 2 * $i) {
                    undef $composite[$j];
                }
            }
        }

        foreach my $k (1 .. ($N - 1) >> 1) {
            if (!exists($composite[2 * $k + 1])) {

                push(@primes, 2 * $k + 1);

                if ($n % (2 * $k) == 0) {    # d = d*p   iff (p-1)|n
                    Math::GMPz::Rmpz_mul_ui($d, $d, 2 * $k + 1);
                }
            }
        }
    }

    state $N = Math::MPFR::Rmpfr_init2_nobless(64);
    Math::MPFR::Rmpfr_mul_z($K, $K, $d, $round);         # K = K*d
    Math::MPFR::Rmpfr_rootn_ui($N, $K, $n - 1, $round);  # N = N^(1/(n-1))
    Math::MPFR::Rmpfr_ceil($N, $N);                      # N = ceil(N)

    my $bound = Math::MPFR::Rmpfr_get_ui($N, $round);    # bound = int(N)

    my $t = Math::GMPf::Rmpf_init2($prec);               # temporary variable
    my $f = Math::GMPf::Rmpf_init2($prec);               # approximation to zeta(n)

    Math::MPFR::Rmpfr_get_f($f, $K, $round);

    for (my $i = 0 ; $primes[$i] <= $bound ; ++$i) {  # primes <= N
        Math::GMPf::Rmpf_set_ui($t, $primes[$i]);        # t = p
        Math::GMPf::Rmpf_pow_ui($t, $t, $n);             # t = t^n
        Math::GMPf::Rmpf_mul($f, $f, $t);                # f = f*t
        Math::GMPf::Rmpf_sub_ui($t, $t, 1);              # t = t-1
        Math::GMPf::Rmpf_div($f, $f, $t);                # f = f/t
    }

    my $q = Math::GMPq::Rmpq_init();

    Math::GMPf::Rmpf_ceil($f, $f);                       # f = ceil(f)
    Math::GMPq::Rmpq_set_f($q, $f);                      # q = f

    Math::GMPq::Rmpq_set_den($q, $d);                    # denominator
    Math::GMPq::Rmpq_neg($q, $q) if $n % 4 == 0;         # q = -q, iff 4|n

    return $q;                                           # Bn
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, bern_from_primes(2 * $i);
}


================================================
FILE: Math/bernoulli_numbers_from_primes_mpfr.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 May 2017
# https://github.com/trizen

# Computation of the nth-Bernoulli number, using prime numbers.

# Algorithm due to Kevin J. McGown (December 8, 2005)
# See his paper: "Computing Bernoulli Numbers Quickly"

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use Math::GMPq;
use Math::MPFR;

sub bern_from_primes {
    my ($n) = @_;

    $n == 0 and return Math::GMPq->new('1');
    $n == 1 and return Math::GMPq->new('1/2');
    $n <  0 and return undef;
    $n %  2 and return Math::GMPq->new('0');

    my $round = Math::MPFR::MPFR_RNDN();

    my $tau   = 6.28318530717958647692528676655900576839433879875;
    my $log2B = (log(4 * $tau * $n) / 2 + $n * log($n) - $n * log($tau) - $n) / log(2);

    my $prec = int($n + $log2B) + ($n <= 90 ? 18 : 0);

    my $d = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_fac_ui($d, $n);                      # d = n!

    my $K = Math::MPFR::Rmpfr_init2($prec);
    Math::MPFR::Rmpfr_const_pi($K, $round);               # K = pi
    Math::MPFR::Rmpfr_pow_si($K, $K, -$n, $round);        # K = K^(-n)
    Math::MPFR::Rmpfr_mul_z($K, $K, $d, $round);          # K = K*d
    Math::MPFR::Rmpfr_div_2ui($K, $K, $n - 1, $round);    # K = K / 2^(n-1)

    Math::GMPz::Rmpz_set_ui($d, 1);                       # d = 1

    my @primes;

    {  # Sieve the primes <= n+1
        my @composite;
        foreach my $i (2 .. sqrt($n) + 1) {
            if (!$composite[$i]) {
                for (my $j = $i**2 ; $j <= $n + 1 ; $j += $i) {
                    $composite[$j] = 1;
                }
            }
        }

        foreach my $p (2 .. $n + 1) {
            if (!$composite[$p]) {

                if ($n % ($p - 1) == 0) {
                    Math::GMPz::Rmpz_mul_ui($d, $d, $p);    # d = d*p   iff (p-1)|n
                }

                push @primes, $p;
            }
        }
    }

    my $N = Math::MPFR::Rmpfr_init2(64);
    Math::MPFR::Rmpfr_mul_z($N, $K, $d, $round);            # N = K*d
    Math::MPFR::Rmpfr_rootn_ui($N, $N, $n - 1, $round);     # N = N^(1/(n-1))
    Math::MPFR::Rmpfr_ceil($N, $N);                         # N = ceil(N)

    $N = Math::MPFR::Rmpfr_get_ui($N, $round);              # N = int(N)

    my $z = Math::MPFR::Rmpfr_init2($prec);                 # zeta(n)
    my $u = Math::GMPz::Rmpz_init();                        # p^n

    Math::MPFR::Rmpfr_set_ui($z, 1, $round);                # z = 1

    #~ my $t1 = Math::MPFR::Rmpfr_init2($prec);
    #~ my $t2 = Math::MPFR::Rmpfr_init2($prec);

    for (my $i = 0 ; $primes[$i] <= $N ; ++$i) {            # primes <= N

        #~ # Version 1
        #~ # 1 min, 45.29s for bern(200_000)
        #~ Math::MPFR::Rmpfr_ui_pow_ui($t1, $primes[$i], $n, $round);    # t1 = p^n
        #~ Math::MPFR::Rmpfr_sub_ui($t2, $t1, 1, $round);                # t2 = t1 - 1
        #~ Math::MPFR::Rmpfr_div($t1, $t1, $t2, $round);                 # t1 = t1 / t2
        #~ Math::MPFR::Rmpfr_mul($z, $z, $t1, $round);                   # z  = z * t1

        #~ # Version 2
        #~ # 1 min, 42.54s for bern(200_000)
        #~ Math::MPFR::Rmpfr_ui_pow_ui($t1, $primes[$i], $n, $round);    # t1 = p^n
        #~ Math::MPFR::Rmpfr_mul($z, $z, $t1, $round);                   # z  = z*t1
        #~ Math::MPFR::Rmpfr_sub_ui($t1, $t1, 1, $round);                # t1 = t1-1
        #~ Math::MPFR::Rmpfr_div($z, $z, $t1, $round);                   # z  = z/t1

        # Version 3 (fastest)
        # 1 min, 39.23s for bern(200_000)
        Math::GMPz::Rmpz_ui_pow_ui($u, $primes[$i], $n);    # u = p^n
        Math::MPFR::Rmpfr_mul_z($z, $z, $u, $round);        # z = z*u
        Math::GMPz::Rmpz_sub_ui($u, $u, 1);                 # u = u-1
        Math::MPFR::Rmpfr_div_z($z, $z, $u, $round);        # z = z/u
    }

    Math::MPFR::Rmpfr_mul($z, $z, $K, $round);              # z = z * K
    Math::MPFR::Rmpfr_mul_z($z, $z, $d, $round);            # z = z * d
    Math::MPFR::Rmpfr_ceil($z, $z);                         # z = ceil(z)

    my $q = Math::GMPq::Rmpq_init();

    Math::GMPq::Rmpq_set_den($q, $d);                       # denominator
    Math::MPFR::Rmpfr_get_z($d, $z, $round);
    Math::GMPz::Rmpz_neg($d, $d) if $n % 4 == 0;            # d = -d, iff 4|n
    Math::GMPq::Rmpq_set_num($q, $d);                       # numerator

    return $q;                                              # Bn
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, bern_from_primes(2 * $i);
}


================================================
FILE: Math/bernoulli_numbers_from_primes_ntheory.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 May 2017
# https://github.com/trizen

# Computation of the nth-Bernoulli number, using prime numbers.

# Algorithm due to Kevin J. McGown (December 8, 2005)
# See his paper: "Computing Bernoulli Numbers Quickly"

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use Math::GMPq;
use Math::MPFR;

use ntheory qw(is_prob_prime forprimes fordivisors);

sub bern_from_primes {
    my ($n) = @_;

    $n == 0 and return Math::GMPq->new('1');
    $n == 1 and return Math::GMPq->new('1/2');
    $n <  0 and return undef;
    $n %  2 and return Math::GMPq->new('0');

    my $round = Math::MPFR::MPFR_RNDN();

    my $tau   = 6.28318530717958647692528676655900576839433879875;
    my $log2B = (log(4 * $tau * $n) / 2 + $n * log($n) - $n * log($tau) - $n) / log(2);

    my $prec = int($n + $log2B) + ($n <= 90 ? 18 : 0);

    my $d = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_fac_ui($d, $n);                      # d = n!

    my $K = Math::MPFR::Rmpfr_init2($prec);
    Math::MPFR::Rmpfr_const_pi($K, $round);               # K = pi
    Math::MPFR::Rmpfr_pow_ui($K, $K, $n, $round);         # K = K^n
    Math::MPFR::Rmpfr_mul_2ui($K, $K, $n - 1, $round);    # K = K * 2^(n-1)
    Math::MPFR::Rmpfr_div_z($K, $K, $d, $round);          # K = K / d
    Math::MPFR::Rmpfr_ui_div($K, 1, $K, $round);          # K = 1 / K

    Math::GMPz::Rmpz_set_ui($d, 1);                       # d = 1

    fordivisors {                                         # divisors of n
        if (is_prob_prime($_ + 1)) {
            Math::GMPz::Rmpz_mul_ui($d, $d, $_ + 1);      # d = d * p, where (p-1)|n
        }
    } $n;

    my $N = Math::MPFR::Rmpfr_init2(64);
    Math::MPFR::Rmpfr_mul_z($N, $K, $d, $round);          # N = K * d
    Math::MPFR::Rmpfr_rootn_ui($N, $N, $n - 1, $round);   # N = K^(1/(n-1))
    Math::MPFR::Rmpfr_ceil($N, $N);                       # N = ceil(N)

    $N = Math::MPFR::Rmpfr_get_ui($N, $round);

    my $z = Math::MPFR::Rmpfr_init2($prec);               # zeta(n)
    my $u = Math::GMPz::Rmpz_init();                      # p^n

    Math::MPFR::Rmpfr_set_ui($z, 1, $round);              # z = 1

    forprimes {                                           # primes <= N
        Math::GMPz::Rmpz_ui_pow_ui($u, $_, $n);           # u = p^n
        Math::MPFR::Rmpfr_mul_z($z, $z, $u, $round);      # z = z*u
        Math::GMPz::Rmpz_sub_ui($u, $u, 1);               # u = u-1
        Math::MPFR::Rmpfr_div_z($z, $z, $u, $round);      # z = z/u
    } $N;

    Math::MPFR::Rmpfr_mul($z, $z, $K, $round);            # z = z * K
    Math::MPFR::Rmpfr_mul_z($z, $z, $d, $round);          # z = z * d
    Math::MPFR::Rmpfr_ceil($z, $z);                       # z = ceil(z)

    my $q = Math::GMPq::Rmpq_init();

    Math::GMPq::Rmpq_set_den($q, $d);                     # denominator
    Math::MPFR::Rmpfr_get_z($d, $z, $round);
    Math::GMPz::Rmpz_neg($d, $d) if $n % 4 == 0;          # d = -d, iff 4|n
    Math::GMPq::Rmpq_set_num($q, $d);                     # numerator

    return $q;                                            # Bn
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, bern_from_primes(2 * $i);
}


================================================
FILE: Math/bernoulli_numbers_from_tangent_numbers.pl
================================================
#!/usr/bin/perl

# Algorithm for computing the Bernoulli numbers from the tangent numbers.

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

# See also:
#   https://oeis.org/A000182
#   https://mathworld.wolfram.com/TangentNumber.html
#   https://en.wikipedia.org/wiki/Alternating_permutation
#   https://en.wikipedia.org/wiki/Bernoulli_number

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use Math::GMPq;

sub bernoulli_number {
    my ($N) = @_;

    my $q = Math::GMPq::Rmpq_init();

    if ($N == 0) {
        Math::GMPq::Rmpq_set_ui($q, 1, 1);
        return $q;
    }

    if ($N == 1) {
        Math::GMPq::Rmpq_set_si($q, -1, 2);
        return $q;
    }

    if ($N & 1) {
        Math::GMPq::Rmpq_set_ui($q, 0, 1);
        return $q;
    }

    my $n = ($N >> 1) - 1;
    my @T = (Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $k (1 .. $n) {
        Math::GMPz::Rmpz_mul_ui($T[$k] = Math::GMPz::Rmpz_init(), $T[$k - 1], $k);
    }

    foreach my $k (1 .. $n) {
        foreach my $j ($k .. $n) {
            Math::GMPz::Rmpz_mul_ui($T[$j], $T[$j], $j - $k + 2);
            Math::GMPz::Rmpz_addmul_ui($T[$j], $T[$j - 1], $j - $k);
        }
    }

    my $t = $T[-1];
    Math::GMPz::Rmpz_mul_ui($t, $t, $N);
    Math::GMPz::Rmpz_neg($t, $t) if ($n & 1);
    Math::GMPq::Rmpq_set_z($q, $t);

    # z = (2^n - 1) * 2^n
    my $z = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_setbit($z, $N);
    Math::GMPz::Rmpz_sub_ui($z, $z, 1);
    Math::GMPz::Rmpz_mul_2exp($z, $z, $N);

    Math::GMPq::Rmpq_div_z($q, $q, $z);

    return $q;
}

foreach my $n (1 .. 50) {
    printf("B(%s) = %s\n", 2 * $n, bernoulli_number(2 * $n));
}


================================================
FILE: Math/bernoulli_numbers_from_zeta.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 October 2016
# Website: https://github.com/trizen

# Computation of the nth-Bernoulli number, using the Zeta function.

use 5.010;
use strict;
use warnings;

use Math::AnyNum;

sub bern_zeta {
    my ($n) = @_;

    # B(n) = (-1)^(n/2 + 1) * zeta(n)*2*n! / (2*pi)^n

    $n == 0 and return Math::AnyNum->one;
    $n == 1 and return Math::AnyNum->new('1/2');
    $n < 0  and return Math::AnyNum->nan;
    $n % 2  and return Math::AnyNum->zero;

    my $ROUND = Math::MPFR::MPFR_RNDN();

    # The required precision is: O(n*log(n))
    my $prec = (
        $n <= 156
        ? CORE::int($n * CORE::log($n) + 1)
        : CORE::int($n * CORE::log($n) / CORE::log(2) - 3 * $n)
    );

    my $f = Math::MPFR::Rmpfr_init2($prec);
    Math::MPFR::Rmpfr_zeta_ui($f, $n, $ROUND);                     # f = zeta(n)

    my $z = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_fac_ui($z, $n);                               # z = n!
    Math::GMPz::Rmpz_div_2exp($z, $z, $n - 1);                     # z = z / 2^(n-1)
    Math::MPFR::Rmpfr_mul_z($f, $f, $z, $ROUND);                   # f = f*z

    my $p = Math::MPFR::Rmpfr_init2($prec);
    Math::MPFR::Rmpfr_const_pi($p, $ROUND);                        # p = PI
    Math::MPFR::Rmpfr_pow_ui($p, $p, $n, $ROUND);                  # p = p^n
    Math::MPFR::Rmpfr_div($f, $f, $p, $ROUND);                     # f = f/p

    Math::GMPz::Rmpz_set_ui($z, 1);                                # z = 1
    Math::GMPz::Rmpz_mul_2exp($z, $z, $n + 1);                     # z = 2^(n+1)
    Math::GMPz::Rmpz_sub_ui($z, $z, 2);                            # z = z-2

    Math::MPFR::Rmpfr_mul_z($f, $f, $z, $ROUND);                   # f = f*z
    Math::MPFR::Rmpfr_round($f, $f);                               # f = [f]

    my $q = Math::GMPq::Rmpq_init();
    Math::MPFR::Rmpfr_get_q($q, $f);                               # q = f
    Math::GMPq::Rmpq_set_den($q, $z);                              # q = q/z
    Math::GMPq::Rmpq_canonicalize($q);                             # remove common factors

    Math::GMPq::Rmpq_neg($q, $q) if $n % 4 == 0;                   # q = -q    (iff 4|n)
    Math::AnyNum->new($q);
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, bern_zeta(2 * $i);
}


================================================
FILE: Math/bernoulli_numbers_ramanujan_congruences.pl
================================================
#!/usr/bin/perl

# Formula due to Ramanujan for computing the nth-Bernoulli number.

# See also:
#   https://en.wikipedia.org/wiki/Bernoulli_number#Ramanujan's_congruences

use 5.020;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload sum binomial);

sub ramanujan_bernoulli_number ($n, $cache = {}) {

    return 1/2 if ($n   == 1);
    return 0   if ($n%2 == 1);

    $cache->{$n} //= do {
        (($n%6 == 4 ? -1/2 : 1) * ($n+3)/3 -
            sum(map {
                binomial($n+3, $n - 6*$_) * __SUB__->($n - 6*$_, $cache)
            } 1 .. ($n - $n%6) / 6)
        ) / binomial($n+3, $n)
    };
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, ramanujan_bernoulli_number(2 * $i);
}


================================================
FILE: Math/bernoulli_numbers_ramanujan_congruences_unreduced.pl
================================================
#!/usr/bin/perl

# Formula due to Ramanujan for computing the nth-Bernoulli number.

# This are the unreduced fractions.

# See also:
#   https://en.wikipedia.org/wiki/Bernoulli_number#Ramanujan's_congruences

use 5.020;
use warnings;

use experimental qw(signatures);

use List::Util qw(sum);
use Math::Bacovia qw(Fraction Number);
use Math::AnyNum qw(binomial bernfrac);

sub ramanujan_bernoulli_number ($n, $cache = {}) {

    return Fraction(1, 2) if ($n   == 1);
    return Fraction(0, 1) if ($n%2 == 1);

    $cache->{$n} //= do {
        (($n%6 == 4 ? Fraction(-1, 2) : 1) * Fraction($n+3, 3) -
            (sum(map {
                Number(binomial($n+3, $n - 6*$_)) * __SUB__->($n - 6*$_, $cache)
            } 1 .. ($n - $n%6) / 6) // 0)
        ) / Number(binomial($n+3, $n))
    };
}

foreach my $n (1..15) {
    say ramanujan_bernoulli_number(2*$n);
}

__END__
Fraction(5, 30)
Fraction(-7, 210)
Fraction(18, 756)
Fraction(-495, 14850)
Fraction(27300, 360360)
Fraction(-783594, 3095820)
Fraction(1060290000, 908820000)
Fraction(-3120392555280, 439977938400)
Fraction(1540021169559600, 28015065842400)
Fraction(-1138211737294401000000, 2151123774030000000)
Fraction(2845151832177208505952000000, 459479203757525952000000)
Fraction(-149443274714737339648102583520000, 1726066502932685055105600000)
Fraction(13609846707523944448974596493300000000000000, 9547304673537038744166600000000000000)
Fraction(-11263363110434888054130093206882749787055697920000000000, 412604138431303034312458421474352537600000000000)
Fraction(3343163067256114252216624560628967465552283801361747968000000000, 5557296138055536045317952219562393233733243699200000000)


================================================
FILE: Math/bernoulli_numbers_recursive.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 21 September 2015
# Website: https://github.com/trizen

# Recursive computation of Bernoulli numbers.

# See: https://en.wikipedia.org/wiki/Bernoulli_number#Recursive_definition
#      https://en.wikipedia.org/wiki/Binomial_coefficient#Recursive_formula

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);
use Math::AnyNum qw(:overload);

no warnings qw(recursion);

memoize('binomial');
memoize('bern_helper');
memoize('bernoulli_number');

sub binomial {
    my ($n, $k) = @_;
    $k == 0 || $n == $k ? 1 : binomial($n - 1, $k - 1) + binomial($n - 1, $k);
}

sub bern_helper {
    my ($n, $k) = @_;
    binomial($n, $k) * (bernoulli_number($k) / ($n - $k + 1));
}

sub bern_diff {
    my ($n, $k, $d) = @_;
    $n < $k ? $d : bern_diff($n, $k + 1, $d - bern_helper($n + 1, $k));
}

sub bernoulli_number {
    my ($n) = @_;

    return 1/2 if $n == 1;
    return 0   if $n % 2;

    $n > 0 ? bern_diff($n - 1, 0, 1) : 1;
}

for my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, bernoulli_number(2 * $i);
}


================================================
FILE: Math/bernoulli_numbers_recursive_2.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 October 2016
# Website: https://github.com/trizen

# Recursive computation of Bernoulli numbers (slightly improved).
# https://en.wikipedia.org/wiki/Bernoulli_number#Recursive_definition

use 5.014;
use strict;
use warnings;

use Memoize qw(memoize);
use Math::AnyNum qw(:overload binomial);

memoize('bernoulli');

sub bernoulli {
    my ($n) = @_;

    return 1/2 if $n == '1';
    return   0 if $n  % '2';
    return   1 if $n == '0';

    my $bern = 1/2 - 1 / ($n + 1);
    for (my $k = '2' ; $k < $n ; $k += '2') {
        $bern -= bernoulli($k) * binomial($n, $k) / ($n - $k + '1');
    }
    $bern;
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", '2' * $i, bernoulli('2' * $i);
}


================================================
FILE: Math/bernoulli_numbers_seidel.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 06 October 2016
# Website: https://github.com/trizen

# Algorithm from:
#   https://oeis.org/wiki/User:Peter_Luschny/ComputationAndAsymptoticsOfBernoulliNumbers#Seidel

use 5.010;
use strict;
use warnings;

use Math::AnyNum;

sub bernoulli_seidel {
    my ($n) = @_;

    $n == 0 and return Math::AnyNum->one;
    $n == 1 and return Math::AnyNum->new('1/2');
    $n % 2  and return Math::AnyNum->zero;

    state $one = Math::GMPz::Rmpz_init_set_ui(1);

    my @D = (
             Math::GMPz::Rmpz_init_set_ui(0),
             Math::GMPz::Rmpz_init_set_ui(1),
             map { Math::GMPz::Rmpz_init_set_ui(0) } (1 .. $n / 2 - 1)
            );

    my ($h, $w) = (1, 1);
    foreach my $i (0 .. $n - 1) {
        if ($w ^= 1) {
            Math::GMPz::Rmpz_add($D[$_], $D[$_], $D[$_ - 1]) for (1 .. $h - 1);
        }
        else {
            $w = $h++;
            Math::GMPz::Rmpz_add($D[$w], $D[$w], $D[$w + 1]) while --$w;
        }
    }

    Math::AnyNum->new($D[$h - 1]) / Math::AnyNum->new((($one << ($n + 1)) - 2) * ($n % 4 == 0 ? -1 : 1));
}

foreach my $i (0 .. 50) {
    printf "B%-3d = %s\n", 2 * $i, bernoulli_seidel(2 * $i);
}


================================================
FILE: Math/bi-unitary_divisors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 September 2023
# https://github.com/trizen

# Generate the bi-unitary divisors of n.

# See also:
#   https://oeis.org/A188999
#   https://oeis.org/A222266

use 5.036;
use ntheory qw(:all);

sub gcud (@list) {  # greatest common unitary divisor

    my $g = gcd(@list);

    foreach my $n (@list) {
        next if ($n == 0);
        while (1) {
            my $t = gcd($g, divint($n, $g));
            last if ($t == 1);
            $g = divint($g, $t);
        }
        last if ($g == 1);
    }

    return $g;
}

sub bi_unitary_divisors ($n) {

    my @d = (1);

    foreach my $pp (factor_exp($n)) {
        my ($p, $e) = @$pp;

        my @t;
        my $r = 1;
        foreach my $j (1 .. $e) {
            $r = mulint($r, $p);
            if (gcud($r, divint($n, $r)) == 1) {
                push @t, map { mulint($r, $_) } @d;
            }
        }
        push @d, @t;
    }

    return sort { $a <=> $b } @d;
}

foreach my $n (1 .. 20) {
    my @biudivisors = bi_unitary_divisors($n);
    say "bi-udivisors of $n: [@biudivisors]";
}

__END__
bi-udivisors of 1: [1]
bi-udivisors of 2: [1 2]
bi-udivisors of 3: [1 3]
bi-udivisors of 4: [1 4]
bi-udivisors of 5: [1 5]
bi-udivisors of 6: [1 2 3 6]
bi-udivisors of 7: [1 7]
bi-udivisors of 8: [1 2 4 8]
bi-udivisors of 9: [1 9]
bi-udivisors of 10: [1 2 5 10]
bi-udivisors of 11: [1 11]
bi-udivisors of 12: [1 3 4 12]
bi-udivisors of 13: [1 13]
bi-udivisors of 14: [1 2 7 14]
bi-udivisors of 15: [1 3 5 15]
bi-udivisors of 16: [1 2 8 16]
bi-udivisors of 17: [1 17]
bi-udivisors of 18: [1 2 9 18]
bi-udivisors of 19: [1 19]
bi-udivisors of 20: [1 4 5 20]


================================================
FILE: Math/binary_gcd_algorithm.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 12 August 2017
# https://github.com/trizen

# Algorithm invented by J. Stein in 1967, described in the
# book "Algorithmic Number Theory" by Eric Bach and Jeffrey Shallit.

use 5.010;
use strict;
use warnings;

sub binary_gcd {
    my ($u, $v) = @_;

    my $g = 1;

    while (($u & 1) == 0 and ($v & 1) == 0) {
        $u >>= 1;
        $v >>= 1;
        $g <<= 1;
    }

    while ($u != 0) {
        if (($u & 1) == 0) {
            $u >>= 1;
        }
        elsif (($v & 1) == 0) {
            $v >>= 1;
        }
        elsif ($u >= $v) {
            $u -= $v;
            $u >>= 1;
        }
        else {
            $v -= $u;
            $v >>= 1;
        }
    }

    return ($g * $v);
}

say binary_gcd(10628640, 3628800);     #=> 1440
say binary_gcd(3628800,  10628640);    #=> 1440


================================================
FILE: Math/binary_gcd_algorithm_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 12 August 2017
# https://github.com/trizen

# Algorithm invented by J. Stein in 1967, described in the
# book "Algorithmic Number Theory" by Eric Bach and Jeffrey Shallit.

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub binary_gcd {
    my ($u, $v) = @_;

    $u = Math::GMPz::Rmpz_init_set($u);
    $v = Math::GMPz::Rmpz_init_set($v);

    my $g = Math::GMPz::Rmpz_init_set_ui(1);

    while (Math::GMPz::Rmpz_even_p($u) and Math::GMPz::Rmpz_even_p($v)) {
        Math::GMPz::Rmpz_div_2exp($v, $v, 1);
        Math::GMPz::Rmpz_div_2exp($u, $u, 1);
        Math::GMPz::Rmpz_mul_2exp($g, $g, 1);
    }

    while (Math::GMPz::Rmpz_sgn($u)) {
        if (Math::GMPz::Rmpz_even_p($u)) {
            Math::GMPz::Rmpz_div_2exp($u, $u, 1);
        }
        elsif (Math::GMPz::Rmpz_even_p($v)) {
            Math::GMPz::Rmpz_div_2exp($v, $v, 1);
        }
        elsif (Math::GMPz::Rmpz_cmp($u, $v) >= 0) {
            Math::GMPz::Rmpz_sub($u, $u, $v);
            Math::GMPz::Rmpz_div_2exp($u, $u, 1);
        }
        else {
            Math::GMPz::Rmpz_sub($v, $v, $u);
            Math::GMPz::Rmpz_div_2exp($v, $v, 1);
        }
    }

    Math::GMPz::Rmpz_mul($g, $g, $v);
    return $g;
}

my $u = Math::GMPz->new('484118311800307409686872049018968526148964320406131317406564776592214983358038627898935326228550128722261905040875508300794183477624832000000000000000000000000');
my $v = Math::GMPz->new('93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000');

say binary_gcd($u, $v); #=> 33464469725118339932738475939854523519700805708105926500308251028510111778609255576238987149312000000000000000000000000
say binary_gcd($v, $u); #=> 33464469725118339932738475939854523519700805708105926500308251028510111778609255576238987149312000000000000000000000000


================================================
FILE: Math/binary_multiplier.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 07 August 2015
# Website: https://github.com/trizen

# A very simple binary multiplier.
# Derived from: https://en.wikipedia.org/wiki/Binary_multiplier#A_more_advanced_approach:_an_unsigned_example

use 5.010;
use strict;
use warnings;

my $a = 0b11110001;
my $b = 0b11011011;

say $a;
say $b;
say $a * $b;

my @a = reverse(split(//, sprintf("%b", $a)));

my $p = 0;
foreach my $i (@a) {
    $i && ($p += $b);
    $b <<= 1;
}

say $p;


================================================
FILE: Math/binary_prime_encoder.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 22 September 2016
# https://github.com/trizen

# Encode prime numbers below a certain limit into a large number.

# Example for primes below 7:
#
#   x = 110101
#
# where each (k+1)-th bit in x is 1 when (k+1) is prime.
#
# This can be illustrated as:
#   [1, 1, 0, 1, 0, 1]
#   [2, 3, 4, 5, 6, 7]
#
# The binary number 110101 is represented by 53 in base 10.

# See also: https://oeis.org/A072762
#           https://en.wikipedia.org/wiki/Prime_constant

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

use Memoize qw(memoize);
use Math::AnyNum qw(:overload);
use ntheory qw(is_prime prev_prime);

memoize('_encode');

sub _encode {
    my ($n) = @_;
    $n < 2 ? 0 : 2 * _encode($n - 1) + (is_prime($n) ? 1 : 0);
}

sub encode_primes {
    my ($limit) = @_;
    _encode(prev_prime($limit + 1));
}

sub decode_primes {
    my ($n) = @_;

    my $pow   = $n >> 1;
    my $shift = 1;

    while (($pow + 1) & $pow) {
        $pow |= $pow >> $shift;
        $shift <<= 1;
    }

    $pow += 1;

    my @primes;
    my $p = 2;

    while ($pow) {
        if ($n & $pow) {
            push @primes, $p;
        }
        ++$p;
        $pow >>= 1;
    }

    @primes;
}

say "Encoded primes below 100: ", encode_primes(100);
say "Decoded primes below 100: ", join(' ', decode_primes(encode_primes(100)));

__END__
Encoded primes below 100: 65709066564613793476872782081
Decoded 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


================================================
FILE: Math/binary_prime_encoder_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 22 September 2016
# https://github.com/trizen

# Encode the first n prime numbers into a large integer.

# See also:
#    https://oeis.org/A135482

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload);
use ntheory qw(nth_prime valuation);

sub encode_primes {
    my ($n) = @_;

    my $sum = 0;
    foreach my $i (1 .. $n) {
        $sum |= 1 << nth_prime($i);
    }

    $sum >> 2;
}

sub decode_primes {
    my ($n) = @_;

    my $p = 2;
    my @primes;

    while ($n) {
        if ($n & 1) {
            push @primes, $p;
        }

        my $v = valuation($n, 2) || 1;
        $n >>= $v;
        $p += $v;
    }

    @primes;
}

say "Encoded first 25 primes: ", encode_primes(25);
say "Decoded first 25 primes: ", join(' ', decode_primes(encode_primes(25)));

__END__
Encoded first 25 primes: 39771395718504928067455191595
Decoded 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


================================================
FILE: Math/binary_prime_sieve_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 18 May 2017
# https://github.com/trizen

# A binary sieve for prime numbers.

# Useful only when memory is very restricted.

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub binary_prime_sieve {
    my ($n) = @_;

    my $t = Math::GMPz::Rmpz_init_set_ui(1);
    my $c = Math::GMPz::Rmpz_init_set_ui(1);

    Math::GMPz::Rmpz_setbit($c, $n);

    foreach my $i (2 .. sqrt($n)) {
        Math::GMPz::Rmpz_mul_2exp($t, $t, $n - $i**2);

        for (my $j = $i**2 ; $j <= $n ; $j += $i) {
            Math::GMPz::Rmpz_ior($c, $c, $t);
            Math::GMPz::Rmpz_div_2exp($t, $t, $i);
        }

        Math::GMPz::Rmpz_set_ui($t, 1);
    }

    my $bin = Math::GMPz::Rmpz_get_str($c, 2);

    my @primes;
    foreach my $p (2 .. $n) {
        substr($bin, $p, 1) || push(@primes, $p);
    }
    return @primes;
}

my $n = shift(@ARGV) // 100;
my @primes = binary_prime_sieve($n);
say join(' ', @primes);
say "PI($n) = ", scalar(@primes);


================================================
FILE: Math/binary_splitting_product.pl
================================================
#!/usr/bin/perl

# Compute the product of a list of numbers, using binary splitting.

# See also:
#   https://en.wikipedia.org/wiki/Binary_splitting

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub binsplit_product ($s, $n, $m) {
    $n > $m  and return 1;
    $n == $m and return $s->[$n];
    my $k = ($n + $m) >> 1;
    __SUB__->($s, $n, $k) * __SUB__->($s, $k + 1, $m);
}

foreach my $n (1 .. 10) {
    my @list = (1 .. $n);
    printf "%2d! = %s\n", $n, binsplit_product(\@list, 0, $#list);
}


================================================
FILE: Math/binomial_sum_with_imaginary_term.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 31 July 2017
# Edit: 01 January 2018
# https://github.com/trizen

# Binomial summation in integers of an expression of the form: (a + b*sqrt(-1))^n

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload binomial);

sub imaginary_binomial_sum {
    my ($c, $d, $n) = @_;

    my $re = 0;
    my $im = 0;

    foreach my $k (0 .. $n) {
        my $t = binomial($n, $k) * $c**($n - $k) * $d**$k;

        if ($k % 4 == 0) {
            $re += $t;
        }
        elsif ($k % 4 == 1) {
            $im += $t;
        }
        elsif ($k % 4 == 2) {
            $re -= $t;
        }
        elsif ($k % 4 == 3) {
            $im -= $t;
        }
    }

    return ($re, $im);
}

#
## Example for: (2 + 3*sqrt(-1))^10
#

my $c = 2;
my $d = 3;
my $n = 10;

my ($re, $im) = imaginary_binomial_sum($c, $d, $n);

say "($c + $d*sqrt(-1))^$n = ($re, $im)";       #=> (-341525, -145668)


================================================
FILE: Math/binomial_theorem.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 19 December 2016
# https://github.com/trizen

# Implementation of the binomial theorem.

# Defined as:
#   (a + b)^n = sum(g(k) * a^(n-k) * b^k, {k=0, n})
#
# where g(k) is:
#   g(0) = 1
#   g(k) = (n - k + 1) * g(k-1) / k

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

#
## The binomial coefficient: (n, k)
#
sub g {
    my ($n, $k) = @_;
    $k == 0 ? 1 : ($n - $k + 1) * g($n, $k - 1) / $k;
}

#
## Binomial summation for (a + b)^n
#
sub binomial_sum {
    my ($a, $b, $n) = @_;
    my $sum = 0;
    foreach my $k (0 .. $n) {
        $sum += g($n, $k) * $a**($n - $k) * $b**$k;
    }
    return $sum;
}

#
## Example for (1 + 1/30)^30
#

my $a = 1;
my $b = 1/30;
my $n = 30;

say binomial_sum($a, $b, $n);       #=> 2.6743187758703


================================================
FILE: Math/bitstring_prime_sieve_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 July 2017
# https://github.com/trizen

# A decently fast bit-string sieve for prime numbers.
# It's asymptotically faster than using Perl's arrays.

# Also useful when memory is very restricted.

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub bitstring_prime_sieve {
    my ($n) = @_;

    my $c = Math::GMPz::Rmpz_init_set_ui(1);

    Math::GMPz::Rmpz_setbit($c, $n + 1);

    my $bound = int(sqrt($n));

    for (my $i = 3 ; $i <= $bound ; $i += 2) {
        if (!Math::GMPz::Rmpz_tstbit($c, $i)) {
            for (my $j = $i * $i ; $j <= $n ; $j += $i << 1) {
                Math::GMPz::Rmpz_setbit($c, $j);
            }
        }
    }

    my @primes = (2);
    foreach my $k (1 .. ($n - 1) >> 1) {
        Math::GMPz::Rmpz_tstbit($c, ($k << 1) + 1) || push(@primes, ($k << 1) + 1);
    }
    return @primes;
}

my $n      = shift(@ARGV) // 100;
my @primes = bitstring_prime_sieve($n);
say join(' ', @primes);
say "PI($n) = ", scalar(@primes);


================================================
FILE: Math/bitstring_prime_sieve_vec.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 May 2018
# https://github.com/trizen

# A decently fast bit-string sieve for prime numbers.

# Useful when memory is very restricted.

use 5.010;
use strict;
use warnings;

sub bitstring_prime_sieve {
    my ($n) = @_;

    my $c     = '';
    my $bound = int(sqrt($n));

    for (my $i = 3 ; $i <= $bound ; $i += 2) {
        if (!vec($c, $i, 1)) {
            for (my $j = $i * $i ; $j <= $n ; $j += $i << 1) {
                vec($c, $j, 1) = 1;
            }
        }
    }

    my @primes = (2);
    foreach my $k (1 .. ($n - 1) >> 1) {
        vec($c, ($k << 1) + 1, 1) || push(@primes, ($k << 1) + 1);
    }
    return @primes;
}

my $n      = shift(@ARGV) // 100;
my @primes = bitstring_prime_sieve($n);
say join(' ', @primes);
say "PI($n) = ", scalar(@primes);


================================================
FILE: Math/both_truncatable_primes_in_base.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 12 January 2019
# Edit: 28 March 2023
# https://github.com/trizen

# Generate the entire sequence of both-truncatable primes in a given base.

# Optimization:
#   there are far fewer right-truncatable primes than are left-truncatable primes,
#   so we can generate only the RTPs and then check which ones are also LTPs.

# Maximum value for each base is given in the following OEIS sequence:
#   https://oeis.org/A323137

# Total number of primes that are both left-truncatable and right-truncatable in base n:
#   https://oeis.org/A323390

# See also:
#   https://www.youtube.com/watch?v=azL5ehbw_24
#   https://en.wikipedia.org/wiki/Truncatable_prime

# Related sequences:
#  https://oeis.org/A076586 - Total number of right truncatable primes in base n.
#  https://oeis.org/A076623 - Total number of left truncatable primes (without zeros) in base n.
#  https://oeis.org/A323390 - Total number of primes that are both left-truncatable and right-truncatable in base 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.

use 5.036;
use ntheory                qw(primes vecmax is_prime);
use Math::Prime::Util::GMP qw(divint mulint addint subint);

sub is_left_truncatable ($n, $base) {

    for (my $r = $base ; $r < $n ; $r = mulint($r, $base)) {
        is_prime(subint($n, mulint($r, divint($n, $r)))) || return 0;
    }

    return 1;
}

sub generate_from_prefix ($p, $base) {

    my @seq = ($p);

    foreach my $d (1 .. $base - 1) {
        my $n = addint(mulint($p, $base), $d);
        if (is_prime($n)) {
            push @seq, grep { is_left_truncatable($_, $base) } generate_from_prefix($n, $base);
        }
    }

    return @seq;
}

sub both_truncatable_primes_in_base ($base) {

    return if $base <= 2;

    my @truncatable;
    foreach my $p (@{primes(2, $base - 1)}) {
        push @truncatable, generate_from_prefix($p, $base);
    }
    return @truncatable;
}

foreach my $base (3 .. 36) {
    my @t = both_truncatable_primes_in_base($base);
    printf("There are %3d both-truncatable primes in base %2d where largest is %s\n", scalar(@t), $base, vecmax(@t));
}

__END__
There are    2 both-truncatable primes in base  3 where largest is 23
There are    3 both-truncatable primes in base  4 where largest is 11
There are    5 both-truncatable primes in base  5 where largest is 67
There are    9 both-truncatable primes in base  6 where largest is 839
There are    7 both-truncatable primes in base  7 where largest is 37
There are   22 both-truncatable primes in base  8 where largest is 1867
There are    8 both-truncatable primes in base  9 where largest is 173
There are   15 both-truncatable primes in base 10 where largest is 739397
There are    6 both-truncatable primes in base 11 where largest is 79
There are   35 both-truncatable primes in base 12 where largest is 105691
There are   11 both-truncatable primes in base 13 where largest is 379
There are   37 both-truncatable primes in base 14 where largest is 37573
There are   17 both-truncatable primes in base 15 where largest is 647
There are   22 both-truncatable primes in base 16 where largest is 3389
There are   12 both-truncatable primes in base 17 where largest is 631
There are   69 both-truncatable primes in base 18 where largest is 202715129
There are   12 both-truncatable primes in base 19 where largest is 211
There are   68 both-truncatable primes in base 20 where largest is 155863
There are   18 both-truncatable primes in base 21 where largest is 1283
There are   44 both-truncatable primes in base 22 where largest is 787817
There are   13 both-truncatable primes in base 23 where largest is 439
There are  145 both-truncatable primes in base 24 where largest is 109893629
There are   16 both-truncatable primes in base 25 where largest is 577
There are   47 both-truncatable primes in base 26 where largest is 4195880189
There are   20 both-truncatable primes in base 27 where largest is 1811
There are   77 both-truncatable primes in base 28 where largest is 14474071
There are   13 both-truncatable primes in base 29 where largest is 379
There are  291 both-truncatable primes in base 30 where largest is 21335388527
There are   15 both-truncatable primes in base 31 where largest is 2203
There are   89 both-truncatable primes in base 32 where largest is 1043557
There are   27 both-truncatable primes in base 33 where largest is 2939
There are   74 both-truncatable primes in base 34 where largest is 42741029
There are   20 both-truncatable primes in base 35 where largest is 2767
There are  241 both-truncatable primes in base 36 where largest is 50764713107
There are   18 both-truncatable primes in base 37 where largest is 853
There are  106 both-truncatable primes in base 38 where largest is 65467229
There are   25 both-truncatable primes in base 39 where largest is 4409
There are  134 both-truncatable primes in base 40 where largest is 8524002457
There are   15 both-truncatable primes in base 41 where largest is 113
There are  450 both-truncatable primes in base 42 where largest is 1272571820725769
There are   23 both-truncatable primes in base 43 where largest is 4861
There are  144 both-truncatable primes in base 44 where largest is 3215447359
There are   33 both-truncatable primes in base 45 where largest is 5897
There are  131 both-truncatable primes in base 46 where largest is 8542971469
There are   24 both-truncatable primes in base 47 where largest is 1741
There are  491 both-truncatable primes in base 48 where largest is 531866995189
There are   27 both-truncatable primes in base 49 where largest is 6421
There are  235 both-truncatable primes in base 50 where largest is 297897697
There are   29 both-truncatable primes in base 51 where largest is 2399
There are  187 both-truncatable primes in base 52 where largest is 2276097403
There are   23 both-truncatable primes in base 53 where largest is 2281
There are  575 both-truncatable primes in base 54 where largest is 586812834217
There are   30 both-truncatable primes in base 55 where largest is 7537
There are  218 both-truncatable primes in base 56 where largest is 3086112347
There are   31 both-truncatable primes in base 57 where largest is 9521
There are  183 both-truncatable primes in base 58 where largest is 24666304823
There are   25 both-truncatable primes in base 59 where largest is 9619
There are 1377 both-truncatable primes in base 60 where largest is 200416308070405393
There are   26 both-truncatable primes in base 61 where largest is 2503
There are  247 both-truncatable primes in base 62 where largest is 2467459748009
There are   37 both-truncatable primes in base 63 where largest is 10271
There are  231 both-truncatable primes in base 64 where largest is 1591175082967


================================================
FILE: Math/brazilian_primes_constant.pl
================================================
#!/usr/bin/perl

# Compute the decimal expansion of the sum of reciprocals of Brazilian primes, also called the Brazilian primes constant.

# The constant begins as:
#   0.3317544666

# OEIS sequences:
#   https://oeis.org/A085104 (Brazillian primes)
#   https://oeis.org/A306759 (Decimal expansion of the sum of reciprocals of Brazilian primes)

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);
use Math::AnyNum;

sub brazillian_constant ($lim) {

    my $N = Math::GMPz->new("$lim");
    my $q = Math::GMPq->new(0);
    my $z = Math::GMPz->new(0);

    my $sum = Math::MPFR::Rmpfr_init2(192);
    Math::MPFR::Rmpfr_set_ui($sum, 0, 0);

    my %seen;

    # The algorithm for generating the Brazillian primes is due to M. F. Hasler.
    # See: https://oeis.org/A085104

    forprimes {
        my $K = $_;
        for my $n (2 .. rootint($N - 1, $K - 1)) {

            Math::GMPz::Rmpz_ui_pow_ui($z, $n, $K);
            Math::GMPz::Rmpz_sub_ui($z, $z, 1);
            Math::GMPz::Rmpz_divexact_ui($z, $z, $n - 1);

            if (
                is_prob_prime(
                                Math::GMPz::Rmpz_fits_ulong_p($z)
                              ? Math::GMPz::Rmpz_get_ui($z)
                              : Math::GMPz::Rmpz_get_str($z, 10)
                             )
              ) {

                # Conjecture: duplicate terms may happen only for t = 2^k-1, for some k
                if ((($z + 1) & $z) == 0) {
                    next if $seen{$z}++;
                }

                if ($z < $N) {
                    Math::GMPq::Rmpq_set_ui($q, 1, 1);
                    Math::GMPq::Rmpq_set_den($q, $z);
                    Math::MPFR::Rmpfr_add_q($sum, $sum, $q, 0);
                }
            }
        }
    } 3, logint($N + 1, 2);

    return Math::AnyNum->new($sum);
}

foreach my $n (1 .. 14) {
    say "B(10^$n) ~ ", brazillian_constant(Math::GMPz->new(10)**$n)->round(-32);
}

__END__
B(10^1)  ~ 0.14285714285714285714285714285714
B(10^2)  ~ 0.28899272838682348594073100542184
B(10^3)  ~ 0.32290223556269144810843769843366
B(10^4)  ~ 0.32952368063536693571523726793301
B(10^5)  ~ 0.33121713119461798438057432911381
B(10^6)  ~ 0.33160386963492172892306297309503
B(10^7)  ~ 0.33171391586547473334091623260371
B(10^8)  ~ 0.33174341910781704122196304798802
B(10^9)  ~ 0.33175132673949885380067237840723
B(10^10) ~ 0.33175356516689372562521462231951
B(10^11) ~ 0.33175420579318423292974799113059
B(10^12) ~ 0.33175439067722742680152185017303
B(10^13) ~ 0.33175444440331880514669754839817
B(10^14) ~ 0.33175446011369675270545267094599
B(10^15) ~ 0.33175446473544852087966767749508
B(10^16) ~ 0.33175446610148680800864203095541  -- took 1 minute
B(10^17) ~ 0.33175446650734519516960634448563  -- took 4 minutes
B(10^18) ~ 0.33175446662828756863723305575693  -- took 20 minutes
B(10^19) ~ 0.33175446666446018177571079766533  -- took 39 minutes
B(10^20) ~ 0.33175446667530957668020208565143  -- took 5 hours and 23 minutes


================================================
FILE: Math/brown_numbers.pl
================================================
#!/usr/bin/perl

# See: https://www.youtube.com/watch?v=-Djj6pfR9KU

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(factorial is_power);

for my $i (1 .. 60) {
    my $n = factorial($i) + 1;
    is_power($n) || next;
    printf("(%d, %d)\n", int(sqrt($n)), $i);
}

__END__
(5, 4)
(11, 5)
(71, 7)


================================================
FILE: Math/carmichael_factorization_method.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 17 March 2019
# https://github.com/trizen

# A new factorization method for numbers with exactly three distinct prime factors of the form:
#
#   n = a * (a+x) * (a+y)
#   n = a * ((a±1)*x ± 1) *  ((a±1)*y ± 1)
#
# for x,y relatively small.

# Many Carmichael numbers and Lucas pseudoprimes are of this form and can be factorized relatively fast by this method.

# See also:
#   https://en.wikipedia.org/wiki/Cubic_function

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(lastfor forcomb);
use Math::AnyNum qw(:overload isqrt icbrt round gcd);

#<<<
sub solve_cubic_equation ($a, $b, $c, $d) {

    my $p = (3*$a*$c - $b*$b) / (3*$a*$a);
    my $q = (2 * $b**3 - 9*$a*$b*$c + 27*$a*$a*$d) / (27 * $a**3);

    my $t = (icbrt(-($q/2) + isqrt(($q**2 / 4) + ($p**3 / 27))) +
             icbrt(-($q/2) - isqrt(($q**2 / 4) + ($p**3 / 27))));

    my $x = round($t - $b/(3*$a));

    return $x;
}
#>>>

sub carmichael_factorization ($n, $l = 2, $h = 23) {

    my $factor = 1;

    my sub try_parameters ($a, $b, $c) {

        my $t = solve_cubic_equation($a, $b, $c, -$n);
        my $g = gcd($t, $n);

        if ($g > 1 and $g < $n) {
            $factor = $g;
            return 1;
        }
    }

    my @range = ($l .. $h);

    forcomb {
        my ($x, $y) = @range[@_];

        my $a = $x * $y;
        my $b = 2 * $a - $x - $y;
        my $c = $a - $x - $y + 1;

        try_parameters($a, $b,      $c)  and do { lastfor, return $factor };
        try_parameters($a, -$b,     $c)  and do { lastfor, return $factor };
        try_parameters(1,  $x + $y, $a)  and do { lastfor, return $factor };
        try_parameters($a, $y - $x, -$c) and do { lastfor, return $factor };

        try_parameters($a, (+2 * $y + 1) * $x + $y, ($y + 1) * $x + ($y + 1)) and do { lastfor, return $factor };
        try_parameters($a, (-2 * $y - 1) * $x - $y, ($y + 1) * $x + ($y + 1)) and do { lastfor, return $factor };
    } scalar(@range), 2;

    return $factor;
}

say carmichael_factorization(7520940423059310542039581);                                          #=> 79443853
say carmichael_factorization(1000000032900000272110000405099);                                    #=> 10000000103
say carmichael_factorization(570115866940668362539466801338334994649);                            #=> 4563211789627
say carmichael_factorization(8325544586081174440728309072452661246289);                           #=> 11153738721817
say carmichael_factorization(1169586052690021349455126348204184925097724507);                     #=> 166585508879747
say carmichael_factorization(61881629277526932459093227009982733523969186747);                    #=> 1233150073853267
say carmichael_factorization(173315617708997561998574166143524347111328490824959334367069087);    #=> 173823271649325368927


================================================
FILE: Math/carmichael_factorization_method_generalized.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 08 May 2019
# https://github.com/trizen

# A simple factorization method, using the binary search algorithm, for numbers of the form:
#
#   n = x * Prod_{k=1..r} ((x±1)*a_k ± 1)
#
# for `r` relatively small.

# Many Carmichael numbers and Lucas pseudoprimes are of this form and can be factorized relatively fast by this method.

# See also:
#   https://en.wikipedia.org/wiki/Binary_search_algorithm

use 5.024;
use warnings;
use experimental qw(signatures);
use ntheory qw(lastfor forcomb);
use Math::AnyNum qw(:overload bsearch_le iroot prod gcd);

sub carmichael_factorization ($n, $k = 3, $l = 2, $h = 6) {

    my @blocks = (
        sub ($x, @params) {
            map { ($x - 1) * $_ + 1 } @params;
        },
        sub ($x, @params) {
            map { ($x + 1) * $_ - 1 } @params;
        },
    );

    my @factors;
    my @range = ($l .. $h);

    forcomb {
        my @params = @range[@_];

        foreach my $block (@blocks) {

            my $r = bsearch_le(
                iroot($n, $k),
                sub ($x) {
                    (prod($block->($x, @params)) * $x) <=> $n;
                }
            );

            my $g = gcd($r, $n);

            if ($g > 1) {
                @factors = grep { $n % $_ == 0 } ($r, $block->($r, @params));
                @factors = ($g) if !@factors;
                lastfor, return @factors;
            }
        }
    } scalar(@range), $k - 1;

    return @factors;
}

#<<<
local $, = ", ";

say carmichael_factorization(7520940423059310542039581,                3);    #=> 79443853
say carmichael_factorization(570115866940668362539466801338334994649,  3);    #=> 4563211789627
say carmichael_factorization(8325544586081174440728309072452661246289, 3);    #=> 11153738721817

say '=' x 80;

say carmichael_factorization(60711773123792542753,                           4, 2,  10);    #=> 2597294701
say carmichael_factorization(73410179782535364796052059,                     2, 2,  18);    #=> 2141993519227
say carmichael_factorization(12946744736260953126701495197312513,            4, 2,  6);     #=> 37927921157953921

say '=' x 80;

say carmichael_factorization(1169586052690021349455126348204184925097724507,                  3, 11, 23);  #=> 166585508879747
say carmichael_factorization(61881629277526932459093227009982733523969186747,                 3, 3,  11);  #=> 1233150073853267
say carmichael_factorization(173315617708997561998574166143524347111328490824959334367069087, 3, 3,  11);  #=> 173823271649325368927

say '=' x 80;

# Works even with larger numbers
say carmichael_factorization(89279013890805987845789287109721287627454944588023686038653206281186298337098760877273881);                                      #=> 245960883729518060519840003581
say carmichael_factorization(131754870930495356465893439278330079857810087607720627102926770417203664110488210785830750894645370240615968198960237761, 4);    #=> 245960883729518060519840003581
#>>>


================================================
FILE: Math/carmichael_numbers_from_multiple.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 March 2023
# https://github.com/trizen

# Generate Carmichael numbers from a given multiple.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub carmichael_from_multiple ($m, $callback) {

    my $L = lcm(map { subint($_, 1) } factor($m));
    my $v = invmod($m, $L) // return;

    for (my $p = $v ; ; $p += $L) {

        gcd($m, $p) == 1 or next;

        my @factors = factor_exp($p);
        (vecall { $_->[1] == 1 } @factors) || next;

        my $n = $m * $p;
        my $l = lcm(map { subint($_->[0], 1) } @factors);

        if (($n - 1) % $l == 0) {
            $callback->($n);
        }
    }
}

carmichael_from_multiple(13 * 19, sub ($n) { say $n });


================================================
FILE: Math/carmichael_numbers_from_multiple_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 March 2023
# https://github.com/trizen

# Generate Carmichael numbers from a given multiple.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub carmichael_from_multiple ($m, $callback) {

    my $t = Math::GMPz::Rmpz_init();
    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    is_square_free($m) || return;

    my $L = lcm(map { subint($_, 1) } factor($m));

    $m = Math::GMPz->new("$m");
    $L = Math::GMPz->new("$L");

    Math::GMPz::Rmpz_invert($v, $m, $L) || return;

    for (my $p = Math::GMPz::Rmpz_init_set($v) ; ; Math::GMPz::Rmpz_add($p, $p, $L)) {

        Math::GMPz::Rmpz_gcd($t, $m, $p);
        Math::GMPz::Rmpz_cmp_ui($t, 1) == 0 or next;

        my @factors = factor_exp($p);
        (vecall { $_->[1] == 1 } @factors) || next;

        Math::GMPz::Rmpz_mul($v, $m, $p);
        Math::GMPz::Rmpz_sub_ui($u, $v, 1);

        Math::GMPz::Rmpz_set_str($t, lcm(map { subint($_->[0], 1) } @factors), 10);

        if (Math::GMPz::Rmpz_divisible_p($u, $t)) {
            $callback->(Math::GMPz::Rmpz_init_set($v));
        }
    }
}

carmichael_from_multiple(13 * 19, sub ($n) { say $n });


================================================
FILE: Math/carmichael_numbers_from_multiple_recursive_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 March 2023
# https://github.com/trizen

# Generate Carmichael numbers from a given multiple.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub carmichael_from_multiple ($m, $callback, $reps = 1e4) {

    my $t = Math::GMPz::Rmpz_init();
    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    is_square_free($m) || return;

    my $L = lcm(map { subint($_, 1) } factor($m));

    $m = Math::GMPz->new("$m");
    $L = Math::GMPz->new("$L");

    Math::GMPz::Rmpz_invert($v, $m, $L) || return;

    for (my $p = Math::GMPz::Rmpz_init_set($v) ; --$reps >= 0 ; Math::GMPz::Rmpz_add($p, $p, $L)) {

        Math::GMPz::Rmpz_gcd($t, $m, $p);
        Math::GMPz::Rmpz_cmp_ui($t, 1) == 0 or next;

        my @factors = factor_exp($p);
        (vecall { $_->[1] == 1 } @factors) || next;

        Math::GMPz::Rmpz_mul($v, $m, $p);
        Math::GMPz::Rmpz_sub_ui($u, $v, 1);

        Math::GMPz::Rmpz_set_str($t, lcm(map { subint($_->[0], 1) } @factors), 10);

        if (Math::GMPz::Rmpz_divisible_p($u, $t)) {
            $callback->(Math::GMPz::Rmpz_init_set($v));
        }
    }
}

my @list = (vecprod(5, 7, 13, 17, 19, 23));

while (@list) {
    my $m = shift(@list);
    carmichael_from_multiple(
        $m,
        sub ($n) {
            say $n;
            push @list, $n;
        }
    );
}


================================================
FILE: Math/carmichael_numbers_generation_erdos_method.pl
================================================
#!/usr/bin/perl

# Erdos construction method for Carmichael numbers:
#   1. Choose an even integer L with many prime factors.
#   2. Let P be the set of primes d+1, where d|L and d+1 does not divide L.
#   3. Find a subset S of P such that prod(S) == 1 (mod L). Then prod(S) is a Carmichael number.

# Alternatively:
#   3. Find a subset S of P such that prod(S) == prod(P) (mod L). Then prod(P) / prod(S) is a Carmichael number.

use 5.020;
use warnings;
use ntheory qw(:all);
use experimental qw(signatures);

# Modular product of a list of integers
sub vecprodmod ($arr, $mod) {
    my $prod = 1;
    foreach my $k (@$arr) {
        $prod = mulmod($prod, $k, $mod);
    }
    $prod;
}

# Primes p such that p-1 divides L and p does not divide L
sub lambda_primes ($L) {
    grep { $L % $_ != 0 } grep { $_ > 2 and is_prime($_) } map { $_ + 1 } divisors($L);
}

sub method_1 ($L) {     # smallest numbers first

    my @P = lambda_primes($L);

    foreach my $k (3 .. @P) {
        forcomb {
            if (vecprodmod([@P[@_]], $L) == 1) {
                say vecprod(@P[@_]);
            }
        } scalar(@P), $k;
    }
}

sub method_2 ($L) {     # largest numbers first

    my @P = lambda_primes($L);
    my $B = vecprodmod(\@P, $L);
    my $T = vecprod(@P);

    foreach my $k (1 .. (@P-3)) {
        forcomb {
            if (vecprodmod([@P[@_]], $L) == $B) {
                my $S = vecprod(@P[@_]);
                say ($T / $S) if ($T != $S);
            }
        } scalar(@P), $k;
    }
}

method_1(720);
method_2(720);

__END__
15841
115921
488881
41041
172081
5310721
12262321
16778881
18162001
76595761
609865201
133205761
561777121
1836304561
832060801
1932608161
20064165121
84127131361
354725143201
1487328704641
3305455474321
1945024664401
2110112460001
8879057210881
65121765643441
30614445878401


================================================
FILE: Math/carmichael_numbers_generation_erdos_method_dynamic_programming.pl
================================================
#!/usr/bin/perl

# Erdos construction method for Carmichael numbers:
#   1. Choose an even integer L with many prime factors.
#   2. Let P be the set of primes d+1, where d|L and d+1 does not divide L.
#   3. Find a subset S of P such that prod(S) == 1 (mod L). Then prod(S) is a Carmichael number.

# Alternatively:
#   3. Find a subset S of P such that prod(S) == prod(P) (mod L). Then prod(P) / prod(S) is a Carmichael number.

use 5.036;
use Math::GMPz qw();
use ntheory    qw(:all);

# Primes p such that p-1 divides L and p does not divide L
sub lambda_primes ($L) {
    grep { $_ > 2 and $L % $_ != 0 and is_prime($_) } map { $_ + 1 } divisors($L);
}

sub method_1 ($L, $callback) {    # smallest numbers first

    my @P = lambda_primes($L);
    my @d = (Math::GMPz->new(1));

    foreach my $p (@P) {

        my @t;
        foreach my $u (@d) {
            my $t = $u * $p;
            push(@t, $t);
            if ($t % $L == 1) {
                $callback->($t);
            }
        }

        push @d, @t;
    }

    return;
}

sub method_2 ($L, $callback) {    # largest numbers first

    my @P = lambda_primes($L);
    my @d = (Math::GMPz->new(1));

    my $T = Math::GMPz->new(vecprod(@P));
    my $s = $T % $L;

    foreach my $p (@P) {

        my @t;
        foreach my $u (@d) {
            my $t = $u * $p;
            push(@t, $t);
            if ($t % $L == $s) {
                $callback->($T / $t) if ($T != $t);
            }
        }

        push @d, @t;
    }

    return;
}

method_1(720, sub ($c) { say $c });
method_2(720, sub ($c) { say $c });

__END__
41041
172081
15841
16778881
832060801
5310721
76595761
488881
20064165121
84127131361
561777121
18162001
115921
1932608161
133205761
1836304561
12262321
30614445878401
2110112460001
609865201
1945024664401
8879057210881
354725143201
3305455474321
1487328704641
65121765643441


================================================
FILE: Math/carmichael_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 August 2022
# Edit: 09 March 2026
# https://github.com/trizen

# Generate all the Carmichael numbers with n prime factors in a given range [a,b].

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (in range) (simple):
#   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)));

# PARI/GP program (in range) (fast):
#   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)));

# PARI/GP program to generate all the Carmichael numbers <= n (fast):
#   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);
#   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));

use 5.036;
use ntheory 0.74 qw(:all);

sub carmichael_numbers_in_range ($A, $B, $k) {

    $A = vecmax($A, pn_primorial($k + 1) >> 1);

    # Largest possisble prime factor for Carmichael numbers <= B
    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;

    my @list;

    sub ($m, $L, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        $lo > $hi && return;

        # Pinch's bound for the second to last prime
        if ($k == 2 and $m < 1_000) {
            my $bound = 2 * $m * $m - 3 * $m + 2;
            if ($hi > $bound) {
                $hi = $bound;
                $lo > $hi && return;
            }
        }

        if ($k == 1) {

            $hi = $m     if ($m < $hi);       # the last prime p_k must be <= m
            $hi = $max_p if ($max_p < $hi);
            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            my $inv_m = invmod($m, $L);
            $inv_m > $hi && return;

            my $t = $inv_m;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);
            $t > $hi && return;

            if (divint($hi - $t, $L) < 1_000) {

                # Approach 1: Fast linear scan for small search spaces
                for (my $p = $t ; $p <= $hi ; $p += $L) {
                    if (($m * $p - 1) % ($p - 1) == 0 and is_prime($p)) {
                        push @list, $m * $p;
                    }
                }
            }
            else {
                # Approach 2: Combinatorial divisor extraction for large spaces
                foreach my $d (divisors($m - 1, $hi)) {
                    my $p = $d + 1;

                    next if $p < $lo;
                    last if $p > $hi;

                    # Only check the congruence and primality
                    if ($p % $L == $inv_m and is_prime($p)) {
                        push @list, $m * $p;
                    }
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {
            if (gcd($m, $p >> 1) == 1) {
                __SUB__->($m * $p, lcm($L, $p - 1), $p + 1, $k - 1);
            }
        }
      }
      ->(1, 1, 3, $k);

    return sort { $a <=> $b } @list;
}

my $from = 1;
my $upto = powint(10, 10);

foreach my $k (3 .. 7) {
    my @arr = carmichael_numbers_in_range($from, $upto, $k);
    say "There are: ", scalar(@arr), " Carmichael numbers <= $upto with $k prime factors";
}

__END__
There are: 335 Carmichael numbers <= 10000000000 with 3 prime factors
There are: 619 Carmichael numbers <= 10000000000 with 4 prime factors
There are: 492 Carmichael numbers <= 10000000000 with 5 prime factors
There are: 99 Carmichael numbers <= 10000000000 with 6 prime factors
There are: 2 Carmichael numbers <= 10000000000 with 7 prime factors


================================================
FILE: Math/carmichael_numbers_in_range_from_prime_factors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 September 2022
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub carmichael_numbers_in_range ($A, $B, $k, $primes, $callback) {

    $A = vecmax($A, pn_primorial($k));

    # Largest possisble prime factor for Carmichael numbers <= B
    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;

    my @P   = sort { $a <=> $b } grep { $_ <= $max_p } vecuniq(@$primes);
    my $end = $#P;

    sub ($m, $lambda, $j, $k) {

        my $y = vecmin($max_p, rootint(divint($B, $m), $k));

        if ($k == 1) {

            my $x = cdivint($A, $m);

            if ($P[-1] < $x) {
                return;
            }

            foreach my $i ($j .. $end) {
                my $p = $P[$i];

                last if ($p > $y);
                next if ($p < $x);

                my $t = $m * $p;

                if (($t - 1) % $lambda == 0 and ($t - 1) % ($p - 1) == 0) {
                    $callback->($t);
                }
            }

            return;
        }

        foreach my $i ($j .. $end) {
            my $p = $P[$i];
            last if ($p > $y);

            gcd($m, $p - 1) == 1 or next;

            # gcd($m*$p, euler_phi($m*$p)) == 1 or die "$m*$p: not cyclic";

            __SUB__->($m * $p, lcm($lambda, $p - 1), $i + 1, $k - 1);
        }
      }
      ->(1, 1, 0, $k);
}

my $lambda = 5040;
my @primes = grep { $_ > 2 and $lambda % $_ != 0 and is_prime($_) } map { $_ + 1 } divisors($lambda);

foreach my $k (3 .. 6) {
    my @arr;
    carmichael_numbers_in_range(1, 10**(2 * $k), $k, \@primes, sub ($n) { push @arr, $n });
    say "$k: ", join(', ', sort { $a <=> $b } @arr);
}

__END__
3: 29341, 115921, 399001, 488881
4: 75361, 552721, 852841, 1569457, 3146221, 5310721, 8927101, 12262321, 27402481, 29020321, 49333201, 80282161
5: 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
6: 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


================================================
FILE: Math/carmichael_numbers_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 February 2023
# Edit: 09 March 2026
# https://github.com/trizen

# Generate all the Carmichael numbers with n prime factors in a given range [a,b].

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (in range) (simple):
#   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)));

# PARI/GP program (in range) (faster):
#   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)));

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub carmichael_numbers_in_range ($A, $B, $k) {

    $A = vecmax($A, pn_primorial($k + 1) >> 1);

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    # max_p = floor((1 + sqrt(8*B + 1))/4)
    my $max_p = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul_2exp($max_p, $B, 3);
    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);
    Math::GMPz::Rmpz_sqrt($max_p, $max_p);
    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);
    Math::GMPz::Rmpz_div_2exp($max_p, $max_p, 2);
    $max_p = Math::GMPz::Rmpz_get_ui($max_p) if Math::GMPz::Rmpz_fits_ulong_p($max_p);

    my @list;

    sub ($m, $L, $lo, $k) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        Math::GMPz::Rmpz_fits_ulong_p($u) || die "Too large value!";

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        $lo > $hi && return;

        # Pinch's bound for the second to last prime
        if ($k == 2 and Math::GMPz::Rmpz_cmp_ui($m, 1_000) <= 0) {
            my $m_ui  = Math::GMPz::Rmpz_get_ui($m);
            my $bound = 2 * $m_ui * $m_ui - 3 * $m_ui + 2;
            if ($hi > $bound) {
                $hi = $bound;
                $lo > $hi && return;
            }
        }

        if ($k == 1) {

            $hi = $max_p                      if ($max_p < $hi);
            $hi = Math::GMPz::Rmpz_get_ui($m) if (Math::GMPz::Rmpz_cmp_ui($m, $hi) < 0);
            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            Math::GMPz::Rmpz_invert($v, $m, $L);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;

            my $inv_m = $t;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);
            $t > $hi && return;

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime($p)) {
                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                    Math::GMPz::Rmpz_sub_ui($u, $v, 1);
                    if (Math::GMPz::Rmpz_divisible_ui_p($u, $p - 1)) {
                        push @list, Math::GMPz::Rmpz_init_set($v);
                    }
                }
            }

            return;
        }

        my $z   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p >> 1) == 1 or next;
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $p - 1);
            Math::GMPz::Rmpz_mul_ui($z, $m, $p);

            __SUB__->($z, $lcm, $p + 1, $k - 1);
        }
      }
      ->(Math::GMPz->new(1), Math::GMPz->new(1), 3, $k);

    return sort { $a <=> $b } @list;
}

my $from = 1;
my $upto = powint(10, 10);

foreach my $k (3 .. 7) {
    my @arr = carmichael_numbers_in_range($from, $upto, $k);
    say "There are: ", scalar(@arr), " Carmichael numbers <= $upto with $k prime factors";
}

__END__
There are: 335 Carmichael numbers <= 10000000000 with 3 prime factors
There are: 619 Carmichael numbers <= 10000000000 with 4 prime factors
There are: 492 Carmichael numbers <= 10000000000 with 5 prime factors
There are: 99 Carmichael numbers <= 10000000000 with 6 prime factors
There are: 2 Carmichael numbers <= 10000000000 with 7 prime factors


================================================
FILE: Math/carmichael_numbers_random.pl
================================================
#!/usr/bin/perl

# 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.

# See also:
#   https://oeis.org/A033502 -- Carmichael numbers of the form (6*k+1)*(12*k+1)*(18*k+1)
#   https://oeis.org/A255441 -- Carmichael numbers of the form (60k+41)(90k+61)(150k+101)
#   https://oeis.org/A255514 -- Carmichael numbers of the form (24*k+13)*(72*k+37)*(192*k+97)
#   https://oeis.org/A182085 -- Carmichael numbers of the form (30k+7)*(60k+13)*(150k+31)
#   https://oeis.org/A182088 -- Carmichael numbers of the form (30n-29)*(60n-59)*(90n-89)*(180n-179)
#   https://oeis.org/A182132 -- Carmichael numbers of the form (30n-7)*(90n-23)*(300n-79)
#   https://oeis.org/A182133 -- Carmichael numbers of the form (30n-17)*(90n-53)*(150n-89)
#   https://oeis.org/A182416 -- Carmichael numbers of the form (60k+13)*(180k+37)*(300k+61)

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;
use Math::Prime::Util::GMP qw(is_prob_prime vecprod random_ndigit_prime);

sub random_carmichael_number ($n = 20) {

    $n = 2 if ($n <= 1);

    while (1) {
        my $p = Math::GMPz::Rmpz_init_set_str(random_ndigit_prime($n), 10);
        my $k = ($p - 1);
        is_prob_prime(2*$k + 1) && is_prob_prime(3*$k + 1) or next;
        return ($p, 2*$k + 1, 3*$k + 1);
    }
}

foreach my $n (2 .. 20) {

    my @factors    = random_carmichael_number($n);
    my $carmichael = vecprod(@factors);

    say "$carmichael = ", join(' * ', @factors);
}

__END__
294409 = 37 * 73 * 109
56052361 = 211 * 421 * 631
71171308081 = 2281 * 4561 * 6841
129140929242289 = 27817 * 55633 * 83449
472631192510407921 = 428671 * 857341 * 1286011
27572283826108082569 = 1662547 * 3325093 * 4987639
345721500688805466654601 = 38624101 * 77248201 * 115872301
130699973774636844248473489 = 279281017 * 558562033 * 837843049
27673744421175202436239020169 = 1664583397 * 3329166793 * 4993750189
328972311969416805526009802207569 = 37990006297 * 75980012593 * 113970018889
2154063839571860482226489311256938129 = 710726387407 * 1421452774813 * 2132179162219
570115866940668362539466801338334994649 = 4563211789627 * 9126423579253 * 13689635368879
1782421577597012564570834220077888509756969 = 66724663694947 * 133449327389893 * 200173991084839
52582793280275762357474570728765725923205529 = 206172530234557 * 412345060469113 * 618517590703669
278521214364869103131896930517366707497856421161 = 3593925000970261 * 7187850001940521 * 10781775002910781
1033219900193456185960963387986087314925660018643009 = 55634881918514887 * 111269763837029773 * 166904645755544659
1081644507889807242059050179401322818854661656619742361 = 564908053691846461 * 1129816107383692921 * 1694724161075539381
341413647754278719970853443358101430514668165478272427161 = 3846300480078170011 * 7692600960156340021 * 11538901440234510031
6271289738172907436343660234664403558286290715038000756209 = 10148500369293939337 * 20297000738587878673 * 30445501107881818009


================================================
FILE: Math/carmichael_strong_fermat_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 September 2022
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

=for comment

# PARI/GP program:
carmichael_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 && Mod(base, q)^(((q-1)>>tv)<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));

=cut

use 5.036;
use ntheory 0.74 qw(:all);

sub carmichael_strong_fermat_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k + 1) >> 1);

    if ($A > $B) {
        return;
    }

    # Largest possisble prime factor for Carmichael numbers <= B
    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;

    my @list;

    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {

        my $hi = vecmin($max_p, rootint(divint($B, $m), $k));

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            my $t = invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (($m * $p - 1) % ($p - 1) == 0 and is_prime($p) and $base % $p != 0) {
                    my $val = valuation($p - 1, 2);
                    if ($val > $k_exp and powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p)) {
                        push @list, $m * $p;
                    }
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            gcd($m, $p - 1) == 1 or next;
            $base % $p == 0 and next;

            my $val = valuation($p - 1, 2);
            $val > $k_exp                                                   or next;
            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

            # gcd($m*$p, euler_phi($m*$p)) == 1 or die "$m*$p: not cyclic";

            __SUB__->($m * $p, lcm($L, $p - 1), $p + 1, $k - 1, $k_exp, $congr);
        }
    };

    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.
    $generator->(1, 1, 3, $k, 0, 1);

    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.
    foreach my $v (0 .. logint($B, 2)) {
        $generator->(1, 1, 3, $k, $v, -1);
    }

    return sort { $a <=> $b } @list;
}

# Generate all the 3-Carmichael numbers in the range [1, 10^8] that are also strong pseudoprimes to base 2.

my $k    = 3;
my $base = 2;
my $from = 1;
my $upto = 1e8;

my @arr = carmichael_strong_fermat_in_range($from, $upto, $k, $base);
say join(', ', @arr);

__END__
15841, 29341, 52633, 252601, 314821, 1909001, 3581761, 4335241, 5049001, 5444489, 15247621, 29111881, 35703361, 36765901, 53711113, 68154001, 99036001


================================================
FILE: Math/carmichael_strong_fermat_pseudoprimes_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 March 2023
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

=for comment

# PARI/GP program:

carmichael_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 && Mod(base, q)^(((q-1)>>tv)<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));

=cut

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub carmichael_strong_fermat_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, Math::GMPz->new(pn_primorial($k)));

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    $A > $B and return;

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    # max_p = floor((1 + sqrt(8*B + 1))/4)
    my $max_p = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul_2exp($max_p, $B, 3);
    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);
    Math::GMPz::Rmpz_sqrt($max_p, $max_p);
    Math::GMPz::Rmpz_add_ui($max_p, $max_p, 1);
    Math::GMPz::Rmpz_div_2exp($max_p, $max_p, 2);
    $max_p = Math::GMPz::Rmpz_get_ui($max_p) if Math::GMPz::Rmpz_fits_ulong_p($max_p);

    my @list;

    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        Math::GMPz::Rmpz_fits_ulong_p($u) || die "Too large value!";

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $hi = $max_p if ($max_p < $hi);
            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            Math::GMPz::Rmpz_invert($v, $m, $L);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime($p)) {
                    my $valuation = valuation($p - 1, 2);
                    if ($valuation > $k_exp and powmod($base, ($p - 1) >> ($valuation - $k_exp), $p) == ($congr % $p)) {
                        Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                        Math::GMPz::Rmpz_sub_ui($u, $v, 1);
                        if (Math::GMPz::Rmpz_divisible_ui_p($u, $p - 1)) {
                            push(@list, Math::GMPz::Rmpz_init_set($v));
                        }
                    }
                }
            }

            return;
        }

        my $z   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;
            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p - 1) == 1 or next;

            my $valuation = valuation($p - 1, 2);
            $valuation > $k_exp                                                   or next;
            powmod($base, ($p - 1) >> ($valuation - $k_exp), $p) == ($congr % $p) or next;

            Math::GMPz::Rmpz_mul_ui($z, $m, $p);
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $p - 1);

            __SUB__->($z, $lcm, $p + 1, $k - 1, $k_exp, $congr);
        }
    };

    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.
    foreach my $v (0 .. logint($B, 2)) {
        $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, $v, -1);
    }

    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.
    $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, 0, 1);

    return sort { $a <=> $b } @list;
}

# Generate all the 3-Carmichael numbers in the range [1, 10^8] that are also strong pseudoprimes to base 2.

my $k    = 3;
my $base = 2;
my $from = 1;
my $upto = 1e8;

my @arr = carmichael_strong_fermat_in_range($from, $upto, $k, $base);
say join(', ', @arr);

__END__
15841, 29341, 52633, 252601, 314821, 1909001, 3581761, 4335241, 5049001, 5444489, 15247621, 29111881, 35703361, 36765901, 53711113, 68154001, 99036001


================================================
FILE: Math/cartesian_product_iter.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 April 2017
# https://github.com/trizen

# Iterative algorithm for computing the Cartesian product.

# Algorithm from:
#   https://stackoverflow.com/a/10947389

use 5.016;
use warnings;

sub cartesian(&@) {
    my ($callback, @arrs) = @_;

    my ($more, @lengths);

    foreach my $arr (@arrs) {
        my $end = $#{$arr};

        if ($end >= 0) {
            $more ||= 1;
        }
        else {
            $more = 0;
            last;
        }

        push @lengths, $end;
    }

    my @temp;
    my @indices = (0) x @arrs;

    while ($more) {
        @temp = @indices;

        for (my $i = $#indices ; $i >= 0 ; --$i) {
            if ($indices[$i] == $lengths[$i]) {
                $indices[$i] = 0;
                $more = 0 if $i == 0;
            }
            else {
                ++$indices[$i];
                last;
            }
        }

        $callback->(map { $_->[CORE::shift(@temp)] } @arrs);
    }
}

cartesian {
    say "@_";
} (['a', 'b'], ['c', 'd', 'e'], ['f', 'g']);


================================================
FILE: Math/cartesian_product_rec.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 April 2017
# https://github.com/trizen

# Recursive algorithm for computing the Cartesian product.

# Algorithm from Math::Cartesian::Product
#   https://metacpan.org/pod/Math::Cartesian::Product

use 5.016;
use warnings;

sub cartesian(&@) {
    my ($callback, @C) = @_;
    my (@c, @r);

    sub {
        if (@c < @C) {
            for my $item (@{$C[@c]}) {
                CORE::push(@c, $item);
                __SUB__->();
                CORE::pop(@c);
            }
        }
        else {
            $callback->(@c);
        }
      }
      ->();
}

cartesian {
    say "@_";
} (['a', 'b'], ['c', 'd', 'e'], ['f', 'g']);


================================================
FILE: Math/cauchy_numbers_of_first_type.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 09 February 2018
# https://github.com/trizen

# A new algorithm for computing the Cauchy numbers of first type.

# See also:
#   https://oeis.org/A006232    (numerators)
#   https://oeis.org/A006233    (denominators)

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload factorial);

sub cauchy_numbers {
    my ($n) = @_;

    my @C = (1);

    foreach my $i (1 .. $n) {
        foreach my $k (0 .. $i - 1) {
            $C[$i] -= $C[$k] / ($i - $k + 1);
        }
    }

    map { (-1)**$_ * $C[$_] * factorial($_) } 0 .. $#C;
}

my @cauchy = cauchy_numbers(30);

foreach my $i (0 .. $#cauchy) {
    printf "C(%2d) = %40s / %s\n", $i, $cauchy[$i]->nude;
}

__END__
C( 0) =                                        1 / 1
C( 1) =                                        1 / 2
C( 2) =                                       -1 / 6
C( 3) =                                        1 / 4
C( 4) =                                      -19 / 30
C( 5) =                                        9 / 4
C( 6) =                                     -863 / 84
C( 7) =                                     1375 / 24
C( 8) =                                   -33953 / 90
C( 9) =                                    57281 / 20
C(10) =                                 -3250433 / 132
C(11) =                                  1891755 / 8
C(12) =                             -13695779093 / 5460
C(13) =                              24466579093 / 840
C(14) =                            -132282840127 / 360
C(15) =                             240208245823 / 48
C(16) =                         -111956703448001 / 1530
C(17) =                            4573423873125 / 4
C(18) =                       -30342376302478019 / 1596
C(19) =                        56310194579604163 / 168
C(20) =                    -12365722323469980029 / 1980
C(21) =                    161867055619224199787 / 1320
C(22) =                 -20953816286242674495191 / 8280
C(23) =                   4380881778942163832799 / 80
C(24) =             -101543126947618093900697699 / 81900
C(25) =              192060902780872132330221667 / 6552
C(26) =            -1092286933245454564213092649 / 1512
C(27) =             2075032177476967189228515625 / 112
C(28) =         -1718089509598695642524656240811 / 3480
C(29) =          1092041494691940355778302728249 / 80
C(30) =     -44810233755305010150728029810063187 / 114576


================================================
FILE: Math/chebyshev_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 January 2020
# https://github.com/trizen

# A simple factorization method, using the Chebyshev T_n(x) polynomials, based on the identity:
#   T_{m n}(x) = T_m(T_n(x))

# where:
#   T_n(x) = (1/2) * V_n(2x, 1)

# where V_n(P, Q) is the Lucas V sequence.

# See also:
#   https://oeis.org/A001075
#   https://en.wikipedia.org/wiki/Lucas_sequence
#   https://en.wikipedia.org/wiki/Iterated_function
#   https://en.wikipedia.org/wiki/Chebyshev_polynomials

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory      qw(prime_iterator sqrtint primes logint);
use Math::AnyNum qw(:overload lucasVmod gcd invmod mulmod is_coprime);

sub chebyshev_factorization ($n, $B = logint($n, 2)**2, $a = 127) {

    my $x = $a;
    my $G = $B * $B;
    my $i = invmod(2, $n);

    my sub chebyshevTmod ($a, $x) {
        mulmod(lucasVmod(2 * $x, 1, $a, $n), $i, $n);
    }

    foreach my $p (@{primes(2, sqrtint($B))}) {
        for (1 .. logint($G, $p)) {
            $x = chebyshevTmod($p, $x);    # T_k(x) (mod n)
        }
    }

    my $it = prime_iterator(sqrtint($B) + 1);
    for (my $p = $it->() ; $p <= $B ; $p = $it->()) {
        $x = chebyshevTmod($p, $x);        # T_k(x) (mod n)
        is_coprime($x - 1, $n) || return gcd($x - 1, $n);
    }

    return gcd($x - 1, $n);
}

say chebyshev_factorization(2**64 + 1,                     20);      #=> 274177           (p-1 is   20-smooth)
say chebyshev_factorization(257221 * 470783,               1000);    #=> 470783           (p-1 is 1000-smooth)
say chebyshev_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)
say chebyshev_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)

say '';

say chebyshev_factorization(333732865481 * 1632480277613, 3000);     #=> 333732865481     (p-1 is 3000-smooth)
say chebyshev_factorization(15597344393 * 12388291753,    3000);     #=> 15597344393      (p-1 is 3000-smooth)
say chebyshev_factorization(43759958467 * 59037829639,    3200);     #=> 43759958467      (p+1 is 3200-smooth)
say chebyshev_factorization(112601635303 * 83979783007,   700);      #=> 112601635303     (p-1 is  700-smooth)
say chebyshev_factorization(228640480273 * 224774973299,  2000);     #=> 228640480273     (p-1 is 2000-smooth)

say '';

say chebyshev_factorization(5140059121 * 8382882743,     2500);      #=> 5140059121       (p-1 is 2500-smooth)
say chebyshev_factorization(18114813019 * 17402508649,   6000);      #=> 18114813019      (p+1 is 6000-smooth)
say chebyshev_factorization(533091092393 * 440050095029, 300);       #=> 533091092393     (p+1 is  300-smooth)


================================================
FILE: Math/chebyshev_factorization_method_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 June 2020
# https://github.com/trizen

# A simple factorization method, using the Chebyshev T_n(x) polynomials, based on the identity:
#   T_{m n}(x) = T_m(T_n(x))

# where:
#   T_n(x) = (1/2) * V_n(2x, 1)

# where V_n(P, Q) is the Lucas V sequence.

# See also:
#   https://oeis.org/A001075
#   https://en.wikipedia.org/wiki/Lucas_sequence
#   https://en.wikipedia.org/wiki/Iterated_function
#   https://en.wikipedia.org/wiki/Chebyshev_polynomials

use 5.020;
use warnings;

use Math::GMPz;
use ntheory      qw(:all);
use experimental qw(signatures);

sub fast_lucasVmod ($P, $n, $m) {    # assumes Q = 1

    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));

    foreach my $bit (todigits($n, 2)) {

        if ($bit) {
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);
            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);
            Math::GMPz::Rmpz_sub($V1, $V1, $P);
            Math::GMPz::Rmpz_sub_ui($V2, $V2, 2);
            Math::GMPz::Rmpz_mod($V1, $V1, $m);
        }
        else {
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
            Math::GMPz::Rmpz_sub($V2, $V2, $P);
            Math::GMPz::Rmpz_sub_ui($V1, $V1, 2);
            Math::GMPz::Rmpz_mod($V2, $V2, $m);
        }
    }

    Math::GMPz::Rmpz_mod($V1, $V1, $m);

    return $V1;
}

sub chebyshev_factorization ($n, $B, $A = 127) {

    # The Chebyshev factorization method, taking
    # advantage of the smoothness of p-1 or p+1.

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $x = Math::GMPz::Rmpz_init_set_ui($A);
    my $i = Math::GMPz::Rmpz_init_set_ui(2);

    Math::GMPz::Rmpz_invert($i, $i, $n);

    my sub chebyshevTmod ($A, $x) {
        Math::GMPz::Rmpz_mul_2exp($x, $x, 1);
        Math::GMPz::Rmpz_set($x, fast_lucasVmod($x, $A, $n));
        Math::GMPz::Rmpz_mul($x, $x, $i);
        Math::GMPz::Rmpz_mod($x, $x, $n);
    }

    my $g   = Math::GMPz::Rmpz_init();
    my $lnB = log($B);

    foreach my $p (@{primes(sqrtint($B))}) {
        chebyshevTmod($p**int($lnB / log($p)), $x);
    }

    my $it = prime_iterator(sqrtint($B) + 1);
    for (my $p = $it->() ; $p <= $B ; $p = $it->()) {

        chebyshevTmod($p, $x);    # T_k(x) (mod n)

        Math::GMPz::Rmpz_sub_ui($g, $x, 1);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return 1 if (Math::GMPz::Rmpz_cmp($g, $n) == 0);
            return $g;
        }
    }

    return 1;
}

foreach my $n (
#<<<
    Math::GMPz->new("4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271"),
    Math::GMPz->new("2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151"),
    Math::GMPz->new("850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733"),
#>>>
  ) {

    say "\n:: Factoring: $n";

    until (is_prime($n)) {

        my $x = int(rand(1e6));
        my $p = chebyshev_factorization($n, 500_000, $x);

        if ($p > 1) {
            say "-> Found factor: $p";
            $n /= $p;
        }
    }
}

__END__
:: Factoring: 4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271
-> Found factor: 31935028572177122017
-> Found factor: 441214532298715667413
-> Found factor: 515113549791151291993
-> Found factor: 896466791041143516471427
-> Found factor: 12993757635350024510533

:: Factoring: 2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151
-> Found factor: 1927199759971282921
-> Found factor: 85625333993726265061
-> Found factor: 2490501032020173490009
-> Found factor: 765996534730183701229
-> Found factor: 58637507352579687279739
-> Found factor: 4393290631695328772611

:: Factoring: 850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733
-> Found factor: 556010720288850785597
-> Found factor: 33311699120128903709
-> Found factor: 341190041753756943379
-> Found factor: 182229202433843943841
-> Found factor: 55554864549706093104640631
-> Found factor: 7672247345452118779313
-> Found factor: 386663601339343857313
-> Found factor: 5658991130760772523
-> Found factor: 1021051300200039481


================================================
FILE: Math/chernick-carmichael_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 May 2019
# https://github.com/trizen

# Generate the smallest extended Chernick-Carmichael number with n prime factors.

# OEIS sequence:
#   https://oeis.org/A318646 -- The least Chernick's "universal form" Carmichael number with n prime factors.

# See also:
#   https://oeis.org/wiki/Carmichael_numbers
#   https://www.ams.org/journals/bull/1939-45-04/S0002-9904-1939-06953-X/home.html

use 5.020;
use warnings;
use ntheory qw(:all);
use experimental qw(signatures);

# Generate the factors of a Chernick-Carmichael number
sub chernick_carmichael_factors ($n, $m) {
    (6*$m + 1, 12*$m + 1, (map { ((9*$m) << $_) + 1 } 1 .. $n - 2));
}

# Check the conditions for an extended Chernick-Carmichael number
sub is_chernick_carmichael ($n, $m) {
    foreach my $k (2 .. $n-2) {
        is_prime(((9*$m) << $k) + 1) || return 0;
    }
    return 1;
}

# Find the smallest Chernick-Carmichael number with n prime factors.
sub chernick_carmichael_number ($n, $callback) {

    # `m` must be divisible by 2^(n-4), for n > 4
    my $multiplier = ($n > 4) ? (1 << ($n - 4)) : 1;

    # Optimization for n > 5
    $multiplier *= 5 if ($n > 5);

    for (my $k = 1 ; ; ++$k) {
        my $m = $k * $multiplier;
        if (is_prime(6*$m + 1) and is_prime(12*$m + 1) and is_prime(18*$m + 1) and is_chernick_carmichael($n, $m)) {
            $callback->(chernick_carmichael_factors($n, $m));
            last;
        }
    }
}

foreach my $n (3 .. 9) {
    chernick_carmichael_number($n, sub (@f) { say "a($n) = ", vecprod(@f) });
}

__END__
a(3) = 1729
a(4) = 63973
a(5) = 26641259752490421121
a(6) = 1457836374916028334162241
a(7) = 24541683183872873851606952966798288052977151461406721
a(8) = 53487697914261966820654105730041031613370337776541835775672321
a(9) = 58571442634534443082821160508299574798027946748324125518533225605795841


================================================
FILE: Math/chernick-carmichael_numbers_below_limit.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 July 2018
# https://github.com/trizen

# Generate all the extended Chernick's Carmichael numbers below a certain limit.

# OEIS sequences:
#   https://oeis.org/A317126
#   https://oeis.org/A317136

# See also:
#   https://oeis.org/wiki/Carmichael_numbers
#   https://www.ams.org/journals/bull/1939-45-04/S0002-9904-1939-06953-X/home.html

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

# Generate the factors of a Chernick number, given n
# and m, where n is the number of distinct prime factors.
sub chernick_carmichael_factors ($n, $m) {
    (6*$m + 1, 12*$m + 1, (map { (1 << $_) * 9*$m + 1 } 1 .. $n-2));
}

# Check the conditions for an extended Chernick-Carmichael number
sub is_chernick_carmichael ($n, $m) {
    ($n == 2) ? (is_prime(6*$m + 1) && is_prime(12*$m + 1))
              : (is_prime((1 << ($n-2)) * 9*$m + 1) && __SUB__->($n-1, $m));
}

my @terms;
my $limit = 0 + ($ARGV[0] // 10**15);

# Generate terms with k distinct prime factors
for (my $n = 3 ; ; ++$n) {

    # We can stop the search when:
    #   (6*m + 1) * (12*m + 1) * Product_{i=1..n-2} (9 * 2^i * m + 1)
    # is greater than the limit, for m=1.
    last if vecprod(chernick_carmichael_factors($n, 1)) > $limit;

    # Set the multiplier, based on the condition that `m` has to be divisible by 2^(k-4).
    my $multiplier = ($n > 4) ? (1 << ($n-4)) : 1;

    # Optimization for n > 5
    $multiplier *= 5 if ($n > 5);

    # Generate the extended Chernick numbers with n distinct prime factors,
    # that are also Carmichael numbers, below the limit we're looking for.
    for (my $k = 1 ; ; ++$k) {

        my $m = $multiplier * $k;

        # All factors must be prime
        is_chernick_carmichael($n, $m) || next;

        # Get the prime factors
        my @f = chernick_carmichael_factors($n, $m);

        # The product of these primes, gives a Carmichael number
        my $c = vecprod(@f);
        last if $c > $limit;
        push @terms, $c;
    }
}

# Sort the terms
my @final_terms = sort { $a <=> $b } @terms;

# Display the terms
foreach my $k (0 .. $#final_terms) {
    say($k + 1, ' ', $final_terms[$k]);
}


================================================
FILE: Math/chernick-carmichael_polynomials.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 February 2020
# https://github.com/trizen

# Generate the polynomials for the extended Chernick-Carmichael numbers with n prime factors.

# OEIS sequence:
#   https://oeis.org/A318646 -- The least Chernick's "universal form" Carmichael number with n prime factors.

# See also:
#   https://oeis.org/wiki/Carmichael_numbers
#   https://www.ams.org/journals/bull/1939-45-04/S0002-9904-1939-06953-X/home.html

# The ratios sum([C(n+1)]) / sum([C(n)]), are given by the OEIS sequence A083705,
#   https://oeis.org/A083705
# where sum([C(n)]) is the sum of the coefficients of the n-th Chernick-Carmichael polynomial,

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::Polynomial;
use List::Util qw(reduce);
use Math::AnyNum qw(:overload sum prod);

sub chernick_carmichael_factors ($n) {
    reduce { $a * $b } (
        Math::Polynomial->new(1, 6), Math::Polynomial->new(1, 12),
        map { Math::Polynomial->new(1, 9 << $_) } 1 .. $n - 2
    );
}

say "=> Polynomials:";
foreach my $n (3 .. 10) {
    say "C($n) = ", chernick_carmichael_factors($n);
}

say "\n=> Sum of coefficients:";
foreach my $n (3 .. 10) {
    say "sum([C($n)]) = ", sum(chernick_carmichael_factors($n)->coeff);
}

say "\n=> Product of coefficients:";
foreach my $n (3 .. 10) {
    say "prod([C($n)]) = ", prod(chernick_carmichael_factors($n)->coeff);
}

__END__
=> Polynomials:
C(3) = (1296 x^3 + 396 x^2 + 36 x + 1)
C(4) = (46656 x^4 + 15552 x^3 + 1692 x^2 + 72 x + 1)
C(5) = (3359232 x^5 + 1166400 x^4 + 137376 x^3 + 6876 x^2 + 144 x + 1)
C(6) = (483729408 x^6 + 171320832 x^5 + 20948544 x^4 + 1127520 x^3 + 27612 x^2 + 288 x + 1)
C(7) = (139314069504 x^7 + 49824129024 x^6 + 6204501504 x^5 + 345674304 x^4 + 9079776 x^3 + 110556 x^2 + 576 x + 1)
C(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)
C(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)
C(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)

=> Sum of coefficients:
sum([C(3)]) = 1729
sum([C(4)]) = 63973
sum([C(5)]) = 4670029
sum([C(6)]) = 677154205
sum([C(7)]) = 195697565245
sum([C(8)]) = 112917495146365
sum([C(9)]) = 130193871903758845
sum([C(10)]) = 300096874738164137725

=> Product of coefficients:
prod([C(3)]) = 18475776
prod([C(4)]) = 88394777100288
prod([C(5)]) = 532962603198108087091200
prod([C(6)]) = 15566146576014516344690540671590727680
prod([C(7)]) = 8607729694274768470180293645913878477204634698636066816
prod([C(8)]) = 355900510244809815184693136856938085570466396628469022965807673827511731486720
prod([C(9)]) = 4371202733642080997695663760838408017640388301504244892063249651693811055142174806499598124164351828951040
prod([C(10)]) = 63565858610074701536163462529753569644918704418351291678528316792385645865008717295355264067966620308836237036012393969126437841481288908800


================================================
FILE: Math/chernick-carmichael_with_n_factors_sieve.pl
================================================
#!/usr/bin/perl

# Sieve for Chernick's "universal form" Carmichael number with n prime factors.
# Inspired by the PARI program by David A. Corneth from OEIS A372238.

# Finding A318646(10) takes ~4 minutes.

# See also:
#   https://oeis.org/A318646
#   https://oeis.org/A372238/a372238.gp.txt

use 5.036;
use ntheory     qw(:all);
use Time::HiRes qw (time);

sub isrem($m, $p, $n) {

    ( 6 * $m + 1) % $p == 0 and ( 6 * $m + 1) > $p and return;
    (12 * $m + 1) % $p == 0 and (12 * $m + 1) > $p and return;

    foreach my $k (1 .. $n - 2) {
        my $t = (9 * $m << $k) + 1;
        if ($t % $p == 0 and $t > $p) {
            return;
        }
    }

    return 1;
}

sub remaindersmodp($p, $n) {
    grep { isrem($_, $p, $n) } (0 .. $p - 1);
}

sub remainders_for_primes($n, $primes) {

    my $res = [[0, 1]];
    my $M   = 1;

    foreach my $p (@$primes) {

        my @rems = remaindersmodp($p, $n);

        if (scalar(@rems) == $p) {
            next;    # skip trivial primes
        }

        if (!@rems) {
            @rems = (0);
        }

        my @nres;
        foreach my $r (@$res) {
            foreach my $rem (@rems) {
                push @nres, [chinese($r, [$rem, $p]), lcm($p, $r->[1])];
            }
        }
        $res = \@nres;
        $M *= $p;
    }

    return ($M, [sort { $a <=> $b } map { $_->[0] } @$res]);
}

sub is($m, $n) {

    is_prime( 6 * $m + 1) || return;
    is_prime(12 * $m + 1) || return;
    is_prime(18 * $m + 1) || return;

    foreach my $k (2 .. $n - 2) {
        is_prime((9 * $m << $k) + 1) || return;
    }

    return 1;
}

sub deltas ($integers) {

    my @deltas;
    my $prev = 0;

    foreach my $n (@$integers) {
        push @deltas, $n - $prev;
        $prev = $n;
    }

    shift(@deltas);
    return \@deltas;
}

sub chernick_carmichael_factors($m, $n) {
    (6 * $m + 1, 12 * $m + 1, (map { (9 * $m << $_) + 1 } 1 .. $n - 2));
}

sub chernick_carmichael_with_n_factors($n, $maxp = nth_prime($n)) {

    my @primes = @{primes($maxp)};

    my ($M, $r) = remainders_for_primes($n, \@primes);
    my @d = @{deltas($r)};
    my $s = vecprod(@primes);

    while (@d and $d[0] == 0) {
        shift @d;
    }

    push @d, $r->[0] + $M - $r->[-1];

    my $m      = $r->[0];
    my $d_len  = scalar(@d);
    my $t0     = time;
    my $prev_m = $m;

    my $two_power = vecmax(1 << ($n - 4), 1);

    for (my $j = 0 ; ; ++$j) {

        if ($m % $two_power == 0 and is($m, $n)) {
            return $m;
        }

        if ($j % 1e7 == 0 and $j > 0) {
            my $tdelta = time - $t0;
            say "Searching for a($n) with m = $m";
            say "Performance: ", (($m - $prev_m) / 1e9) / $tdelta, " * 10^9 terms per second";
            $t0     = time;
            $prev_m = $m;
        }

        $m += $d[$j % $d_len];
    }
}

foreach my $n (3 .. 9) {
    my $m = chernick_carmichael_with_n_factors($n);
    say "[$n] m = $m";

    foreach my $k ($n .. $n + 100) {
        my $c = vecprod(chernick_carmichael_factors($m, $k));
        if (is_carmichael($c)) {
            say "[$k] $c";
        }
        else {
            last;
        }
    }

    is_carmichael(vecprod(chernick_carmichael_factors($m, $n))) || die "not a Carmichael number";
}

__END__
[3] m = 1
[3] 1729
[4] 63973
[4] m = 1
[4] 63973
[5] m = 380
[5] 26641259752490421121
[6] 1457836374916028334162241
[6] m = 380
[6] 1457836374916028334162241
[7] m = 780320
[7] 24541683183872873851606952966798288052977151461406721
[8] m = 950560
[8] 53487697914261966820654105730041031613370337776541835775672321
[9] 58571442634534443082821160508299574798027946748324125518533225605795841
[9] m = 950560
[9] 58571442634534443082821160508299574798027946748324125518533225605795841
[10] m = 3208386195840
[10] 24616075028246330441656912428380582403261346369700917629170235674289719437963233744091978433592331048416482649086961226304033068172880278517841921


================================================
FILE: Math/chinese_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 01 June 2022
# https://github.com/trizen

# Concept for an integer factorization method based on the Chinese Remainder Theorem (CRT).

# Example:
#   n = 43*97

# We have:
#   n == 1 mod 2
#   n == 1 mod 3
#   n == 1 mod 5
#   n == 6 mod 7
#   n == 2 mod 11

# 43 = chinese(Mod(1,2), Mod(1,3), Mod(3,5), Mod(1,7))
# 97 = chinese(Mod(1,2), Mod(1,3), Mod(2,5), Mod(6,7))

# For some small primes p, we try to find pairs of a and b, such that:
#   a*b == n mod p

# Then using either the `a` or the `b` values, we can construct a factor of n, using the CRT.

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);
use Math::GMPz;

sub CRT_factor ($n) {

    return $n if is_prime($n);

    my $congruences = [0];

    my $LCM   = 1;
    my $limit = vecmin(sqrtint($n), 1e6);

    for (my $p = 2 ; $p <= $limit ; $p = next_prime($p)) {

        my $r = modint($n, $p);

        if ($r == 0) {
            return $p;
        }

        my @new_congruences;

        foreach my $c (@$congruences) {
            foreach my $d (1 .. $p - 1) {
                my $t = [$d, $p];

                my $z = chinese([$c, $LCM], $t);
                my $g = gcd($z, $n);

                if ($g > 1 and $g < $n) {
                    return $g;
                }

                push @new_congruences, $z;
            }
        }

        $LCM         = lcm($LCM, $p);
        $congruences = \@new_congruences;
    }

    return 1;
}

say CRT_factor(43 * 97);      #=> 97
say CRT_factor(503 * 863);    #=> 863

say CRT_factor(Math::GMPz->new(2)**32 + 1);    #=> 641
say CRT_factor(Math::GMPz->new(2)**64 + 1);    #=> 274177

say CRT_factor(Math::GMPz->new("273511610089"));      #=> 377827
say CRT_factor(Math::GMPz->new("24259337155997"));    #=> 5944711


================================================
FILE: Math/coin_change.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 November 2015
# Edit: 15 May 2021
# https://github.com/trizen

# The classic coin-change problem.

use 5.010;
use strict;
use warnings;

use List::Util qw(sum0);
no warnings qw(recursion);

my @denominations = (.01, .05, .1, .25, .5, 1, 2, 5, 10, 20, 50, 100);

sub change {
    my ($n, $pos, $solution) = @_;
    my $sum = sum0(@$solution);

    if ($sum == $n) {
        return $solution;    # found a solution
    }
    elsif ($sum > $n or $pos > $#denominations) {
        return;
    }

    (
        change($n, $pos + 1, $solution),
        change($n, $pos, [@$solution, $denominations[$pos]]),
    )
}

my $amount = 0.26;               # the amount of money

my @solutions = change($amount, 0, []);
print("All the possible solutions for $amount, are:\n");

my $best = $solutions[0];
foreach my $s (@solutions) {

    # Print the solutions
    print("\t[" . join(", ", @{$s}) . "]\n");

    # Find the best solution (which uses the minimum number of coins)
    if (@$s < @$best) {
        $best = $s;
    }
}

print("The best solution is: [", join(", ", @$best) . "]\n");


================================================
FILE: Math/collatz_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 06 July 2018
# https://github.com/trizen

# The following 1628-digit number: 46785696846401151 * 3^3377 requires 41763 steps to get down to 1.

# Collatz function on higher powers of 3 multiplied with n = 46785696846401151:
#      collatz(n * 3^8818) = 101856
#      collatz(n * 3^9071) = 106610
#      collatz(n * 3^9296) = 108210
#      collatz(n * 3^9586) = 110042
#      collatz(n * 3^9660) = 113569
#      collatz(n * 3^9870) = 113951

# See also:
#   https://oeis.org/A006877
#   https://oeis.org/A006577

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub collatz {
    my ($n) = @_;

    $n = Math::GMPz->new("$n");

    state $two = Math::GMPz::Rmpz_init_set_ui(2);
    my $count = Math::GMPz::Rmpz_remove($n, $n, $two);

    while (Math::GMPz::Rmpz_cmp_ui($n, 1) > 0) {

        Math::GMPz::Rmpz_mul_ui($n, $n, 3);
        Math::GMPz::Rmpz_add_ui($n, $n, 1);

        $count += 1 + Math::GMPz::Rmpz_remove($n, $n, $two);
    }

    return $count;
}

my $factor = Math::GMPz->new("46785696846401151");
my $base   = Math::GMPz->new(3);

my $max = 0;

foreach my $n (0 .. 2500) {
    my $t = collatz($factor * $base**$n);

    if ($t > $max) {
        say "collatz($factor * $base^$n) = $t";
        $max = $t;
    }
}


================================================
FILE: Math/complex_exponentiation_in_real_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 13 August 2017
# https://github.com/trizen

# Identity for complex exponentiation in real numbers, based on the identity:
#
#   exp(x*i) = cos(x) + sin(x)*i
#

use 5.010;
use strict;
use warnings;

#
## Real base and complex exponent
#
sub complex_power {
    my ($x, $r, $i) = @_;

    (
        $x**$r * cos(log($x) * $i),
        $x**$r * sin(log($x) * $i),
    )
}

#
## Complex base and complex exponent
#
sub complex_power2 {
    my ($x, $y, $r, $i) = @_;

     ($x, $y) = (log($x*$x + $y*$y) / 2, atan2($y, $x));    # log($x + $y*i)
     ($x, $y) = ($x*$r - $y*$i, $x*$i + $y*$r);             # ($x + $y*i) * ($r + $i*i)

     (exp($x) * cos($y), exp($x) * sin($y));                # exp($x + $y*i)
}

#
## Example for 12^(3+4i)
#

{
    # base
    my $x = 12;

    # exponent
    my $r = 3;
    my $i = 4;

    my ($real, $imag) = complex_power($x, $r, $i);

    say "$x^($r + $i*i) = $real + $imag*i";   #=> -1503.99463080925 + -850.872581822307*i
}

#
## Example for (5+2i)^(3+7i)
#

{
    # base
    my $x = 5;
    my $y = 2;

    # exponent
    my $r = 3;
    my $i = 7;

    my ($real, $imag) = complex_power2($x, $y, $r, $i);

    say "($x + $y*i)^($r + $i*i) = $real + $imag*i";    #=> 10.1847486230437 + 3.84152292303168*i
}


================================================
FILE: Math/complex_logarithm_in_real_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 December 2017
# https://github.com/trizen

# Identity for computing the natural logarithm of a complex number, in real numbers, with the identity:
#
#   log(a+b*i) = log(a^2 + b^2)/2 + atan(b/a)*i
#

use 5.010;
use strict;
use warnings;

sub complex_log {
    my ($re, $im) = @_;

    (
        log($re**2 + $im**2)/2,
        atan2($im, $re)
    );
}

#
## Example for log(3+5i)
#

my $re = 3;
my $im = 5;

my ($real, $imag) = complex_log($re, $im);

say "log($re + $im*i) = $real + $imag*i";   #=> 1.76318026230808 + 1.03037682652431*i


================================================
FILE: Math/complex_modular_multiplicative_inverse.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 December 2018
# https://github.com/trizen

# Algorithm for computing the modular multiplicative inverse of complex numbers:
#   1/a mod n, with |gcd(a, n)| = 1.

# Solution to `x` for:
#   a*x = 1 (mod n)

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(:overload conj round);
use experimental qw(signatures lexical_subs);

sub complex_gcd ($a, $b) {

    my ($x, $y) = ($a, $b);

    while ($b != 0) {
        my $q = round($a / $b);
        my $r = $a - $b * $q;

        ($a, $b) = ($b, $r);
    }

    return $a;
}

sub complex_modular_inverse ($a, $n) {

    my $g = complex_gcd($a, $n);

    abs($g) == 1 or return undef;

    my sub inverse ($a, $n, $i) {

        my ($u, $w) = ($i, 0);
        my ($q, $r) = (0, 0);

        my $c = $n;

        while ($c != 0) {

            $q = round($a / $c);
            $r = $a - $c * $q;

            ($a, $c) = ($c, $r);
            ($u, $w) = ($w, $u - $q * $w);
        }

        return $u % $n;
    }

    (grep { ($_ * $a) % $n == 1 } map { inverse($a, $n, $_) } (conj($g), 1, -1, i, -i))[0];
}

say complex_modular_inverse(42,          2017);       #=> 1969
say complex_modular_inverse(3 + 4 * i,   2017);       #=> 1291+968i
say complex_modular_inverse(91 + 23 * i, 2017);       #=> 590+405i
say complex_modular_inverse(43 + 99 * i, 2017);       #=> 1709+1272i
say complex_modular_inverse(43 + 99 * i, 1234567);    #=> 1019551+667302i

# Non-existent inverses
say complex_modular_inverse(43 + 99 * i, 1234) // 'undefined';    #=> undefined


================================================
FILE: Math/complex_zeta_in_real_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 August 2017
# https://github.com/trizen

# Computing the zeta function for a complex input, using only real numbers.

# Defined as:
#   zeta(a + b*i) = Sum_{n>=1} 1/n^(a + b*i)

# where we have the identity:
#   1/n^(a + b*i) = (cos(log(n) * b) - i*sin(log(n) * b)) / n**a

use 5.010;
use strict;
use warnings;

use experimental qw(signatures);

sub complex_zeta ($r = 1 / 2, $s = 14.134725142, $rep = 1e6) {

    my $real = 0;
    my $imag = 0;

    foreach my $n (1 .. $rep) {
        $real += cos(log($n) * $s) / $n**$r;
        $imag -= sin(log($n) * $s) / $n**$r;
    }

    return ($real, $imag);
}

my $r = 3;      # real part
my $s = 4;      # imaginary part

my ($real, $imag) = complex_zeta($r, $s);
say "zeta($r + $s*i) =~ complex($real, $imag)";    #=> complex(0.890554906959998, -0.0080759454242689)


================================================
FILE: Math/congruence_of_powers_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 July 2019
# Edit: 22 March 2022
# https://github.com/trizen

# A simple factorization method, based on congruences of powers.

# Given a composite integer `n`, if we find:
#
#   a^k == b^k (mod n)
#
# for some k >= 2, then gcd(a-b, n) may be a non-trivial factor of n.

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use Math::AnyNum qw(ipow);
use experimental qw(signatures);

use constant {
              MIN_FACTOR => 1e6,    # ignore small factors
              LOG_BRANCH => 1,      # true to use the log branch in addition to the root branch
              FULL_RANGE => 0,      # true to use the full range from 0 to log_2(n)
             };

sub perfect_power ($n) {
    return 1 if ($n == 0);
    return 1 if ($n == 1);
    return is_power($n);
}

sub cgpow_factor ($n, $verbose = 0) {

    my %seen;

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $f = sub ($r, $e1, $k, $e2) {
        my @factors;

        my @divs1 = divisors($e1);
        my @divs2 = divisors($e2);

        foreach my $d1 (@divs1) {
            my $x = $r**$d1;
            foreach my $d2 (@divs2) {
                my $y = $k**$d2;
                foreach my $j (-1, 1) {

                    my $t = $x - $j * $y;
                    my $g = Math::GMPz->new(gcd($t, $n));

                    if ($g > MIN_FACTOR and $g < $n and !$seen{$g}++) {

                        if ($verbose) {
                            if ($r == $k) {
                                say "[*] Congruence of powers: a^$d1 == b^$d2 (mod n) -> $g";
                            }
                            else {
                                say "[*] Congruence of powers: $r^$d1 == $k^$d2 (mod n) -> $g";
                            }
                        }

                        push @factors, $g;
                    }
                }
            }
        }

        @factors;
    };

    my @params;
    my $orig  = $n;
    my $const = 64;

    my @range;

    if (FULL_RANGE) {
        @range = reverse(2 .. logint($n, 2));
    }
    else {
        @range = reverse(2 .. vecmin($const, logint($n, 2)));
    }

    my $process = sub ($root, $e) {

        for my $j (1, 0) {

            my $k = $root + $j;
            my $u = powmod($k, $e, $n);

            foreach my $z ($u, $n - $u) {

                if (my $t = perfect_power($z)) {

                    my $r1 = rootint($z, $t);
                    ##my $r2 = rootint($z, $e);

                    push @params, [Math::GMPz->new($r1), $t, Math::GMPz->new($k), $e];
                    ##push @params, [Math::GMPz->new($r2), $e, Math::GMPz->new($k), $e];
                }
            }
        }
    };

    for my $e (@range) {
        my $root = Math::GMPz->new(rootint($n, $e));
        $process->($root, $e);
    }

    if (LOG_BRANCH) {

        for my $root (@range) {
            my $e = Math::GMPz->new(logint($n, $root));
            $process->($root, $e);
        }

        my %seen_param;
        @params = grep { !$seen_param{join(' ', @$_)}++ } @params;
    }

    my @divisors;

    foreach my $args (@params) {
        push @divisors, $f->(@$args);
    }

    @divisors = sort { $a <=> $b } @divisors;

    my @factors;
    foreach my $d (@divisors) {
        my $g = Math::GMPz->new(gcd($n, $d));

        if ($g > MIN_FACTOR and $g < $n) {
            while ($n % $g == 0) {
                $n /= $g;
                push @factors, $g;
            }
        }
    }

    push @factors, $orig / vecprod(@factors);
    return sort { $a <=> $b } @factors;
}

if (@ARGV) {
    say join ', ', cgpow_factor($ARGV[0], 1);
    exit;
}

# Large roots
say join ' * ', cgpow_factor(ipow(1009,     24) + ipow(29,  12));
say join ' * ', cgpow_factor(ipow(1009,     24) - ipow(29,  12));
say join ' * ', cgpow_factor(ipow(59388821, 12) - ipow(151, 36));

say '-' x 80;

# Small roots
say join ' * ', cgpow_factor(ipow(2,  256) - 1);
say join ' * ', cgpow_factor(ipow(10, 120) + 1);
say join ' * ', cgpow_factor(ipow(10, 120) - 1);
say join ' * ', cgpow_factor(ipow(10, 120) - 25);
say join ' * ', cgpow_factor(ipow(10, 105) - 1);
say join ' * ', cgpow_factor(ipow(10, 105) + 1);
say join ' * ', cgpow_factor(ipow(10, 120) - 2134 * 2134);
say join ' * ', cgpow_factor((ipow(2, 128) - 1) * (ipow(2, 256) - 1));
say join ' * ', cgpow_factor(ipow(ipow(4, 64) - 1, 3) - 1);

say join ' * ', cgpow_factor((ipow(2, 128) - 1) * (ipow(3, 128) - 1));
say join ' * ', cgpow_factor((ipow(5, 48) + 1) * (ipow(3, 120) + 1));
say join ' * ', cgpow_factor((ipow(5, 48) + 1) * (ipow(3, 120) - 1));
say join ' * ', cgpow_factor((ipow(5, 48) - 1) * (ipow(3, 120) + 1));

__END__
1074309286591662655506002 * 1154140443257087164049583013000044736320575461201
1018052 * 1018110 * 1699854 * 45120343 * 14006607073 * 1036518447751 * 1074309285719975471632201
1038960 * 5594587 * 23044763 * 61015275368249 * 534765538858459 * 4033015478857732019 * 109215797426552565244488121
--------------------------------------------------------------------------------
4294967295 * 4294967297 * 18446744073709551617 * 340282366920938463463374607431768211457
100000001 * 9999999900000001 * 99999999000000009999999900000001 * 10000000099999999999999989999999899999999000000000000000100000001
50851 * 1000001 * 1040949 * 1110111 * 1450031 * 2463661 * 2906161 * 99009901 * 99990001 * 165573604901641 * 9999000099990001 * 100009999999899989999000000010001
999999999999999999999999999999999999999999999999999999999995 * 1000000000000000000000000000000000000000000000000000000000005
1111111 * 1269729 * 787569631 * 900900990991 * 900009090090909909099991 * 1109988789001111109989898989900111110998878900111
1313053 * 10000001 * 1236109099 * 61549824583 * 1099988890111109888900011 * 910009191000909089989898989899909091000919100091
999999999999999999999999999999999999999999999999999999997866 * 1000000000000000000000000000000000000000000000000000000002134
1114129 * 2451825 * 6700417 * 16843009 * 1103806595329 * 18446744073709551617 * 18446744073709551617 * 340282366920938463463374607431768211457
340282366920938463463374607431768211454 * 115792089237316195423570985008687907852929702298719625575994209400481361428481
7913 * 1109760 * 43046722 * 84215045 * 4294967297 * 926510094425921 * 18446744073709551617 * 1716841910146256242328924544641
1273028 * 29423041 * 145127617 * 240031591394168814433 * 4892905104216215334417146433664153647610647561409
1013824 * 1236031 * 1519505 * 43584805 * 47763361 * 1743392201 * 76293945313 * 50446744628921761 * 240031591394168814433
1083264 * 1331139 * 1971881 * 122070313 * 29802322387695313 * 617180487788001154016207027393267755290289744417


================================================
FILE: Math/consecutive_partitions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 30 April 2019
# https://github.com/trizen

# Given an array of `n` elements, generate all the possible consecutive partitions (with no swaps and go gaps).

# For example, given the array [1,2,3,4,5], there are 16 different ways to
# subdivide the array (using all of its elements in their original order):
#
#   [[1, 2, 3, 4, 5]]
#   [[1], [2, 3, 4, 5]]
#   [[1, 2], [3, 4, 5]]
#   [[1, 2, 3], [4, 5]]
#   [[1, 2, 3, 4], [5]]
#   [[1], [2], [3, 4, 5]]
#   [[1], [2, 3], [4, 5]]
#   [[1], [2, 3, 4], [5]]
#   [[1, 2], [3], [4, 5]]
#   [[1, 2], [3, 4], [5]]
#   [[1, 2, 3], [4], [5]]
#   [[1], [2], [3], [4, 5]]
#   [[1], [2], [3, 4], [5]]
#   [[1], [2, 3], [4], [5]]
#   [[1, 2], [3], [4], [5]]
#   [[1], [2], [3], [4], [5]]
#

# In general, for a given array with `n` elements, there are `2^(n-1)` possibilities.

use 5.014;
use strict;
use warnings;

use ntheory qw(forcomb vecsum);

sub split_at_indices {
    my ($array, $indices) = @_;

    my $i = 0;
    my @parts;

    foreach my $j (@$indices) {
        push @parts, [@{$array}[$i .. $j]];
        $i = $j + 1;
    }

    return @parts;
}

sub consecutive_partitions {
    my (@array) = @_;

    my @subsets;

    foreach my $k (0 .. @array) {
        forcomb {
            my @t = split_at_indices(\@array, \@_);
            if (vecsum(map { scalar(@$_) } @t) == @array) {
                push @subsets, \@t;
            }
        } scalar(@array), $k;
    }

    return @subsets;
}

my @subsets = consecutive_partitions(1, 2, 3, 4, 5);

foreach my $subset (@subsets) {
    say join(', ', map { "[@$_]" } @$subset);
}


================================================
FILE: Math/continued_fraction_expansion_of_sqrt_of_n.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 April 2019
# https://github.com/trizen

# Compute the simple continued fraction expansion for the square root of a given number.

# Algorithm from:
#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf

# See also:
#   https://en.wikipedia.org/wiki/Continued_fraction
#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(is_square isqrt idiv);
use experimental qw(signatures);

sub cfrac_sqrt ($n) {

    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;
    my $r = 2 * $x;

    return ($x) if is_square($n);

    my @cfrac = ($x);

    do {
        $y = $r * $z - $y;
        $z = ($n - $y*$y) / $z;
        $r = idiv(($x + $y), $z);

        push @cfrac, $r;
    } until ($z == 1);

    return @cfrac;
}

foreach my $n (1 .. 20) {
    say "sqrt($n) = [", join(', ', cfrac_sqrt($n)), "]";
}

__END__
sqrt(1) = [1]
sqrt(2) = [1, 2]
sqrt(3) = [1, 1, 2]
sqrt(4) = [2]
sqrt(5) = [2, 4]
sqrt(6) = [2, 2, 4]
sqrt(7) = [2, 1, 1, 1, 4]
sqrt(8) = [2, 1, 4]
sqrt(9) = [3]
sqrt(10) = [3, 6]
sqrt(11) = [3, 3, 6]
sqrt(12) = [3, 2, 6]
sqrt(13) = [3, 1, 1, 1, 1, 6]
sqrt(14) = [3, 1, 2, 1, 6]
sqrt(15) = [3, 1, 6]
sqrt(16) = [4]
sqrt(17) = [4, 8]
sqrt(18) = [4, 4, 8]
sqrt(19) = [4, 2, 1, 3, 1, 2, 8]
sqrt(20) = [4, 2, 8]


================================================
FILE: Math/continued_fraction_expansion_of_sqrt_of_n_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 April 2019
# https://github.com/trizen

# Compute the simple continued fraction expansion for the square root of a given number.

# Algorithm from:
#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf

# See also:
#   https://en.wikipedia.org/wiki/Continued_fraction
#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub cfrac_sqrt {
    my ($n) = @_;

    $n = Math::GMPz->new("$n");

    my $x = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_sqrt($x, $n);

    return ($x) if Math::GMPz::Rmpz_perfect_square_p($n);

    my $y = Math::GMPz::Rmpz_init_set($x);
    my $z = Math::GMPz::Rmpz_init_set_ui(1);
    my $r = Math::GMPz::Rmpz_init();

    my @cfrac = ($x);

    Math::GMPz::Rmpz_add($r, $x, $x);    # r = x+x

    do {
        my $t = Math::GMPz::Rmpz_init();

        # y = (r*z - y)
        Math::GMPz::Rmpz_submul($y, $r, $z);    # y = y - t*z
        Math::GMPz::Rmpz_neg($y, $y);           # y = -y

        # z = floor((n - y*y) / z)
        Math::GMPz::Rmpz_mul($t, $y, $y);       # t = y*y
        Math::GMPz::Rmpz_sub($t, $n, $t);       # t = n-t
        Math::GMPz::Rmpz_divexact($z, $t, $z);  # z = t/z

        # t = floor((x + y) / z)
        Math::GMPz::Rmpz_add($t, $x, $y);       # t = x+y
        Math::GMPz::Rmpz_tdiv_q($t, $t, $z);    # t = floor(t/z)

        $r = $t;
        push @cfrac, $t;

    } until (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);

    return @cfrac;
}

foreach my $n (1 .. 20) {
    say "sqrt($n) = [", join(', ', cfrac_sqrt($n)), "]";
}

__END__
sqrt(1) = [1]
sqrt(2) = [1, 2]
sqrt(3) = [1, 1, 2]
sqrt(4) = [2]
sqrt(5) = [2, 4]
sqrt(6) = [2, 2, 4]
sqrt(7) = [2, 1, 1, 1, 4]
sqrt(8) = [2, 1, 4]
sqrt(9) = [3]
sqrt(10) = [3, 6]
sqrt(11) = [3, 3, 6]
sqrt(12) = [3, 2, 6]
sqrt(13) = [3, 1, 1, 1, 1, 6]
sqrt(14) = [3, 1, 2, 1, 6]
sqrt(15) = [3, 1, 6]
sqrt(16) = [4]
sqrt(17) = [4, 8]
sqrt(18) = [4, 4, 8]
sqrt(19) = [4, 2, 1, 3, 1, 2, 8]
sqrt(20) = [4, 2, 8]


================================================
FILE: Math/continued_fraction_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 October 2018
# https://github.com/trizen

# Simple implementation of the continued fraction factorization method (CFRAC),
# combined with modular arithmetic (variation of the Brillhart-Morrison algorithm).

# See also:
#   https://en.wikipedia.org/wiki/Pell%27s_equation
#   https://en.wikipedia.org/wiki/Continued_fraction_factorization
#   https://trizenx.blogspot.com/2018/10/continued-fraction-factorization-method.html

# "Gaussian elimination" algorithm from:
#    https://github.com/martani/Quadratic-Sieve

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz             qw();
use List::Util             qw(first);
use ntheory                qw(is_prime factor_exp forprimes next_prime is_square_free);
use Math::Prime::Util::GMP qw(is_power vecprod sqrtint rootint gcd urandomb);

use constant {
              B_SMOOTH_METHOD => 0,    # 1 to use the B-smooth formula for the factor base
              ROUND_DIVISION  => 0,    # 1 to use round division instead of floor division
             };

sub gaussian_elimination ($rows, $n) {

    my @A   = @$rows;
    my $m   = $#A;
    my $ONE = Math::GMPz::Rmpz_init_set_ui(1);

    my @I = map { $ONE << $_ } 0 .. $m;

    my $nrow = -1;
    my $mcol = $m < $n ? $m : $n;

    foreach my $col (0 .. $mcol) {
        my $npivot = -1;

        foreach my $row ($nrow + 1 .. $m) {
            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {
                $npivot = $row;
                $nrow++;
                last;
            }
        }

        next if ($npivot == -1);

        if ($npivot != $nrow) {
            @A[$npivot, $nrow] = @A[$nrow, $npivot];
            @I[$npivot, $nrow] = @I[$nrow, $npivot];
        }

        foreach my $row ($nrow + 1 .. $m) {
            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {
                $A[$row] ^= $A[$nrow];
                $I[$row] ^= $I[$nrow];
            }
        }
    }

    return (\@A, \@I);
}

sub is_smooth_over_prod ($n, $k) {

    state $g = Math::GMPz::Rmpz_init_nobless();
    state $t = Math::GMPz::Rmpz_init_nobless();

    Math::GMPz::Rmpz_set($t, $n);
    Math::GMPz::Rmpz_gcd($g, $t, $k);

    while (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
        Math::GMPz::Rmpz_remove($t, $t, $g);
        return 1 if Math::GMPz::Rmpz_cmpabs_ui($t, 1) == 0;
        Math::GMPz::Rmpz_gcd($g, $t, $g);
    }

    return 0;
}

sub check_factor ($n, $g, $factors) {

    while ($n % $g == 0) {

        $n /= $g;
        push @$factors, $g;

        if (is_prime($n)) {
            push @$factors, $n;
            return 1;
        }
    }

    return $n;
}

sub next_multiplier ($k) {

    $k += 2;

    until (is_square_free($k)) {
        ++$k;
    }

    return $k;
}

sub cffm ($n, $verbose = 0, $multiplier = 1) {

    local $| = 1;

    # Check for primes and negative numbers
    return ()   if $n <= 1;
    return ($n) if is_prime($n);

    # Check for perfect powers
    if (my $k = is_power($n)) {
        my @factors = __SUB__->(Math::GMPz->new(rootint($n, $k)), $verbose);
        return sort { $a <=> $b } ((@factors) x $k);
    }

    my $N = $n * $multiplier;

    my $x = Math::GMPz::Rmpz_init();
    my $y = Math::GMPz::Rmpz_init();
    my $z = Math::GMPz::Rmpz_init_set_ui(1);

    my $w = Math::GMPz::Rmpz_init();
    my $r = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_sqrt($x, $N);
    Math::GMPz::Rmpz_set($y, $x);

    Math::GMPz::Rmpz_add($w, $x, $x);
    Math::GMPz::Rmpz_set($r, $w);

    my $f2 = Math::GMPz::Rmpz_init_set($x);
    my $f1 = Math::GMPz::Rmpz_init_set_ui(1);

    my (@A, @Q);

    my $B  = int(exp(sqrt(log("$n") * log(log("$n"))) / 2));                      # B-smooth limit
    my $nf = int(exp(sqrt(log("$n") * log(log("$n"))))**(sqrt(2) / 4) / 1.25);    # number of primes in factor-base

    my @factor_base = (2);

#<<<
    if (B_SMOOTH_METHOD) {
        forprimes {
            if (Math::GMPz::Rmpz_kronecker_ui($N, $_) >= 0) {
                push @factor_base, $_;
            }
        } 3, $B;
    }
    else {
        for (my $p = 3 ; @factor_base < $nf ; $p = next_prime($p)) {
            if (Math::GMPz::Rmpz_kronecker_ui($N, $p) >= 0) {
                push @factor_base, $p;
            }
        }
    }
#>>>

    my %factor_index;
    @factor_index{@factor_base} = (0 .. $#factor_base);

    my $exponents_signature = sub (@factors) {
        my $sig = Math::GMPz::Rmpz_init_set_ui(0);

        foreach my $p (@factors) {
            if ($p->[1] & 1) {
                Math::GMPz::Rmpz_setbit($sig, $factor_index{$p->[0]});
            }
        }

        return $sig;
    };

    my $L  = scalar(@factor_base) + 1;                 # maximum number of matrix-rows
    my $FP = Math::GMPz->new(vecprod(@factor_base));

    if ($verbose) {
        printf("[*] Factoring %s (%s digits)...\n\n", "$n", length("$n"));
        say "*** Step 1/2: Finding smooth relations ***";
        printf("Target: %s relations, with B = %s\n", $L, $factor_base[-1]);
    }

    my $t = Math::GMPz::Rmpz_init();

    while (@A < $L) {

        # y = r*z - y
        Math::GMPz::Rmpz_mul($t, $r, $z);
        Math::GMPz::Rmpz_sub($y, $t, $y);

        # z = (n - y*y) / z
        Math::GMPz::Rmpz_mul($t, $y, $y);
        Math::GMPz::Rmpz_sub($t, $N, $t);
        Math::GMPz::Rmpz_divexact($z, $t, $z);

        # r = (x + y) / z
        Math::GMPz::Rmpz_add($t, $x, $y);

        if (ROUND_DIVISION) {

            # Round (x+y)/z to nearest integer
            Math::GMPz::Rmpz_set($r, $z);
            Math::GMPz::Rmpz_addmul_ui($r, $t, 2);
            Math::GMPz::Rmpz_div($r, $r, $z);
            Math::GMPz::Rmpz_div_2exp($r, $r, 1);
        }
        else {

            # Floor division: floor((x+y)/z)
            Math::GMPz::Rmpz_div($r, $t, $z);
        }

        # f1 = (f1 + r*f2) % n
        Math::GMPz::Rmpz_addmul($f1, $f2, $r);
        Math::GMPz::Rmpz_mod($f1, $f1, $n);

        # swap f1 with f2
        ($f1, $f2) = ($f2, $f1);

#<<<
        if (Math::GMPz::Rmpz_perfect_square_p($z)) {
            my $g = Math::GMPz->new(gcd($f1 - Math::GMPz->new(sqrtint($z)), $n));

            if ($g > 1 and $g < $n) {
                return sort { $a <=> $b } (
                    __SUB__->($g, $verbose),
                    __SUB__->($n / $g, $verbose)
                );
            }
        }
#>>>

        if (is_smooth_over_prod($z, $FP)) {

            my $abs_z   = abs($z);
            my @factors = factor_exp($abs_z);

            if (@factors) {
                push @A, $exponents_signature->(@factors);
                push @Q, [map { Math::GMPz::Rmpz_init_set($_) } ($f1, $abs_z)];
            }

            if ($verbose) {
                printf("Progress: %d/%d relations.\r", scalar(@A), $L);
            }
        }

        if (Math::GMPz::Rmpz_cmpabs_ui($z, 1) == 0) {

            my $k = next_multiplier($multiplier);

            say "Trying again with multiplier k = $k\n" if $verbose;
            return __SUB__->($n, $verbose, $k);
        }
    }

    if ($verbose) {
        say "\n\n*** Step 2/2: Linear Algebra ***";
        say "Performing Gaussian elimination...";
    }

    if (@A < $L) {
        push @A, map { Math::GMPz::Rmpz_init_set_ui(0) } 1 .. ($L - @A + 1);
    }

    my ($A, $I) = gaussian_elimination(\@A, $L - 1);

    my $LR = ((first { $A->[-$_] } 1 .. @$A) // 0) - 1;

    if ($verbose) {
        say "Found $LR linear dependencies...";
        say "Finding factors from congruences of squares...\n";
    }

    my @factors;
    my $rem = $n;

  SOLUTIONS: foreach my $solution (@{$I}[@$I - $LR .. $#$I]) {

        my $X = 1;
        my $Y = 1;

        foreach my $i (0 .. $#Q) {

            Math::GMPz::Rmpz_tstbit($solution, $i) || next;

            ($X *= $Q[$i][0]) %= $n;
            ($Y *= $Q[$i][1]);

            my $g = Math::GMPz->new(gcd($X - Math::GMPz->new(sqrtint($Y)), $rem));

            if ($g > 1 and $g < $rem) {
                if ($verbose) {
                    say "`-> found factor: $g";
                }
                $rem = check_factor($rem, $g, \@factors);
                last SOLUTIONS if $rem == 1;
            }
        }
    }

    say '' if $verbose;

    my @final_factors;

    foreach my $f (@factors) {
        if (is_prime($f)) {
            push @final_factors, $f;
        }
        else {
            push @final_factors, __SUB__->($f, $verbose);
        }
    }

    if ($rem != 1) {
        if ($rem != $n) {
            push @final_factors, __SUB__->($rem, $verbose);
        }
        else {
            push @final_factors, $rem;
        }
    }

    # Failed to factorize n (try again with a multiplier)
    if ($rem == $n) {
        my $k = next_multiplier($multiplier);
        say "Trying again with multiplier k = $k\n" if $verbose;
        return __SUB__->($n, $verbose, $k);
    }

    # Return all the prime factors of n
    return sort { $a <=> $b } @final_factors;
}

my @composites = (
    @ARGV ? (map { Math::GMPz->new($_) } @ARGV) : do {
        map { Math::GMPz->new(urandomb($_)) + 2 } 2 .. 70;
    }
);

# Run some tests when no argument is provided
foreach my $n (@composites) {

    my @f = cffm($n, @ARGV ? 1 : 0);

    say "$n = ", join(' * ', map { is_prime($_) ? $_ : "$_ (composite)" } @f);
    die 'error' if Math::GMPz->new(vecprod(@f)) != $n;
}


================================================
FILE: Math/continued_fractions.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 November 2015
# Website: https://github.com/trizen

# Continued fractions

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

sub root2 {
    my ($n) = @_;

    return 0 if $n <= 0;

    1.0/(
        2.0 + root2($n-1)
    )
}

sub e {
    my($i, $n) = @_;

    return 0 if $n >= $i;

    1.0/(
        1.0 + 1.0/(
            2.0*$n + 1.0/(
                1.0 + e($i, $n+1)
            )
        )
    )
}

say 1+root2(100);       # sqrt(2)
say 2+e(100, 1);        # e


================================================
FILE: Math/continued_fractions_for_e.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 May 2016
# Edit: 14 July 2017
# Website: https://github.com/trizen

# Continued fractions for the "e" mathematical constant.

use 5.010;
use strict;

sub e_1 {
    my ($i, $limit) = @_;
    $limit > 0 ? ($i / ($i + e_1($i + 1, $limit - 1))) : 0;
}

sub e_2 {
    my ($i, $limit) = @_;
    $limit > 0 ? 1 / (1 + 1 / (2 * $i + 1 / (1 + e_2($i + 1, $limit - 1)))) : 0;
}

sub e_3 {
    my ($i, $limit) = @_;
    $limit > 0 ? (1 / (2 * $i + 1 + e_3($i + 1, $limit - 1))) : 0;
}

sub e_4 {
    my ($i, $n) = @_;

    return 0 if $n >= $i;

    1 / (
        1 + 1 / (
            1 + 1 / (
                (3 * $n) + 1 / (
                    (12 * $n + 6) + 1 / (
                        (3 * $n + 2) + e_4($i, $n + 1)
                    )
                )
            )
        )
    );
}

sub e_5 {
    my ($i, $n) = @_;

    return 0 if $n >= $i;

    1 / (
        3 + 1 / (
            2*$n + 1 / (
                3 + 1 / (
                    1 + 1 / (
                        2*$n + 1 / (
                            1 + e_5($i, $n + 1)
                        )
                    )
                )
            )
        )
    );
}

sub e_6 {
    my ($i, $n) = @_;

    return 0 if $n >= $i;

    2 / (
        8*($n+1) - 2 + 2 / (
            4*($n+1) + 1 + e_6($i, $n+1)
        )
    );
}

sub e_7 {
    my ($i, $n) = @_;

    return 0 if $n >= $i;

    8 / (
        16*$n + 4 + 8 / (
            8*($n+1) - 2 + e_7($i, $n+1)
        )
    );
}

sub e_8 {
    my ($i, $n) = @_;

    return 0 if $n >= $i;

    1 / (
        4*($n-1) + 1 + 1 / (
            1 + 1/(
                1 + e_8($i, $n+1)
            )
        )
    );
}

sub e_9 {
    my ($i, $n) = @_;

    return 0 if $n >= $i;

    1/(
        2 + 1/(
            4*$n + 1 + 1/(
                -2 + 1/ (
                    -4*$n - 3 + e_9($i, $n+1)
                )
            )
        )
    )
}

my $r = 100;        # number of repetitions

say 1 + 1 / e_1(1, $r);                  # good convergence
say 2 + e_2(1, $r);                      # very fast convergence
say sqrt(1 + 2 / e_3(1, $r));            # very fast convergence
say sqrt(7 + 1 / (2 + (e_4($r, 1))));    # extremely fast convergence (best)
say ((5 + 1/(2 +  e_5($r, 1)))/2);       # extremely fast convergence
say sqrt(7 + 2/(5 + e_6($r, 1)));        # extremely fast convergence
say sqrt(7 + e_7($r, 1));                # very fast convergence
say ((1 + e_8($r, 1))**2);               # very fast convergence
say 3 + 1/(-4 + e_9($r, 1));             # extremely fast convergence


================================================
FILE: Math/continued_fractions_for_nth_roots.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 February 2019
# https://github.com/trizen

# Approximate n-th roots, using continued fractions.

# See also:
#   https://en.wikipedia.org/wiki/Generalized_continued_fraction#Roots_of_positive_numbers

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload irootrem);

sub cfrac_nth_root ($z, $m, $n, $y, $r, $k = 1) {

    return 0 if ($r <= 0);

    ($k**2 * $n**2 - $m**2) * $y**2 / (
        (2 * $k + 1) * $n * (2 * $z - $y) - __SUB__->($z, $m, $n, $y, $r - 1, $k + 1)
    );
}

sub nth_root ($z, $n, $r = 98) {
    my ($x, $y) = irootrem($z, $n);         # express z as x^n + y

    my $m = 1;
    my $t = cfrac_nth_root($z, $m, $n, $y, $r);

    $x**$m + ((2 * $x * $m * $y) / ($n * (2 * $z - $y) - $m * $y - $t));
}

say nth_root(1234,   2)->as_dec;    #=> 35.1283361405005916058703116253563067645404854788
say nth_root(12345,  3)->as_dec;    #=> 23.1116187498072686808719733295882901745171370026
say nth_root(123456, 5)->as_dec;    #=> 10.4304354640976648337531700856866384705501389373

say "\n=> Approximations to 2^(1/3):";

foreach my $k (1 .. 10) {
    say "   2^(1/3) =~ ", nth_root(2, 3, $k);
}

__END__
=> Approximations to 2^(1/3):
   2^(1/3) =~ 131/104
   2^(1/3) =~ 286/227
   2^(1/3) =~ 17494/13885
   2^(1/3) =~ 49147/39008
   2^(1/3) =~ 4725601/3750712
   2^(1/3) =~ 12205019/9687130
   2^(1/3) =~ 320084311/254051086
   2^(1/3) =~ 1829589323/1452146008
   2^(1/3) =~ 60779482705/48240707392
   2^(1/3) =~ 410233899668/325602861943


================================================
FILE: Math/continued_fractions_for_pi.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 May 2016
# Website: https://github.com/trizen

# Continued fractions for PI.
# Inspired by: https://www.youtube.com/watch?v=fd39yK2GZSA

use 5.010;
use strict;

sub pi_1 {
    my ($i, $limit) = @_;
    $limit > 0 ? ($i**2 / (2 + pi_1($i + 2, $limit - 1))) : 0;
}

sub pi_2 {
    my ($i, $limit) = @_;
    $limit > 0 ? ($i**2 / (2 * $i + 1 + pi_2($i + 1, $limit - 1))) : 0;
}

sub pi_3 {
    my ($i, $limit) = @_;
    $limit > 0 ? ((2 * $i + 1)**2 / (6 + pi_3($i + 1, $limit - 1))) : 0;
}

say 4 / (1 + pi_1(1, 100000));    # slow convergence
say 4 / (1 + pi_2(1, 100));       # fast convergence
say 3 + pi_3(0, 100000);          # slow convergence


================================================
FILE: Math/continued_fractions_for_square_roots.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 November 2015
# https://github.com/trizen

# Square roots as continued fractions

# See also:
#   https://en.wikipedia.org/wiki/Continued_fraction#Generalized_continued_fraction_for_square_roots

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

sub square_root {
    my ($n, $precision) = @_;
    $precision > 0 ? ($n - 1) / (2 + square_root($n, $precision - 1)) : 0;
}

for my $i (1 .. 10) {
    printf("sqrt(%2d) = %s\n", $i, 1 + square_root($i, 1000));
}


================================================
FILE: Math/continued_fractions_prime_constant.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 May 2016
# Website: https://github.com/trizen

# Continued fraction constant for primes.

use 5.010;
use strict;
use ntheory qw(nth_prime);

sub prime_constant {
    my ($i, $limit) = @_;
    my $p = nth_prime($i);
    $limit > 0 ? ($p / ($p + prime_constant($i + 1, $limit - 1))) : 0;
}

my $pc = prime_constant(1, 10000);

say $pc;
say 1 / (1 + $pc);    # "1" is considered prime here

__END__
0.71961651193526
0.581525004592215


================================================
FILE: Math/convergent_series.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 31 July 2015
# Website: https://github.com/trizen

# A simple generator of convergent infinite series.

use 5.010;
use strict;
use warnings;

use List::Util qw(first);
use Term::ReadLine qw();
use Storable qw(store retrieve);

my $db = 'convergent_series.db';

my %map;
if (-e $db) {
    %map = %{retrieve($db)};
}
else {
    generate_all();
    save_database();
}

sub save_database {
    store(\%map, 'convergent_series.db');
}

#
## sum(i^k / (j*n)^l)
#
sub generate_squared_series {

    my $ref = \%map;

    my %f;
    foreach my $i (1 .. 4) {
        foreach my $j (1 .. 4) {
            foreach my $k (1 .. 3) {
                foreach my $l (2 .. 3) {

                    my $sum = 0;
                    foreach my $n (1 .. 10000000) {
                        $sum += $i**$k / ($j * $n)**$l;
                    }

                    my $formula = "sum($i**$k/($j*n)**$l)";

                    $formula =~ s/\b1\*(?=[\d(n])//g;
                    $formula =~ s/[\d)]\K\*\*1\b//g;
                    $formula =~ s/\b1\K\*\*\d+//g;
                    $formula =~ s{/1\b}{}g;
                    $formula =~ s/\((\d+|n)\)/$1/g;

                    my $form = ($f{$formula} //= \$formula);

                    $ref = \%map;
                    say "$formula ($sum)";

                    foreach my $char (split(//, $sum)) {
                        if (not defined first { $formula eq ${$_} } @{$ref->{f}}) {
                            push @{$ref->{f}}, $form;
                        }
                        $ref = ($ref->{d}{$char} //= {});
                    }

                }
            }
        }
    }
}

sub generate_all {
    generate_squared_series();

    # more to come...

    print "\n** Database generated successfully!\n\n";
}

sub lookup {
    my ($n) = @_;

    my %found;
    foreach my $i (2 .. 100) {

        foreach my $pair ([$n, ""],
                          [$n**(1 / $i),    "**$i"],
                          [$n**$i,          "**(1/$i)"],
                          [$n**(-($i - 1)), "**(-${\($i-1)})"],
                          [$n / $i,         "*$i"],
                          [$n * $i,         "/$i"],
                          (map { [$n**$i / $_, "*$_)**(1/$i)"] } 2 .. 9)) {

            my $j = $pair->[0];
            my @chars = split(//, $j);

            my $max = 0;
            my $ref = \%map;

            my @match;
            while (@chars and exists($ref->{d}{$chars[0]})) {
                my $char = shift @chars;
                $ref = $ref->{d}{$char};
                push @match, $char;
                ++$max;
            }

            if ($max >= 6) {
                push @{$found{$max}}, [$ref->{f}, $pair->[1], join('', @match)];
            }
        }
    }

    my @matches;
    foreach my $key (sort { $b <=> $a } keys %found) {
        my $arrs = $found{$key};

        my %seen;
        foreach my $arr (@{$arrs}) {
            foreach my $f (@{$arr->[0]}) {

                my $func = "${$f}$arr->[1]";
                if (($func =~ tr/)//) != ($func =~ tr/(//)) {
                    $func = "($func";
                }

                next if $seen{$func}++;
                push @matches, sprintf("%-50s%s", $func, "($arr->[2])");
            }
        }
    }
    return @matches;
}

my %const = (
             e  => exp(1),
             pi => atan2(0, -'inf'),
            );

my $term = Term::ReadLine->new("Convergent series");
while (defined(my $expr = $term->readline("Enter an expression: "))) {

    {
        local $" = '|';
        $expr =~ s/\b(@{[keys %const]})\b/$const{$1}/g;
    }

    my $n = eval($expr);

    if ($@) {
        warn "\n[!] Invalid expression: $expr\n\t$@\n";
        next;
    }
    elsif (not defined($n)) {
        next;
    }

    my @formulas = lookup($n);

    if (@formulas) {
        print "\n[+] Found the following formulas for $n:\n\t";
        print join("\n\t", @formulas), "\n\n";
    }
    else {
        print "\n[-] Can't find any formula for $n\n\n";
    }
}

__END__

use 5.010;
use strict;

sub pi {
    my $sum = 0;

    for my $k(0..10) {
        $sum += (1/16**$k) * (4/(8*$k+1) - 2/(8*$k+4) - 1/(8*$k+5) - 1/(8*$k+6));
    }

    $sum;
}

sub zeta {
    my ($n) = @_;

    my $sum = 0;
    for my $i(1..100000) {
        $sum += 1/$i**$i;
    }

    $sum;
}

say zeta(2);
say pi();


================================================
FILE: Math/cosmic_calendar.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 April 2014
# https://trizenx.blogspot.com

# Inspired from: Cosmos.A.Space.Time.Odyssey.S01E01
#                            by Neil deGrasse Tyson

use 5.010;
use strict;
use warnings;

use Term::ReadLine;

# Here is the definition of the cosmic year
my @cosmic_year = [(13.798 + [+0.037, -0.037]->[rand 2]) * 10**9, 'years'];

push @cosmic_year, [$cosmic_year[-1][0] / 12,         'months'];
push @cosmic_year, [$cosmic_year[-1][0] / 30.4368499, 'days'];
push @cosmic_year, [$cosmic_year[-1][0] / 24,         'hours'];
push @cosmic_year, [$cosmic_year[-1][0] / 60,         'minutes'];
push @cosmic_year, [$cosmic_year[-1][0] / 60,         'seconds'];
push @cosmic_year, [$cosmic_year[-1][0] / 1000,       'milliseconds'];

print <<'EOF';
This program will scale the age of the universe to a normal year.

You can insert any number you want, and the program will map it
into this cosmic year to have a feeling how long ago it was,
compared to the age of the universe.

EOF

sub output {
    my ($value, $type) = @_;
    printf "\n=> In the cosmic scale, that happened about %.2f %s ago!\n\n", $value, $type;
}

BLOCK: {
    my $term  = Term::ReadLine->new('Cosmic Calendar');
    my $value = eval $term->readline("How long ago? (any expression, in years): ");

    foreach my $bit (@cosmic_year) {
        $value >= $bit->[0]
            && output($value / $bit->[0], $bit->[1])
            && redo BLOCK;
    }

    warn "\n[!] Your value `$value' is too small, compared to the Cosmic Calendar!\n\n";
    redo;
}


================================================
FILE: Math/count_of_brilliant_numbers.pl
================================================
#!/usr/bin/perl

# Count the number of Brilliant numbers < 10^n.

# Brilliant numbers are semiprimes such that both prime factors have the same number of digits in base 10.

# OEIS sequence:
#   https://oeis.org/A086846 --  Number of brilliant numbers < 10^n.

# See also:
#   https://rosettacode.org/wiki/Brilliant_numbers

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub brilliant_numbers_count_fast ($n) {

    my $count = 0;
    my $len   = length(sqrtint($n));

    foreach my $k (1 .. $len - 1) {
        my $pi = prime_count(powint(10, $k - 1), powint(10, $k) - 1);
        $count += binomial($pi, 2) + $pi;
    }

    my $min = powint(10, $len - 1);
    my $max = powint(10, $len) - 1;

    forprimes {
        $count += prime_count($_, vecmin($max, divint($n, $_)));
    } $min, $max;

    return $count;
}

sub brilliant_numbers_count_faster ($n) {

    my $count = 0;
    my $len   = length(sqrtint($n));

    foreach my $k (1 .. $len - 1) {
        my $pi = prime_count(powint(10, $k - 1), powint(10, $k) - 1);
        $count += binomial($pi, 2) + $pi;
    }

    my $min = powint(10, $len - 1);
    my $max = powint(10, $len) - 1;

    my $pi_min = prime_count($min);
    my $pi_max = prime_count($max);

    my $j = -1;

    forprimes {
        if ($_ * $_ <= $n) {
            $count += (($n >= $_ * $max) ? $pi_max : prime_count(divint($n, $_))) - $pi_min - ++$j;
        }
        else {
            lastfor;
        }
    } $min, $max;

    return $count;
}

sub brilliant_numbers_count_slow ($n) {

    my $count = 0;
    my $len   = length(sqrtint($n));

    foreach my $k (1 .. $len - 1) {
        my $pi = prime_count(10**($k - 1), 10**$k - 1);
        $count += binomial($pi, 2) + $pi;
    }

    my $P = primes(10**($len - 1), 10**$len - 1);

    foreach my $i (0 .. $#{$P}) {
        foreach my $j ($i .. $#{$P}) {
            $P->[$i] * $P->[$j] > $n ? last : ++$count;
        }
    }

    return $count;
}

foreach my $n (1 .. 12) {
    my $v = powint(10, $n) - 1;
    printf("Less than 10^%s, there are %s brilliant numbers\n", $n, brilliant_numbers_count_faster($v));
}

__END__
Less than 10^1, there are 3 brilliant numbers
Less than 10^2, there are 10 brilliant numbers
Less than 10^3, there are 73 brilliant numbers
Less than 10^4, there are 241 brilliant numbers
Less than 10^5, there are 2504 brilliant numbers
Less than 10^6, there are 10537 brilliant numbers
Less than 10^7, there are 124363 brilliant numbers
Less than 10^8, there are 573928 brilliant numbers
Less than 10^9, there are 7407840 brilliant numbers
Less than 10^10, there are 35547994 brilliant numbers
Less than 10^11, there are 491316166 brilliant numbers
Less than 10^12, there are 2409600865 brilliant numbers
Less than 10^13, there are 34896253009 brilliant numbers
Less than 10^14, there are 174155363186 brilliant numbers
Less than 10^15, there are 2601913448896 brilliant numbers
Less than 10^16, there are 13163230391312 brilliant numbers


================================================
FILE: Math/count_of_cube-full_numbers.pl
================================================
#!/usr/bin/perl

# Fast algorithm for counting the number of cube-full numbers <= n.
# A positive integer n is considered cube-full, if for every prime p that divides n, so does p^3.

# See also:
#   THE DISTRIBUTION OF CUBE-FULL NUMBERS, by P. SHIU (1990).

# OEIS:
#   https://oeis.org/A036966 -- 3-full (or cube-full, or cubefull) numbers: if a prime p divides n then so does p^3.

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub cubefull_count($n) {
    my $total = 0;

    for my $a (1 .. rootint($n, 5)) {
        is_square_free($a) || next;
        for my $b (1 .. rootint(divint($n, powint($a, 5)), 4)) {
            gcd($a, $b) == 1 or next;
            is_square_free($b) || next;
            my $t = mulint(powint($a, 5), powint($b, 4));
            $total += rootint(divint($n, $t), 3);
        }
    }

    return $total;
}

foreach my $n (1 .. 20) {
    say "C_3(10^$n) = ", cubefull_count(powint(10, $n));
}

__END__
C_3(10^1) = 2
C_3(10^2) = 7
C_3(10^3) = 20
C_3(10^4) = 51
C_3(10^5) = 129
C_3(10^6) = 307
C_3(10^7) = 713
C_3(10^8) = 1645
C_3(10^9) = 3721
C_3(10^10) = 8348
C_3(10^11) = 18589
C_3(10^12) = 41136
C_3(10^13) = 90619
C_3(10^14) = 198767
C_3(10^15) = 434572
C_3(10^16) = 947753
C_3(10^17) = 2062437
C_3(10^18) = 4480253
C_3(10^19) = 9718457
C_3(10^20) = 21055958


================================================
FILE: Math/count_of_integers_with_gpf_of_n_equals_p.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 March 2020
# https://github.com/trizen

# Given `n` and `p`, count the number of integers k <= n, such that:
#    gpf(k) = p
# where `gpf(k)` is the greatest prime factor of k.

# This is equivalent with the number of p-smooth numbers <= floor(n/p).

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.020;
use integer;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub count_with_gpf ($n, $p) {
    smooth_count($n/$p, $p);
}

foreach my $n (1 .. 10) {
    say "a(10^$n) for primes below 20: {", join(', ', map { count_with_gpf(powint(10, $n), $_) } @{primes(20)}), "}";
}

__END__
a(10^1)  for primes below 20: {3, 3, 2, 1, 0, 0, 0, 0}
a(10^2)  for primes below 20: {6, 13, 14, 12, 9, 7, 5, 5}
a(10^3)  for primes below 20: {9, 30, 46, 55, 51, 50, 45, 44}
a(10^4)  for primes below 20: {13, 53, 108, 163, 184, 211, 212, 224}
a(10^5)  for primes below 20: {16, 84, 212, 381, 503, 651, 731, 840}
a(10^6)  for primes below 20: {19, 122, 365, 766, 1159, 1674, 2073, 2572}
a(10^7)  for primes below 20: {23, 166, 578, 1387, 2365, 3769, 5100, 6809}
a(10^8)  for primes below 20: {26, 217, 861, 2322, 4411, 7681, 11290, 16141}
a(10^9)  for primes below 20: {29, 276, 1224, 3664, 7673, 14498, 22986, 35060}
a(10^10) for primes below 20: {33, 342, 1677, 5522, 12618, 25721, 43765, 70947}


================================================
FILE: Math/count_of_integers_with_lpf_of_n_equals_p.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 March 2020
# https://github.com/trizen

# Given `n` and `p`, count the number of integers k <= n, such that:
#    lpf(k) = p
# where `lpf(k)` is the least prime factor of k.

# This is equivalent with the number of p-rough numbers <= floor(n/p).

# See also:
#   https://en.wikipedia.org/wiki/Rough_number

use 5.020;
use integer;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub count_with_lpf ($n, $p) {

    #~ return rough_count($n/$p, $p);

    if ($p > sqrt($n)) {
        return 1;
    }

    my $u = 0;
    my $t = $n / $p;

    for (my $q = 2 ; $q < $p ; $q = next_prime($q)) {

        my $v = __SUB__->($t - ($t % $q), $q);

        if ($v == 1) {
            $u += prime_count($q, $p - 1);
            last;
        }
        else {
            $u += $v;
        }
    }

    $t - $u;
}

foreach my $n (1 .. 10) {
    say "a(10^$n) for primes below 20: {", join(', ', map { count_with_lpf(powint(10, $n), $_) } @{primes(20)}), "}";
}

__END__
a(10^1)  for primes below 20: {5, 2, 1, 1, 1, 1, 1, 1}
a(10^2)  for primes below 20: {50, 17, 7, 4, 1, 1, 1, 1}
a(10^3)  for primes below 20: {500, 167, 67, 38, 21, 17, 11, 9}
a(10^4)  for primes below 20: {5000, 1667, 667, 381, 208, 160, 111, 95}
a(10^5)  for primes below 20: {50000, 16667, 6667, 3809, 2078, 1598, 1128, 950}
a(10^6)  for primes below 20: {500000, 166667, 66667, 38095, 20779, 15984, 11284, 9503}
a(10^7)  for primes below 20: {5000000, 1666667, 666667, 380953, 207792, 159840, 112830, 95017}
a(10^8)  for primes below 20: {50000000, 16666667, 6666667, 3809524, 2077921, 1598401, 1128285, 950134}
a(10^9)  for primes below 20: {500000000, 166666667, 66666667, 38095238, 20779221, 15984017, 11282835, 9501332}
a(10^10) for primes below 20: {5000000000, 1666666667, 666666667, 380952381, 207792208, 159840160, 112828349, 95013344}


================================================
FILE: Math/count_of_inverse_tau_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 May 2026
# https://github.com/trizen

# Count the numbers in a given range [A,B] that have exactly `n` divisors.

use 5.036;
use ntheory 0.74 qw(:all);

prime_precalc(1e7);

sub unique_permutations($array, $callback) {
    sub ($items, $current_perm) {

        if (!@$items) {
            $callback->($current_perm);
            return;
        }

        my %level_seen;
        for my $i (0 .. $#$items) {
            my $item = $items->[$i];

            # Skip iterations for duplicate elements in the same level
            next if $level_seen{$item}++;

            my @new_items = @$items;
            splice(@new_items, $i, 1);

            my @new_perm = (@$current_perm, $item);
            __SUB__->(\@new_items, \@new_perm);
        }
    }->($array, []);
}

sub count_prime_signature_numbers($n, $prime_signature) {

    my $k = scalar(@$prime_signature);

    if ($k == 0) {
        return 1 if (1 <= $n);
        return 0;
    }

    $n >= 1 || return 0;

    my $count = 0;

    my $generate = sub ($m, $lo, $k, $P, $sum_e, $j = 0) {

        my $e  = $P->[$k - 1];
        my $hi = rootint(divint($n, $m), $sum_e);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {
            $count += prime_count($hi) - $j;
            return;
        }

        if ($k == 2) {
            my $e2 = $P->[0];
            foreach my $p (@{primes($lo, $hi)}) {
                my $t = mulint($m, powint($p, $e));
                my $u = rootint(divint($n, $t), $e2);
                $count += prime_count($u) - ++$j;
            }
            return;
        }

        for (my $p = $lo ; $p <= $hi ;) {
            my $t = mulint($m, powint($p, $e));
            my $r = next_prime($p);
            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e, ++$j);
            $p = $r;
        }
    };

    my $sum_e = vecsum(@$prime_signature) || return 0;

    if ($sum_e > logint($n, 2)) {
        return 0;
    }

    unique_permutations(
        $prime_signature,
        sub ($perm) {
            $generate->(1, 2, scalar(@$perm), $perm, $sum_e);
        }
    );

    return $count;
}

sub count_prime_signature_numbers_in_range($A, $B, $signature) {
    my $term_1 = count_prime_signature_numbers($A - 1, $signature);
    my $term_2 = count_prime_signature_numbers($B,     $signature);
    $term_2 - $term_1;
}

sub multiplicative_partitions($n, $max_value = $n) {

    my @results;
    my @divs = divisors($n);

    shift(@divs);    # remove divisor '1'

    my $end = $#divs;
    sub ($target, $min_idx, $path) {

        if ($target == 1) {
            push @results, $path;
            return;
        }

        for my $i ($min_idx .. $end) {
            my $d = $divs[$i];

            # Prune branch if the divisor exceeds the remaining target
            last if $d > $target;
            last if $d > $max_value;

            if ($target % $d == 0) {
                __SUB__->(divint($target, $d), $i, [@$path, $d]);
            }
        }
    }->($n, 0, []);

    return @results;
}

sub count_inverse_tau($A, $B, $n) {

    my @signatures = map {
        [map { $_ - 1 } @$_]
    } multiplicative_partitions($n, logint($B, 2) + 1);

    my @counts;
    foreach my $sig (@signatures) {
        push @counts, count_prime_signature_numbers_in_range($A, $B, $sig);
    }

    vecsum(@counts);
}

count_inverse_tau(1, 462, 16) == 16 or die "error";
count_inverse_tau(1,   powint(2, 9),  10) == 13    or die "error";
count_inverse_tau(1,   powint(2, 40), 5040) == 103 or die "error";
count_inverse_tau(1e5, 1e5 + 500, 48) == 10 or die "error";
count_inverse_tau(100050, 100500, 48) == 10 or die "error";

# Number of k <= 2^(n-1) such that tau(k) = n
# https://oeis.org/A393179
foreach my $n (1 .. 32) {
    say "a($n) = ", count_inverse_tau(1, powint(2, $n - 1), $n);
}


================================================
FILE: Math/count_of_k-almost_primes.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 May 2020
# https://github.com/trizen

# Count the number of k-almost primes <= n.

# Definition:
#   A number is k-almost prime if it is the product of k prime numbers (not necessarily distinct).
#   In other works, a number n is k-almost prime iff: bigomega(n) = k.

# See also:
#   https://mathworld.wolfram.com/AlmostPrime.html

# OEIS:
#   https://oeis.org/A072000 -- count of 2-almost primes
#   https://oeis.org/A072114 -- count of 3-almost primes
#   https://oeis.org/A082996 -- count of 4-almost primes
#   https://oeis.org/A126280 -- Triangle read by rows: T(k,n) is number of numbers <= 10^n that are products of k primes.

use 5.036;
use ntheory qw(:all);

sub k_prime_count ($n, $k) {

    if ($k == 1) {
        return prime_count($n);
    }

    if ($k == 2) {
        return semiprime_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $j = 0) {

        my $s = rootint(divint($n, $m), $k);

        if ($k == 2) {

            forprimes {
                $count += prime_count(divint($n, mulint($m, $_))) - $j++;
            } $p, $s;

            return;
        }

        foreach my $q (@{primes($p, $s)}) {
            __SUB__->($m * $q, $q, $k - 1, $j++);
        }
    }->(1, 2, $k);

    return $count;
}

# Run some tests

foreach my $k (1 .. 10) {

    my $upto = pn_primorial($k) + int(rand(1e5));

    my $x = k_prime_count($upto, $k);
    my $y = almost_prime_count($k, $upto);

    say "Testing: $k with n = $upto -> $x";

    $x == $y
      or die "Error: $x != $y";
}

say '';

foreach my $k (1 .. 10) {
    printf("Count of %2d-almost primes <= 10^n: %s\n", $k, join(', ', map { k_prime_count(powint(10, $_), $k) } 0 .. 10));
}

__END__
Count of  1-almost primes <= 10^n: 0, 4, 25, 168, 1229, 9592, 78498, 664579, 5761455, 50847534, 455052511
Count of  2-almost primes <= 10^n: 0, 4, 34, 299, 2625, 23378, 210035, 1904324, 17427258, 160788536, 1493776443
Count of  3-almost primes <= 10^n: 0, 1, 22, 247, 2569, 25556, 250853, 2444359, 23727305, 229924367, 2227121996
Count of  4-almost primes <= 10^n: 0, 0, 12, 149, 1712, 18744, 198062, 2050696, 20959322, 212385942, 2139236881
Count of  5-almost primes <= 10^n: 0, 0, 4, 76, 963, 11185, 124465, 1349779, 14371023, 150982388, 1570678136
Count of  6-almost primes <= 10^n: 0, 0, 2, 37, 485, 5933, 68963, 774078, 8493366, 91683887, 977694273
Count of  7-almost primes <= 10^n: 0, 0, 0, 14, 231, 2973, 35585, 409849, 4600247, 50678212, 550454756
Count of  8-almost primes <= 10^n: 0, 0, 0, 7, 105, 1418, 17572, 207207, 2367507, 26483012, 291646797
Count of  9-almost primes <= 10^n: 0, 0, 0, 2, 47, 671, 8491, 101787, 1180751, 13377156, 148930536
Count of 10-almost primes <= 10^n: 0, 0, 0, 0, 22, 306, 4016, 49163, 578154, 6618221, 74342563


================================================
FILE: Math/count_of_k-omega_primes.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 March 2021
# https://github.com/trizen

# Count the number of k-omega primes <= n.

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub omega_prime_count_rec ($n, $k = 1) {

    if ($k == 1) {
        return prime_power_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $s = rootint(divint($n, $m), $k), $j = 1) {

        if ($k == 2) {

            for (; $p <= $s ; ++$j) {

                my $r = next_prime($p);

                for (my $t = mulint($m, $p) ; $t <= $n ; $t = mulint($t, $p)) {

                    my $w = divint($n, $t);

                    if ($r > $w) {
                        last;
                    }

                    $count += prime_count($w) - $j;

                    for (my $r2 = $r ; $r2 <= $w ; $r2 = next_prime($r2)) {

                        my $u = vecprod($t, $r2, $r2);

                        if ($u > $n) {
                            last;
                        }

                        for (; $u <= $n ; $u = mulint($u, $r2)) {
                            ++$count;
                        }
                    }
                }

                $p = $r;
            }

            return;
        }

        for (; $p <= $s ; ++$j) {

            my $r = next_prime($p);

            for (my $t = mulint($m, $p) ; $t <= $n ; $t = mulint($t, $p)) {
                my $s = rootint(divint($n, $t), $k - 1);
                last if ($r > $s);
                __SUB__->($t, $r, $k - 1, $s, $j + 1);
            }

            $p = $r;
        }
    }->(1, 2, $k);

    return $count;
}

# Run some tests

foreach my $k (1 .. 10) {

    my $upto = pn_primorial($k) + int(rand(1e5));

    my $x = omega_prime_count_rec($upto, $k);
    my $y = omega_prime_count($k, $upto);

    say "Testing: $k with n = $upto -> $x";

    $x == $y
      or die "Error: $x != $y";
}

say '';

foreach my $k (1 .. 8) {
    say("Count of $k-omega primes for 10^n: ", join(', ', map { omega_prime_count_rec(10**$_, $k) } 0 .. 8));
}

__END__
Count of 1-omega primes for 10^n: 0, 7, 35, 193, 1280, 9700, 78734, 665134, 5762859
Count of 2-omega primes for 10^n: 0, 2, 56, 508, 4097, 33759, 288726, 2536838, 22724609
Count of 3-omega primes for 10^n: 0, 0, 8, 275, 3695, 38844, 379720, 3642766, 34800362
Count of 4-omega primes for 10^n: 0, 0, 0, 23, 894, 15855, 208034, 2389433, 25789580
Count of 5-omega primes for 10^n: 0, 0, 0, 0, 33, 1816, 42492, 691209, 9351293
Count of 6-omega primes for 10^n: 0, 0, 0, 0, 0, 25, 2285, 72902, 1490458
Count of 7-omega primes for 10^n: 0, 0, 0, 0, 0, 0, 8, 1716, 80119
Count of 8-omega primes for 10^n: 0, 0, 0, 0, 0, 0, 0, 1, 719


================================================
FILE: Math/count_of_k-powerfree_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 August 2021
# https://github.com/trizen

# Sub-linear formula for computing the count of k-powerfree numbers <= n.

# See also:
#   https://oeis.org/A013928 -- Number of (positive) squarefree numbers < n.
#   https://oeis.org/A060431 -- Number of cubefree numbers <= n.
#   https://oeis.org/A071172 -- Number of squarefree integers <= 10^n.
#   https://oeis.org/A160112 -- Number of cubefree integers not exceeding 10^n.

use 5.020;
use strict;
use warnings;

use ntheory qw(vecall factor_exp powint divint forsquarefree rootint);
use experimental qw(signatures);

sub is_powerfree ($n, $k = 2) {
    (vecall { $_->[1] < $k } factor_exp($n)) ? 1 : 0;
}

sub powerfree_count ($n, $k = 2) {
    my $count = 0;
    forsquarefree {
        $count += ((scalar(@_) & 1) ? -1 : 1) * divint($n, powint($_, $k));
    } rootint($n, $k);
    return $count;
}

foreach my $k (2 .. 10) {
    printf("Number of %2d-powerfree numbers <= 10^j: {%s}\n", $k,
           join(', ', map { powerfree_count(powint(10, $_), $k) } 0 .. 10));
}

use Test::More tests => 10;

foreach my $k (1..10) {
    my $n = 100;

    is_deeply(
        [map { powerfree_count($_, $k) } 1..$n],
        [map { scalar grep { is_powerfree($_, $k) } 1..$_ } 1..$n],
    );
}

__END__
Number of  2-powerfree numbers <= 10^j: {1, 7, 61, 608, 6083, 60794, 607926, 6079291, 60792694, 607927124, 6079270942}
Number of  3-powerfree numbers <= 10^j: {1, 9, 85, 833, 8319, 83190, 831910, 8319081, 83190727, 831907372, 8319073719}
Number of  4-powerfree numbers <= 10^j: {1, 10, 93, 925, 9240, 92395, 923939, 9239385, 92393839, 923938406, 9239384029}
Number of  5-powerfree numbers <= 10^j: {1, 10, 97, 965, 9645, 96440, 964388, 9643874, 96438737, 964387341, 9643873409}
Number of  6-powerfree numbers <= 10^j: {1, 10, 99, 984, 9831, 98297, 982954, 9829527, 98295260, 982952591, 9829525925}
Number of  7-powerfree numbers <= 10^j: {1, 10, 100, 993, 9918, 99173, 991721, 9917199, 99171986, 991719856, 9917198560}
Number of  8-powerfree numbers <= 10^j: {1, 10, 100, 997, 9960, 99595, 995940, 9959393, 99593921, 995939202, 9959392012}
Number of  9-powerfree numbers <= 10^j: {1, 10, 100, 999, 9981, 99800, 997997, 9979956, 99799564, 997995634, 9979956329}
Number of 10-powerfree numbers <= 10^j: {1, 10, 100, 1000, 9991, 99902, 999008, 9990065, 99900642, 999006414, 9990064132}


================================================
FILE: Math/count_of_k-powerful_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 February 2020
# https://github.com/trizen

# Fast recursive algorithm for counting the number of k-powerful numbers <= n.
# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.

# Example:
#   2-powerful = a^2 * b^3,             for a,b >= 1
#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1
#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1

# OEIS:
#   https://oeis.org/A001694 -- 2-powerful numbers
#   https://oeis.org/A036966 -- 3-powerful numbers
#   https://oeis.org/A036967 -- 4-powerful numbers
#   https://oeis.org/A069492 -- 5-powerful numbers
#   https://oeis.org/A069493 -- 6-powerful numbers

# See also:
#   https://oeis.org/A118896 -- Number of powerful numbers <= 10^n.

use 5.020;
use warnings;

use ntheory      qw(rootint divint gcd is_square_free mulint powint);
use experimental qw(signatures);

sub powerful_count ($n, $k = 2) {

    my $count = 0;

    sub ($m, $r) {

        if ($r <= $k) {
            $count += rootint(divint($n, $m), $r);
            return;
        }

        foreach my $v (1 .. rootint(divint($n, $m), $r)) {

            gcd($m, $v) == 1   or next;
            is_square_free($v) or next;

            __SUB__->(mulint($m, powint($v, $r)), $r - 1);
        }
      }
      ->(1, 2 * $k - 1);

    return $count;
}

foreach my $k (2 .. 10) {
    printf("Number of %2d-powerful <= 10^j: {%s}\n", $k, join(', ', map { powerful_count(powint(10, $_), $k) } 0 .. ($k + 15)));
}

__END__
Number of  2-powerful <= 10^j: {1, 4, 14, 54, 185, 619, 2027, 6553, 21044, 67231, 214122, 680330, 2158391, 6840384, 21663503, 68575557, 217004842, 686552743}
Number of  3-powerful <= 10^j: {1, 2, 7, 20, 51, 129, 307, 713, 1645, 3721, 8348, 18589, 41136, 90619, 198767, 434572, 947753, 2062437, 4480253}
Number 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}
Number 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}
Number 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}
Number 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}
Number 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}
Number 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}
Number 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}


================================================
FILE: Math/count_of_k-powerful_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 28 February 2021
# Edit: 11 April 2024
# https://github.com/trizen

# Fast recursive algorithm for counting the number of k-powerful numbers in a given range [A,B].
# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.

# Example:
#   2-powerful = a^2 * b^3,             for a,b >= 1
#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1
#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1

# OEIS:
#   https://oeis.org/A001694 -- 2-powerful numbers
#   https://oeis.org/A036966 -- 3-powerful numbers
#   https://oeis.org/A036967 -- 4-powerful numbers
#   https://oeis.org/A069492 -- 5-powerful numbers
#   https://oeis.org/A069493 -- 6-powerful numbers

# See also:
#   https://oeis.org/A118896 -- Number of powerful numbers <= 10^n.

use 5.036;
use ntheory 0.74 qw(:all);

sub powerful_count_in_range ($A, $B, $k = 2) {

    return 0 if ($A > $B);

    my $count = 0;

    sub ($m, $r) {

        my $from = 1;
        my $upto = rootint(divint($B, $m), $r);

        if ($r <= $k) {

            if ($A > $m) {

                # Optimization by Dana Jacobsen (from Math::Prime::Util::PP)
                my $l = cdivint($A, $m);
                if (($l >> $r) == 0) {
                    $from = 2;
                }
                else {
                    $from = rootint($l, $r);
                    $from++ if (powint($from, $r) != $l);
                }
            }

            $count += $upto - $from + 1;
            return;
        }

        foreach my $v ($from .. $upto) {
            gcd($m, $v) == 1   or next;
            is_square_free($v) or next;
            __SUB__->(mulint($m, powint($v, $r)), $r - 1);
        }
      }
      ->(1, 2 * $k - 1);

    return $count;
}

require Math::Sidef;

foreach my $k (2 .. 10) {

    my $lo = int rand powint(10, $k - 1);
    my $hi = int rand powint(10, $k);

    my $c1 = powerful_count_in_range($lo, $hi, $k);
    my $c2 = Math::Sidef::powerful_count($k, $lo, $hi);

    $c1 eq $c2 or die "Error for [$lo, $hi] -- ($c1 != $c2)\n";

    printf("Number of %2d-powerful in range 10^j .. 10^(j+1): {%s}\n",
           $k, join(", ", map { powerful_count_in_range(powint(10, $_), powint(10, $_ + 1), $k) } 0 .. $k + 7));
}

__END__
Number of  2-powerful in range 10^j .. 10^(j+1): {4, 10, 41, 132, 435, 1409, 4527, 14492, 46188, 146892}
Number of  3-powerful in range 10^j .. 10^(j+1): {2, 5, 13, 32, 79, 179, 407, 933, 2077, 4628, 10242}
Number of  4-powerful in range 10^j .. 10^(j+1): {1, 4, 6, 14, 33, 61, 119, 230, 443, 836, 1572, 2925}
Number of  5-powerful in range 10^j .. 10^(j+1): {1, 2, 5, 8, 16, 32, 55, 95, 165, 285, 495, 848, 1403}
Number of  6-powerful in range 10^j .. 10^(j+1): {1, 1, 4, 6, 9, 17, 33, 52, 86, 130, 217, 350, 552, 876}
Number 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}
Number 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}
Number 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}
Number 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}


================================================
FILE: Math/count_of_perfect_powers.pl
================================================
#!/usr/bin/perl

# Efficient formula for counting the numbers of perfect powers <= n.

# Formula:
#   a(n) = n - Sum_{1..floor(log_2(n))} mu(k) * (floor(n^(1/k)) - 1)
#        = 1 - Sum_{2..floor(log_2(n))} mu(k) * (floor(n^(1/k)) - 1)

# See also:
#   https://oeis.org/A069623

use 5.036;
use ntheory qw(logint rootint moebius vecsum);

sub perfect_power_count ($n) {
    1 - vecsum(map { moebius($_) * (rootint($n, $_) - 1) } 2 .. logint($n, 2));
}

foreach my $n (0 .. 15) {
    printf("a(10^%d) = %s\n", $n, perfect_power_count(10**$n));
}

__END__
a(10^0) = 1
a(10^1) = 4
a(10^2) = 13
a(10^3) = 41
a(10^4) = 125
a(10^5) = 367
a(10^6) = 1111
a(10^7) = 3395
a(10^8) = 10491
a(10^9) = 32670
a(10^10) = 102231
a(10^11) = 320990
a(10^12) = 1010196
a(10^13) = 3184138
a(10^14) = 10046921
a(10^15) = 31723592


================================================
FILE: Math/count_of_prime_power.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 02 December 2018
# https://github.com/trizen

# A nice algorithm in terms of the prime-counting function for computing the number of prime powers <= n.
#   a(n) = Sum_{k=1..floor(log_2(n))} π(floor(n^(1/k)))

# Example: a(10^n) for n=1..15:
#   a(10^1)  = 7
#   a(10^2)  = 35
#   a(10^3)  = 193
#   a(10^4)  = 1280
#   a(10^5)  = 9700
#   a(10^6)  = 78734
#   a(10^7)  = 665134
#   a(10^8)  = 5762859
#   a(10^9)  = 50851223
#   a(10^10) = 455062595
#   a(10^11) = 4118082969
#   a(10^12) = 37607992088
#   a(10^13) = 346065767406
#   a(10^14) = 3204942420923
#   a(10^15) = 29844572385358

# See also:
#   https://oeis.org/A025528
#   https://oeis.org/A267712
#   https://en.wikipedia.org/wiki/Prime-counting_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(vecsum logint rootint prime_count);

sub prime_power_count($n) {
    vecsum(map { prime_count(rootint($n, $_)) } 1 .. logint($n, 2));
}

foreach my $n (1 .. 14) {   # takes ~2.1s
    say "a(10^$n) = ", prime_power_count(10**$n);
}


================================================
FILE: Math/count_of_prime_signature_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 April 2026
# https://github.com/trizen

# Count the number of k-omega numbers <= n that have a given prime signature.

use 5.036;
use ntheory 0.74 qw(:all);

prime_precalc(1e7);

sub count_prime_signature_numbers($n, $prime_signature) {

    my $k = scalar(@$prime_signature);

    if ($k == 0) {
        return 1 if (1 <= $n);
        return 0;
    }

    $n >= 1 || return 0;

    my $count = 0;

    my $generate = sub ($m, $lo, $k, $P, $sum_e, $j = 0) {

        my $e = $P->[$k - 1];
        my $hi = rootint(divint($n, $m), $sum_e);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {
            $count += prime_count($hi) - $j;
            return;
        }

        if ($k == 2) {
            my $e2 = $P->[0];
            foreach my $p (@{primes($lo, $hi)}) {
                my $t = mulint($m, powint($p, $e));
                my $u = rootint(divint($n, $t), $e2);
                $count += prime_count($u) - ++$j;
            }
            return;
        }

        for (my $p = $lo; $p <= $hi; ) {
            my $t = mulint($m, powint($p, $e));
            my $r = next_prime($p);
            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e, ++$j);
            $p = $r;
        }
    };

    my %seen;
    my $sum_e = vecsum(@$prime_signature) || return 0;

    if ($sum_e > logint($n, 2)) {
        return 0;
    }

    forperm {
        my @perm = @{$prime_signature}[@_];
        if (!$seen{join(' ', @perm)}++) {
            $generate->(1, 2, scalar(@perm), \@perm, $sum_e);
        }
    } $k;

    return $count;
}

sub count_prime_signature_numbers_in_range($A, $B, $signature) {
    my $term_1 = count_prime_signature_numbers($A - 1, $signature);
    my $term_2 = count_prime_signature_numbers($B,     $signature);
    $term_2 - $term_1;
}

#
## Example
#
sub A395379($n) {
    my $A = powint((nth_prime($n - 1) || 1), 7);
    my $B = powint(nth_prime($n),            7) - 1;

    my $term_1 = count_prime_signature_numbers_in_range($A, $B, [7]);
    my $term_2 = count_prime_signature_numbers_in_range($A, $B, [3, 1]);
    my $term_3 = count_prime_signature_numbers_in_range($A, $B, [1, 1, 1]);

    $term_1 + $term_2 + $term_3;
}

join(' ', map { A395379($_) } 1 .. 9) eq join(' ', 15, 408, 16838, 167649, 4140037, 9474308, 74874018, 102945521, 527810589)
  or die "error";

my $prime_signature = [3, 2, 2];
my $n               = 10000;

count_prime_signature_numbers($n, $prime_signature) == 7                or die "error";
count_prime_signature_numbers_in_range(2e3, 1e4, $prime_signature) == 6 or die "error";


================================================
FILE: Math/count_of_rough_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 July 2020
# https://github.com/trizen

# Count the number of B-rough numbers <= n.

# See also:
#   https://en.wikipedia.org/wiki/Rough_number

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub my_rough_count ($n, $p) {

    my %cache;

    sub ($n, $p) {

        if ($p > sqrtint($n)) {
            return 1;
        }

        if ($p == 2) {
            return ($n >> 1);
        }

        if ($p == 3) {
            my $t = divint($n, 3);
            return ($t - ($t >> 1));
        }

        my $key = "$n,$p";

        return $cache{$key}
            if exists $cache{$key};

        my $u = 0;
        my $t = divint($n, $p);

        for (my $q = 2 ; $q < $p ; $q = next_prime($q)) {

            my $v = __SUB__->($t - ($t % $q), $q);

            if ($v == 1) {
                $u += prime_count($q, $p - 1);
                last;
            }
            else {
                $u += $v;
            }
        }

        $cache{$key} = $t - $u;
    }->($n * $p, $p);
}

foreach my $p (@{primes(30)}) {
    say "Φ(10^n, $p) for n <= 10: [", join(', ', map { my_rough_count(powint(10, $_), $p) } 0 .. 10), "]";
}

__END__
Φ(10^n,  2) for n <= 10: [1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000, 10000000000]
Φ(10^n,  3) for n <= 10: [1, 5, 50, 500, 5000, 50000, 500000, 5000000, 50000000, 500000000, 5000000000]
Φ(10^n,  5) for n <= 10: [1, 3, 33, 333, 3333, 33333, 333333, 3333333, 33333333, 333333333, 3333333333]
Φ(10^n,  7) for n <= 10: [1, 2, 26, 266, 2666, 26666, 266666, 2666666, 26666666, 266666666, 2666666666]
Φ(10^n, 11) for n <= 10: [1, 1, 22, 228, 2285, 22857, 228571, 2285713, 22857142, 228571428, 2285714285]
Φ(10^n, 13) for n <= 10: [1, 1, 21, 207, 2077, 20779, 207792, 2077921, 20779221, 207792207, 2077922077]
Φ(10^n, 17) for n <= 10: [1, 1, 20, 190, 1917, 19181, 191808, 1918081, 19180820, 191808190, 1918081917]
Φ(10^n, 19) for n <= 10: [1, 1, 19, 179, 1806, 18053, 180524, 1805251, 18052535, 180525355, 1805253568]
Φ(10^n, 23) for n <= 10: [1, 1, 18, 170, 1711, 17103, 171021, 1710234, 17102401, 171024023, 1710240224]
Φ(10^n, 29) for n <= 10: [1, 1, 17, 163, 1634, 16361, 163586, 1635877, 16358819, 163588196, 1635881952]


================================================
FILE: Math/count_of_rough_numbers_recursive.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 September 2025
# Edit: 13 March 2026
# https://github.com/trizen

# Count the number of B-rough numbers <= n.

# See also:
#   https://en.wikipedia.org/wiki/Rough_number

use 5.036;
use ntheory 0.74 qw(:all);

sub my_rough_count($n, $k) {

    my @P = @{primes($k - 1)};

    return $n if (@P == 0);

    my %cache;

    sub ($n, $a) {

        # Meissel-Lehmer truncation (The Sublinear Secret)
        if ($P[$a - 1] > sqrt($n)) {
            return prime_count($n) - $a + 1;
        }

        return $cache{$a}{$n}
          if exists $cache{$a}{$n};

        # Initial count: odd numbers ≤ n
        my $count = $n - ($n >> 1);

        # Inclusion-Exclusion principle
        for my $j (1 .. $a - 1) {
            last if ($P[$j] > $n);
            $count -= __SUB__->(divint($n, $P[$j]), $j);
        }

        $cache{$a}{$n} = $count;
    }->($n, scalar @P);
}

foreach my $p (@{primes(30)}) {
    say "Φ(10^n, $p) for n <= 10: [", join(', ', map { my_rough_count(powint(10, $_), $p) } 0 .. 10), "]";
}

__END__
Φ(10^n,  2) for n <= 10: [1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000, 10000000000]
Φ(10^n,  3) for n <= 10: [1, 5, 50, 500, 5000, 50000, 500000, 5000000, 50000000, 500000000, 5000000000]
Φ(10^n,  5) for n <= 10: [1, 3, 33, 333, 3333, 33333, 333333, 3333333, 33333333, 333333333, 3333333333]
Φ(10^n,  7) for n <= 10: [1, 2, 26, 266, 2666, 26666, 266666, 2666666, 26666666, 266666666, 2666666666]
Φ(10^n, 11) for n <= 10: [1, 1, 22, 228, 2285, 22857, 228571, 2285713, 22857142, 228571428, 2285714285]
Φ(10^n, 13) for n <= 10: [1, 1, 21, 207, 2077, 20779, 207792, 2077921, 20779221, 207792207, 2077922077]
Φ(10^n, 17) for n <= 10: [1, 1, 20, 190, 1917, 19181, 191808, 1918081, 19180820, 191808190, 1918081917]
Φ(10^n, 19) for n <= 10: [1, 1, 19, 179, 1806, 18053, 180524, 1805251, 18052535, 180525355, 1805253568]
Φ(10^n, 23) for n <= 10: [1, 1, 18, 170, 1711, 17103, 171021, 1710234, 17102401, 171024023, 1710240224]
Φ(10^n, 29) for n <= 10: [1, 1, 17, 163, 1634, 16361, 163586, 1635877, 16358819, 163588196, 1635881952]


================================================
FILE: Math/count_of_smooth_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 May 2020
# https://github.com/trizen

# Count the number of B-smooth numbers <= n.

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.036;
use ntheory qw(:all);

sub my_smooth_count ($n, $p) {

    if ($p == 2) {
        return 1 + logint($n, 2);
    }

    my $q = prev_prime($p);

    my $count = 0;
    foreach my $k (0 .. logint($n, $p)) {
        $count += __SUB__->(divint($n, powint($p, $k)), $q);
    }

    return $count;
}

foreach my $p (@{primes(50)}) {
    say "Ψ(10^n, $p) for n <= 10: [", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), "]";
}

__END__
Ψ(10^n, 2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]
Ψ(10^n, 3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]
Ψ(10^n, 5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]
Ψ(10^n, 7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]
Ψ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]
Ψ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]
Ψ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]
Ψ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]
Ψ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]
Ψ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]
Ψ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]
Ψ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]
Ψ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]
Ψ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]
Ψ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]


================================================
FILE: Math/count_of_smooth_numbers_memoized.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 06 April 2026
# https://github.com/trizen

# Count the number of B-smooth numbers <= n. (memoized version)

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.036;
use ntheory qw(:all);

sub my_smooth_count ($n, $p) {

    my @cache;
    my @P = @{primes($p)};

    sub ($x, $i) {

        $x || return 0;

        # Count powers of 2 in [1..$x] = number of bits in $x.
        $i || return 1 + logint($x, 2);

        # All of 1..$x are P[$i]-smooth when $x < P[$i]
        return $x if $x < $P[$i];

        $cache[$i]{$x} //= __SUB__->($x, $i - 1) + __SUB__->(divint($x, $P[$i]), $i);
    }->($n, $#P);
}

foreach my $p (@{primes(50)}) {
    say "Ψ(10^n, $p) for n <= 10: [", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), "]";
}

__END__
Ψ(10^n, 2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]
Ψ(10^n, 3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]
Ψ(10^n, 5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]
Ψ(10^n, 7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]
Ψ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]
Ψ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]
Ψ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]
Ψ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]
Ψ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]
Ψ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]
Ψ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]
Ψ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]
Ψ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]
Ψ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]
Ψ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]


================================================
FILE: Math/count_of_smooth_numbers_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 July 2020
# https://github.com/trizen

# Count the number of B-smooth numbers <= n.

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.036;
use ntheory qw(:all);

use Math::GMPz;

sub my_smooth_count ($n, $k) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    if ($k < 2 or Math::GMPz::Rmpz_sgn($n) <= 0) {
        return 0;
    }

    if (Math::GMPz::Rmpz_cmp_ui($n, $k) <= 0) {
        return $n;
    }

    my $count = sub {
        my ($n, $p) = @_;

        if ($p == 2) {
            return Math::GMPz::Rmpz_sizeinbase($n, 2);
        }

        my $t = Math::GMPz::Rmpz_init();
        my $q = prev_prime($p);

        my $sum = 0;

        for (my $k = 0; ; ++$k) {

            Math::GMPz::Rmpz_ui_pow_ui($t, $p, $k);
            Math::GMPz::Rmpz_tdiv_q($t, $n, $t);

            if (Math::GMPz::Rmpz_cmp_ui($t, $q) <= 0) {
                $sum += Math::GMPz::Rmpz_get_ui($t);
                last;
            }
            else {
                $sum += __SUB__->($t, $q);
            }
        }

        $sum;
    }->($n, prev_prime($k + 1));

    return $count;
}

foreach my $p (@{primes(50)}) {
    say "Ψ(10^n, $p) for n <= 10: [", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), "]";
}

__END__
Ψ(10^n,  2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]
Ψ(10^n,  3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]
Ψ(10^n,  5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]
Ψ(10^n,  7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]
Ψ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]
Ψ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]
Ψ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]
Ψ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]
Ψ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]
Ψ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]
Ψ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]
Ψ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]
Ψ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]
Ψ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]
Ψ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]


================================================
FILE: Math/count_of_smooth_numbers_mpz_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 July 2020
# https://github.com/trizen

# Count the number of B-smooth numbers <= n.

# Inspired by Dana Jacobsen's "smooth_count(n,k)" algorithm from Math::Prime::Util::PP.

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.036;
use ntheory qw(:all);

use Math::GMPz;

sub my_smooth_count ($n, $k) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    if ($k < 2 or Math::GMPz::Rmpz_sgn($n) <= 0) {
        return 0;
    }

    if (Math::GMPz::Rmpz_cmp_ui($n, $k) <= 0) {
        return $n;
    }

    my $count = sub ($n, $k) {

        my $sum = Math::GMPz::Rmpz_sizeinbase($n, 2);

        if ($k == 2) {
            return $sum;
        }

        my $t = Math::GMPz::Rmpz_init();

        for (my $p = 3 ; $p <= $k ; $p = next_prime($p)) {

            Math::GMPz::Rmpz_tdiv_q_ui($t, $n, $p);

            if (Math::GMPz::Rmpz_cmp_ui($t, $p) <= 0) {
                $sum += Math::GMPz::Rmpz_get_ui($t);
            }
            else {
                $sum += __SUB__->($t, $p);
            }
        }

        $sum;
    }->($n, prev_prime($k + 1));

    return $count;
}

foreach my $p (@{primes(50)}) {
    say "Ψ(10^n, $p) for n <= 10: [", join(', ', map { my_smooth_count(powint(10, $_), $p) } 0 .. 10), "]";
}

__END__
Ψ(10^n,  2) for n <= 10: [1, 4, 7, 10, 14, 17, 20, 24, 27, 30, 34]
Ψ(10^n,  3) for n <= 10: [1, 7, 20, 40, 67, 101, 142, 190, 244, 306, 376]
Ψ(10^n,  5) for n <= 10: [1, 9, 34, 86, 175, 313, 507, 768, 1105, 1530, 2053]
Ψ(10^n,  7) for n <= 10: [1, 10, 46, 141, 338, 694, 1273, 2155, 3427, 5194, 7575]
Ψ(10^n, 11) for n <= 10: [1, 10, 55, 192, 522, 1197, 2432, 4520, 7838, 12867, 20193]
Ψ(10^n, 13) for n <= 10: [1, 10, 62, 242, 733, 1848, 4106, 8289, 15519, 27365, 45914]
Ψ(10^n, 17) for n <= 10: [1, 10, 67, 287, 945, 2579, 6179, 13389, 26809, 50351, 89679]
Ψ(10^n, 19) for n <= 10: [1, 10, 72, 331, 1169, 3419, 8751, 20198, 42950, 85411, 160626]
Ψ(10^n, 23) for n <= 10: [1, 10, 76, 369, 1385, 4298, 11654, 28434, 63768, 133440, 263529]
Ψ(10^n, 29) for n <= 10: [1, 10, 79, 402, 1581, 5158, 14697, 37627, 88415, 193571, 399341]
Ψ(10^n, 31) for n <= 10: [1, 10, 82, 434, 1778, 6070, 18083, 48366, 118599, 270648, 581272]
Ψ(10^n, 37) for n <= 10: [1, 10, 84, 461, 1958, 6952, 21535, 59867, 152482, 361173, 804369]
Ψ(10^n, 41) for n <= 10: [1, 10, 86, 485, 2129, 7833, 25133, 72345, 190767, 467495, 1076462]
Ψ(10^n, 43) for n <= 10: [1, 10, 88, 508, 2300, 8740, 28955, 86086, 234423, 592949, 1408465]
Ψ(10^n, 47) for n <= 10: [1, 10, 90, 529, 2463, 9639, 32876, 100688, 282397, 735425, 1797897]


================================================
FILE: Math/count_of_smooth_numbers_with_k_factors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 March 2020
# https://github.com/trizen

# Count the number of B-smooth numbers below a given limit, where each number has at least k distinct prime factors.

# Problem inspired by:
#   https://projecteuler.net/problem=268

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub smooth_numbers ($initial, $limit, $primes) {

    my @h = ($initial);

    foreach my $p (@$primes) {
        foreach my $n (@h) {
            if ($n * $p <= $limit) {
                push @h, $n * $p;
            }
        }
    }

    return \@h;
}

my $PRIME_MAX = 100;    # the prime factors must all be <= this value
my $LEAST_K   = 4;      # each number must have at least this many distinct prime factors

sub count_smooth_numbers ($limit) {

    my $count  = 0;
    my @primes = @{primes($PRIME_MAX)};

    forcomb {

        my $c = [@primes[@_]];
        my $v = vecprod(@$c);

        if ($v <= $limit) {

            my $h = smooth_numbers($v, $limit, $c);

            foreach my $n (@$h) {
                my $new_h = smooth_numbers(1, divint($limit, $n), [grep { $_ < $c->[0] } @primes]);
                $count += scalar @$new_h;
            }
        }

    } scalar(@primes), $LEAST_K;

    return $count;
}

say "\n# Count of $PRIME_MAX-smooth numbers with at least $LEAST_K distinct prime factors:\n";

foreach my $n (1 .. 16) {
    my $count = count_smooth_numbers(powint(10, $n));
    say "C(10^$n) = $count";
}

__END__

# Count of 100-smooth numbers with at least 4 distinct prime factors:

C(10^1)  = 0
C(10^2)  = 0
C(10^3)  = 23
C(10^4)  = 811
C(10^5)  = 8963
C(10^6)  = 53808
C(10^7)  = 235362
C(10^8)  = 866945
C(10^9)  = 2855050
C(10^10) = 8668733
C(10^11) = 24692618
C(10^12) = 66682074
C(10^13) = 171957884
C(10^14) = 425693882
C(10^15) = 1015820003
C(10^16) = 2344465914


================================================
FILE: Math/count_of_squarefree_k-almost_primes.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 March 2021
# https://github.com/trizen

# Count the number of squarefree k-almost primes <= n.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime

=for comment

# PARI/GP program:

a(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);

=cut

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub squarefree_almost_prime_count ($n, $k) {

    if ($k == 0) {
        return (($n <= 0) ? 0 : 1);
    }

    if ($k == 1) {
        return prime_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $j = 1) {

        my $s = rootint(divint($n, $m), $k);

        if ($k == 2) {

            forprimes {
                $count += prime_count(divint($n, mulint($m, $_))) - $j++;
            } $p, $s;

            return;
        }

        for (; $p <= $s ; ++$j) {
            my $r = next_prime($p);
            __SUB__->(mulint($m, $p), $r, $k - 1, $j + 1);
            $p = $r;
        }
    }->(1, 2, $k);

    return $count;
}

# Run some tests

foreach my $k (1 .. 7) {

    my $upto = pn_primorial($k) + int(rand(1e5));

    my $x = squarefree_almost_prime_count($upto, $k);
    my $y = scalar grep { is_square_free($_) } @{almost_primes($k, 1, $upto)};

    say "Testing: $k with n = $upto -> $x";

    $x == $y
      or die "Error: $x != $y";
}

say '';

foreach my $k (1 .. 8) {
    say("Count of squarefree $k-almost primes for 10^n: ",
        join(', ', map { squarefree_almost_prime_count(10**$_, $k) } 0 .. 9));
}

__END__
Count of squarefree 1-almost primes for 10^n: 0, 4, 25, 168, 1229, 9592, 78498, 664579, 5761455, 50847534
Count of squarefree 2-almost primes for 10^n: 0, 2, 30, 288, 2600, 23313, 209867, 1903878, 17426029, 160785135
Count of squarefree 3-almost primes for 10^n: 0, 0, 5, 135, 1800, 19919, 206964, 2086746, 20710806, 203834084
Count of squarefree 4-almost primes for 10^n: 0, 0, 0, 16, 429, 7039, 92966, 1103888, 12364826, 133702610
Count of squarefree 5-almost primes for 10^n: 0, 0, 0, 0, 24, 910, 18387, 286758, 3884936, 48396263
Count of squarefree 6-almost primes for 10^n: 0, 0, 0, 0, 0, 20, 1235, 32396, 605939, 9446284
Count of squarefree 7-almost primes for 10^n: 0, 0, 0, 0, 0, 0, 8, 1044, 38186, 885674
Count of squarefree 8-almost primes for 10^n: 0, 0, 0, 0, 0, 0, 0, 1, 516, 29421


================================================
FILE: Math/count_of_squarefree_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 February 2017
# https://github.com/trizen

# Counts the number of squarefree numbers in the range [1, n].

# See also:
#   https://oeis.org/A053462
#   https://projecteuler.net/problem=193
#   https://en.wikipedia.org/wiki/Square-free_integer
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function

use 5.010;
use strict;
use integer;

use ntheory qw(moebius sqrtint);

sub squarefree_count {
    my ($n) = @_;

    my $k     = 1;
    my $count = 0;

    foreach my $m (moebius(1, sqrtint($n))) {
        $count += $m * ($n / ($k++)**2);
    }

    return $count;
}

say squarefree_count(10**9);    #=> 607927124


================================================
FILE: Math/count_subtriangles.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 September 2015
# Website: https://github.com/trizen

# A general formula for counting the number of possible triangles inside a triangle.

use strict;
use warnings;

## The formula is:
#
#    Sum((2n+1)(k-n-1), {n=0, k-1})
#
# where "k" is the number of rows of the triangle.

## Closed forms:
#
#   (k^3)/3 - (k^2)/2 + (k/6)
#   (1/6)(k-1)k(2k-1)
#

# For example, the following triangle:
#    1
#   234
#  56789

# Has 3 rows and 5 different triangles inside:
#    1
#   234
#  56789
#
#    1
#   234
#
#    2
#   567
#
#    3
#   678
#
#    4
#   789

sub count_subtriangles {
    my ($k) = @_;

    my $sum = 0;
    foreach my $n (0 .. $k - 1) {
        $sum += (2 * $n + 1) * ($k - $n - 1);
    }
    $sum;
}

foreach my $k (1 .. 20) {
    my $closed = ($k - 1) * $k * (2 * $k - 1) / 6;
    printf("%2d: %10s %10s\n", $k, count_subtriangles($k), $closed);
}

__END__
 1: 0
 2: 1
 3: 5
 4: 14
 5: 30
 6: 55
 7: 91
 8: 140
 9: 204
10: 285
11: 385
12: 506
13: 650
14: 819
15: 1015
16: 1240
17: 1496
18: 1785
19: 2109
20: 2470


================================================
FILE: Math/cube-full_numbers.pl
================================================
#!/usr/bin/perl

# Fast algorithm for generating all the cube-full numbers <= n.
# A positive integer n is considered cube-full, if for every prime p that divides n, so does p^3.

# See also:
#   THE DISTRIBUTION OF CUBE-FULL NUMBERS, by P. SHIU (1990).

# OEIS:
#   https://oeis.org/A036966 -- 3-full (or cube-full, or cubefull) numbers: if a prime p divides n then so does p^3.

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub cubefull_numbers ($n) {    # cubefull numbers <= n

    my @cubeful;

    for my $a (1 .. rootint($n, 5)) {
        is_square_free($a) || next;
        for my $b (1 .. rootint(divint($n, powint($a, 5)), 4)) {
            gcd($a, $b) == 1 or next;
            is_square_free($b) || next;
            my $v = mulint(powint($a, 5), powint($b, 4));
            foreach my $c (1 .. rootint(divint($n, $v), 3)) {
                my $z = vecprod($v, $c, $c, $c);
                push @cubeful, $z;
            }
        }
    }

    sort { $a <=> $b } @cubeful;
}

say join(', ', cubefull_numbers(1e4));

__END__
1, 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


================================================
FILE: Math/cuboid.pl
================================================
       sub say{print@_,$/}sub cube
      {my($x,$y,$z)=map{int}@_;my(
     $c,$h,$v,$d,$s)=((qw{+ - | /}
    ),$ARGV[3]||' ');my($p,$o)=(0,
   0);say ' 'x($z+1),$c,$h x$x,$c;
  for(1..$z){say ' 'x($z-$_+1),$d,
 $s x$x,$d,$s x($_-1-$p),$_>$y?!$p
 ?do{$p=1;$o=$z-$y;$c}:$p++?$d:$c:
 $v;}say$c,$h x$x,$c,$z<$y?do{$s x
 $z,$v}:$p?do{$s x($z-$o),$d}:do{$
 s x$z,$c};for(1..$y){say$v,$s x$x
 ,$v,$z-1>=$y?$_>=$z?($s x$x,$c):(
 $s x($z-$_-$o),$d):$z==$y?do{$s#
 x($y-$_),$d}:$y-$_>$z?do{$s x$z
 ,$v}:$y-$_==$z?do{$s x($y-$_),
 $c}:do{$s x($y-$_),$d}}say$c,
 $h x$x,$c}cube @ARGV>2?@ARGV
 [0..2]:map{rand($_)}20,10,8


================================================
FILE: Math/cyclotomic_factorization_method.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 22 May 2022
# https://github.com/trizen

# A variant of the Cyclotomic factorization method.

# See also:
#   https://www.ams.org/journals/mcom/1989-52-185/S0025-5718-1989-0947467-1/S0025-5718-1989-0947467-1.pdf

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use POSIX qw(ULONG_MAX);

use experimental qw(signatures);

sub cyclotomic_factor ($m, $n = 3628800, $upto = 100) {

    $n = Math::GMPz->new("$n");
    $m = Math::GMPz->new("$m");

    Math::GMPz::Rmpz_sgn($m) || return 1;

    # n must be >= 0
    (Math::GMPz::Rmpz_sgn($n) || return 1) > 0
      or return 1;

    return 1 if (Math::GMPz::Rmpz_cmp_ui($m, 1) == 0);

    my @factor_exp = factor_exp($n);

    # Generate the squarefree divisors of n, along
    # with the number of prime factors of each divisor
    my @sd;
    foreach my $pe (@factor_exp) {
        my ($p) = @$pe;

        $p =
          ($p < ULONG_MAX)
          ? Math::GMPz::Rmpz_init_set_ui($p)
          : Math::GMPz::Rmpz_init_set_str("$p", 10);

        push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;
        push @sd, [$p, 1];
    }

    push @sd, [Math::GMPz->new(1), 0];

    my $prod = Math::GMPz::Rmpz_init_set_ui(1);
    my $g    = Math::GMPz::Rmpz_init();
    my $x    = Math::GMPz::Rmpz_init_set_ui(2);

    foreach my $k (2 .. $upto) {
        my $x = Math::GMPz::Rmpz_init_set_ui($k);

        foreach my $pair (@sd) {
            my ($d, $c) = @$pair;

            my $base = Math::GMPz::Rmpz_init();
            Math::GMPz::Rmpz_divexact($base, $n, $d);
            Math::GMPz::Rmpz_powm($base, $x, $base, $m);    # x^(n/d) mod m
            Math::GMPz::Rmpz_sub_ui($base, $base, 1);

            Math::GMPz::Rmpz_gcd($g, $base, $m);

            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
                last if (Math::GMPz::Rmpz_cmp($g, $m) == 0);
                return $g;
            }

            if ($c % 2 == 1) {
                Math::GMPz::Rmpz_invert($base, $base, $m);
            }

            Math::GMPz::Rmpz_mul($prod, $prod, $base);
            Math::GMPz::Rmpz_mod($prod, $prod, $m);
        }
    }

    return 1;
}

say cyclotomic_factor(Math::GMPz->new(2)**64 + 1,  40320, 100);     #=> 274177
say cyclotomic_factor(Math::GMPz->new(2)**128 - 1, 40320, 100);     #=> 18446744073709551615


================================================
FILE: Math/cyclotomic_factorization_method_2.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 23 May 2022
# https://github.com/trizen

# A variant of the Cyclotomic factorization method.

# See also:
#   https://www.ams.org/journals/mcom/1989-52-185/S0025-5718-1989-0947467-1/S0025-5718-1989-0947467-1.pdf

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use POSIX qw(ULONG_MAX);

use experimental qw(signatures);

sub cyclotomic_factor ($n, @bases) {

    $n = Math::GMPz->new("$n");

    Math::GMPz::Rmpz_cmp_ui($n, 1) > 0 or return;

    if (@bases) {
        @bases = map { Math::GMPz->new("$_") } @bases;
    }
    else {
        @bases = map { Math::GMPz->new($_) } (2 .. logint($n, 2));
    }

    my $cyclotomicmod = sub ($n, $x, $m) {

        my @factor_exp = factor_exp($n);

        # Generate the squarefree divisors of n, along
        # with the number of prime factors of each divisor
        my @sd;
        foreach my $pe (@factor_exp) {
            my ($p) = @$pe;
            push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;
            push @sd, [$p, 1];
        }

        push @sd, [Math::GMPz::Rmpz_init_set_ui(1), 0];

        my $prod = Math::GMPz::Rmpz_init_set_ui(1);

        foreach my $pair (@sd) {
            my ($d, $c) = @$pair;

            my $base = Math::GMPz::Rmpz_init();
            my $exp  = CORE::int($n / $d);

            Math::GMPz::Rmpz_powm_ui($base, $x, $exp, $m);    # x^(n/d) mod m
            Math::GMPz::Rmpz_sub_ui($base, $base, 1);

            if ($c % 2 == 1) {
                Math::GMPz::Rmpz_invert($base, $base, $m) || return $base;
            }

            Math::GMPz::Rmpz_mul($prod, $prod, $base);
            Math::GMPz::Rmpz_mod($prod, $prod, $m);
        }

        $prod;
    };

    my @factors;
    state $g = Math::GMPz::Rmpz_init_nobless();

  OUTER: foreach my $x (@bases) {
        my $limit = 1 + logint($n, $x);

        foreach my $k (3 .. $limit) {
            my $c = $cyclotomicmod->($k, $x, $n);

            Math::GMPz::Rmpz_gcd($g, $n, $c);
            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {

                my $valuation = Math::GMPz::Rmpz_remove($n, $n, $g);
                push(@factors, (Math::GMPz::Rmpz_init_set($g)) x $valuation);

                if (Math::GMPz::Rmpz_cmp_ui($n, 1) == 0 or is_prob_prime($n)) {
                    last OUTER;
                }
            }
        }
    }

    if (Math::GMPz::Rmpz_cmp_ui($n, 1) > 0) {
        push @factors, $n;
    }

    @factors = sort { Math::GMPz::Rmpz_cmp($a, $b) } @factors;
    return @factors;
}

say join ' * ', cyclotomic_factor(Math::GMPz->new(2)**120 + 1);
say join ' * ', cyclotomic_factor(Math::GMPz->new(2)**128 - 1);
say join ' * ', cyclotomic_factor(((Math::GMPz->new(10)**258 - 1) / 9 - Math::GMPz->new(10)**(258 >> 1) - 1), 10);

__END__
257 * 65281 * 4278255361 * 18518800563924107521
3 * 5 * 17 * 257 * 65537 * 4294967297 * 18446744073709551617
10 * 11 * 11 * 91 * 101 * 10001 * 100000001 * 10000000000000001 * 100000000000000000000000000000001 * 909090909090909090909090909090909090909091 * 10000000000000000000000000000000000000000000000000000000000000001 * 1098901098901098901098901098901098901098900989010989010989010989010989010989010989011


================================================
FILE: Math/cyclotomic_polynomial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 July 2018
# https://github.com/trizen

# Efficient formula for computing the n-th cyclotomic polynomial.

# Formula:
#   cyclotomic(n, x) = Prod_{d|n} (x^(n/d) - 1)^moebius(d)

# Optimization: by generating only the squarefree divisors of n and keeping track of
# the number of prime factors of each divisor, we do not need the Moebius function.

# See also:
#   https://en.wikipedia.org/wiki/Cyclotomic_polynomial

use 5.010;
use strict;
use warnings;

use ntheory qw(:all);
use Math::AnyNum qw(:overload prod);

sub cyclotomic_polynomial {
    my ($n, $x) = @_;

    # Special case for x = 1: cyclotomic(n, 1) is A020500.
    if ($x == 1) {
        my $k = is_prime_power($n) || return 1;
        my $p = rootint($n, $k);
        return $p;
    }

    # Special case for x = -1: cyclotomic(n, -1) is A020513.
    if ($x == -1) {
        ($n % 2 == 0) || return 1;
        my $k = is_prime_power($n >> 1) || return 1;
        my $p = rootint($n >> 1, $k);
        return $p;
    }

    # Generate the squarefree divisors of n, along
    # with the number of prime factors of each divisor
    my @d;
    foreach my $p (map { $_->[0] } factor_exp($n)) {
        push @d, map { [$_->[0] * $p, $_->[1] + 1] } @d;
        push @d, [$p, 1];
    }

    push @d, [1, 0];

    # Multiply the terms
    prod(map { ($x**($n / $_->[0]) - 1)**((-1)**$_->[1]) } @d);
}

say cyclotomic_polynomial(5040, 4 / 3);
say join(', ', map { cyclotomic_polynomial($_, 2) } 1 .. 20);    # https://oeis.org/A019320


================================================
FILE: Math/definite_integral_numerical_approximation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 21 February 2018
# https://github.com/trizen

# Simple numerical approximation for definite integrals.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub integral ($from, $to, $expr, $dx = 0.0001) {
    my $sum = 0;

    for (my $x = $from ; $x <= $to ; $x += $dx) {
        $sum += $expr->($x) * $dx;
    }

    return $sum;
}

say integral(0, atan2(0, -1), sub ($x) { sin($x) });              # 1.99999999867257
say integral(2,  100, sub ($x) { 1 / log($x) });                  # 29.0810390821689
say integral(-3, 5,   sub ($x) { 10 * $x**3 + $x * cos($x) });    # 1355.97975127903


================================================
FILE: Math/dickson_linear_forms_prime_sieve.pl
================================================
#!/usr/bin/perl

# Sieve for linear forms primes of the form `a_1*m + b_1`, `a_2*m + b_2`, ..., `a_k*m + b_k`.
# Inspired by the PARI program by David A. Corneth from OEIS A372238.

# See also:
#   https://oeis.org/A088250
#   https://oeis.org/A318646
#   https://oeis.org/A372238/a372238.gp.txt
#   https://en.wikipedia.org/wiki/Dickson%27s_conjecture

use 5.036;
use ntheory     qw(:all);
use List::Util  qw(all);
use Time::HiRes qw(time);

sub isrem($m, $p, $terms) {

    foreach my $k (@$terms) {
        my $t = $k->[0] * $m + $k->[1];
        if ($t % $p == 0 and $t > $p) {
            return;
        }
    }

    return 1;
}

sub remaindersmodp($p, $terms) {
    grep { isrem($_, $p, $terms) } (0 .. $p - 1);
}

sub remainders_for_primes($primes, $terms) {

    my $res = [[0, 1]];
    my $M   = 1;

    foreach my $p (@$primes) {

        my @rems = remaindersmodp($p, $terms);

        if (scalar(@rems) == $p) {
            next;    # skip trivial primes
        }

        if (!@rems) {
            @rems = (0);
        }

        my @nres;
        foreach my $r (@$res) {
            foreach my $rem (@rems) {
                push @nres, [chinese($r, [$rem, $p]), lcm($p, $r->[1])];
            }
        }

        $res = \@nres;
        $M *= $p;
    }

    return ($M, [sort { $a <=> $b } map { $_->[0] } @$res]);
}

sub deltas ($integers) {

    my @deltas;
    my $prev = 0;

    foreach my $n (@$integers) {
        push @deltas, $n - $prev;
        $prev = $n;
    }

    shift(@deltas);
    return \@deltas;
}

sub linear_form_primes($terms, $maxp = nth_prime(scalar(@$terms))) {

    my @primes = @{primes($maxp)};

    my ($M, $r) = remainders_for_primes(\@primes, $terms);
    my @d = @{deltas($r)};

    while (@d and $d[0] == 0) {
        shift @d;
    }

    push @d, $r->[0] + $M - $r->[-1];

    my $m      = $r->[0];
    my $d_len  = scalar(@d);
    my $t0     = time;
    my $prev_m = $m;
    my $n      = scalar(@$terms);

    for (my $j = 0 ; ; ++$j) {

        my $ok = 1;
        foreach my $k (@$terms) {
            if (!is_prime($k->[0] * $m + $k->[1])) {
                $ok = 0;
                last;
            }
        }

        if ($ok) {
            return $m;
        }

        if ($j % 1e7 == 0 and $j > 0) {
            my $tdelta = time - $t0;
            say "Searching for a($n) with m = $m";
            say "Performance: ", (($m - $prev_m) / 1e9) / $tdelta, " * 10^9 terms per second";
            $t0     = time;
            $prev_m = $m;
        }

        $m += $d[$j % $d_len];
    }
}

foreach my $n (1 .. 10) {
    my @terms = map { [$_, 1] } (1 .. $n);
    my $m     = linear_form_primes(\@terms);
    say "a($n) = $m";
}

__END__
a(1) = 1
a(2) = 1
a(3) = 2
a(4) = 330
a(5) = 10830
a(6) = 25410
a(7) = 512820
a(8) = 512820
a(9) = 12960606120
a(10) = 434491727670


================================================
FILE: Math/dickson_linear_forms_prime_sieve_in_range.pl
================================================
#!/usr/bin/perl

# Sieve for linear forms primes of the form `a_1*m + b_1`, `a_2*m + b_2`, ..., `a_k*m + b_k`.
# Inspired by the PARI program by David A. Corneth from OEIS A372238.

# See also:
#   https://oeis.org/A088250
#   https://oeis.org/A318646
#   https://oeis.org/A372238/a372238.gp.txt
#   https://en.wikipedia.org/wiki/Dickson%27s_conjecture

use 5.036;
use ntheory     qw(:all);
use Time::HiRes qw(time);
use Test::More tests => 36;

sub isrem($m, $p, $terms) {

    foreach my $k (@$terms) {
        my $t = $k->[0] * $m + $k->[1];
        if ($t % $p == 0 and $t > $p) {     # FIXME: the second condition can be removed (see version 2)
            return;
        }
    }

    return 1;
}

sub remaindersmodp($p, $terms) {
    grep { isrem($_, $p, $terms) } (0 .. $p - 1);
}

sub remainders_for_primes($primes, $terms) {

    my $res = [[0, 1]];
    my $M   = 1;

    foreach my $p (@$primes) {

        my @rems = remaindersmodp($p, $terms);

        if (scalar(@rems) == $p) {
            next;    # skip trivial primes
        }

        my @nres;
        foreach my $r (@$res) {
            foreach my $rem (@rems) {
                push @nres, [chinese($r, [$rem, $p]), lcm($p, $r->[1])];
            }
        }

        $M *= $p;
        $res = \@nres;
    }

    return ($M, [sort { $a <=> $b } map { $_->[0] } @$res]);
}

sub deltas ($integers) {

    my @deltas;
    my $prev = 0;

    foreach my $n (@$integers) {
        push @deltas, $n - $prev;
        $prev = $n;
    }

    shift(@deltas);
    return \@deltas;
}

sub linear_form_primes_in_range($A, $B, $terms) {

    return [] if ($A > $B);

    my $terms_len  = scalar(@$terms);
    my $range_size = int(exp(LambertW(log($B - $A + 1))));

    my $max_p  = nth_prime(vecmin($terms_len, $range_size));
    my @primes = @{primes($max_p)};

    my ($M, $r) = remainders_for_primes(\@primes, $terms);
    my @d = @{deltas($r)};

    while (@d and $d[0] == 0) {
        shift @d;
    }

    push @d, $r->[0] + $M - $r->[-1];

    my $m      = $r->[0];
    my $d_len  = scalar(@d);
    my $t0     = time;
    my $prev_m = $m;
    my $d_sum  = vecsum(@d);

    $m += $d_sum * divint($A, $d_sum);

    my $j = 0;

    while ($m < $A) {
        $m += $d[$j++ % $d_len];
    }

    my @arr;

    while (1) {
        my $ok = 1;
        foreach my $k (@$terms) {
            if (!is_prime($k->[0] * $m + $k->[1])) {
                $ok = 0;
                last;
            }
        }

        if ($ok) {
            push @arr, $m;
        }

        if ($j % 1e7 == 0 and $j > 0) {
            my $tdelta = time - $t0;
            say "Searching with m = $m";
            say "Performance: ", (($m - $prev_m) / 1e9) / $tdelta, " * 10^9 terms per second";
            $t0     = time;
            $prev_m = $m;
        }

        $m += $d[$j++ % $d_len];
        last if ($m > $B);
    }

    return \@arr;
}

is_deeply(linear_form_primes_in_range(1, 41, [[1, 41]]),                                           [2, 6, 12, 18, 20, 26, 30, 32, 38]);
is_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]);
is_deeply(linear_form_primes_in_range(1, 100, [[1, 1], [2, 1]]),                                   [1, 2, 6, 18, 30, 36, 78, 96]);
is_deeply(linear_form_primes_in_range(1, 1000, [[1, 1], [2, 1], [3, 1]]),                          [2, 6, 36, 210, 270, 306, 330, 336, 600, 726]);
is_deeply(linear_form_primes_in_range(1, 10000, [[1, 1], [2, 1], [3, 1], [4, 1]]),                 [330, 1530, 3060, 4260, 4950, 6840]);
is_deeply(linear_form_primes_in_range(1, 12000, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]),         [10830]);
is_deeply(linear_form_primes_in_range(9538620, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9538620, 9780870, 9783060, 9993270]);
is_deeply(linear_form_primes_in_range(9538620 + 1, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9780870, 9783060, 9993270]);

is_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]);
is_deeply(linear_form_primes_in_range(1, 10000, [[1, -1], [2, -1], [3, -1], [4, -1]]), [6, 90, 1410, 1890]);
is_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]);
is_deeply(linear_form_primes_in_range(1, 500, [[2, 1], [4, 3], [8, 7]]),               [2, 5, 20, 44, 89, 179, 254, 359]);
is_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1]]),            [3, 6, 21, 45, 90, 180, 255, 360]);
is_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1], [16, -1]]),  [3, 45, 90, 180, 255]);
is_deeply(linear_form_primes_in_range(1, 500, [[17, 1], [23, 5]]),                     [18, 24, 66, 126, 186, 216, 378, 384, 426]);

#<<<
is_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]);
is_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]);
#>>>

sub f($n, $multiple = 1, $alpha = 1) {

    my @terms = map { [$multiple * $_, $alpha] } 1 .. $n;

    my $A = 1;
    my $B = 2 * $A;

    while (1) {
        my @arr = @{linear_form_primes_in_range($A, $B, \@terms)};

        if (@arr) {
            return $arr[0];
        }

        $A = $B + 1;
        $B = 2 * $A;
    }
}

is_deeply([map { f($_, 1, +1) } 1 .. 8], [1, 1, 2, 330, 10830, 25410,  512820,  512820]);     # A088250
is_deeply([map { f($_, 1, -1) } 1 .. 8], [3, 3, 4, 6,   6,     154770, 2894220, 2894220]);    # A088651
is_deeply([map { f($_, 9, +1) } 1 .. 8], [2, 2, 4, 170, 9860,  23450,  56980,   56980]);      # A372238
is_deeply([map { f($_, 2, -1) } 1 .. 8], [2, 2, 2, 3,   3,     77385,  1447110, 1447110]);    # A124492
is_deeply([map { f($_, 2, +1) } 1 .. 8], [1, 1, 1, 165, 5415,  12705,  256410,  256410]);     # A071576

is_deeply([map { f($_, $_, +1) } 1 .. 8], [1, 1, 2, 765,  2166, 4235,  73260,  2780085]);
is_deeply([map { f($_, $_, -1) } 1 .. 8], [3, 2, 2, 3225, 18,   25795, 413460, 7505190]);

is_deeply([map { f($_, $_, -13) } 1 .. 6], [15, 8,  6,  15,  24, 2800]);
is_deeply([map { f($_, $_, +13) } 1 .. 6], [4,  12, 10, 90,  18, 40705]);
is_deeply([map { f($_, $_, -23) } 1 .. 6], [25, 13, 10, 255, 6,  5]);
is_deeply([map { f($_, $_, +23) } 1 .. 6], [6,  9,  10, 60,  48, 13300]);

is_deeply([map { f($_, 1, +23) } 1 .. 6], [6, 18, 30, 210, 240, 79800]);
is_deeply([map { f($_, 1, -23) } 1 .. 8], [25, 26, 30, 30, 30, 30, 142380, 1319010]);

is_deeply([map { f($_, 1, +101) } 1 .. 6], [2,   6,   96,  180, 3990, 1683990]);
is_deeply([map { f($_, 1, -101) } 1 .. 6], [103, 104, 104, 240, 3630, 78540]);

is_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
is_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
is_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
is_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

say "\n=> The least Chernick's \"universal form\" Carmichael number with n prime factors";

foreach my $n (3 .. 9) {

    my $terms = [map { [$_, 1] } (6, 12, (map { 9 * (1 << $_) } 1 .. $n - 2))];

    my $A = 1;
    my $B = 2 * $A;

    while (1) {
        my @arr = @{linear_form_primes_in_range($A, $B, $terms)};

        @arr = grep { valuation($_, 2) >= $n - 4 } @arr;

        if (@arr) {
            say "a($n) = $arr[0]";
            last;
        }

        $A = $B + 1;
        $B = 2 * $A;
    }
}

say "\n=> Smallest number k such that r*k + 1 is prime for all r = 1 to n";

foreach my $n (1 .. 9) {
    say "a($n) = ", f($n, 1, 1);
}

__END__
=> The least Chernick's "universal form" Carmichael number with n prime factors
a(3) = 1
a(4) = 1
a(5) = 380
a(6) = 380
a(7) = 780320
a(8) = 950560
a(9) = 950560

=> Smallest number k such that r*k + 1 is prime for all r = 1 to n

a(1) = 1
a(2) = 1
a(3) = 2
a(4) = 330
a(5) = 10830
a(6) = 25410
a(7) = 512820
a(8) = 512820


================================================
FILE: Math/dickson_linear_forms_prime_sieve_in_range_2.pl
================================================
#!/usr/bin/perl

# Sieve for linear forms primes of the form `a_1*m + b_1`, `a_2*m + b_2`, ..., `a_k*m + b_k`.

# See also:
#   https://oeis.org/A088250
#   https://oeis.org/A318646
#   https://oeis.org/A372238/a372238.gp.txt
#   https://en.wikipedia.org/wiki/Dickson%27s_conjecture

use utf8;
use 5.036;
use ntheory     qw(:all);
use Time::HiRes qw(time);
use Test::More tests => 36;

sub remainders_mod_p($p, $terms) {
    my @bad;    # bad[m] = 1 means m is forbidden modulo p

    foreach my $pair (@$terms) {
        my ($n, $k) = @$pair;

        $n %= $p;
        $k %= $p;

        if ($n == 0) {

            # Term is constant mod p
            if ($k == 0) {

                # Always 0 mod p -> no admissible residue exists
                return ();
            }
            next;    # This term forbids no residue for this p
        }

        # Forbid the unique residue m ≡ -k * n^{-1} (mod p)
        my $n_inv    = invmod($n, $p);
        my $m_forbid = (-$k * $n_inv) % $p;
        $bad[$m_forbid] = 1;
    }

    return grep { !$bad[$_] } 0 .. $p - 1;
}

sub combine_crt($arr, $M, $p, $S_p) {

    my @res;
    my $Minv = invmod($M % $p, $p);

    foreach my $r (@$arr) {
        my $r_mod_p = $r % $p;
        foreach my $s (@$S_p) {
            push @res, (((($s - $r_mod_p) % $p) * $Minv) % $p) * $M + $r;
        }
    }

    return \@res;
}

sub remainders_for_primes($primes) {

    my $M        = 1;
    my $residues = [0];

    foreach my $pair (@$primes) {
        my ($p, $S_p) = @$pair;

        # Early return if no valid residues
        return ($M, []) unless @$S_p;

        $residues = combine_crt($residues, $M, $p, $S_p);
        $M *= $p;
    }

    return ($M, [sort { $a <=> $b } @$residues]);
}

sub deltas ($integers) {

    my @deltas;
    my $prev = 0;

    foreach my $n (@$integers) {
        push @deltas, $n - $prev;
        $prev = $n;
    }

    shift(@deltas);
    return \@deltas;
}

sub select_optimal_primes ($A, $B, $terms) {

    my $range = $B - $A + 1;
    return () if $range <= 0;

    my $target_modulus = (1 + rootint($range, 5))**4;

    my $M = 1;
    my @primes;

    for (my $p = 2 ; $M <= $target_modulus ; $p = next_prime($p)) {
        my @S_p = remainders_mod_p($p, $terms);

        if (scalar(@S_p) == $p) {
            next;    # skip trivial primes
        }

        push(@primes, [$p, \@S_p]);
        $M *= $p;
    }

    return @primes;
}

sub linear_form_primes_in_range($A, $B, $terms) {

    return [] if ($A > $B);
    return [] if !@$terms;

    # Select an optimal subset of small primes for the modular sieve
    my @primes = select_optimal_primes($A, $B, $terms);
    return [] unless @primes;

    my ($M, $r) = remainders_for_primes(\@primes);

    # If there are no admissible residues modulo M, there can be no solutions
    return [] if !@$r;

    # Compute differences
    my @d = @{deltas($r)};

    # Remove leading zeros
    while (@d and $d[0] == 0) {
        shift @d;
    }

    # Add wraparound delta
    push @d, $r->[0] + $M - $r->[-1];

    my $compute_small_values = 0;
    my $small_values_limit   = vecmin(500, $B);
    my $original_A           = undef;

    if ($A < $small_values_limit) {
        $original_A           = $A;
        $A                    = $small_values_limit + 1;
        $compute_small_values = 1;
    }

    my $m      = $r->[0];
    my $d_len  = scalar(@d);
    my $t0     = time;
    my $prev_m = $m;

    # Jump near to the start of the range
    $m += $M * divint($A, $M);

    my $j = 0;

    while ($m < $A) {
        $m += $d[$j++ % $d_len];
    }

    my @multiples = map { $_->[0] } @$terms;
    my @alphas    = map { $_->[1] } @$terms;
    my @range     = (0 .. $#multiples);

    my ($ok, @arr);

    # Compute small values if needed
    if ($compute_small_values) {
        foreach my $k ($original_A .. $small_values_limit) {

            $ok = 1;
            foreach my $i (@range) {
                if (!is_prime($multiples[$i] * $k + $alphas[$i])) {
                    $ok = 0;
                    last;
                }
            }

            $ok && push @arr, $k;
        }
    }

    while ($m <= $B) {

        $ok = 1;
        foreach my $k (@range) {
            if (!is_prime($multiples[$k] * $m + $alphas[$k])) {
                $ok = 0;
                last;
            }
        }

        if ($ok) {
            push @arr, $m;
        }

        if ($j % 1e7 == 0 and $j > 0) {
            my $tdelta = time - $t0;
            say "Searching with m = $m";
            say "Performance: ", (($m - $prev_m) / 1e9) / $tdelta, " * 10^9 terms per second";
            $t0     = time;
            $prev_m = $m;
        }

        $m += $d[$j++ % $d_len];
    }

    return \@arr;
}

is_deeply(linear_form_primes_in_range(1, 41, [[1, 41]]),                                           [2, 6, 12, 18, 20, 26, 30, 32, 38]);
is_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]);
is_deeply(linear_form_primes_in_range(1, 100, [[1, 1], [2, 1]]),                                   [1, 2, 6, 18, 30, 36, 78, 96]);
is_deeply(linear_form_primes_in_range(1, 1000, [[1, 1], [2, 1], [3, 1]]),                          [2, 6, 36, 210, 270, 306, 330, 336, 600, 726]);
is_deeply(linear_form_primes_in_range(1, 10000, [[1, 1], [2, 1], [3, 1], [4, 1]]),                 [330, 1530, 3060, 4260, 4950, 6840]);
is_deeply(linear_form_primes_in_range(1, 12000, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]),         [10830]);
is_deeply(linear_form_primes_in_range(9538620, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9538620, 9780870, 9783060, 9993270]);
is_deeply(linear_form_primes_in_range(9538620 + 1, 9993270, [[1, 1], [2, 1], [3, 1], [4, 1], [5, 1]]), [9780870, 9783060, 9993270]);

is_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]);
is_deeply(linear_form_primes_in_range(1, 10000, [[1, -1], [2, -1], [3, -1], [4, -1]]), [6, 90, 1410, 1890]);
is_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]);
is_deeply(linear_form_primes_in_range(1, 500, [[2, 1], [4, 3], [8, 7]]),               [2, 5, 20, 44, 89, 179, 254, 359]);
is_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1]]),            [3, 6, 21, 45, 90, 180, 255, 360]);
is_deeply(linear_form_primes_in_range(1, 500, [[2, -1], [4, -1], [8, -1], [16, -1]]),  [3, 45, 90, 180, 255]);
is_deeply(linear_form_primes_in_range(1, 500, [[17, 1], [23, 5]]),                     [18, 24, 66, 126, 186, 216, 378, 384, 426]);

#<<<
is_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]);
is_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]);
#>>>

sub f($n, $multiple = 1, $alpha = 1) {

    my @terms = map { [$multiple * $_, $alpha] } 1 .. $n;

    my $A = 1;
    my $B = 2 * $A;

    while (1) {
        my @arr = @{linear_form_primes_in_range($A, $B, \@terms)};

        if (@arr) {
            return $arr[0];
        }

        $A = $B + 1;
        $B = 2 * $A;
    }
}

is_deeply([map { f($_, 1, +1) } 1 .. 8], [1, 1, 2, 330, 10830, 25410,  512820,  512820]);     # A088250
is_deeply([map { f($_, 1, -1) } 1 .. 8], [3, 3, 4, 6,   6,     154770, 2894220, 2894220]);    # A088651
is_deeply([map { f($_, 9, +1) } 1 .. 8], [2, 2, 4, 170, 9860,  23450,  56980,   56980]);      # A372238
is_deeply([map { f($_, 2, -1) } 1 .. 8], [2, 2, 2, 3,   3,     77385,  1447110, 1447110]);    # A124492
is_deeply([map { f($_, 2, +1) } 1 .. 8], [1, 1, 1, 165, 5415,  12705,  256410,  256410]);     # A071576

is_deeply([map { f($_, $_, +1) } 1 .. 8], [1, 1, 2, 765,  2166, 4235,  73260,  2780085]);
is_deeply([map { f($_, $_, -1) } 1 .. 8], [3, 2, 2, 3225, 18,   25795, 413460, 7505190]);

is_deeply([map { f($_, $_, -13) } 1 .. 6], [15, 8,  6,  15,  24, 2800]);
is_deeply([map { f($_, $_, +13) } 1 .. 6], [4,  12, 10, 90,  18, 40705]);
is_deeply([map { f($_, $_, -23) } 1 .. 6], [25, 13, 10, 255, 6,  5]);
is_deeply([map { f($_, $_, +23) } 1 .. 6], [6,  9,  10, 60,  48, 13300]);

is_deeply([map { f($_, 1, +23) } 1 .. 6], [6, 18, 30, 210, 240, 79800]);
is_deeply([map { f($_, 1, -23) } 1 .. 8], [25, 26, 30, 30, 30, 30, 142380, 1319010]);

is_deeply([map { f($_, 1, +101) } 1 .. 6], [2,   6,   96,  180, 3990, 1683990]);
is_deeply([map { f($_, 1, -101) } 1 .. 6], [103, 104, 104, 240, 3630, 78540]);

is_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
is_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
is_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
is_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

say "\n=> The least Chernick's \"universal form\" Carmichael number with n prime factors";

foreach my $n (3 .. 9) {

    my $terms = [map { [$_, 1] } (6, 12, (map { 9 * (1 << $_) } 1 .. $n - 2))];

    my $A = 1;
    my $B = 2 * $A;

    while (1) {
        my @arr = @{linear_form_primes_in_range($A, $B, $terms)};

        @arr = grep { valuation($_, 2) >= $n - 4 } @arr;

        if (@arr) {
            say "a($n) = $arr[0]";
            last;
        }

        $A = $B + 1;
        $B = 2 * $A;
    }
}

say "\n=> Smallest number k such that r*k + 1 is prime for all r = 1 to n";

foreach my $n (1 .. 10) {
    say "a($n) = ", f($n, 1, 1);
}

__END__
=> The least Chernick's "universal form" Carmichael number with n prime factors
a(3) = 1
a(4) = 1
a(5) = 380
a(6) = 380
a(7) = 780320
a(8) = 950560

=> Smallest number k such that r*k + 1 is prime for all r = 1 to n

a(1) = 1
a(2) = 1
a(3) = 2
a(4) = 330
a(5) = 10830
a(6) = 25410
a(7) = 512820
a(8) = 512820
a(9) = 12960606120
a(10) = 434491727670


================================================
FILE: Math/difference_of_k_powers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 28 April 2017
# https://github.com/trizen

# Find the smallest representations for natural numbers as the difference of some k power.

# Example:
#   781 =  4^5 - 3^5
#   992 = 10^3 - 2^3
#   999 = 32^2 - 5^2

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(root ceil log2);

OUTER: foreach my $n (1 .. 1000) {
    foreach my $i (2 .. ceil(log2($n))) {
        my $s = ceil(root($n, $i));
        foreach my $k (0 .. $s) {
            if ($s**$i - $k**$i == $n) {
                say "$n = $s^$i - $k^$i";
                next OUTER;
            }
        }
    }
}


================================================
FILE: Math/difference_of_powers_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 July 2019
# Edit: 22 March 2022
# https://github.com/trizen

# A simple factorization method for numbers that can be expressed as a difference of powers.

# Very effective for numbers of the form:
#
#   n^k - 1
#
# where k has many divisors.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use ntheory qw(divisors rootint logint is_power gcd vecprod powint);

use constant {
              MIN_FACTOR => 1,    # ignore small factors
              LOG_BRANCH => 0,    # true to use the log branch in addition to the root branch
             };

sub diff_power_factorization ($n, $verbose = 0) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $orig = $n;
    my @diff_powers_params;

    my $diff_powers = sub ($r1, $e1, $r2, $e2) {
        my @factors;

        my @divs1 = divisors($e1);
        my @divs2 = divisors($e2);

        foreach my $d1 (@divs1) {
            my $x = $r1**$d1;
            foreach my $d2 (@divs2) {
                my $y = $r2**$d2;
                foreach my $j (1, -1) {

                    my $t = $x - $j * $y;
                    my $g = gcd($t, $n);

                    if ($g > MIN_FACTOR and $g < $n) {
                        while ($n % $g == 0) {
                            $n /= $g;
                            push @factors, $g;
                        }
                    }
                }
            }
        }

        sort { $a <=> $b } @factors;
    };

    my $diff_power_check = sub ($r1, $e1) {

        my $u  = $r1**$e1;
        my $dx = abs($u - $n);

        if ($dx >= 1 and Math::GMPz::Rmpz_perfect_power_p($dx)) {

            my $e2 = ($dx == 1) ? 1 : is_power($dx);
            my $r2 = Math::GMPz->new(rootint($dx, $e2));

            if ($verbose) {
                if ($u > $n) {
                    say "[*] Difference of powers detected: ", sprintf("%s^%s - %s^%s", $r1, $e1, $r2, $e2);
                }
                else {
                    say "[*] Sum of powers detected: ", sprintf("%s^%s + %s^%s", $r1, $e1, $r2, $e2);
                }
            }

            push @diff_powers_params, [$r1, $e1, $r2, $e2];
        }
    };

    # Sum and difference of powers of the form a^k ± b^k, where a and b are large.
    foreach my $e1 (reverse 2 .. logint($n, 2)) {

        my $t = Math::GMPz->new(rootint($n, $e1));

        $diff_power_check->($t,     $e1);    # sum of powers
        $diff_power_check->($t + 1, $e1);    # difference of powers
    }

    # Sum and difference of powers of the form a^k ± b^k, where a and b are small.
    if (LOG_BRANCH) {
        foreach my $r1 (2 .. logint($n, 2)) {

            my $t = logint($n, $r1);

            $diff_power_check->(Math::GMPz->new($r1), $t);        # sum of powers
            $diff_power_check->(Math::GMPz->new($r1), $t + 1);    # difference of powers
        }

        my %seen_param;
        @diff_powers_params = grep { !$seen_param{join(' ', @$_)}++ } @diff_powers_params;
    }

    my @factors;

    foreach my $fp (@diff_powers_params) {
        push @factors, $diff_powers->(@$fp);
    }

    push @factors, $orig / vecprod(@factors);
    return sort { $a <=> $b } @factors;
}

if (@ARGV) {
    say join ', ', diff_power_factorization($ARGV[0], 1);
    exit;
}

# Large roots
say join ' * ', diff_power_factorization(powint(1009,     24) + powint(29,  12));
say join ' * ', diff_power_factorization(powint(1009,     24) - powint(29,  12));
say join ' * ', diff_power_factorization(powint(59388821, 12) - powint(151, 36));

say '-' x 80;

# Small roots
say join ' * ', diff_power_factorization(powint(2,  256) - 1);
say join ' * ', diff_power_factorization(powint(10, 120) + 1);
say join ' * ', diff_power_factorization(powint(10, 120) - 1);
say join ' * ', diff_power_factorization(powint(10, 120) - 25);
say join ' * ', diff_power_factorization(powint(10, 105) - 1);
say join ' * ', diff_power_factorization(powint(10, 105) + 1);
say join ' * ', diff_power_factorization(powint(10, 120) - 2134 * 2134);

__END__
2 * 537154643295831327753001 * 1154140443257087164049583013000044736320575461201
6 * 6 * 13 * 19 * 31 * 37 * 140 * 33937 * 36359 * 45120343 * 14006607073 * 1036518447751 * 1074309285719975471632201
3 * 3 * 10 * 12 * 13 * 14 * 19 * 61 * 1745327 * 5594587 * 28145554676761 * 85497773607889 * 1769442985679221 * 203250599010814323919992393181
--------------------------------------------------------------------------------
3 * 5 * 17 * 257 * 65537 * 4294967297 * 18446744073709551617 * 340282366920938463463374607431768211457
100000001 * 9999999900000001 * 99999999000000009999999900000001 * 10000000099999999999999989999999899999999000000000000000100000001
3 * 9 * 11 * 37 * 91 * 101 * 9091 * 9901 * 10001 * 11111 * 90090991 * 99009901 * 99990001 * 109889011 * 9999000099990001 * 10099989899000101 * 100009999999899989999000000010001
3 * 5 * 5 * 29 * 2298850574712643678160919540229885057471264367816091954023 * 199999999999999999999999999999999999999999999999999999999999
9 * 111 * 11111 * 1111111 * 90090991 * 900900990991 * 900009090090909909099991 * 1109988789001111109989898989900111110998878900111
11 * 91 * 9091 * 909091 * 769223077 * 156985855573 * 1099988890111109888900011 * 910009191000909089989898989899909091000919100091
3 * 7 * 7 * 36 * 61 * 167280026764804282368685178989628638340582134493141518903 * 18518518518518518518518518518518518518518518518518518518479


================================================
FILE: Math/difference_of_three_squares_solutions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 August 2017
# Edit: 26 October 2017
# https://github.com/trizen

# An efficient algorithm for finding solutions to the equation:
#
#   x^2 - (x - a)^2 - (x - 2*a)^2 = n
#
# where only `n` is known.

# This algorithm uses the divisors of `n` to generate all the positive integer solutions.

# See also:
#   https://projecteuler.net/problem=135

use 5.010;
use strict;
use warnings;

use ntheory qw(divisors);

sub difference_of_three_squares_solutions {
    my ($n) = @_;

    my @divisors = divisors($n);

    my @solutions;
    foreach my $divisor (@divisors) {

        last if $divisor > sqrt($n);

        my $p = $divisor;
        my $q = $n / $divisor;
        my $k = $q + $p;

        ($k % 4 == 0) ? ($k >>= 2) : next;

        my $x1 = 3*$k - (($q - $p) >> 1);
        my $x2 = 3*$k + (($q - $p) >> 1);

        if (($x1 - 2*$k) > 0) {
            push @solutions, [$x1, $k];
        }

        if ($x1 != $x2) {
            push @solutions, [$x2, $k];
        }
    }

    return sort { $a->[0] <=> $b->[0] } @solutions;
}

my $n         = 900;
my @solutions = difference_of_three_squares_solutions($n);

foreach my $solution (@solutions) {

    my $x = $solution->[0];
    my $k = $solution->[1];

    say "[$x, $k] => $x^2 - ($x - $k)^2 - ($x - 2*$k)^2 = $n";
}

__END__
[35, 17] => 35^2 - (35 - 17)^2 - (35 - 2*17)^2 = 900
[45, 15] => 45^2 - (45 - 15)^2 - (45 - 2*15)^2 = 900
[67, 17] => 67^2 - (67 - 17)^2 - (67 - 2*17)^2 = 900
[115, 25] => 115^2 - (115 - 25)^2 - (115 - 2*25)^2 = 900
[189, 39] => 189^2 - (189 - 39)^2 - (189 - 2*39)^2 = 900
[563, 113] => 563^2 - (563 - 113)^2 - (563 - 2*113)^2 = 900


================================================
FILE: Math/difference_of_two_squares_solutions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 August 2017
# Edit: 26 October 2017
# https://github.com/trizen

# A simple and efficient algorithm for finding all the non-negative integer solutions to the equation:
#
#   x^2 - y^2 = n
#
# where `n` is known (along with its prime factorization).

# Blog post:
#   https://trizenx.blogspot.com/2017/10/representing-integers-as-difference-of.html

use 5.010;
use strict;
use warnings;

use ntheory qw(divisors);

sub difference_of_two_squares_solutions {
    my ($n) = @_;

    my @solutions;
    foreach my $divisor (divisors($n)) {

        last if $divisor > sqrt($n);

        my $p = $divisor;
        my $q = $n / $divisor;

        ($p + $q) % 2 == 0 or next;

        my $x = ($q + $p) >> 1;
        my $y = ($q - $p) >> 1;

        unshift @solutions, [$x, $y];
    }

    return @solutions;
}

foreach my $n (1 .. 1e2) {
    (my @solutions = difference_of_two_squares_solutions($n)) || next;

    say "$n = ", join(' = ', map { "$_->[0]^2 - $_->[1]^2" } @solutions);

    # Verify solutions
    foreach my $solution(@solutions) {
        if ($solution->[0]**2 - $solution->[1]**2 != $n) {
            die "Error for $n: (@$solution)";
        }
    }
}

__END__
99937 = 721^2 - 648^2 = 1369^2 - 1332^2 = 49969^2 - 49968^2
99939 = 2390^2 - 2369^2 = 7142^2 - 7135^2 = 16658^2 - 16655^2 = 49970^2 - 49969^2
99940 = 358^2 - 168^2 = 1334^2 - 1296^2 = 5002^2 - 4992^2 = 24986^2 - 24984^2
99941 = 429^2 - 290^2 = 49971^2 - 49970^2
99943 = 2948^2 - 2931^2 = 49972^2 - 49971^2
99944 = 465^2 - 341^2 = 837^2 - 775^2 = 987^2 - 935^2 = 1935^2 - 1909^2 = 12495^2 - 12491^2 = 24987^2 - 24985^2
99945 = 1133^2 - 1088^2 = 3339^2 - 3324^2 = 5557^2 - 5548^2 = 9997^2 - 9992^2 = 16659^2 - 16656^2 = 49973^2 - 49972^2
99947 = 606^2 - 517^2 = 49974^2 - 49973^2
99948 = 8332^2 - 8326^2 = 24988^2 - 24986^2
99949 = 457^2 - 330^2 = 49975^2 - 49974^2
99951 = 16660^2 - 16657^2 = 49976^2 - 49975^2
99952 = 6251^2 - 6243^2 = 12496^2 - 12492^2 = 24989^2 - 24987^2
99953 = 447^2 - 316^2 = 513^2 - 404^2 = 7143^2 - 7136^2 = 49977^2 - 49976^2
99955 = 9998^2 - 9993^2 = 49978^2 - 49977^2
99956 = 24990^2 - 24988^2
99957 = 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
99959 = 2640^2 - 2621^2 = 49980^2 - 49979^2
99960 = 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
99961 = 49981^2 - 49980^2
99963 = 322^2 - 61^2 = 618^2 - 531^2 = 1738^2 - 1709^2 = 5558^2 - 5549^2 = 16662^2 - 16659^2 = 49982^2 - 49981^2
99964 = 440^2 - 306^2 = 24992^2 - 24990^2
99965 = 9999^2 - 9994^2 = 49983^2 - 49982^2
99967 = 7144^2 - 7137^2 = 49984^2 - 49983^2
99968 = 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
99969 = 425^2 - 284^2 = 1087^2 - 1040^2 = 16663^2 - 16660^2 = 49985^2 - 49984^2
99971 = 49986^2 - 49985^2
99972 = 2786^2 - 2768^2 = 8334^2 - 8328^2 = 24994^2 - 24992^2
99973 = 323^2 - 66^2 = 49987^2 - 49986^2
99975 = 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
99976 = 12499^2 - 12495^2 = 24995^2 - 24993^2
99977 = 2949^2 - 2932^2 = 49989^2 - 49988^2
99979 = 410^2 - 261^2 = 850^2 - 789^2 = 4550^2 - 4539^2 = 49990^2 - 49989^2
99980 = 5004^2 - 4994^2 = 24996^2 - 24994^2
99981 = 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
99983 = 3852^2 - 3839^2 = 49992^2 - 49991^2
99984 = 2095^2 - 2071^2 = 4172^2 - 4160^2 = 6253^2 - 6245^2 = 8335^2 - 8329^2 = 12500^2 - 12496^2 = 24997^2 - 24995^2
99985 = 10001^2 - 9996^2 = 49993^2 - 49992^2
99987 = 16666^2 - 16663^2 = 49994^2 - 49993^2
99988 = 3578^2 - 3564^2 = 24998^2 - 24996^2
99989 = 49995^2 - 49994^2
99991 = 49996^2 - 49995^2
99992 = 489^2 - 373^2 = 891^2 - 833^2 = 12501^2 - 12497^2 = 24999^2 - 24997^2
99993 = 16667^2 - 16664^2 = 49997^2 - 49996^2
99995 = 1446^2 - 1411^2 = 7146^2 - 7139^2 = 10002^2 - 9997^2 = 49998^2 - 49997^2
99996 = 680^2 - 602^2 = 1936^2 - 1910^2 = 8336^2 - 8330^2 = 25000^2 - 24998^2
99997 = 319^2 - 42^2 = 2641^2 - 2622^2 = 49999^2 - 49998^2
99999 = 320^2 - 49^2 = 468^2 - 345^2 = 1240^2 - 1199^2 = 5560^2 - 5551^2 = 16668^2 - 16665^2 = 50000^2 - 49999^2
100000 = 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


================================================
FILE: Math/digits_to_number_subquadratic_algorithm.pl
================================================
#!/usr/bin/perl

# Subquadratic algorithm for converting a given list of digits in a given base, to an integer.

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub FastIntegerInput ($digits, $B) {

    my @l = reverse @$digits;
    my ($b, $k) = ($B, scalar(@l));

    while ($k > 1) {
        my @T;
        for (1 ... (@l >> 1)) {
            push(@T, addint(shift(@l), mulint($b, shift(@l))));
        }
        push(@T, shift(@l)) if @l;
        @l = @T;
        $b = mulint($b, $b);
        $k = ($k >> 1) + ($k % 2);
    }

    $l[0];
}

foreach my $B (2 .. 100) {    # run some tests
    my $N = factorial($B);    # int(rand(~0));

    my @a = todigits($N, $B);
    my $K = FastIntegerInput(\@a, $B);

    if ($N != $K) {
        die "Error for N = $N -> got $K";
    }
}

say join ', ', FastIntegerInput([todigits(5040, 10)], 10);    #=> 5040
say join ', ', FastIntegerInput([todigits(5040, 11)], 11);    #=> 5040
say join ', ', FastIntegerInput([todigits(5040, 12)], 12);    #=> 5040
say join ', ', FastIntegerInput([todigits(5040, 13)], 13);    #=> 5040


================================================
FILE: Math/digits_to_number_subquadratic_algorithm_mpz.pl
================================================
#!/usr/bin/perl

# Subquadratic algorithm for converting a given list of digits in a given base, to an integer.

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub FastIntegerInput ($digits, $base = 10) {

    my $L = [map { Math::GMPz->new("$_") } reverse @$digits];
    my $B = Math::GMPz->new("$base");

    # Subquadratic Algorithm 1.25 FastIntegerInput from "Modern Computer Arithmetic v0.5.9"
    for (my $k = scalar(@$L) ; $k > 1 ; $k = ($k >> 1) + ($k & 1)) {

        my @T;
        for (0 .. ($k >> 1) - 1) {
            my $t = Math::GMPz::Rmpz_init_set($L->[2 * $_]);
            Math::GMPz::Rmpz_addmul($t, $L->[2 * $_ + 1], $B);
            push(@T, $t);
        }

        push(@T, $L->[-1]) if ($k & 1);
        $L = \@T;
        Math::GMPz::Rmpz_mul($B, $B, $B);
    }

    return $L->[0];
}

foreach my $B (2 .. 100) {    # run some tests
    my $N = factorial($B);    # int(rand(~0));

    my @a = todigits($N, $B);
    my $K = FastIntegerInput(\@a, $B);

    if ($N != $K) {
        die "Error for N = $N -> got $K";
    }
}

say join ', ', FastIntegerInput([todigits(5040, 10)], 10);    #=> 5040
say join ', ', FastIntegerInput([todigits(5040, 11)], 11);    #=> 5040
say join ', ', FastIntegerInput([todigits(5040, 12)], 12);    #=> 5040
say join ', ', FastIntegerInput([todigits(5040, 13)], 13);    #=> 5040


================================================
FILE: Math/dirichlet_hyperbola_method.pl
================================================
#!/usr/bin/perl

# Simple implementation of Dirichlet's hyperbola method.

# Useful to compute partial sums of in sublinear time:
#   Sum_{d|n} g(d) * h(n/d)

# See also:
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use Math::AnyNum qw(faulhaber_sum);
use experimental qw(signatures);

sub dirichlet_hyperbola_method ($n, $g, $h, $G, $H) {

    my $s = sqrtint($n);

    my $A = 0;
    my $B = 0;
    my $C = 0;

    foreach my $k (1 .. $s) {

        my $gk = $g->($k);
        my $hk = $h->($k);

        $A += $gk * $H->(divint($n, $k));
        $A += $hk * $G->(divint($n, $k));

        $B += $gk;
        $C += $hk;
    }

    $A - $B * $C;
}

sub g ($n) { $n }
sub h ($n) { moebius($n) }

sub G ($n) { faulhaber_sum($n, 1) }    # partial sums of g(n): Sum_{k=1..n} g(k)
sub H ($n) { mertens($n) }             # partial sums of h(n): Sum_{k=1..n} h(k)

foreach my $n (1 .. 8) {
    say "S(10^$n) = ", dirichlet_hyperbola_method(powint(10, $n), \&g, \&h, \&G, \&H);
}

__END__
S(10^1) = 32
S(10^2) = 3044
S(10^3) = 304192
S(10^4) = 30397486
S(10^5) = 3039650754
S(10^6) = 303963552392
S(10^7) = 30396356427242
S(10^8) = 3039635516365908


================================================
FILE: Math/discrete_logarithm_pollard_rho.pl
================================================
#!/usr/bin/perl

# Pohlig-Hellman with Pollard's rho for each prime-power factor.

# Pollard's rho algorithm for logarithms
# https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm_for_logarithms

use 5.036;
use ntheory qw(:all);

# Pollard's rho for discrete logarithm in a group of prime order
sub _pollard_rho_log($g, $h, $p, $n, $max_tries = 10) {

    # Trivial cases
    return 0 if ($h == 1);
    return 1 if ($g == $h);

    # For very small prime orders, brute force is simpler and reliable
    if ($p <= 100) {
        my $t = 1;
        for my $i (0 .. $p - 1) {
            return $i if $t == $h;
            $t = mulmod($t, $g, $n);
        }
        return undef;
    }

    foreach my $attempt (1 .. $max_tries) {

        # Random starting point (a,b) with X = g^a * h^b
        my $a1 = urandomm($p);
        my $b1 = urandomm($p);
        my $x1 = mulmod(powmod($g, $a1, $n), powmod($h, $b1, $n), $n);

        my $a2 = $a1;
        my $b2 = $b1;
        my $x2 = $x1;

        # Floyd's cycle detection
        my $iter = sub($a, $b, $x) {
            my $r = ($x % 3);
            if ($r == 0) {
                $a = addmod($a, 1, $p);
                $x = mulmod($x, $g, $n);
            }
            elsif ($r == 1) {
                $b = addmod($b, 1, $p);
                $x = mulmod($x, $h, $n);
            }
            else {
                $a = mulmod(2,  $a, $p);
                $b = mulmod(2,  $b, $p);
                $x = mulmod($x, $x, $n);
            }
            return ($a, $b, $x);
        };

        while (1) {

            # Tortoise step
            ($a1, $b1, $x1) = $iter->($a1, $b1, $x1);

            # Hare step (two iterations)
            ($a2, $b2, $x2) = $iter->($a2, $b2, $x2);
            ($a2, $b2, $x2) = $iter->($a2, $b2, $x2);

            if ($x1 == $x2) {

                # Collision: g^{a1} h^{b1} = g^{a2} h^{b2}
                my $da = submod($a1, $a2, $p);
                my $db = submod($b2, $b1, $p);

                if ($db == 0) {
                    last;    # degenerate case, restart
                }

                my $x = mulmod($da, invmod($db, $p), $p);

                if (powmod($g, $x, $n) == $h) {
                    return $x;
                }
                last;    # verification failed, restart
            }
        }
    }

    return undef;    # failed after max_tries
}

# Solve g^x = a (mod n) where g has order exactly p^e * r,
# and we want x modulo p^e.
sub _prime_power_log($a, $g, $n, $p, $e, $full_order) {

    my $L = $full_order;
    my $r = divint($L, powint($p, $e));    # co-factor

    # Move into the subgroup of order p^e
    my $g0 = powmod($g, $r, $n);
    my $a0 = powmod($a, $r, $n);

    my $x     = 0;
    my $cur_g = $g0;                       # current generator, order p^{e-i}
    my $cur_a = $a0;                       # current element
    my $f     = 1;                         # current digit multiplier

    my $sub_g = powmod($g0, powint($p, $e - 1), $n);    # generator of order p

    foreach my $i (0 .. $e - 1) {

        # Create an element of order p by raising to p^{e-1-i}
        my $exp   = powint($p, $e - $i - 1);
        my $sub_a = powmod($cur_a, $exp, $n);           # corresponding element

        # Solve the discrete log in the prime-order subgroup
        my $d = _pollard_rho_log($sub_g, $sub_a, $p, $n) // return undef;

        $x = addint($x, mulint($d, $f));
        $f = mulint($f, $p);

        # Remove the already found part
        $cur_a = mulmod($cur_a, powmod($cur_g, -$d, $n), $n);
        $cur_g = powmod($cur_g, $p, $n);                        # next generator, order p^{e-1-i}
    }

    return $x;
}

# Solve g^x = a (mod n) where gcd(g, n) = 1, using Pohlig-Hellman over order of g.
# Suitable when n is a prime power (or when called per prime-power factor of n).
sub _dlog_coprime_prime_power_mod($a, $g, $n) {

    my $order = znorder($g, $n) // return undef;

    # Quick necessary condition: a must lie in the subgroup generated by g
    if (powmod($a, $order, $n) != 1) {
        return undef;
    }

    # Trivial case
    if ($order == 1) {
        return ($a == 1 ? 0 : undef);
    }

    # Factor the order into prime powers and solve for each
    my @factors  = factor_exp($order);
    my @residues = ();

    foreach my $pp (@factors) {
        my ($p, $e) = @$pp;
        my $x = _prime_power_log($a, $g, $n, $p, $e, $order) // return undef;
        push @residues, [$x, powint($p, $e)];
    }

    # Combine via CRT
    my $x = chinese(@residues);

    # Verify
    (defined($x) && powmod($g, $x, $n) == $a) ? $x : undef;
}

sub discrete_log($a, $g, $n) {

    # Normalise inputs
    $a = modint($a, $n);
    $g = modint($g, $n);

    # Handle non-coprime case: gcd(g, n) > 1
    if (gcd($g, $n) != 1) {

        my $g_pow = 1;     # g^k mod n (original n), for direct equality check
        my $n_red = $n;    # modulus being reduced
        my $a_red = $a;    # target being reduced
        my $d_acc = 1;     # accumulated product: (g/D_1)*(g/D_2)*...*(g/D_k) mod n_red
        my $k     = 0;

        while (gcd($g, $n_red) != 1) {

            # Check if g^k already equals a (mod n)
            return $k if $g_pow == $a;

            my $D = gcd($g, $n_red);
            return undef if $a_red % $D != 0;

            $n_red = divint($n_red, $D);
            $a_red = divint($a_red, $D);
            $d_acc = mulmod($d_acc, divint($g, $D), $n_red);
            $k++;
            $g_pow = mulmod($g_pow, $g, $n);
        }

        # Final direct check after stripping
        return $k if $g_pow == $a;

        # Phase 2: gcd(g, n_red) = 1 now; solve g^y = a_red * inv(d_acc) (mod n_red)
        my $inv_d = invmod($d_acc, $n_red) // return undef;
        my $a_new = mulmod($a_red, $inv_d, $n_red);
        my $y     = discrete_log($a_new, $g, $n_red);
        return defined($y) ? $k + $y : undef;
    }

    # Coprime case: gcd(g, n) = 1

    # Factor n into prime powers
    my @n_factors = factor_exp($n);

    # Composite n: solve g^x = a (mod p^e) for each prime-power factor, then CRT
    my @residues = ();

    foreach my $pp (@n_factors) {
        my ($p, $e) = @$pp;
        my $pe  = powint($p, $e);
        my $g_i = modint($g, $pe);
        my $a_i = modint($a, $pe);

        my $r = _dlog_coprime_prime_power_mod($a_i, $g_i, $pe);
        return undef unless defined $r;

        my $ord_i = znorder($g_i, $pe) // return undef;
        push @residues, [$r, $ord_i];
    }

    # Combine via CRT
    my $x = chinese(@residues) // return undef;

    # Verify the result
    (powmod($g, $x, $n) == $a) ? $x : undef;
}

use Test::More tests => 1309;

is(discrete_log(5678, 5, 10007), 8620);

foreach my $test (
                  [[5675,              5,      10000019],          2003974],            # 5675 = 5^2003974 mod 10000019
                  [[18478760,          5,      314138927],         34034873],
                  [[553521,            459996, 557057],            15471],
                  [[7443282,           4,      13524947],          6762454],
                  [[32712908945642193, 5,      71245073933756341], 5945146967010377],
  ) {
    my ($t, $v) = @$test;
    say "Testing: discrete_log(", join(', ', @$t), ") = ", $v;
    is(discrete_log($t->[0], $t->[1], $t->[2]), $v);
}

is_deeply(
          [map { discrete_log(powint(2, $_) - 5, 3, powint(2, $_ + 1)) } 0 .. 35],
          [undef,  0,       undef,    1,        7,        3,         27,       43,        75,        139,        11,         779,
           267,    1291,    3339,     7435,     32011,    48395,     81163,    146699,    277771,    15627,      1588491,    2637067,
           539915, 4734219, 13122827, 63454475, 29900043, 231226635, 97008907, 902315275, 365444363, 1439186187, 3586669835, 7881637131
          ]
         );

is_deeply([map { discrete_log(-1, 3, powint(3, $_) - 2) // 0 } 2 .. 30],
          [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]);

# Non-coprime tests
is(discrete_log(36, 44, 50), 2);    # 44^2 = 1936 = 36 (mod 50), gcd(44,50)=2
is(discrete_log(0,  2,  4),  2);    # 2^2 = 4 = 0 (mod 4)
is(discrete_log(4,  6,  8),  2);    # 6^2 = 36 = 4 (mod 8)

# Composite modulus, coprime base
is(discrete_log(130, 85, 177), 15);    # 177 = 3*59, gcd(85,177)=1
is(discrete_log(100, 52, 209), 10);    # 209 = 11*19, 52^10 = 100 (mod 209)

# Verify no-solution cases still return undef
is(discrete_log(3, 4, 6), undef);      # no solution exists

is(discrete_log(1, 2, 7), 0);
is(discrete_log(2, 2, 7), 1);
is(discrete_log(4, 2, 7), 2);
is(discrete_log(1, 3, 7), 0);

is(discrete_log(3, 2, 5), 3);          # 2^3 mod 5 = 3
is(discrete_log(4, 2, 5), 2);

is(discrete_log(2,     4,     7),      2);
is(discrete_log(4,     5,     7),      2);
is(discrete_log(5,     3,     7),      5);
is(discrete_log(130,   85,    177),    15);
is(discrete_log(79,    92,    129),    2);
is(discrete_log(115,   116,   141),    26);
is(discrete_log(67741, 90737, 120309), 146);
is(discrete_log(12,    42,    122),    13);
is(discrete_log(36,    44,    50),     2);
is(discrete_log(34,    170,   187),    5);

# Small modulus cycles

is(discrete_log(8, 2, 11), 3);
is(discrete_log(5, 2, 11), 4);
is(discrete_log(9, 3, 11), 2);

# Edge cases

is(discrete_log(1, 1, 13), 0);
is(discrete_log(1, 5, 13), 0);

# g == a
is(discrete_log(7, 7, 19), 1);

# modulus 2
is(discrete_log(1, 1, 2), 0);

# Non-prime modulus

is(discrete_log(4, 2, 15), 2);    # 2^2 = 4 mod 15
is(discrete_log(1, 4, 9),  0);

# Cases where solution may not exist

is(discrete_log(3, 4, 7), undef);
is(discrete_log(3, 2, 4), undef);
is(discrete_log(6, 4, 8), undef);

# Verify correctness by recomputing power

for my $n (7, 11, 13, 17) {
    for my $g (2 .. $n - 1) {
        for my $k (0 .. $n - 1) {

            my $a = powmod($g, $k, $n);
            my $r = discrete_log($a, $g, $n);

            ok(defined($r), "discrete_log($a, $g, $n)");
            is(powmod($g, $r, $n), $a) if defined($r);
        }
    }
}

# Randomized tests

for (1 .. 100) {
    my $n = urandomm(200000 - 50000) + 50000;
    my $g = urandomm($n - 2) + 2;
    my $k = urandomm(50000);

    my $a = powmod($g, $k, $n);
    my $r = discrete_log($a, $g, $n);

    ok(defined($r), "discrete_log($a, $g, $n)");
    is(powmod($g, $r, $n), $a) if defined($r);
}

# Computationally intensive tests

my $p = 1000003;
my $g = 2;
my $k = 123456;

my $a = powmod($g, $k, $p);

is(powmod($g, discrete_log($a, $g, $p), $p), $a);

# Larger exponent

my $k2 = 654321;
my $a2 = powmod($g, $k2, $p);

is(powmod($g, discrete_log($a2, $g, $p), $p), $a2);

# Large prime modulus stress test

my $p2 = 10000019;
my $g2 = 2;
my $k3 = 777777;

my $a3 = powmod($g2, $k3, $p2);

is(powmod($g2, discrete_log($a3, $g2, $p2), $p2), $a3);


================================================
FILE: Math/discrete_logarithm_pollard_rho_mpz.pl
================================================
#!/usr/bin/perl

# Pohlig-Hellman with Pollard's rho for each prime-power factor.

# Pollard's rho algorithm for logarithms
# https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm_for_logarithms

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

# Pollard's rho for discrete logarithm in a group of prime order
sub _znlog_pollard_rho ($g, $h, $p, $n, $max_tries = 10) {

    if (Math::GMPz::Rmpz_cmp_ui($h, 1) == 0) {
        return Math::GMPz::Rmpz_init_set_ui(0);
    }
    if (Math::GMPz::Rmpz_cmp($g, $h) == 0) {
        return Math::GMPz::Rmpz_init_set_ui(1);
    }

    # For very small prime orders, brute force is simpler and reliable
    if (Math::GMPz::Rmpz_cmp_ui($p, 100) <= 0) {
        my $t = Math::GMPz::Rmpz_init_set_ui(1);
        for my $i (0 .. Math::GMPz::Rmpz_get_ui($p) - 1) {
            if (Math::GMPz::Rmpz_cmp($t, $h) == 0) {
                return Math::GMPz::Rmpz_init_set_ui($i);
            }
            Math::GMPz::Rmpz_mul($t, $t, $g);
            Math::GMPz::Rmpz_mod($t, $t, $n);
        }
        return undef;
    }

    state $rng = Math::GMPz::zgmp_randinit_default_nobless();

    state $tmp   = Math::GMPz::Rmpz_init_nobless();
    state $a1    = Math::GMPz::Rmpz_init_nobless();
    state $b1    = Math::GMPz::Rmpz_init_nobless();
    state $x1    = Math::GMPz::Rmpz_init_nobless();
    state $a2    = Math::GMPz::Rmpz_init_nobless();
    state $b2    = Math::GMPz::Rmpz_init_nobless();
    state $x2    = Math::GMPz::Rmpz_init_nobless();
    state $da    = Math::GMPz::Rmpz_init_nobless();
    state $db    = Math::GMPz::Rmpz_init_nobless();
    state $invdb = Math::GMPz::Rmpz_init_nobless();

    foreach my $attempt (1 .. $max_tries) {

        # Random starting point (a,b) with X = g^a * h^b
        Math::GMPz::Rmpz_urandomm($a1, $b1, $rng, $p, 2);

        Math::GMPz::Rmpz_powm($x1,  $g, $a1, $n);
        Math::GMPz::Rmpz_powm($tmp, $h, $b1, $n);
        Math::GMPz::Rmpz_mul($x1, $x1, $tmp);
        Math::GMPz::Rmpz_mod($x1, $x1, $n);

        Math::GMPz::Rmpz_set($a2, $a1);
        Math::GMPz::Rmpz_set($b2, $b1);
        Math::GMPz::Rmpz_set($x2, $x1);

        while (1) {

            # Tortoise step (Inlined)
            my $r1 = Math::GMPz::Rmpz_mod_ui($tmp, $x1, 3);
            if ($r1 == 0) {
                Math::GMPz::Rmpz_add_ui($a1, $a1, 1);
                Math::GMPz::Rmpz_mul($x1, $x1, $g);
                Math::GMPz::Rmpz_mod($x1, $x1, $n);
            }
            elsif ($r1 == 1) {
                Math::GMPz::Rmpz_add_ui($b1, $b1, 1);
                Math::GMPz::Rmpz_mul($x1, $x1, $h);
                Math::GMPz::Rmpz_mod($x1, $x1, $n);
            }
            else {
                Math::GMPz::Rmpz_mul_2exp($a1, $a1, 1);
                Math::GMPz::Rmpz_mul_2exp($b1, $b1, 1);
                Math::GMPz::Rmpz_mod($a1, $a1, $p);
                Math::GMPz::Rmpz_mod($b1, $b1, $p);
                Math::GMPz::Rmpz_powm_ui($x1, $x1, 2, $n);
            }

            # Hare step (Inlined, two iterations)
            for (1 .. 2) {
                my $r2 = Math::GMPz::Rmpz_mod_ui($tmp, $x2, 3);
                if ($r2 == 0) {
                    Math::GMPz::Rmpz_add_ui($a2, $a2, 1);
                    Math::GMPz::Rmpz_mul($x2, $x2, $g);
                    Math::GMPz::Rmpz_mod($x2, $x2, $n);
                }
                elsif ($r2 == 1) {
                    Math::GMPz::Rmpz_add_ui($b2, $b2, 1);
                    Math::GMPz::Rmpz_mul($x2, $x2, $h);
                    Math::GMPz::Rmpz_mod($x2, $x2, $n);
                }
                else {
                    Math::GMPz::Rmpz_mul_2exp($a2, $a2, 1);
                    Math::GMPz::Rmpz_mul_2exp($b2, $b2, 1);
                    Math::GMPz::Rmpz_mod($a2, $a2, $p);
                    Math::GMPz::Rmpz_mod($b2, $b2, $p);
                    Math::GMPz::Rmpz_powm_ui($x2, $x2, 2, $n);
                }
            }

            if (Math::GMPz::Rmpz_cmp($x1, $x2) == 0) {

                # Collision: g^{a1} h^{b1} = g^{a2} h^{b2}
                Math::GMPz::Rmpz_sub($da, $a1, $a2);
                Math::GMPz::Rmpz_mod($da, $da, $p);

                Math::GMPz::Rmpz_sub($db, $b2, $b1);
                Math::GMPz::Rmpz_mod($db, $db, $p);

                last if Math::GMPz::Rmpz_sgn($db) == 0;    # Degenerate case, restart

                Math::GMPz::Rmpz_invert($invdb, $db, $p) || last;

                my $x = Math::GMPz::Rmpz_init();
                Math::GMPz::Rmpz_mul($x, $da, $invdb);
                Math::GMPz::Rmpz_mod($x, $x, $p);

                Math::GMPz::Rmpz_powm($tmp, $g, $x, $n);
                return $x if Math::GMPz::Rmpz_cmp($tmp, $h) == 0;

                last;                                      # Verification failed, restart
            }
        }
    }
    return undef;    # failed after max_tries
}

# Solve g^x = a (mod n) where g has order exactly p^e * r,
# and we want x modulo p^e.
sub _znlog_prime_power ($a, $g, $n, $p, $e, $full_order) {

    my $L = $full_order;
    state $r = Math::GMPz::Rmpz_init_nobless();
    Math::GMPz::Rmpz_pow_ui($r, $p, $e);
    Math::GMPz::Rmpz_divexact($r, $L, $r);    # co-factor

    # Move into the subgroup of order p^e
    state $g0 = Math::GMPz::Rmpz_init_nobless();
    state $a0 = Math::GMPz::Rmpz_init_nobless();
    Math::GMPz::Rmpz_powm($g0, $g, $r, $n);
    Math::GMPz::Rmpz_powm($a0, $a, $r, $n);

    my $x = Math::GMPz::Rmpz_init_set_ui(0);

    state $cur_g = Math::GMPz::Rmpz_init_nobless();    # current generator, order p^{e-i}
    state $cur_a = Math::GMPz::Rmpz_init_nobless();    # current element
    Math::GMPz::Rmpz_set($cur_g, $g0);
    Math::GMPz::Rmpz_set($cur_a, $a0);

    state $f = Math::GMPz::Rmpz_init_nobless();        # current digit multiplier
    Math::GMPz::Rmpz_set_ui($f, 1);

    state $tmp   = Math::GMPz::Rmpz_init_nobless();
    state $sub_g = Math::GMPz::Rmpz_init();            # generator of order p
    state $sub_a = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_pow_ui($tmp, $p, $e - 1);
    Math::GMPz::Rmpz_powm($sub_g, $g0, $tmp, $n);

    foreach my $i (0 .. $e - 1) {

        # Create an element of order p by raising to p^{e-1-i}
        Math::GMPz::Rmpz_pow_ui($tmp, $p, $e - $i - 1);
        Math::GMPz::Rmpz_powm($sub_a, $cur_a, $tmp, $n);    # corresponding element

        # Solve the discrete log in the prime-order subgroup
        my $d = _znlog_pollard_rho($sub_g, $sub_a, $p, $n) // return undef;

        Math::GMPz::Rmpz_mul($tmp, $d, $f);
        Math::GMPz::Rmpz_add($x, $x, $tmp);
        Math::GMPz::Rmpz_mul($f, $f, $p);

        # Remove the already found part
        Math::GMPz::Rmpz_powm($tmp, $cur_g, $d, $n);
        Math::GMPz::Rmpz_invert($tmp, $tmp, $n) || return undef;
        Math::GMPz::Rmpz_mul($cur_a, $cur_a, $tmp);
        Math::GMPz::Rmpz_mod($cur_a, $cur_a, $n);

        Math::GMPz::Rmpz_powm($cur_g, $cur_g, $p, $n);    # next generator, order p^{e-1-i}
    }
    return $x;
}

sub _znlog_coprime_prime_power ($a, $g, $n) {
    my $order = Math::GMPz->new((znorder($g, $n) // return undef));

    state $tmp   = Math::GMPz::Rmpz_init_nobless();
    state $p_mpz = Math::GMPz::Rmpz_init_nobless();

    # Quick necessary condition: a must lie in the subgroup generated by g
    Math::GMPz::Rmpz_powm($tmp, $a, $order, $n);
    return undef if Math::GMPz::Rmpz_cmp_ui($tmp, 1) != 0;

    # Trivial case
    if (Math::GMPz::Rmpz_cmp_ui($order, 1) == 0) {
        return (Math::GMPz::Rmpz_cmp_ui($a, 1) == 0) ? 0 : undef;
    }

    # Factor the order into prime powers and solve for each
    my @factors  = factor_exp($order);
    my @residues = ();

    foreach my $pp (@factors) {
        my ($p, $e) = @$pp;
        Math::GMPz::Rmpz_set_str($p_mpz, $p, 10);
        my $x = _znlog_prime_power($a, $g, $n, $p_mpz, $e, $order) // return undef;
        push @residues, [$x, powint($p, $e)];
    }

    # Combine via CRT
    my $x = chinese(@residues) // return undef;

    # Verify
    Math::GMPz::Rmpz_set_str($tmp, $x, 10);
    Math::GMPz::Rmpz_powm($tmp, $g, $tmp, $n);
    return (Math::GMPz::Rmpz_cmp($tmp, $a) == 0) ? $x : undef;
}

sub _znlog_pohlig_hellman ($a, $g, $n) {

    my $tmp = Math::GMPz::Rmpz_init_nobless();

    Math::GMPz::Rmpz_gcd($tmp, $g, $n);

    # Handle non-coprime case: gcd(g, n) != 1
    if (Math::GMPz::Rmpz_cmp_ui($tmp, 1) != 0) {
        my $g_pow = Math::GMPz::Rmpz_init_set_ui(1);    # g^k mod n (original n), for direct equality check
        my $n_red = Math::GMPz::Rmpz_init_set($n);      # modulus being reduced
        my $a_red = Math::GMPz::Rmpz_init_set($a);      # target being reduced
        my $d_acc = Math::GMPz::Rmpz_init_set_ui(1);    # accumulated product: (g/D_1)*(g/D_2)*...*(g/D_k) mod n_red

        my $k = 0;
        while (1) {

            # Check if g^k already equals a (mod n)
            Math::GMPz::Rmpz_gcd($tmp, $g, $n_red);
            last if Math::GMPz::Rmpz_cmp_ui($tmp, 1) == 0;

            return $k if Math::GMPz::Rmpz_cmp($g_pow, $a) == 0;
            return undef unless Math::GMPz::Rmpz_divisible_p($a_red, $tmp);

            Math::GMPz::Rmpz_div($n_red, $n_red, $tmp);
            Math::GMPz::Rmpz_div($a_red, $a_red, $tmp);

            Math::GMPz::Rmpz_div($tmp, $g, $tmp);
            Math::GMPz::Rmpz_mul($d_acc, $d_acc, $tmp);
            Math::GMPz::Rmpz_mul($g_pow, $g_pow, $g);
            Math::GMPz::Rmpz_mod($d_acc, $d_acc, $n_red);
            Math::GMPz::Rmpz_mod($g_pow, $g_pow, $n);

            ++$k;
        }

        # Final direct check after stripping
        return $k if Math::GMPz::Rmpz_cmp($g_pow, $a) == 0;

        # Phase 2: gcd(g, n_red) = 1 now; solve g^y = a_red * inv(d_acc) (mod n_red)
        Math::GMPz::Rmpz_invert($tmp, $d_acc, $n_red) || return undef;
        Math::GMPz::Rmpz_mul($tmp, $tmp, $a_red);

        my $new_a = Math::GMPz::Rmpz_init();
        my $new_g = Math::GMPz::Rmpz_init();

        Math::GMPz::Rmpz_mod($new_a, $tmp, $n_red);
        Math::GMPz::Rmpz_mod($new_g, $g,   $n_red);

        my $y = __SUB__->($new_a, $new_g, $n_red) // return undef;
        return ($y + $k);
    }

    # Coprime case: gcd(g, n) = 1

    # Factor n into prime powers
    my @n_factors = factor_exp($n);
    my @residues  = ();

    my $pe  = Math::GMPz::Rmpz_init();
    my $g_i = Math::GMPz::Rmpz_init();
    my $a_i = Math::GMPz::Rmpz_init();

    # Composite n: solve g^x = a (mod p^e) for each prime-power factor, then CRT
    foreach my $pp (@n_factors) {
        my ($p, $e) = @$pp;

        Math::GMPz::Rmpz_set_str($pe, $p, 10);
        Math::GMPz::Rmpz_pow_ui($pe, $pe, $e);
        Math::GMPz::Rmpz_mod($g_i, $g, $pe);
        Math::GMPz::Rmpz_mod($a_i, $a, $pe);

        my $r     = _znlog_coprime_prime_power($a_i, $g_i, $pe) // return undef;
        my $ord_i = znorder($g_i, $pe)                          // return undef;

        push @residues, [$r, $ord_i];
    }

    # Combine via CRT
    my $x = Math::GMPz::Rmpz_init_set_str((chinese(@residues) // return undef), 10);

    # Verify the result
    Math::GMPz::Rmpz_powm($tmp, $g, $x, $n);
    if (Math::GMPz::Rmpz_cmp($tmp, $a) == 0) {
        return $x;
    }

    return undef;
}

sub discrete_log ($a, $g, $n) {

    $a = Math::GMPz->new("$a");
    $g = Math::GMPz->new("$g");
    $n = Math::GMPz->new("$n");

    my $sgn = Math::GMPz::Rmpz_sgn($n) || return undef;

    if ($sgn < 0) {
        $n = Math::GMPz::Rmpz_init_set($n);
        Math::GMPz::Rmpz_abs($n, $n);
    }

    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) == 0;

    $a = Math::GMPz::Rmpz_init_set($a);
    $g = Math::GMPz::Rmpz_init_set($g);

    Math::GMPz::Rmpz_mod($a, $a, $n);
    Math::GMPz::Rmpz_mod($g, $g, $n);

    if (Math::GMPz::Rmpz_cmp_ui($a, 1) == 0 or Math::GMPz::Rmpz_cmp_ui($g, 0) == 0) {
        return 0;
    }

    my $res = _znlog_pohlig_hellman($a, $g, $n) // return undef;
    return join '', $res;
}

use Test::More tests => 1309;

is(discrete_log(5678, 5, 10007), 8620);

foreach my $test (
                  [[5675,              5,      10000019],          2003974],            # 5675 = 5^2003974 mod 10000019
                  [[18478760,          5,      314138927],         34034873],
                  [[553521,            459996, 557057],            15471],
                  [[7443282,           4,      13524947],          6762454],
                  [[32712908945642193, 5,      71245073933756341], 5945146967010377],
  ) {
    my ($t, $v) = @$test;
    say "Testing: discrete_log(", join(', ', @$t), ") = ", $v;
    is(discrete_log($t->[0], $t->[1], $t->[2]), $v);
}

is_deeply(
          [map { discrete_log(powint(2, $_) - 5, 3, powint(2, $_ + 1)) } 0 .. 35],
          [undef,  0,       undef,    1,        7,        3,         27,       43,        75,        139,        11,         779,
           267,    1291,    3339,     7435,     32011,    48395,     81163,    146699,    277771,    15627,      1588491,    2637067,
           539915, 4734219, 13122827, 63454475, 29900043, 231226635, 97008907, 902315275, 365444363, 1439186187, 3586669835, 7881637131
          ]
         );

is_deeply([map { discrete_log(-1, 3, powint(3, $_) - 2) // 0 } 2 .. 30],
          [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]);

# Non-coprime tests
is(discrete_log(36, 44, 50), 2);    # 44^2 = 1936 = 36 (mod 50), gcd(44,50)=2
is(discrete_log(0,  2,  4),  2);    # 2^2 = 4 = 0 (mod 4)
is(discrete_log(4,  6,  8),  2);    # 6^2 = 36 = 4 (mod 8)

# Composite modulus, coprime base
is(discrete_log(130, 85, 177), 15);    # 177 = 3*59, gcd(85,177)=1
is(discrete_log(100, 52, 209), 10);    # 209 = 11*19, 52^10 = 100 (mod 209)

# Verify no-solution cases still return undef
is(discrete_log(3, 4, 6), undef);      # no solution exists

is(discrete_log(1, 2, 7), 0);
is(discrete_log(2, 2, 7), 1);
is(discrete_log(4, 2, 7), 2);
is(discrete_log(1, 3, 7), 0);

is(discrete_log(3, 2, 5), 3);          # 2^3 mod 5 = 3
is(discrete_log(4, 2, 5), 2);

is(discrete_log(2,     4,     7),      2);
is(discrete_log(4,     5,     7),      2);
is(discrete_log(5,     3,     7),      5);
is(discrete_log(130,   85,    177),    15);
is(discrete_log(79,    92,    129),    2);
is(discrete_log(115,   116,   141),    26);
is(discrete_log(67741, 90737, 120309), 146);
is(discrete_log(12,    42,    122),    13);
is(discrete_log(36,    44,    50),     2);
is(discrete_log(34,    170,   187),    5);

# Small modulus cycles

is(discrete_log(8, 2, 11), 3);
is(discrete_log(5, 2, 11), 4);
is(discrete_log(9, 3, 11), 2);

# Edge cases

is(discrete_log(1, 1, 13), 0);
is(discrete_log(1, 5, 13), 0);

# g == a
is(discrete_log(7, 7, 19), 1);

# modulus 2
is(discrete_log(1, 1, 2), 0);

# Non-prime modulus

is(discrete_log(4, 2, 15), 2);    # 2^2 = 4 mod 15
is(discrete_log(1, 4, 9),  0);

# Cases where solution may not exist

is(discrete_log(3, 4, 7), undef);
is(discrete_log(3, 2, 4), undef);
is(discrete_log(6, 4, 8), undef);

# Verify correctness by recomputing power

for my $n (7, 11, 13, 17) {
    for my $g (2 .. $n - 1) {
        for my $k (0 .. $n - 1) {

            my $a = powmod($g, $k, $n);
            my $r = discrete_log($a, $g, $n);

            ok(defined($r), "discrete_log($a, $g, $n)");
            is(powmod($g, $r, $n), $a) if defined($r);
        }
    }
}

# Randomized tests

for (1 .. 100) {
    my $n = urandomm(200000 - 50000) + 50000;
    my $g = urandomm($n - 2) + 2;
    my $k = urandomm(50000);

    my $a = powmod($g, $k, $n);
    my $r = discrete_log($a, $g, $n);

    ok(defined($r), "discrete_log($a, $g, $n)");
    is(powmod($g, $r, $n), $a) if defined($r);
}

# Computationally intensive tests

my $p = 1000003;
my $g = 2;
my $k = 123456;

my $a = powmod($g, $k, $p);

is(powmod($g, discrete_log($a, $g, $p), $p), $a);

# Larger exponent

my $k2 = 654321;
my $a2 = powmod($g, $k2, $p);

is(powmod($g, discrete_log($a2, $g, $p), $p), $a2);

# Large prime modulus stress test

my $p2 = 10000019;
my $g2 = 2;
my $k3 = 777777;

my $a3 = powmod($g2, $k3, $p2);

is(powmod($g2, discrete_log($a3, $g2, $p2), $p2), $a3);


================================================
FILE: Math/discrete_root.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 January 2017
# https://github.com/trizen

# An example for finding the smallest value `x` in:
#
#   x^e = r (mod n)

use 5.010;
use strict;
use warnings;

use ntheory qw(invmod powmod euler_phi);

sub discrete_root {
    my ($e, $r, $n) = @_;
    my $d = invmod($e, euler_phi($n));
    powmod($r, $d, $n);
}

#
## Solves for x in x^65537 = 1653 (mod 2279)
#

say discrete_root(65537, 1653, 2279);        # 1234


================================================
FILE: Math/divisors_descending_lazy.pl
================================================
#!/usr/bin/perl

# Lazily generate the positive divisors of a given integer `n`, in descending order.

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

prime_set_config(bigint => 'Math::GMPz');

# Binary search: returns first index i such that all arr[0..i-1] <= val
sub bsearch_le ($arr, $val) {
    my ($lo,  $hi)  = (0, scalar @$arr);
    while ($lo < $hi) {
        my $mid = ($lo + $hi) >> 1;
        $arr->[$mid] <= $val ? ($lo = $mid + 1) : ($hi = $mid);
    }
    return $lo;
}

# Max-heap helper: Sifts down to maintain max-heap property
sub sift_down ($heap, $pos) {
    my $n = @$heap;
    while (1) {
        my $max = $pos;
        my $c1  = 2 * $pos + 1;
        my $c2  = $c1 + 1;
        $max = $c1 if $c1 < $n && $heap->[$c1][0] > $heap->[$max][0];
        $max = $c2 if $c2 < $n && $heap->[$c2][0] > $heap->[$max][0];
        last if $max == $pos;
        @{$heap}[$pos, $max] = @{$heap}[$max, $pos];
        $pos = $max;
    }
}

sub heap_push ($heap, $v) {
    my $pos = @$heap;
    push @$heap, $v;
    while ($pos > 0) {
        my $parent = ($pos - 1) >> 1;
        last if $heap->[$parent][0] >= $heap->[$pos][0];
        @{$heap}[$parent, $pos] = @{$heap}[$pos, $parent];
        $pos = $parent;
    }
}

sub heap_pop ($heap) {
    return pop @$heap if @$heap <= 1;
    my $top = $heap->[0];
    $heap->[0] = pop @$heap;
    sift_down($heap, 0);
    return $top;
}

sub lazy_divisors ($n, $callback) {

    # Build factor chains from the prime factorisation of f
    my @chains;
    for my $pe (factor_exp($n)) {
        my ($p, $v) = @$pe;
        my @C = map { powint($p, $_) } 0 .. $v;
        push @chains, \@C if @C;
    }

    @chains = sort { @$b <=> @$a } @chains;

    # Distribute chains into two arrays
    my @A = (Math::GMPz->new(1));
    my @B = (Math::GMPz->new(1));

    for my $C (@chains) {
        my $ref = (@A < @B) ? \@A : \@B;
        @$ref = map {
            my $x = $_;
            map { $x * $_ } @$C
        } @$ref;
    }

    @A = sort { $a <=> $b } @A;
    @B = sort { $a <=> $b } @B;

    my $s = $n;    # maximum divisor
                   #my $s = sqrtint($n);

    # Seed the max-heap
    my @h;
    for my $i (0 .. $#A) {
        my $lim = $s / $A[$i];              # Largest B[j] such that A[i] * B[j] <= n
        my $j   = bsearch_le(\@B, $lim);
        next unless $j > 0;
        push @h, [$A[$i] * $B[$j - 1], $i, $j - 1];
    }

    # Heapify using O(n) bottom-up approach
    sift_down(\@h, $_) for reverse(0 .. ((@h >> 1) - 1));

    # Build all divisors as products of one divisor from @A and one from @B,
    # then merge the row-wise sequences in descending order with a max-heap.
    while (@h) {
        my ($k, $i, $j) = @{heap_pop(\@h)};

        $callback->($k);

        # Push the next divisor combination into the heap
        if ($j > 0) {
            heap_push(\@h, [$A[$i] * $B[$j - 1], $i, $j - 1]);
        }
    }

    return;
}

lazy_divisors(5040, sub($d) { say $d });


================================================
FILE: Math/divisors_lazy.pl
================================================
#!/usr/bin/perl

# Lazily generate the positive divisors of a given integer `n`, in ascending order.

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

prime_set_config(bigint => 'Math::GMPz');

sub sift_down($heap, $pos) {

    my $n = @$heap;
    while (1) {

        my $min = $pos;
        my $c1  = 2 * $pos + 1;
        my $c2  = $c1 + 1;

        $min = $c1 if $c1 < $n && $heap->[$c1][0] < $heap->[$min][0];
        $min = $c2 if $c2 < $n && $heap->[$c2][0] < $heap->[$min][0];

        last if $min == $pos;
        @{$heap}[$pos, $min] = @{$heap}[$min, $pos];
        $pos = $min;
    }
}

sub heap_push($heap, $v) {

    my $pos = @$heap;
    push @$heap, $v;

    while ($pos > 0) {
        my $parent = ($pos - 1) >> 1;
        last if $heap->[$parent][0] <= $heap->[$pos][0];
        @{$heap}[$parent, $pos] = @{$heap}[$pos, $parent];
        $pos = $parent;
    }
}

sub heap_pop($heap) {
    return pop @$heap if @$heap <= 1;
    my $top = $heap->[0];
    $heap->[0] = pop @$heap;
    sift_down($heap, 0);
    return $top;
}

sub divisors_lazy ($n, $callback) {

    # Build factor chains from the prime factorisation of f
    my @chains;
    for my $pe (factor_exp($n)) {
        my ($p, $v) = @$pe;
        my @C = map { powint($p, $_) } 0 .. $v;
        push @chains, \@C;
    }

    @chains = sort { @$b <=> @$a } @chains;

    # Distribute chains into two arrays
    my @A = (Math::GMPz->new(1));
    my @B = (Math::GMPz->new(1));

    for my $C (@chains) {
        my $ref = (@A < @B) ? \@A : \@B;
        my @new;
        for my $x (@$ref) {
            for my $c (@$C) {
                push @new, $x * $c;
            }
        }
        @$ref = @new;
    }

    @A = sort { $a <=> $b } @A;
    @B = sort { $a <=> $b } @B;

    my @h;

    # Seed each row with its smallest product
    for my $i (0 .. $#A) {
        push @h, [$A[$i] * $B[0], $i, 0];
    }

    sift_down(\@h, $_) for reverse(0 .. ((@h >> 1) - 1));

    my $end_B = $#B;

    while (@h) {
        my ($k, $i, $j) = @{heap_pop(\@h)};

        $callback->($k);

        # Advance to the next larger product in the same row
        if ($j < $end_B) {
            heap_push(\@h, [$A[$i] * $B[$j + 1], $i, $j + 1]);
        }
    }

    return;
}

divisors_lazy(5040, sub ($d) { say $d });


================================================
FILE: Math/divisors_lazy_fast.pl
================================================
#!/usr/bin/perl

# Lazily generate the divisors of a given number, in ascending order, by using a Min-Heap.

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

prime_set_config(bigint => 'Math::GMPz');

# Generates and sorts divisors for a specific partition of prime factors
sub _gen_divs ($factors, $one) {
    my @res = ($one);
    foreach my $f (@$factors) {
        my ($p, $e) = @$f;
        my @next_res = @res;
        my $p_pow    = $one * $p;
        for my $i (1 .. $e) {
            push @next_res, map { $_ * $p_pow } @res;
            $p_pow = $p_pow * $p if $i < $e;
        }
        @res = @next_res;
    }

    # Numerically sort the partial divisors
    return [sort { $a <=> $b } @res];
}

# Sift down a heap element to maintain Min-Heap property
sub _sift_down ($h, $idx) {
    my $len  = scalar @$h;
    my $item = $h->[$idx];
    my $val  = $item->[0];

    while (1) {
        my $left = 2 * $idx + 1;
        last if $left >= $len;
        my $right     = $left + 1;
        my $min_child = $left;

        if ($right < $len && $h->[$right][0] < $h->[$left][0]) {
            $min_child = $right;
        }
        last if $val <= $h->[$min_child][0];

        $h->[$idx] = $h->[$min_child];
        $idx = $min_child;
    }
    $h->[$idx] = $item;
}

# Helper: Push a new item into the Min-Heap
sub _push_heap ($h, $item) {
    push @$h, $item;
    my $idx = $#$h;
    my $val = $item->[0];

    while ($idx > 0) {
        my $parent = int(($idx - 1) / 2);
        last if $h->[$parent][0] <= $val;
        $h->[$idx] = $h->[$parent];
        $idx = $parent;
    }
    $h->[$idx] = $item;
}

sub divisors_lazy ($n, $callback) {

    return if $n < 1;
    my $one = Math::GMPz->new(1);

    # 1. Factorize N using Math::Prime::Util
    my @pe = factor_exp($n);

    # 2. Partition factors to balance the number of divisors in A and B
    # Sort factors by their exponent+1 descending to pack the largest first
    @pe = sort { $b->[1] <=> $a->[1] } @pe;

    my (@partA, @partB);
    my ($divA,  $divB) = (1, 1);

    foreach my $f (@pe) {
        if ($divA <= $divB) {
            push @partA, $f;
            $divA *= ($f->[1] + 1);
        }
        else {
            push @partB, $f;
            $divB *= ($f->[1] + 1);
        }
    }

    # 3. Generate the two small sorted arrays of partial divisors
    my $A = _gen_divs(\@partA, $one);
    my $B = _gen_divs(\@partB, $one);

    # 4. Priority Queue (Min-Heap) for lazy sorted cross-multiplication
    # Elements in the heap are array references: [ product_value, index_A, index_B ]
    my @heap = ([$A->[0] * $B->[0], 0, 0]);

    while (@heap) {

        my $curr = $heap[0];
        my $val  = $curr->[0];
        my $i    = $curr->[1];
        my $j    = $curr->[2];

        # Trigger the callback for the absolute smallest next divisor
        $callback->($val);

        # Determine possible next steps in the A x B matrix
        my $has_next_j = ($j + 1 < @$B);
        my $has_next_i = ($j == 0 && $i + 1 < @$A);

        if ($has_next_j && $has_next_i) {

            # Add the new row starter into the heap
            _push_heap(\@heap, [$A->[$i + 1] * $B->[0], $i + 1, 0]);

            $curr->[0] = $A->[$i] * $B->[$j + 1];
            $curr->[2] = $j + 1;
            _sift_down(\@heap, 0);
        }
        elsif ($has_next_j) {

            # Reuse root
            $curr->[0] = $A->[$i] * $B->[$j + 1];
            $curr->[2] = $j + 1;
            _sift_down(\@heap, 0);
        }
        elsif ($has_next_i) {

            # Reuse root
            $curr->[0] = $A->[$i + 1] * $B->[0];
            $curr->[1] = $i + 1;
            _sift_down(\@heap, 0);
        }
        else {
            # Exhausted this path, pop from heap entirely
            my $last = pop @heap;
            if (@heap) {
                $heap[0] = $last;
                _sift_down(\@heap, 0);
            }
        }
    }
}

divisors_lazy(5040, sub ($d) { say $d });


================================================
FILE: Math/divisors_less_than_k.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 August 2019
# https://github.com/trizen

# Generate all the divisors d of n, such that d <= k.

use 5.010;
use strict;
use warnings;

use ntheory qw(factor_exp divisors);

sub divisors_le {
    my ($n, $k) = @_;

    my @d  = (1);
    my @pp = grep { $_->[0] <= $k } factor_exp($n);

    foreach my $pp (@pp) {

        my ($p, $e) = @$pp;

        my @t;
        my $r = 1;

        for my $i (1 .. $e) {
            $r *= $p;
            foreach my $u (@d) {
                push(@t, $u * $r) if ($u * $r <= $k);
            }
        }

        push @d, @t;
    }

    return sort { $a <=> $b } @d;
}

# Generate the divisors of 5040 less than or equal to 42
say join ' ', divisors_le(5040, 42);


================================================
FILE: Math/divisors_of_factorial_below_limit.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 December 2018
# https://github.com/trizen

# Generate the divisors of n! below a given limit.

use 5.020;
use warnings;

use experimental qw(signatures);
use ntheory qw(primes todigits vecsum valuation factorial);

sub divisors_of_factorial ($f, $limit = factorial($f)) {

    my @primes = @{primes($f)};

    my @d = (1);
    foreach my $p (@primes) {

        # Maximum power of p in f!
        my $pow = ($f - vecsum(todigits($f, $p))) / ($p - 1);

        foreach my $n (@d) {
            if ($n * $p <= $limit) {
                last if (valuation($n, $p) >= $pow);
                push @d, $n * $p;
            }
        }
    }

    return \@d;
}

my $n     = 30;
my $limit = 10**12;

my $d = divisors_of_factorial($n, $limit);

printf "There are %s divisors of $n! below $limit\n", scalar(@$d);
printf "Sum of divisors of $n! below $limit = %s\n", vecsum(@$d);

__END__
There are 372197 divisors of 30! below 1000000000000
Sum of divisors of 30! below 1000000000000 = 53793088959503349


================================================
FILE: Math/divisors_of_factorial_in_range_iterator.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 December 2018
# https://github.com/trizen

# Generate the divisors of n! in a given range, using a closure iterator.

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.020;
use warnings;

use experimental qw(signatures);
use ntheory qw(vecmin primes todigits vecsum valuation factorial);

sub divisors_of_factorial_iterator ($f, $low, $high) {

    my @primes = map { [$_, ($f - vecsum(todigits($f, $_))) / ($_ - 1)] } @{primes($f)};

    my @s = map { [1] } 1 .. @primes;

    sub {
        my $n = 0;

        while ($n < $low) {

            $n = vecmin(map { $_->[0] } @s);

            foreach my $i (0 .. $#primes) {
                shift(@{$s[$i]}) if ($s[$i][0] == $n);
                my $p = $primes[$i][0];
                last if valuation($n, $p) >= $primes[$i][1];
                push(@{$s[$i]}, $n * $p);
            }
        }

        return undef if ($n > $high);
        return $n;
    }
}

my $n    = 30;
my $low  = 10**8;
my $high = 10**12;

my $iter = divisors_of_factorial_iterator($n, $low, $high);

my $sum = 0;
for (my $n = $iter->() ; defined($n) ; $n = $iter->()) {
    $sum += $n;
}
say "Sum of divisors of $n! between $low and $high = $sum";

__END__
Sum of divisors of 30! between 100000000 and 1000000000000 = 53791918385367774


================================================
FILE: Math/dixon_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 28 January 2019
# https://github.com/trizen

# Simple implementation of Dixon's factorization method.

# See also:
#   https://en.wikipedia.org/wiki/Dixon%27s_factorization_method
#   https://trizenx.blogspot.com/2018/10/continued-fraction-factorization-method.html

# Some parts of code inspired by:
#    https://github.com/martani/Quadratic-Sieve

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz qw();
use List::Util qw(first);
use ntheory qw(is_prime factor_exp forprimes next_prime);
use Math::Prime::Util::GMP qw(is_power vecprod sqrtint rootint gcd urandomb);

sub gaussian_elimination ($rows, $n) {

    my @A   = @$rows;
    my $m   = $#A;
    my $ONE = Math::GMPz::Rmpz_init_set_ui(1);

    my @I = map { $ONE << $_ } 0 .. $m;

    my $nrow = -1;
    my $mcol = $m < $n ? $m : $n;

    foreach my $col (0 .. $mcol) {
        my $npivot = -1;

        foreach my $row ($nrow + 1 .. $m) {
            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {
                $npivot = $row;
                $nrow++;
                last;
            }
        }

        next if ($npivot == -1);

        if ($npivot != $nrow) {
            @A[$npivot, $nrow] = @A[$nrow, $npivot];
            @I[$npivot, $nrow] = @I[$nrow, $npivot];
        }

        foreach my $row ($nrow + 1 .. $m) {
            if (Math::GMPz::Rmpz_tstbit($A[$row], $col)) {
                $A[$row] ^= $A[$nrow];
                $I[$row] ^= $I[$nrow];
            }
        }
    }

    return (\@A, \@I);
}

sub is_smooth_over_prod ($n, $k) {

    state $g = Math::GMPz::Rmpz_init_nobless();
    state $t = Math::GMPz::Rmpz_init_nobless();

    Math::GMPz::Rmpz_set($t, $n);
    Math::GMPz::Rmpz_gcd($g, $t, $k);

    while (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
        Math::GMPz::Rmpz_remove($t, $t, $g);
        return 1 if Math::GMPz::Rmpz_cmp_ui($t, 1) == 0;
        Math::GMPz::Rmpz_gcd($g, $t, $g);
    }

    return 0;
}

sub check_factor ($n, $g, $factors) {

    while ($n % $g == 0) {

        $n /= $g;
        push @$factors, $g;

        if (is_prime($n)) {
            push @$factors, $n;
            return 1;
        }
    }

    return $n;
}

sub dixon_factorization ($n, $verbose = 0) {

    local $| = 1;

    # Check for primes and negative numbers
    return ()   if $n <= 1;
    return ($n) if is_prime($n);

    # Check for perfect powers
    if (my $k = is_power($n)) {
        my @factors = __SUB__->(Math::GMPz->new(rootint($n, $k)), $verbose);
        return sort { $a <=> $b } ((@factors) x $k);
    }

    # Check for divisibility by 2
    if (Math::GMPz::Rmpz_even_p($n)) {

        my $v = Math::GMPz::Rmpz_scan1($n, 0);
        my $t = $n >> $v;

        my @factors = (2) x $v;

        if ($t > 1) {
            push @factors, __SUB__->($t, $verbose);
        }

        return @factors;
    }

    my $B  = 8 * int(exp(sqrt(log("$n") * log(log("$n"))) / 2));               # B-smooth limit
    my $nf = 2 * int(exp(sqrt(log("$n") * log(log("$n"))))**(sqrt(2) / 4));    # number of primes in factor-base

    my @factor_base = (2);

    if (length("$n") <= 25) {
        forprimes {
            if (Math::GMPz::Rmpz_kronecker_ui($n, $_) >= 0) {
                push @factor_base, $_;
            }
        }
        3, $B;
    }
    else {
        for (my $p = 3 ; @factor_base < $nf ; $p = next_prime($p)) {
            if (Math::GMPz::Rmpz_kronecker_ui($n, $p) >= 0) {
                push @factor_base, $p;
            }
        }
    }

    my %factor_index;
    @factor_index{@factor_base} = (0 .. $#factor_base);

    my sub exponents_signature (@factors) {
        my $sig = Math::GMPz::Rmpz_init_set_ui(0);

        foreach my $p (@factors) {
            if ($p->[1] & 1) {
                Math::GMPz::Rmpz_setbit($sig, $factor_index{$p->[0]});
            }
        }

        return $sig;
    }

    my $L  = scalar(@factor_base) + 1;                 # maximum number of matrix-rows
    my $FP = Math::GMPz->new(vecprod(@factor_base));

    if ($verbose) {
        printf("[*] Factoring %s (%s digits)...\n\n", "$n", length("$n"));
        say "*** Step 1/2: Finding smooth relations ***";
        printf("Target: %s relations, with B = %s\n", $L, $factor_base[-1]);
    }

    my (@A, @Q);

    my $u = Math::GMPz::Rmpz_init();
    my $t = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_sqrt($u, $n);
    Math::GMPz::Rmpz_sqrt($t, $n);

    while (1) {

        # u += 1
        Math::GMPz::Rmpz_add_ui($u, $u, 1);

        # v = (u*u) % n
        Math::GMPz::Rmpz_powm_ui($v, $u, 2, $n);

        if (is_smooth_over_prod($v, $FP)) {
            my @factors = factor_exp($v);

            if (@factors) {
                push @A, exponents_signature(@factors);
                push @Q, [map { Math::GMPz::Rmpz_init_set($_) } ($u, $v)];
            }

            if ($verbose) {
                printf("Progress: %d/%d relations.\r", scalar(@A), $L);
            }

            last if (@A >= $L);
        }

        # t -= 1
        Math::GMPz::Rmpz_sub_ui($t, $t, 1);

        # v = (t*t) % n
        Math::GMPz::Rmpz_powm_ui($v, $t, 2, $n);
        Math::GMPz::Rmpz_sub($v, $n, $v);

        if (is_smooth_over_prod($v, $FP)) {
            my @factors = factor_exp($v);

            if (@factors) {
                push @A, exponents_signature(@factors);
                push @Q, [map { Math::GMPz::Rmpz_init_set($_) } ($t, $v)];
            }

            if ($verbose) {
                printf("Progress: %d/%d relations.\r", scalar(@A), $L);
            }

            last if (@A >= $L);
        }
    }

    if ($verbose) {
        say "This step took ", $u -Math::GMPz->new(sqrtint($n)), " iterations.";
        say "\n*** Step 2/2: Linear Algebra ***";
        say "Performing Gaussian elimination...";
    }

    if (@A < $L) {
        push @A, map { Math::GMPz::Rmpz_init_set_ui(0) } 1 .. ($L - @A + 1);
    }

    my ($A, $I) = gaussian_elimination(\@A, $L - 1);

    my $LR = ((first { $A->[-$_] } 1 .. @$A) // 0) - 1;

    if ($verbose) {
        say "Found $LR linear dependencies...";
        say "Finding factors from congruences of squares...\n";
    }

    my @factors;
    my $rem = $n;

  SOLUTIONS: foreach my $solution (@{$I}[@$I - $LR .. $#$I]) {

        my $X = 1;
        my $Y = 1;

        foreach my $i (0 .. $#Q) {

            Math::GMPz::Rmpz_tstbit($solution, $i) || next;

            ($X *= $Q[$i][0]) %= $n;
            ($Y *= $Q[$i][1]);

            my $g = Math::GMPz->new(gcd($X - Math::GMPz->new(sqrtint($Y)), $rem));

            if ($g > 1 and $g < $rem) {
                if ($verbose) {
                    say "`-> found factor: $g";
                }
                $rem = check_factor($rem, $g, \@factors);
                last SOLUTIONS if $rem == 1;
            }
        }
    }

    say '' if $verbose;

    my @final_factors;

    foreach my $f (@factors) {
        if (is_prime($f)) {
            push @final_factors, $f;
        }
        else {
            push @final_factors, __SUB__->($f, $verbose);
        }
    }

    if ($rem != 1) {
        if ($rem != $n) {
            push @final_factors, __SUB__->($rem, $verbose);
        }
        else {
            push @final_factors, $rem;
        }
    }

    return sort { $a <=> $b } @final_factors;
}

my @composites = (
    @ARGV ? (map { Math::GMPz->new($_) } @ARGV) : do {
        map { Math::GMPz->new(urandomb($_)) + 2 } 2 .. 60;
    }
);

# Run some tests when no argument is provided
foreach my $n (@composites) {

    my @f = dixon_factorization($n, @ARGV ? 1 : 0);

    say "$n = ", join(' * ', map { is_prime($_) ? $_ : "$_ (composite)" } @f);
    die 'error' if Math::GMPz->new(vecprod(@f)) != $n;
}


================================================
FILE: Math/e_from_binomial.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 July 2016
# Website: https://github.com/trizen

# A new identity for e, based on (n+1)^n / n^n, as n->infinity,
# with the binomial expansion of (n+1)^n derived by the author.

#    n -> ∞
#     ---
#     \     binomial(n, k)
#     /    ---------------  =  e
#     ---      n^(n-k)
#    k = 0

use 5.014;
use strict;
use warnings;

use Math::AnyNum qw(:overload binomial);

my $n = 5000;
my $sum = 0.0;

foreach my $k(0 .. $n) {
    $sum += binomial($n, $k) / $n**($n-$k);
}

say $sum;


================================================
FILE: Math/e_primorial.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 September 2015
# Website: https://github.com/trizen

# Compute a new constant, called e-primorial
# using the following formula:
#   1 + sum({n=0, Inf}, 1/n#)
# where 'n#' is the product of the first n primes.

# Example:
#   1 + 1/2 + 1/(2*3) + 1/(2*3*5) + 1/(2*3*5*7)

use 5.010;
use strict;
use warnings;

use bignum (try => 'GMP');
use ntheory qw(forprimes);

my $s = 0;
my $p = 1;

forprimes {
    $s += 1 / ($p *= $_);
}
1000;

say $s;

__END__
0.705230171791800965147431682888248513743607733565505914344254271579448720350814858381153069719904774040199744849124258793026220304812181974452618661012021323159778159738892351792865007915208229244324416883081570696757761526547730409991939570626315095656064297092991040559037018681680261221057850602197069242610518384960529122692938064843534568180026418571495177395781060935455813529379203383024423075030933708131887415


================================================
FILE: Math/ecm_factorization_method.pl
================================================
#!/usr/bin/perl

# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra.

# Algorithm presented in the YouTube video:
#   https://www.youtube.com/watch?v=2JlpeQWtGH8

# See also:
#   https://en.wikipedia.org/wiki/Lenstra_elliptic-curve_factorization

use 5.020;
use strict;
use warnings;

use Math::GMPz qw();
use experimental qw(signatures);
use ntheory qw(is_prime_power logint);
use Math::Prime::Util::GMP qw(primes vecprod random_nbit_prime);

sub ecm ($N, $zrange = 200, $plimit = 20000) {

    # Check for perfect powers
    if (is_prime_power($N, \my $p)) {
        return $p;
    }

    # Make sure `N` is a Math::GMPz object
    if (ref($N) ne 'Math::GMPz') {
        $N = Math::GMPz->new("$N");
    }

    # Primes up to `plimit`
    my @primes = @{primes($plimit)};

    # Temporary mpz objects
    my $t  = Math::GMPz::Rmpz_init();
    my $t1 = Math::GMPz::Rmpz_init();
    my $t2 = Math::GMPz::Rmpz_init();

    foreach my $z (-$zrange .. $zrange) {

        my $x = Math::GMPz::Rmpz_init_set_ui(0);
        my $y = Math::GMPz::Rmpz_init_set_ui(1);

        foreach my $p (@primes) {

            my ($xn, $yn);
            my ($sx, $sy, $k) = ($x, $y, $p**logint($plimit, $p));

            my $first = 1;

            while ($k) {

                if ($k & 1) {

                    if ($first) {
                        ($xn, $yn) = ($sx, $sy);
                        $first = 0;
                    }
                    else {
                        Math::GMPz::Rmpz_sub($t, $sx, $xn);

                        if (!Math::GMPz::Rmpz_invert($t2, $t, $N)) {
                            Math::GMPz::Rmpz_gcd($t2, $t, $N);
                            Math::GMPz::Rmpz_cmp($t2, $N) ? return $t2 : last;
                        }

                        my $u = $t2;

                        # u * (sy - yn)
                        Math::GMPz::Rmpz_sub($t, $sy, $yn);
                        Math::GMPz::Rmpz_mul($t, $t, $u);
                        Math::GMPz::Rmpz_mod($t2, $t, $N);

                        my $L = $t2;

                        # L^2 - xn - sx
                        Math::GMPz::Rmpz_mul($t, $L, $L);
                        Math::GMPz::Rmpz_sub($t, $t, $xn);
                        Math::GMPz::Rmpz_sub($t, $t, $sx);
                        Math::GMPz::Rmpz_mod($t, $t, $N);

                        my $x_sum = Math::GMPz::Rmpz_init_set($t);

                        Math::GMPz::Rmpz_sub($t, $xn, $x_sum);
                        Math::GMPz::Rmpz_mul($t, $t, $L);
                        Math::GMPz::Rmpz_sub($t, $t, $yn);
                        Math::GMPz::Rmpz_mod($t, $t, $N);

                        $yn = Math::GMPz::Rmpz_init_set($t);
                        $xn = $x_sum;
                    }
                }

                Math::GMPz::Rmpz_mul_2exp($t, $sy, 1);

                if (!Math::GMPz::Rmpz_invert($t2, $t, $N)) {
                    Math::GMPz::Rmpz_gcd($t2, $t, $N);
                    Math::GMPz::Rmpz_cmp($t2, $N) ? return $t2 : last;
                }

                my $u = $t2;

                # u * (3 * sx^2 + z) % N
                Math::GMPz::Rmpz_mul($t, $sx, $sx);
                Math::GMPz::Rmpz_mul_ui($t, $t, 3);

                $z < 0
                  ? Math::GMPz::Rmpz_sub_ui($t, $t, -$z)
                  : Math::GMPz::Rmpz_add_ui($t, $t, $z);

                Math::GMPz::Rmpz_mul($t, $t, $u);
                Math::GMPz::Rmpz_mod($t2, $t, $N);

                my $L = $t2;

                # (L*L - 2*sx) % N
                Math::GMPz::Rmpz_mul($t, $L, $L);
                Math::GMPz::Rmpz_submul_ui($t, $sx, 2);
                Math::GMPz::Rmpz_mod($t, $t, $N);

                my $x2 = Math::GMPz::Rmpz_init_set($t);

                # (L * (sx - x2) - sy) % N
                Math::GMPz::Rmpz_sub($t, $sx, $x2);
                Math::GMPz::Rmpz_mul($t, $t, $L);
                Math::GMPz::Rmpz_sub($t, $t, $sy);
                Math::GMPz::Rmpz_mod($t, $t, $N);

                $sy = Math::GMPz::Rmpz_init_set($t);
                $sx = $x2;

                # Failure when t = 0
                return $N if !Math::GMPz::Rmpz_sgn($t);

                $k >>= 1;
            }

            ($x, $y) = ($xn, $yn);
        }
    }

    return $N;    # failed to factorize N
}

# Factoring the 7th Fermat number: 2^128 + 1
say ecm(Math::GMPz->new(2)**128 + 1, 100, 8000);    # takes ~1 second

say "\n=> More tests:";

foreach my $k (10 .. 40) {

    my $n = Math::GMPz->new(vecprod(map { random_nbit_prime($k) } 1 .. 2));
    my $p = ecm($n, logint($n, 2), logint($n, 2)**2);

    if ($p > 1 and $p < $n) {
        say "$n = $p * ", $n / $p;
    }
    else {
        say "Failed to factor $n";
    }
}


================================================
FILE: Math/elementary_cellular_automaton_generalized.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 October 2019
# https://github.com/trizen

# Generalization of the elementary cellular automaton, by using `n` color-states and looking at `k` neighbors left-to-right.

# 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.

# See also:
#   https://en.wikipedia.org/wiki/Cellular_automaton
#   https://en.wikipedia.org/wiki/Elementary_cellular_automaton
#   https://rosettacode.org/wiki/Elementary_cellular_automaton

# YouTube lectures:
#   https://www.youtube.com/watch?v=S3tYzCPuVsA
#   https://www.youtube.com/watch?v=pGGIE5uhPRQ

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);
use Algorithm::Combinatorics qw(variations_with_repetition);

sub automaton ($n, $k, $rule, $callback, $iter = 50, $cells = [1]) {

    my @states = variations_with_repetition([0 .. $n - 1], 2 * $k + 1);
    my @digits = reverse todigits($rule, $n);

    my @lookup;

    foreach my $i (0 .. $#states) {
        $lookup[fromdigits($states[$i], $n)] = $digits[$i] // 0;
    }

    my @padding         = (0) x (($iter - scalar(@$cells)) >> 1);
    my @cells           = (@padding, @$cells, @padding);
    my @neighbors_range = (-$k .. $k);

    my $len = scalar(@cells);

    for (1 .. ($iter >> 1)) {
        $callback->(@cells);
        @cells = @lookup[map {
            my $i = $_; fromdigits([map { $cells[($i + $_) % $len] } @neighbors_range], $n)
        } 0 .. $#cells];
    }

    return @cells;
}

my @chars = (' ', '*', '.', '#');

say "\n=> 2x1 Automaton";

automaton(2, 1, 90, sub (@row) {
    say join '', map { $chars[$_] } @row;
});

say "\n=> 3x1 Automaton";

automaton(3, 1, "843693805713", sub (@row) {
    say join '', map { $chars[$_] } @row;
});

say "\n=> 3x2 Automaton";

automaton(3, 2, "590193390821886729275563552433397050190", sub (@row) {
    say join '', map { $chars[$_] } @row;
}, 80);


================================================
FILE: Math/elliptic-curve_factorization_method.pl
================================================
#!/usr/bin/perl

# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra.

# Algorithm presented in the below video:
#   https://www.youtube.com/watch?v=2JlpeQWtGH8

# See also:
#   https://en.wikipedia.org/wiki/Lenstra_elliptic-curve_factorization

use 5.020;
use strict;
use warnings;

use Math::GMPz qw();
use experimental qw(signatures);
use ntheory qw(is_prime_power logint gcd);
use Math::Prime::Util::GMP qw(primes invmod);

sub ecm ($N, $zrange = 100, $plimit = 10000) {

    if (is_prime_power($N, \my $p)) {
        return $p;
    }

    my @primes = @{primes($plimit)};

    foreach my $z (-$zrange .. $zrange) {

        my $x = 0;
        my $y = 1;

        foreach my $p (@primes) {
            my $k = $p**logint($plimit, $p);

            my ($xn, $yn);
            my ($sx, $sy, $t) = ($x, $y, $k);

            my $first = 1;

            while ($t) {

                if ($t & 1) {
                    if ($first) {
                        ($xn, $yn) = ($sx, $sy);
                        $first = 0;
                    }
                    else {
                        my $u = invmod($sx - $xn, $N);

                        if (not defined $u) {
                            my $d = gcd($sx - $xn, $N);
                            $d == $N ? last : return $d;
                        }

                        $u = Math::GMPz->new($u);

                        my $L  = ($u * ($sy - $yn)) % $N;
                        my $xs = ($L * $L - $xn - $sx) % $N;

                        $yn = ($L * ($xn - $xs) - $yn) % $N;
                        $xn = $xs;
                    }
                }

                my $u = invmod(2 * $sy, $N);

                if (not defined $u) {
                    my $d = gcd(2 * $sy, $N);
                    $d == $N ? last : return $d;
                }

                $u = Math::GMPz->new($u);

                my $L  = ($u * (3 * $sx * $sx + $z)) % $N;
                my $x2 = ($L * $L - 2 * $sx) % $N;

                $sy = ($L * ($sx - $x2) - $sy) % $N;
                $sx = $x2;

                $sy || return $N;

                $t >>= 1;
            }
            ($x, $y) = ($xn, $yn);
        }
    }

    return $N;    # failed
}

if (@ARGV) {

    my ($str, $B1, $B2) = @ARGV;

    my $n = Math::GMPz->new($str);
    printf("[*] Factoring: %s (%d digits)...\n", $n, length("$n"));

    my $factor = ecm($n, $B1 // 100, $B2 // 1000);

    if ($factor > 1 and $factor < $n) {
        say "`-> found factor: $factor";
        exit 0;
    }
    else {
        say "`-> no factor found...";
        exit 1;
    }
}

say ecm(Math::GMPz->new("14304849576137459"));
say ecm(79710615566344993);
say ecm(Math::GMPz->new(2)**128 + 1);    # takes ~3.4 seconds


================================================
FILE: Math/elliptic-curve_factorization_method_with_B2_stage.pl
================================================
#!/usr/bin/perl

# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra, with B2 stage.

# Code translated from the SymPy file "ntheory/ecm.py".

package Point {

    use 5.036;
    use Math::Prime::Util::GMP qw(:all);

    if (!defined(&submod)) {
        *submod = sub ($x, $y, $m) {
            addmod($x, "-$y", $m);
        };
    }

    if (!defined(&muladdmod)) {
        *muladdmod = sub ($x, $y, $z, $m) {
            addmod(mulmod($x, $y, $m), $z, $m);
        };
    }

    sub new {
        my ($class, $x_cord, $z_cord, $a_24, $mod) = @_;
        bless {
               x_cord => $x_cord,
               z_cord => $z_cord,
               a_24   => $a_24,
               mod    => $mod,
              }, $class;
    }

    sub add ($self, $Q, $diff) {
        my $u = mulmod(submod($self->{x_cord}, $self->{z_cord}, $self->{mod}), addmod($Q->{x_cord}, $Q->{z_cord}, $self->{mod}), $self->{mod});
        my $v = mulmod(addmod($self->{x_cord}, $self->{z_cord}, $self->{mod}), submod($Q->{x_cord}, $Q->{z_cord}, $self->{mod}), $self->{mod});
        my ($add, $subt) = (addmod($u, $v, $self->{mod}), submod($u, $v, $self->{mod}));
        my $new_x_cord = mulmod($diff->{z_cord}, mulmod($add, $add, $self->{mod}), $self->{mod});
        my $new_z_cord = mulmod($diff->{x_cord}, mulmod($subt, $subt, $self->{mod}), $self->{mod});
        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});
    }

    sub double ($self) {
        my $u          = powmod(addmod($self->{x_cord}, $self->{z_cord}, $self->{mod}), 2, $self->{mod});
        my $v          = powmod(submod($self->{x_cord}, $self->{z_cord}, $self->{mod}), 2, $self->{mod});
        my $diff       = submod($u, $v, $self->{mod});
        my $new_x_cord = mulmod($u,    $v,                                                $self->{mod});
        my $new_z_cord = mulmod($diff, muladdmod($self->{a_24}, $diff, $v, $self->{mod}), $self->{mod});
        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});
    }

    sub mont_ladder ($self, $k) {

        my $Q = $self;
        my $R = $self->double();

        my @bits = todigits($k, 2);
        shift @bits;

        foreach my $i (@bits) {
            if ($i eq '1') {
                $Q = $R->add($Q, $self);
                $R = $R->double();
            }
            else {
                $R = $Q->add($R, $self);
                $Q = $Q->double();
            }
        }

        return $Q;
    }
}

use 5.036;
use List::Util             qw(uniq min);
use Math::Prime::Util::GMP qw(:all);

if (!defined(&submod)) {
    *submod = sub ($x, $y, $m) {
        addmod($x, "-$y", $m);
    };
}

if (!defined(&mulsubmod)) {
    *mulsubmod = sub ($x, $y, $z, $m) {
        addmod(mulmod($x, "-$y", $m), $z, $m);
    };
}

if (!defined(&muladdmod)) {
    *muladdmod = sub ($x, $y, $z, $m) {
        addmod(mulmod($x, $y, $m), $z, $m);
    };
}

sub ecm_one_factor ($n, $B1 = 10_000, $B2 = 100_000, $max_curves = 200) {

    if (($B1 % 2 == 1) or ($B2 % 2 == 1)) {
        die "The Bounds should be even integers";
    }

    is_prime($n) && return $n;

    my $D = min(sqrtint($B2), ($B1 >> 1) - 1);
    my $k = consecutive_integer_lcm($B1);

    my (@S, @beta);
    my @deltas_list;

    my $r_min  = $B1 + 2 * $D;
    my $r_max  = $B2 + 2 * $D;
    my $r_step = 4 * $D;

    for (my $r = $r_min ; $r <= $r_max ; $r += $r_step) {
        my @deltas;
        foreach my $q (sieve_primes($r - 2 * $D, $r + 2 * $D)) {
            push @deltas, ((abs($q - $r) - 1) >> 1);
        }
        push @deltas_list, [uniq(@deltas)];
    }

    for (1 .. $max_curves) {

        # Suyama's parametrization
        my $sigma = urandomr(6, subint($n, 1));
        my $u     = mulsubmod($sigma, $sigma, 5, $n);
        my $v     = mulmod($sigma, 4, $n);
        my $u_3   = powmod($u, 3, $n);

        my $inv = invmod(mulmod(mulmod($u_3, $v, $n),              16,                       $n), $n) || return gcd(lcm($u_3, $v), $n);
        my $a24 = mulmod(mulmod(powmod(submod($v, $u, $n), 3, $n), muladdmod(3, $u, $v, $n), $n), $inv, $n);

        my $Q = Point->new($u_3, powmod($v, 3, $n), $a24, $n);
        $Q = $Q->mont_ladder($k);
        my $g = gcd($Q->{z_cord}, $n);

        # Stage 1 factor
        if ($g > 1 and $g < $n) {
            return $g;
        }

        # Stage 1 failure. Q.z = 0, Try another curve
        elsif ($g == $n) {
            next;
        }

        # Stage 2 - Improved Standard Continuation
        $S[0] = $Q;
        my $Q2 = $Q->double();
        $S[1]    = $Q2->add($Q, $Q);
        $beta[0] = mulmod($S[0]->{x_cord}, $S[0]->{z_cord}, $n);
        $beta[1] = mulmod($S[1]->{x_cord}, $S[1]->{z_cord}, $n);

        foreach my $d (2 .. $D - 1) {
            $S[$d]    = $S[$d - 1]->add($Q2, $S[$d - 2]);
            $beta[$d] = mulmod($S[$d]->{x_cord}, $S[$d]->{z_cord}, $n);
        }

        $g = 1;

        my $W = $Q->mont_ladder(4 * $D);
        my $T = $Q->mont_ladder($B1 - 2 * $D);
        my $R = $Q->mont_ladder($B1 + 2 * $D);

        foreach my $deltas (@deltas_list) {
            my $alpha = mulmod($R->{x_cord}, $R->{z_cord}, $n);
            foreach my $delta (@$deltas) {
                $g = mulmod(
                            $g,
                            addmod(
                                   submod(
                                          mulmod(submod($R->{x_cord}, $S[$delta]->{x_cord}, $n), addmod($R->{z_cord}, $S[$delta]->{z_cord}, $n), $n),
                                          $alpha, $n
                                         ),
                                   $beta[$delta],
                                   $n
                                  ),
                            $n
                           );
            }

            # Swap
            ($T, $R) = ($R, $R->add($W, $T));
        }

        $g = gcd($n, $g);

        # Stage 2 Factor found
        if ($g > 1 and $g < $n) {
            return $g;
        }
    }

    # ECM failed, Increase the bounds
    die "Increase the bounds";
}

# Params from:
#   https://www.rieselprime.de/ziki/Elliptic_curve_method

my @ECM_PARAMS = (

    # d      B1     curves
    [5,  200,        4],
    [10, 360,        7],
    [13, 600,        20],
    [15, 2000,       10],
    [20, 11000,      90],
    [25, 50000,      300],
    [30, 250000,     700],
    [35, 1000000,    1800],
    [40, 3000000,    5100],
    [45, 11000000,   10600],
    [50, 43000000,   19300],
    [55, 110000000,  49000],
    [60, 260000000,  124000],
    [65, 850000000,  210000],
    [70, 2900000000, 340000],
                 );

sub ecm ($n, $B1 = undef, $B2 = undef, $max_curves = undef) {

    $n <= 1 and die "n must be greater than 1";

    if (!defined($B1)) {
        foreach my $row (@ECM_PARAMS) {
            my ($d, $B1, $curves) = @$row;
            ## say ":: Trying to find a prime factor with $d digits using B1 = $B1 with $curves curves";
            my @f = eval { __SUB__->($n, $B1, $B1 * 20, $curves) };
            return @f if !$@;
        }
    }

    state $primorial = primorial(100_000);

    my @factors;
    my $g = gcd($n, $primorial);

    if ($g > 1) {
        push @factors, factor($g);
        foreach my $p (@factors) {
            $n = divint($n, powint($p, valuation($n, $p)));
        }
    }

    while ($n > 1) {
        my $factor = eval { ecm_one_factor($n, $B1, $B2, $max_curves) };

        if ($@) {
            die "Failed to factor $n: $@";
        }

        push @factors, $factor;
        $n = divint($n, powint($factor, valuation($n, $factor)));
    }

    @factors = uniq(@factors);

    my @final_factors;
    foreach my $factor (@factors) {
        if (is_prime($factor)) {
            push @final_factors, $factor;
        }
        else {
            push @final_factors, __SUB__->($factor, $B1, $B2, $max_curves);
        }
    }

    return sort { $a <=> $b } @final_factors;
}

# Support for numbers provided as command-line arguments
if (@ARGV) {
    foreach my $n (@ARGV) {
        say "rad($n) = ", join ' * ', ecm($n);
    }
    exit;
}

say join ' * ', ecm('314159265358979323');                #=> 317213509 * 990371647
say join ' * ', ecm('14304849576137459');                 #=> 16100431 * 888476189
say join ' * ', ecm('9804659461513846513');               #=> 4641991 * 2112166839943
say join ' * ', ecm('25645121643901801');                 #=> 5394769 * 4753701529
say join ' * ', ecm('17177619065692036843');              #=> 2957613037 * 5807933239
say join ' * ', ecm('195905123644566489241411490581');    #=> 259719190596553 * 754295911652077

say join ' * ', ecm(addint(powint(2, 64), 1));            #=> 274177 * 67280421310721
say join ' * ', ecm(subint(powint(2, 128), 1));           #=> 3 * 5 * 17 * 257 * 641 * 65537 * 274177 * 6700417 * 67280421310721
say join ' * ', ecm(addint(powint(2, 128), 1));           #=> 59649589127497217 * 5704689200685129054721

# Run some tests when no argument is provided
foreach my $n (map { addint(urandomb($_), 2) } 2 .. 100) {
    say "rad($n) = ", join(' * ', map { is_prime($_) ? $_ : "$_ (composite)" } ecm($n));
}


================================================
FILE: Math/elliptic-curve_factorization_method_with_B2_stage_mpz.pl
================================================
#!/usr/bin/perl

# The elliptic-curve factorization method (ECM), due to Hendrik Lenstra, with B2 stage. (GMPz implementation)

# Code translated from the SymPy file "ntheory/ecm.py".

package Point {

    use 5.020;
    use warnings;
    use Math::GMPz   qw();
    use experimental qw(signatures);

    sub new {
        my ($class, $x_cord, $z_cord, $a_24, $mod) = @_;
        bless {
               x_cord => $x_cord,
               z_cord => $z_cord,
               a_24   => $a_24,
               mod    => $mod,
              }, $class;
    }

    state $t1 = Math::GMPz::Rmpz_init();
    state $t2 = Math::GMPz::Rmpz_init();
    state $u  = Math::GMPz::Rmpz_init();
    state $v  = Math::GMPz::Rmpz_init();

    sub add ($self, $Q, $diff, $new_x_cord = undef, $new_z_cord = undef) {

        Math::GMPz::Rmpz_sub($u, $self->{x_cord}, $self->{z_cord});
        Math::GMPz::Rmpz_add($t2, $Q->{x_cord}, $Q->{z_cord});
        Math::GMPz::Rmpz_mul($u, $u, $t2);
        Math::GMPz::Rmpz_mod($u, $u, $self->{mod});

        Math::GMPz::Rmpz_add($v, $self->{x_cord}, $self->{z_cord});
        Math::GMPz::Rmpz_sub($t2, $Q->{x_cord}, $Q->{z_cord});
        Math::GMPz::Rmpz_mul($v, $v, $t2);
        Math::GMPz::Rmpz_mod($v, $v, $self->{mod});

        Math::GMPz::Rmpz_add($t1, $u, $v);
        Math::GMPz::Rmpz_sub($t2, $u, $v);

        $new_x_cord //= Math::GMPz::Rmpz_init();
        $new_z_cord //= Math::GMPz::Rmpz_init();

        Math::GMPz::Rmpz_mul($new_x_cord, $t1,         $t1);
        Math::GMPz::Rmpz_mul($new_x_cord, $new_x_cord, $diff->{z_cord});
        Math::GMPz::Rmpz_mod($new_x_cord, $new_x_cord, $self->{mod});

        Math::GMPz::Rmpz_mul($new_z_cord, $t2,         $t2);
        Math::GMPz::Rmpz_mul($new_z_cord, $new_z_cord, $diff->{x_cord});
        Math::GMPz::Rmpz_mod($new_z_cord, $new_z_cord, $self->{mod});

        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});
    }

    sub double ($self, $new_x_cord = undef, $new_z_cord = undef) {

        Math::GMPz::Rmpz_add($u, $self->{x_cord}, $self->{z_cord});
        Math::GMPz::Rmpz_powm_ui($u, $u, 2, $self->{mod});

        Math::GMPz::Rmpz_sub($v, $self->{x_cord}, $self->{z_cord});
        Math::GMPz::Rmpz_powm_ui($v, $v, 2, $self->{mod});

        Math::GMPz::Rmpz_sub($t1, $u, $v);

        $new_x_cord //= Math::GMPz::Rmpz_init();
        $new_z_cord //= Math::GMPz::Rmpz_init();

        Math::GMPz::Rmpz_mul($new_x_cord, $u, $v);
        Math::GMPz::Rmpz_mod($new_x_cord, $new_x_cord, $self->{mod});

        Math::GMPz::Rmpz_mul($t2, $self->{a_24}, $t1);
        Math::GMPz::Rmpz_add($t2, $t2, $v);
        Math::GMPz::Rmpz_mod($t2, $t2, $self->{mod});
        Math::GMPz::Rmpz_mul($new_z_cord, $t1, $t2);
        Math::GMPz::Rmpz_mod($new_z_cord, $new_z_cord, $self->{mod});

        return Point->new($new_x_cord, $new_z_cord, $self->{a_24}, $self->{mod});
    }

    sub mont_ladder ($self, $k) {

        my $Q = $self;
        my $R = $self->double();

        if (ref($k) ne 'Math::GMPz') {
            $k = Math::GMPz::Rmpz_init_set_str("$k", 10);
        }

        my $new_x_cord_1 = Math::GMPz::Rmpz_init();
        my $new_x_cord_2 = Math::GMPz::Rmpz_init();
        my $new_z_cord_1 = Math::GMPz::Rmpz_init();
        my $new_z_cord_2 = Math::GMPz::Rmpz_init();

        foreach my $i (split(//, substr(Math::GMPz::Rmpz_get_str($k, 2), 1))) {
            if ($i eq '1') {
                $Q = $R->add($Q, $self, $new_x_cord_1, $new_z_cord_1);
                $R = $R->double($new_x_cord_2, $new_z_cord_2);
            }
            else {
                $R = $Q->add($R, $self, $new_x_cord_2, $new_z_cord_2);
                $Q = $Q->double($new_x_cord_1, $new_z_cord_1);
            }
        }

        return $Q;
    }
}

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz             qw();
use List::Util             qw(uniq min);
use Math::Prime::Util::GMP qw(:all);

sub ecm_one_factor ($n, $B1 = 10_000, $B2 = 100_000, $max_curves = 200, $seed = undef) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz::Rmpz_init_set_str("$n", 10);
    }

    if (($B1 % 2 == 1) or ($B2 % 2 == 1)) {
        die "The Bounds should be even integers";
    }

    is_prime($n) && return $n;

    my $D = min(sqrtint($B2), ($B1 >> 1) - 1);
    my $k = Math::GMPz::Rmpz_init_set_str(consecutive_integer_lcm($B1), 10);

    my @S;
    my @beta = map { Math::GMPz::Rmpz_init() } 1 .. $D;
    my @xz   = map { [Math::GMPz::Rmpz_init(), Math::GMPz::Rmpz_init()] } 1 .. $D;

    my @deltas_list;

    my $r_min  = $B1 + 2 * $D;
    my $r_max  = $B2 + 2 * $D;
    my $r_step = 4 * $D;

    for (my $r = $r_min ; $r <= $r_max ; $r += $r_step) {
        my @deltas;
        foreach my $q (sieve_primes($r - 2 * $D, $r + 2 * $D)) {
            push @deltas, ((abs($q - $r) - 1) >> 1);
        }
        push @deltas_list, [uniq(@deltas)];
    }

    state $u     = Math::GMPz::Rmpz_init();
    state $v     = Math::GMPz::Rmpz_init();
    state $u_3   = Math::GMPz::Rmpz_init();
    state $sigma = Math::GMPz::Rmpz_init();
    state $t     = Math::GMPz::Rmpz_init();
    state $t1    = Math::GMPz::Rmpz_init();
    state $t2    = Math::GMPz::Rmpz_init();
    state $inv   = Math::GMPz::Rmpz_init();
    state $a24   = Math::GMPz::Rmpz_init();
    state $v_3   = Math::GMPz::Rmpz_init();
    state $alpha = Math::GMPz::Rmpz_init();
    state $g     = Math::GMPz::Rmpz_init();

    my $state = Math::GMPz::zgmp_randinit_default();

    if (defined($seed)) {
        Math::GMPz::zgmp_randseed_ui($state, $seed);
    }

    for (1 .. $max_curves) {

        # Suyama's parametrization
        Math::GMPz::Rmpz_sub_ui($sigma, $n, 7);
        Math::GMPz::Rmpz_urandomm($sigma, $state, $sigma, 1);
        Math::GMPz::Rmpz_add_ui($sigma, $sigma, 6);

        Math::GMPz::Rmpz_mul($u, $sigma, $sigma);
        Math::GMPz::Rmpz_sub_ui($u, $u, 5);
        Math::GMPz::Rmpz_mod($u, $u, $n);

        Math::GMPz::Rmpz_mul_2exp($v, $sigma, 2);
        Math::GMPz::Rmpz_mod($v, $v, $n);

        Math::GMPz::Rmpz_powm_ui($u_3, $u, 3, $n);

        Math::GMPz::Rmpz_mul($t, $u_3, $v);
        Math::GMPz::Rmpz_mul_2exp($t, $t, 4);
        Math::GMPz::Rmpz_mod($t, $t, $n);

        Math::GMPz::Rmpz_invert($inv, $t, $n) || return do {
            Math::GMPz::Rmpz_lcm($g, $u_3, $v);
            Math::GMPz::Rmpz_gcd($g, $g, $n);
            Math::GMPz::Rmpz_init_set($g);
        };

        Math::GMPz::Rmpz_sub($a24, $v, $u);
        Math::GMPz::Rmpz_powm_ui($a24, $a24, 3, $n);

        Math::GMPz::Rmpz_mul_ui($t, $u, 3);
        Math::GMPz::Rmpz_add($t, $t, $v);
        Math::GMPz::Rmpz_mul($a24, $a24, $t);
        Math::GMPz::Rmpz_mod($a24, $a24, $n);
        Math::GMPz::Rmpz_mul($a24, $a24, $inv);
        Math::GMPz::Rmpz_mod($a24, $a24, $n);

        Math::GMPz::Rmpz_powm_ui($v_3, $v, 3, $n);

        my $Q = Point->new($u_3, $v_3, $a24, $n);
        $Q = $Q->mont_ladder($k);
        Math::GMPz::Rmpz_gcd($g, $Q->{z_cord}, $n);

        # Stage 1 factor
        if ($g > 1 and $g < $n) {
            return Math::GMPz::Rmpz_init_set($g);
        }

        # Stage 1 failure. Q.z = 0, Try another curve
        elsif ($g == $n) {
            next;
        }

        # Stage 2 - Improved Standard Continuation
        $S[0] = $Q;
        my $Q2 = $Q->double($xz[0][0], $xz[0][1]);
        $S[1] = $Q2->add($Q, $Q, $xz[1][0], $xz[1][1]);

        foreach my $d (0 .. 1) {
            Math::GMPz::Rmpz_mul($beta[$d], $S[$d]->{x_cord}, $S[$d]->{z_cord});
            Math::GMPz::Rmpz_mod($beta[$d], $beta[$d], $n);
        }

        foreach my $d (2 .. $D - 1) {
            $S[$d] = $S[$d - 1]->add($Q2, $S[$d - 2], $xz[$d][0], $xz[$d][1]);
            Math::GMPz::Rmpz_mul($beta[$d], $S[$d]->{x_cord}, $S[$d]->{z_cord});
            Math::GMPz::Rmpz_mod($beta[$d], $beta[$d], $n);
        }

        Math::GMPz::Rmpz_set_ui($t, 1);

        my $W = $Q->mont_ladder(4 * $D);
        my $T = $Q->mont_ladder($B1 - 2 * $D);
        my $R = $Q->mont_ladder($B1 + 2 * $D);

        foreach my $deltas (@deltas_list) {

            Math::GMPz::Rmpz_mul($alpha, $R->{x_cord}, $R->{z_cord});
            Math::GMPz::Rmpz_mod($alpha, $alpha, $n);

            foreach my $delta (@$deltas) {
                Math::GMPz::Rmpz_sub($t1, $R->{x_cord}, $S[$delta]->{x_cord});
                Math::GMPz::Rmpz_add($t2, $R->{z_cord}, $S[$delta]->{z_cord});
                Math::GMPz::Rmpz_mul($t1, $t1, $t2);
                Math::GMPz::Rmpz_mod($t1, $t1, $n);
                Math::GMPz::Rmpz_sub($t1, $t1, $alpha);
                Math::GMPz::Rmpz_add($t1, $t1, $beta[$delta]);
                Math::GMPz::Rmpz_mul($t, $t, $t1);
                Math::GMPz::Rmpz_mod($t, $t, $n);
            }

            # Swap
            ($T, $R) = ($R, $R->add($W, $T));
        }

        Math::GMPz::Rmpz_gcd($g, $t, $n);

        # Stage 2 Factor found
        if ($g > 1 and $g < $n) {
            return Math::GMPz::Rmpz_init_set($g);
        }
    }

    # ECM failed, Increase the bounds
    die "Increase the bounds";
}

# Params from:
#   https://www.rieselprime.de/ziki/Elliptic_curve_method

my @ECM_PARAMS = (

    # d      B1     curves
    [5,  200,        4],
    [10, 360,        7],
    [13, 600,        20],
    [15, 2000,       10],
    [20, 11000,      90],
    [25, 50000,      300],
    [30, 250000,     700],
    [35, 1000000,    1800],
    [40, 3000000,    5100],
    [45, 11000000,   10600],
    [50, 43000000,   19300],
    [55, 110000000,  49000],
    [60, 260000000,  124000],
    [65, 850000000,  210000],
    [70, 2900000000, 340000],
                 );

sub ecm ($n, $B1 = undef, $B2 = undef, $max_curves = undef, $seed = undef) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz::Rmpz_init_set_str("$n", 10);
    }

    $n <= 1 and die "n must be greater than 1";

    if (!defined($B1)) {
        foreach my $row (@ECM_PARAMS) {
            my ($d, $B1, $curves) = @$row;
            ## say ":: Trying to find a prime factor with $d digits using B1 = $B1 with $curves curves";
            my @f = eval { __SUB__->($n, $B1, $B1 * 20, $curves, $seed) };
            return @f if !$@;
        }
    }

    state $primorial = primorial(100_000);

    my @factors;
    my $g = gcd($n, $primorial);

    if ($g > 1) {
        $n = Math::GMPz::Rmpz_init_set($n);    # copy
        push @factors, factor($g);
        my $t = Math::GMPz::Rmpz_init();
        foreach my $p (@factors) {
            Math::GMPz::Rmpz_set_ui($t, $p);
            Math::GMPz::Rmpz_remove($n, $n, $t);
        }
    }

    while ($n > 1) {
        my $factor = eval { ecm_one_factor($n, $B1, $B2, $max_curves, $seed) };

        if ($@) {
            die "Failed to factor $n: $@";
        }

        push @factors, $factor;
        $n = Math::GMPz::Rmpz_init_set($n);
        Math::GMPz::Rmpz_remove($n, $n, $factor);
    }

    @factors = uniq(@factors);

    my @final_factors;
    foreach my $factor (@factors) {
        if (is_prime($factor)) {
            push @final_factors, $factor;
        }
        else {
            push @final_factors, __SUB__->($factor, $B1, $B2, $max_curves);
        }
    }

    return sort { $a <=> $b } @final_factors;
}

# Support for numbers provided as command-line arguments
if (@ARGV) {
    foreach my $n (@ARGV) {
        say "rad($n) = ", join ' * ', ecm($n);
    }
    exit;
}

say join ' * ', ecm('314159265358979323');                #=> 317213509 * 990371647
say join ' * ', ecm('14304849576137459');                 #=> 16100431 * 888476189
say join ' * ', ecm('9804659461513846513');               #=> 4641991 * 2112166839943
say join ' * ', ecm('25645121643901801');                 #=> 5394769 * 4753701529
say join ' * ', ecm('17177619065692036843');              #=> 2957613037 * 5807933239
say join ' * ', ecm('195905123644566489241411490581');    #=> 259719190596553 * 754295911652077

say join ' * ', ecm(Math::GMPz->new(2)**64 + 1);          #=> 274177 * 67280421310721
say join ' * ', ecm(Math::GMPz->new(2)**128 - 1);         #=> 3 * 5 * 17 * 257 * 641 * 65537 * 274177 * 6700417 * 67280421310721
say join ' * ', ecm(Math::GMPz->new(2)**128 + 1);         #=> 59649589127497217 * 5704689200685129054721

# Run some tests when no argument is provided
foreach my $n (map { Math::GMPz->new(urandomb($_)) + 2 } 2 .. 100) {
    say "rad($n) = ", join(' * ', map { is_prime($_) ? $_ : "$_ (composite)" } ecm($n));
}


================================================
FILE: Math/equally_spaced_squares_solutions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 26 January 2019
# https://github.com/trizen

# Given a positive integer `n`, find the integer values `k` such that both `k-2*n` and `k+2*n` are squares.

# If `n = 4*x*y`, then `k = 4*(x^2 + y^2)`, with rational values x and y.

# For `n = 18`, we have the following solutions:
#   a(18) = [45, 85, 325]
#
# which produce the following squares:
#   45 + 2*18 =  9^2  ;  45 - 2*18 =  3^2
#   85 + 2*18 = 11^2  ;  85 - 2*18 =  7^2
#  325 + 2*18 = 19^2  ; 325 - 2*18 = 17^2

# See also:
#   https://oeis.org/A323728
#   https://en.wikipedia.org/wiki/Difference_of_two_squares

use 5.010;
use strict;
use warnings;

use ntheory qw(divisors sqrtint);
use Math::AnyNum qw(:overload min);

sub equally_spaced_squares {
    my ($n) = @_;

    my $limit = sqrtint($n);

    my @solutions;
    foreach my $d (divisors($n)) {

        last if $d > $limit;

        my $x = $d;
        my $y = ($n / $d);

        unshift @solutions, $x**2 + $y**2;
    }

    return @solutions;
}

foreach my $n (1 .. 20) {
    say "a($n) = [", join(", ", equally_spaced_squares($n)), "]";
}

say '';
say "A323728 = [", join(', ', map { min equally_spaced_squares($_) } 1 .. 100), ", ...]";

__END__
a(1) = [2]
a(2) = [5]
a(3) = [10]
a(4) = [8, 17]
a(5) = [26]
a(6) = [13, 37]
a(7) = [50]
a(8) = [20, 65]
a(9) = [18, 82]
a(10) = [29, 101]
a(11) = [122]
a(12) = [25, 40, 145]
a(13) = [170]
a(14) = [53, 197]
a(15) = [34, 226]
a(16) = [32, 68, 257]
a(17) = [290]
a(18) = [45, 85, 325]
a(19) = [362]
a(20) = [41, 104, 401]

A323728 = [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, ...]


================================================
FILE: Math/esthetic_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 31 May 2020
# https://github.com/trizen

# Fast algorithm for generating esthetic numbers in a given base.

# See also:
#   https://rosettacode.org/wiki/Esthetic_numbers

# OEIS:
#   https://oeis.org/A000975 -- base 2
#   https://oeis.org/A033068 -- base 3
#   https://oeis.org/A033075 -- base 10

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(fromdigits todigitstring);

sub generate_esthetic ($root, $upto, $callback, $base = 10) {

    my $v = fromdigits($root, $base);

    return if ($v > $upto);
    $callback->($v);

    my $t = $root->[-1];

    __SUB__->([@$root, $t + 1], $upto, $callback, $base) if ($t + 1 < $base);
    __SUB__->([@$root, $t - 1], $upto, $callback, $base) if ($t - 1 >= 0);
}

sub between_esthetic ($from, $upto, $base = 10) {
    my @list;
    foreach my $k (1 .. $base - 1) {
        generate_esthetic([$k], $upto,
            sub($n) { push(@list, $n) if ($n >= $from) }, $base);
    }
    sort { $a <=> $b } @list;
}

sub first_n_esthetic ($n, $base = 10) {
    for (my $m = $n * $n ; 1 ; $m *= $base) {
        my @list = between_esthetic(1, $m, $base);
        return @list[0 .. $n - 1] if @list >= $n;
    }
}

foreach my $base (2 .. 16) {
    say "20 first ${\(sprintf('%2d', $base))}-esthetic numbers: ",
        join(', ', first_n_esthetic(20, $base));
}

say "\nBase 10 esthetic numbers between 100,000,000 and 130,000,000:";
for (my @list = between_esthetic(1e8, 1.3e8) ; @list ;) {
    say join(' ', splice(@list, 0, 9));
}

__END__
20 first  2-esthetic numbers: 1, 2, 5, 10, 21, 42, 85, 170, 341, 682, 1365, 2730, 5461, 10922, 21845, 43690, 87381, 174762, 349525, 699050
20 first  3-esthetic numbers: 1, 2, 3, 5, 7, 10, 16, 21, 23, 30, 32, 48, 50, 64, 70, 91, 97, 145, 151, 192
20 first  4-esthetic numbers: 1, 2, 3, 4, 6, 9, 11, 14, 17, 25, 27, 36, 38, 46, 57, 59, 68, 70, 100, 102
20 first  5-esthetic numbers: 1, 2, 3, 4, 5, 7, 11, 13, 17, 19, 23, 26, 36, 38, 55, 57, 67, 69, 86, 88
20 first  6-esthetic numbers: 1, 2, 3, 4, 5, 6, 8, 13, 15, 20, 22, 27, 29, 34, 37, 49, 51, 78, 80, 92
20 first  7-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 9, 15, 17, 23, 25, 31, 33, 39, 41, 47, 50, 64, 66
20 first  8-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 10, 17, 19, 26, 28, 35, 37, 44, 46, 53, 55, 62
20 first  9-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 19, 21, 29, 31, 39, 41, 49, 51, 59, 61
20 first 10-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 12, 21, 23, 32, 34, 43, 45, 54, 56, 65
20 first 11-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 23, 25, 35, 37, 47, 49, 59, 61
20 first 12-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 14, 25, 27, 38, 40, 51, 53, 64
20 first 13-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 15, 27, 29, 41, 43, 55, 57
20 first 14-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 16, 29, 31, 44, 46, 59
20 first 15-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 17, 31, 33, 47, 49
20 first 16-esthetic numbers: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 18, 33, 35, 50

Base 10 esthetic numbers between 100,000,000 and 130,000,000:
101010101 101010121 101010123 101012101 101012121 101012123 101012321 101012323 101012343
101012345 101210101 101210121 101210123 101212101 101212121 101212123 101212321 101212323
101212343 101212345 101232101 101232121 101232123 101232321 101232323 101232343 101232345
101234321 101234323 101234343 101234345 101234543 101234545 101234565 101234567 121010101
121010121 121010123 121012101 121012121 121012123 121012321 121012323 121012343 121012345
121210101 121210121 121210123 121212101 121212121 121212123 121212321 121212323 121212343
121212345 121232101 121232121 121232123 121232321 121232323 121232343 121232345 121234321
121234323 121234343 121234345 121234543 121234545 121234565 121234567 123210101 123210121
123210123 123212101 123212121 123212123 123212321 123212323 123212343 123212345 123232101
123232121 123232123 123232321 123232323 123232343 123232345 123234321 123234323 123234343
123234345 123234543 123234545 123234565 123234567 123432101 123432121 123432123 123432321
123432323 123432343 123432345 123434321 123434323 123434343 123434345 123434543 123434545
123434565 123434567 123454321 123454323 123454343 123454345 123454543 123454545 123454565
123454567 123456543 123456545 123456565 123456567 123456765 123456767 123456787 123456789


================================================
FILE: Math/ethiopian_multiplication.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Derived: 13 July 2016
# Coded: 23 October 2016
# Website: https://github.com/trizen

# A derivation of the Ethiopian multiplication method (also known as "Russian multiplication").

# a*b = sum((floor(a * 2^(-k)) mod 2) * b*2^k, {k = 0, floor(log(a)/log(2))})

# See also:
#   https://mathworld.wolfram.com/RussianMultiplication.html

use 5.010;
use strict;
use warnings;

sub ethiopian_multiplication {
    my ($x, $y) = @_;

    my $r = 0;
    foreach my $k (0 .. log($x) / log(2)) {
        $r += (($x >> $k) % 2) * ($y << $k);
    }
    return $r;
}

say ethiopian_multiplication(3,  5);    #=>  15
say ethiopian_multiplication(7, 41);    #=> 287


================================================
FILE: Math/ethiopian_multiplication_binary.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Derived: 13 July 2016
# Coded: 23 October 2016
# Website: https://github.com/trizen

# A derivation of the Ethiopian multiplication method (also known as "Russian multiplication").

# a*b = sum((floor(a * 2^(-k)) mod 2) * b*2^k, {k = 0, floor(log(a)/log(2))})

# See also:
#   https://mathworld.wolfram.com/RussianMultiplication.html

use 5.010;
use strict;
use warnings;

use ntheory qw(hammingweight todigitstring);

sub ethiopian_multiplication {
    my ($x, $y) = @_;

    # We can swap "x" with "y" if "y" has a lower Hamming-weight value than "x".
    # This optimization reduces considerably the number of required additions.

    my $h1 = hammingweight($x);
    my $h2 = hammingweight($y);

    if ($h2 < $h1) {
        ($x, $y) = ($y, $x);
    }

    my @r;
    while ($x > 0) {

        if ($x & 1) {
            push @r, '0b' . todigitstring($y, 2);
        }

        $y <<= 1;
        $x >>= 1;
    }

    return join('+', @r);
}

say ethiopian_multiplication(3,  5);    #=>                  0b101+0b1010
say ethiopian_multiplication(63, 7);    #=> 0b111111+0b1111110+0b11111100


================================================
FILE: Math/even_fermat_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 February 2023
# https://github.com/trizen

# Generate all the k-omega even Fermat pseudoprimes in range [a,b]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# OEIS sequences:
#   https://oeis.org/A006935 -- Even pseudoprimes to base 2
#   https://oeis.org/A130433 -- Even pseudoprimes to base 3

# PARI/GP program:
#   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)));

# FIXME: it doesn't generate all the terms for bases > 2.

use 5.036;
use ntheory 0.74 qw(:all);

sub even_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    if ($k <= 1) {
        return;
    }

    $A = vecmax($A, pn_primorial($k));

    my %seen;
    my @list;

    sub ($m, $L, $lo, $j) {

        my $hi = rootint(divint($B, $m), $j);

        if ($lo > $hi) {
            return;
        }

        if ($j == 1) {

            if ($L == 1) {    # optimization
                foreach my $p (@{primes($lo, $hi)}) {

                    $base % $p == 0 and next;

                    for (my $v = $m * $p ; $v <= $B ; $v *= $p) {
                        $v >= $A or next;
                        $k == 1 and is_prime($v) and next;
                        powmod($base, $v, $v) == $base or next;
                        push(@list, $v) if !$seen{$v}++;
                    }
                }
                return;
            }

            my $t = invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime_power($p) and gcd($m, $p) == 1 and gcd($base, $p) == 1) {
                    my $v = $m * $p;
                    $v >= $A or next;
                    $k == 1 and is_prime($v) and next;

                    #($v - 1) % znorder($base, $p) == 0 or next;
                    powmod($base, $v, $v) == $base or next;
                    push(@list, $v) if !$seen{$v}++;
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $z = znorder($base, $p);
            gcd($m, $z) == 1 or next;
            my $l = lcm($L, $z);

            for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {

                if ($q > $p) {
                    powmod($base, $z, $q) == 1 or last;
                }

                __SUB__->($v, $l, $p + 1, $j - 1);
            }
        }
      }
      ->(2, 1, 3, $k - 1);

    return sort { $a <=> $b } @list;
}

# Generate all the even Fermat pseudoprimes to base 2 in range [1, 10^5]

my $from = 1;
my $upto = 1e7;
my $base = 2;

my @arr;
foreach my $k (1 .. 100) {
    last if pn_primorial($k) > $upto;
    push @arr, even_fermat_pseudoprimes_in_range($from, $upto, $k, $base);
}

say join(', ', sort { $a <=> $b } @arr);

__END__
161038, 215326, 2568226, 3020626, 7866046, 9115426


================================================
FILE: Math/even_squarefree_fermat_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 February 2023
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (in range):
#   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)));

# PARI/GP program (in range) (version 2):
#   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)));

# FIXME: it may not generate all the terms for bases > 2.

use 5.036;
use warnings;
use ntheory 0.74 qw(:all);

sub even_squarefree_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    if ($k <= 1) {
        return;
    }

    my @list;

    sub ($m, $L, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            my $t = invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime($p) and $base % $p != 0) {
                    if (($m * $p - 1) % znorder($base, $p) == 0) {
                        push(@list, $m * $p);
                    }
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $z = znorder($base, $p);
            gcd($m, $z) == 1 or next;

            __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1);
        }
      }
      ->(2, 1, 3, $k - 1);

    return sort { $a <=> $b } @list;
}

# Generate all the even squarefree Fermat pseudoprimes to base 2 with 5 prime factors in the range [100, 10^10]

my $k    = 5;
my $base = 2;
my $from = 100;
my $upto = 1e11;

my @arr = even_squarefree_fermat_pseudoprimes_in_range($from, $upto, $k, $base);
say join(', ', @arr);

__END__
209665666, 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


================================================
FILE: Math/exponential_divisors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 September 2023
# https://github.com/trizen

# Generate the exponential divisors (or e-divisors) of n.

# See also:
#   https://oeis.org/A051377
#   https://oeis.org/A322791

use 5.036;
use ntheory qw(:all);

sub exponential_divisors ($n) {

    my @d = (1);

    foreach my $pp (factor_exp($n)) {
        my ($p, $e) = @$pp;

        my @t;
        foreach my $k (divisors($e)) {
            my $r = powint($p, $k);
            push @t, map { mulint($r, $_) } @d;
        }
        @d = @t;
    }

    return sort { $a <=> $b } @d;
}

foreach my $n (1 .. 20) {
    my @edivisors = exponential_divisors($n);
    say "e-divisors of $n: [@edivisors]";
}

__END__
e-divisors of 1: [1]
e-divisors of 2: [2]
e-divisors of 3: [3]
e-divisors of 4: [2 4]
e-divisors of 5: [5]
e-divisors of 6: [6]
e-divisors of 7: [7]
e-divisors of 8: [2 8]
e-divisors of 9: [3 9]
e-divisors of 10: [10]
e-divisors of 11: [11]
e-divisors of 12: [6 12]
e-divisors of 13: [13]
e-divisors of 14: [14]
e-divisors of 15: [15]
e-divisors of 16: [2 4 16]
e-divisors of 17: [17]
e-divisors of 18: [6 18]
e-divisors of 19: [19]
e-divisors of 20: [10 20]


================================================
FILE: Math/factorial_difference_of_prime_squares.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 April 2026
# https://github.com/trizen

# An efficient algorithm for generating pairs of primes (p,q) such that n! = p^2 - q^2.

# Number of pairs of primes (p, q) such that n! = p^2 - q^2:
#   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));

# Least prime p such that p^2 - n! is the square of a prime:
#   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];

# Least prime q such that q^2 + n! is the square of a prime:
#   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];

use 5.036;
use Math::GMPz;
use Math::Prime::Util::GMP qw(
  sieve_primes factorial divisors vecprod
  is_euler_plumb_pseudoprime is_prob_prime
);

sub factorial_difference_of_prime_squares ($n) {

    # No prime pairs can exist for n < 4
    return () if $n < 4;

    my $N = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_fac_ui($N, $n);

    my $z = Math::GMPz::Rmpz_init();
    my $U = Math::GMPz::Rmpz_init();
    my $p = Math::GMPz::Rmpz_init();
    my $q = Math::GMPz::Rmpz_init();

    my @pairs;
    foreach my $d (divisors(vecprod(sieve_primes(3, $n)))) {

        # U = 2*gcd(d^n, n!) -- unitary divisor of n!
        Math::GMPz::Rmpz_set_str($U, "$d", 10);
        Math::GMPz::Rmpz_pow_ui($U, $U, $n);
        Math::GMPz::Rmpz_gcd($U, $U, $N);
        Math::GMPz::Rmpz_mul_2exp($U, $U, 1);

        # p = (n!/U + U)/2
        Math::GMPz::Rmpz_divexact($z, $N, $U);
        Math::GMPz::Rmpz_add($p, $z, $U);
        Math::GMPz::Rmpz_div_2exp($p, $p, 1);

        # q = |(n!/U - U)|/2
        Math::GMPz::Rmpz_sub($q, $z, $U);
        Math::GMPz::Rmpz_abs($q, $q);
        Math::GMPz::Rmpz_div_2exp($q, $q, 1);

        if (   is_euler_plumb_pseudoprime($p)
            && is_euler_plumb_pseudoprime($q)
            && is_prob_prime($q)
            && is_prob_prime($p)) {
            push @pairs, [Math::GMPz::Rmpz_init_set($p), Math::GMPz::Rmpz_init_set($q)];
        }
    }

    sort { $a->[0] <=> $b->[0] } @pairs;
}

foreach my $n (0 .. 30) {
    my @pairs = factorial_difference_of_prime_squares($n);

    # Check results
    my $factorial = Math::GMPz->new(factorial($n));
    $_->[0]**2 - $_->[1]**2 == $factorial or die "error" for @pairs;

    # Display results
    say "For $n!, there exists ", scalar(@pairs), " solutions:";
    say "$_->[0]^2 - $_->[1]^2" for @pairs;
    say '';
}

__END__
For 0!, there exists 0 solutions:

For 1!, there exists 0 solutions:

For 2!, there exists 0 solutions:

For 3!, there exists 0 solutions:

For 4!, there exists 1 solutions:
7^2 - 5^2

For 5!, there exists 3 solutions:
13^2 - 7^2
17^2 - 13^2
31^2 - 29^2

For 6!, there exists 3 solutions:
29^2 - 11^2
41^2 - 31^2
181^2 - 179^2

For 7!, there exists 3 solutions:
73^2 - 17^2
83^2 - 43^2
149^2 - 131^2

For 8!, there exists 4 solutions:
223^2 - 97^2
269^2 - 179^2
347^2 - 283^2
1447^2 - 1433^2

For 9!, there exists 2 solutions:
1201^2 - 1039^2
12967^2 - 12953^2

For 10!, there exists 2 solutions:
36313^2 - 36263^2
129607^2 - 129593^2

For 11!, there exists 2 solutions:
7109^2 - 3259^2
36563^2 - 36013^2

For 12!, there exists 3 solutions:
45341^2 - 39709^2
72101^2 - 68699^2
435731^2 - 435181^2

For 13!, there exists 3 solutions:
870517^2 - 866933^2
5661203^2 - 5660653^2
20217677^2 - 20217523^2

For 14!, there exists 4 solutions:
297377^2 - 35423^2
661949^2 - 592451^2
6099959^2 - 6092809^2
67060549^2 - 67059899^2

For 15!, there exists 5 solutions:
3240247^2 - 3031753^2
4185353^2 - 4026103^2
40776019^2 - 40759981^2
46663007^2 - 46648993^2
53380589^2 - 53368339^2

For 16!, there exists 2 solutions:
6847843^2 - 5096093^2
58136737^2 - 57956513^2

For 17!, there exists 5 solutions:
51948199^2 - 48403801^2
87861751^2 - 85813751^2
89713543^2 - 87708793^2
835084871^2 - 834871879^2
9704457163^2 - 9704438837^2

For 18!, there exists 3 solutions:
80015629^2 - 356621^2
163799983^2 - 142926767^2
456144379^2 - 449071621^2

For 19!, there exists 6 solutions:
390403049^2 - 175412201^2
908301613^2 - 838669613^2
1327887233^2 - 1281264767^2
2057302931^2 - 2027523181^2
18767444567^2 - 18764203433^2
14311188285517^2 - 14311188281267^2

For 20!, there exists 4 solutions:
1613360743^2 - 412348007^2
11195989613^2 - 11086806637^2
28754247503^2 - 28711911247^2
5453127791537^2 - 5453127568463^2

For 21!, there exists 4 solutions:
22511523371^2 - 21346609621^2
311875323841^2 - 311793403841^2
260407664689049^2 - 260407664590951^2
3385299640323773^2 - 3385299640316227^2

For 22!, there exists 5 solutions:
34121600333^2 - 6346879667^2
57095454341^2 - 46215691909^2
83676315727^2 - 76666323023^2
3430259922251^2 - 3430096082251^2
751383593333977^2 - 751383592586023^2

For 23!, there exists 11 solutions:
162109085183^2 - 20672173567^2
656267398957^2 - 636266361043^2
892205965993^2 - 877598694743^2
1266766081351^2 - 1256520707399^2
3401826685091^2 - 3398024834909^2
8680344828157^2 - 8678855588093^2
14656797059231^2 - 14655915120481^2
56312004691573^2 - 56311775148427^2
77105261510737^2 - 77105093869487^2
839781670416053^2 - 839781655023947^2
53413257724968960121^2 - 53413257724968959879^2

For 24!, there exists 9 solutions:
949484701001^2 - 530162989751^2
1834878431671^2 - 1657205617079^2
3607753595353^2 - 3520715495897^2
3764762240999^2 - 3681438079001^2
2240108389503221^2 - 2240108251016971^2
8303923486852687^2 - 8303923449493937^2
11378955886483363^2 - 11378955859220387^2
42562058088586199^2 - 42562058081297449^2
30515856862740485083^2 - 30515856862740474917^2

For 25!, there exists 9 solutions:
5056628950459^2 - 3171480143291^2
15547146353953^2 - 15040031572703^2
24829505058341^2 - 24515160847909^2
78216645569761^2 - 78117427211489^2
323315014757437^2 - 323291026101187^2
361050891430769^2 - 361029410149519^2
48825371059806643^2 - 48825370900962893^2
289270185997405469^2 - 289270185970594531^2
869657436831744004459^2 - 869657436831743995541^2

For 26!, there exists 5 solutions:
23744121396563^2 - 12668537396563^2
2420056766080999^2 - 2419973441919001^2
3076902436019147^2 - 3076836900019147^2
5286204571667072827^2 - 5286204571628927173^2
7521024835597405469^2 - 7521024835570594531^2

For 27!, there exists 6 solutions:
2760884016693079^2 - 2758911322275671^2
4373016330764051^2 - 4371771146764051^2
22393110528219359^2 - 22392867396999391^2
229834993220225567^2 - 229834969531774433^2
613526442325000909^2 - 613526433450999091^2
1298054391195579737777^2 - 1298054391195575543473^2

For 28!, there exists 8 solutions:
562608177258653^2 - 107887054397597^2
1538719341436099^2 - 1436234266092349^2
5857545513097433^2 - 5831462174566183^2
30609246539348357^2 - 30604265803348357^2
30749651390795191^2 - 30744693400826441^2
99357332502156361^2 - 99355798188125111^2
20795317161553348577^2 - 20795317154222651423^2
81191752107687936938791^2 - 81191752107687935061209^2

For 29!, there exists 10 solutions:
8107890641155673^2 - 7542952250624423^2
27713890446749977^2 - 27553910098218727^2
39950026854848041^2 - 39839212890183209^2
273496089503346041^2 - 273479924695814791^2
280729626197308811^2 - 280713877930691189^2
25398805484533309601^2 - 25398805310474690399^2
91320372584077338157^2 - 91320372535666661843^2
60280199575371812669429^2 - 60280199575371739330571^2
1760604331207163905255501^2 - 1760604331207163902744499^2
2459025884082733056898909^2 - 2459025884082733055101091^2

For 30!, there exists 12 solutions:
38041292277848569^2 - 34378584298317319^2
72475104448878283^2 - 70621440831121717^2
3339209683791654313^2 - 3339169965645376937^2
37741346736786394283^2 - 37741343222697800533^2
123050184466946838757^2 - 123050183389122932507^2
193289433625415493109^2 - 193289432939260913141^2
209816218817173808551^2 - 209816218185066191449^2
4825773025539501469937^2 - 4825773025512018530063^2
9044795471839217034017^2 - 9044795471824553747233^2
24368120467294881310207^2 - 24368120467289438689793^2
821653821267644252160080707^2 - 821653821267644252159919293^2
1624646959674835599360040817^2 - 1624646959674835599359959183^2


================================================
FILE: Math/factorial_dsc_algorithm.pl
================================================
#!/usr/bin/perl

# The DSC-Factorial algorithm (divide, swing and conquer), by Peter Luschny.

# See also:
#   https://oeis.org/A000142/a000142.pdf

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(forprimes);
use experimental qw(signatures);

sub Product ($s, $n, $m) {
    $n >  $m and return 1;
    $n == $m and return $s->[$n];
    my $k = ($n + $m) >> 1;
    Product($s, $n, $k) * Product($s, $k + 1, $m);
}

sub PrimeSwing($n) {
    my @factors;

    forprimes {
        my $prime = $_;
        my ($q, $p) = ($n, 1);

        while ($q > 0) {
            $q = int($q / $prime);
            $p *= $prime if ($q & 1);
        }

        push(@factors, Math::GMPz::Rmpz_init_set_ui($p)) if ($p > 1);
    } $n;

    Product(\@factors, 0, $#factors);
}

sub Factorial($n) {
    return 1 if ($n < 2);
    Factorial($n >> 1)**2 * PrimeSwing($n);
}

foreach my $n (0 .. 30) {
    say "$n! = ", Factorial($n);
}


================================================
FILE: Math/factorial_expansion_of_reciprocals.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 December 2018
# https://github.com/trizen

# Factorial expansion of reciprocals of natural numbers.

# For n>1, the length of the factorial expansion of 1/n is the n-th Kempner number `k`, such that:
#   1/n = Sum_{j=0..k} f(j) / j!

# See also:
#   https://oeis.org/A002034
#   https://oeis.org/A122416
#   https://en.wikipedia.org/wiki/Kempner_function

use 5.020;
use strict;
use warnings;

use ntheory qw(factor_exp);
use experimental qw(signatures);
use Math::AnyNum qw(sum factorial bsearch_le);

sub f ($n, $x) {
    return $x->floor if ($n == 0);
    ($x * factorial($n))->floor - (($x * factorial($n - 1))->floor * $n);
}

sub kempner_function ($n) {

    return 0 if ($n == 1);

    my @f = factor_exp($n);
    my $x = Math::AnyNum->new_q(1, $n);

    my $min = 2;
    my $max = $f[-1][0] * $f[-1][1];

    my %seen;

    for (; ;) {

        my $k = bsearch_le(
            $min, $max,
            sub {
                0 <=> f($_, $x);
            }
        );

        if ($seen{$k}++) {
            ++$min;
            ++$max;
        }

        if (   f($k + 0, $x) != 0
            or f($k + 1, $x) != 0
            or f($k + 2, $x) != 0
            or f($k + 3, $x) != 0
        ) {
            $min = $k + 1;
            next;
        }

        if (f($k - 1, $x) == 0) {
            $max = $k;
            next;
        }

        return $k - 1;
    }
}

foreach my $n (1 .. 50) {

    my $x = Math::AnyNum->new_q(1, $n);
    my $k = kempner_function($n);

    my @a = map { f($_, $x) } 0 .. $k;
    my $r = sum(map { $a[$_] / factorial($_) } 0 .. $k);

    say "F($r) = [", join(', ', @a), "]";
    die "error: $r != $x" if ($r != $x);
}

say "\n[2..100] Kempner numbers: ", join(', ', map { kempner_function($_) } 2 .. 100);

__END__
F(1) = [1]
F(1/2) = [0, 0, 1]
F(1/3) = [0, 0, 0, 2]
F(1/4) = [0, 0, 0, 1, 2]
F(1/5) = [0, 0, 0, 1, 0, 4]
F(1/6) = [0, 0, 0, 1]
F(1/7) = [0, 0, 0, 0, 3, 2, 0, 6]
F(1/8) = [0, 0, 0, 0, 3]
F(1/9) = [0, 0, 0, 0, 2, 3, 2]
F(1/10) = [0, 0, 0, 0, 2, 2]
F(1/11) = [0, 0, 0, 0, 2, 0, 5, 3, 1, 4, 0, 10]
F(1/12) = [0, 0, 0, 0, 2]
F(1/13) = [0, 0, 0, 0, 1, 4, 1, 2, 5, 4, 8, 5, 0, 12]
F(1/14) = [0, 0, 0, 0, 1, 3, 3, 3]
F(1/15) = [0, 0, 0, 0, 1, 3]
F(1/16) = [0, 0, 0, 0, 1, 2, 3]
F(1/17) = [0, 0, 0, 0, 1, 2, 0, 2, 3, 6, 8, 9, 0, 9, 2, 7, 0, 16]
F(1/18) = [0, 0, 0, 0, 1, 1, 4]
F(1/19) = [0, 0, 0, 0, 1, 1, 1, 6, 2, 0, 9, 5, 2, 6, 11, 11, 13, 8, 0, 18]
F(1/20) = [0, 0, 0, 0, 1, 1]
F(1/21) = [0, 0, 0, 0, 1, 0, 4, 2]
F(1/22) = [0, 0, 0, 0, 1, 0, 2, 5, 0, 6, 5, 5]
F(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]
F(1/24) = [0, 0, 0, 0, 1]
F(1/25) = [0, 0, 0, 0, 0, 4, 4, 5, 4, 7, 2]
F(1/26) = [0, 0, 0, 0, 0, 4, 3, 4, 6, 6, 9, 2, 6, 6]
F(1/27) = [0, 0, 0, 0, 0, 4, 2, 4, 5, 3]
F(1/28) = [0, 0, 0, 0, 0, 4, 1, 5]
F(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]
F(1/30) = [0, 0, 0, 0, 0, 4]
F(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]
F(1/32) = [0, 0, 0, 0, 0, 3, 4, 3, 4]
F(1/33) = [0, 0, 0, 0, 0, 3, 3, 5, 5, 7, 3, 7]
F(1/34) = [0, 0, 0, 0, 0, 3, 3, 1, 1, 7, 9, 4, 6, 4, 8, 3, 8, 8]
F(1/35) = [0, 0, 0, 0, 0, 3, 2, 4]
F(1/36) = [0, 0, 0, 0, 0, 3, 2]
F(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]
F(1/38) = [0, 0, 0, 0, 0, 3, 0, 6, 5, 0, 4, 8, 1, 3, 5, 13, 6, 12, 9, 9]
F(1/39) = [0, 0, 0, 0, 0, 3, 0, 3, 1, 7, 6, 1, 8, 4]
F(1/40) = [0, 0, 0, 0, 0, 3]
F(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]
F(1/42) = [0, 0, 0, 0, 0, 2, 5, 1]
F(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]
F(1/44) = [0, 0, 0, 0, 0, 2, 4, 2, 4, 3, 2, 8]
F(1/45) = [0, 0, 0, 0, 0, 2, 4]
F(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]
F(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]
F(1/48) = [0, 0, 0, 0, 0, 2, 3]
F(1/49) = [0, 0, 0, 0, 0, 2, 2, 4, 6, 7, 7, 1, 6, 11, 2]
F(1/50) = [0, 0, 0, 0, 0, 2, 2, 2, 6, 3, 6]

[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


================================================
FILE: Math/factorial_from_primes.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 18 July 2016
# Website: https://github.com/trizen

# A fast algorithm, based on powers of primes,
# for exactly computing very large factorials.

use 5.020;
use strict;
use warnings;

use Math::GMPz qw(:mpz);
use experimental qw(signatures);
use ntheory qw(forprimes todigits vecsum);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub factorial ($n) {

    my $t = Rmpz_init();
    my $f = Rmpz_init_set_ui(1);

    Rmpz_mul_2exp($f, $f, my $p = factorial_power($n, 2));

    forprimes {
        if ($p == 1) {
            Rmpz_mul_ui($f, $f, $_);
        }
        else {
            Rmpz_ui_pow_ui($t, $_, $p = factorial_power($n, $_));
            Rmpz_mul($f, $f, $t);
        }
    } 3, $n;

    $f;
}

say factorial($ARGV[0] // 1234);

for (0..10) {
    say factorial($_);
}


================================================
FILE: Math/factorial_from_primes_simple.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 18 July 2016
# Website: https://github.com/trizen

# A fast algorithm, based on powers of primes,
# for exactly computing very large factorials.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use ntheory qw(forprimes);
use Math::AnyNum qw(:overload sumdigits);

sub factorial_power ($n, $p) {
    ($n - sumdigits($n, $p)) / ($p - 1);
}

sub factorial ($n) {

    my $f = 1;

    forprimes {
        $f *= $_**factorial_power($n, $_);
    } $n;

    return $f;
}

for my $n (0 .. 50) {
    say "$n! = ", factorial($n);
}


================================================
FILE: Math/factorial_from_primorials.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 21 March 2019
# https://github.com/trizen

# 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!.

# Example for n = 10:
#   a(10) = 5040 = 2^4 * 3^2 * 5 * 7

# By mapping each prime factor `p` to `primorial(p)`, we get:
#
#   primorial(2)^4 * primorial(3)^2 * primorial(5) * primorial(7) = 10!
#
# where `primorial(p)` is the product of primes <= p.

# OEIS sequence by Allan C. Wechsler (Mar 20 2019):
#   https://oeis.org/A307035

# Efficient formula:
#   a(n) = a(n-1) * (A319626(n) / A319627(n))

use 5.020;
use strict;
use warnings;

use Memoize qw(memoize);
use experimental qw(signatures);
use ntheory qw(factor_exp prev_prime);
use Math::AnyNum qw(:overload ipow factorial primorial prod);

memoize('f');

sub g($n) {

    my $prod = 1;
    foreach my $pp (factor_exp($n)) {
        my ($p, $e) = @$pp;

        if ($p > 2) {
            $prod *= (Math::AnyNum->new($p) / prev_prime($p))**$e;
        }
        else {
            $prod *= ipow($p, $e);
        }
    }

    return $prod;
}

sub f($n) {
    return 1 if ($n <= 1);
    f($n - 1) * g($n);
}

sub isok ($n, $v) {
    prod(map { ipow(primorial($_->[0]), $_->[1]) } factor_exp($v)) == factorial($n);
}

foreach my $n (1 .. 100) {
    my $v = f($n);
    say "a($n) = $v = ", join(' * ', map { "$_->[0]^$_->[1]" } factor_exp($v));
    isok($n, $v) or die "error for $n";
}

__END__
a(1) = 1 =
a(2) = 2 = 2^1
a(3) = 3 = 3^1
a(4) = 12 = 2^2 * 3^1
a(5) = 20 = 2^2 * 5^1
a(6) = 60 = 2^2 * 3^1 * 5^1
a(7) = 84 = 2^2 * 3^1 * 7^1
a(8) = 672 = 2^5 * 3^1 * 7^1
a(9) = 1512 = 2^3 * 3^3 * 7^1
a(10) = 5040 = 2^4 * 3^2 * 5^1 * 7^1
a(11) = 7920 = 2^4 * 3^2 * 5^1 * 11^1
a(12) = 47520 = 2^5 * 3^3 * 5^1 * 11^1
a(13) = 56160 = 2^5 * 3^3 * 5^1 * 13^1
a(14) = 157248 = 2^6 * 3^3 * 7^1 * 13^1
a(15) = 393120 = 2^5 * 3^3 * 5^1 * 7^1 * 13^1
a(16) = 6289920 = 2^9 * 3^3 * 5^1 * 7^1 * 13^1
a(17) = 8225280 = 2^9 * 3^3 * 5^1 * 7^1 * 17^1
a(18) = 37013760 = 2^8 * 3^5 * 5^1 * 7^1 * 17^1
a(19) = 41368320 = 2^8 * 3^5 * 5^1 * 7^1 * 19^1
a(20) = 275788800 = 2^10 * 3^4 * 5^2 * 7^1 * 19^1
a(21) = 579156480 = 2^9 * 3^5 * 5^1 * 7^2 * 19^1
a(22) = 1820206080 = 2^10 * 3^5 * 5^1 * 7^1 * 11^1 * 19^1
a(23) = 2203407360 = 2^10 * 3^5 * 5^1 * 7^1 * 11^1 * 23^1
a(24) = 26440888320 = 2^12 * 3^6 * 5^1 * 7^1 * 11^1 * 23^1
a(25) = 73446912000 = 2^12 * 3^4 * 5^3 * 7^1 * 11^1 * 23^1
a(26) = 173601792000 = 2^13 * 3^4 * 5^3 * 7^1 * 13^1 * 23^1
a(27) = 585906048000 = 2^10 * 3^7 * 5^3 * 7^1 * 13^1 * 23^1
a(28) = 3281073868800 = 2^12 * 3^7 * 5^2 * 7^2 * 13^1 * 23^1
a(29) = 4137006182400 = 2^12 * 3^7 * 5^2 * 7^2 * 13^1 * 29^1
a(30) = 20685030912000 = 2^12 * 3^7 * 5^3 * 7^2 * 13^1 * 29^1
a(31) = 22111584768000 = 2^12 * 3^7 * 5^3 * 7^2 * 13^1 * 31^1
a(32) = 707570712576000 = 2^17 * 3^7 * 5^3 * 7^2 * 13^1 * 31^1
a(33) = 1667845251072000 = 2^16 * 3^8 * 5^3 * 7^1 * 11^1 * 13^1 * 31^1
a(34) = 4362056810496000 = 2^17 * 3^8 * 5^3 * 7^1 * 11^1 * 17^1 * 31^1
a(35) = 10178132557824000 = 2^17 * 3^7 * 5^3 * 7^2 * 11^1 * 17^1 * 31^1
a(36) = 91603193020416000 = 2^17 * 3^9 * 5^3 * 7^2 * 11^1 * 17^1 * 31^1
a(37) = 109332843282432000 = 2^17 * 3^9 * 5^3 * 7^2 * 11^1 * 17^1 * 37^1
a(38) = 244391061454848000 = 2^18 * 3^9 * 5^3 * 7^2 * 11^1 * 19^1 * 37^1
a(39) = 433238699851776000 = 2^17 * 3^10 * 5^3 * 7^2 * 13^1 * 19^1 * 37^1
a(40) = 5776515998023680000 = 2^20 * 3^9 * 5^4 * 7^2 * 13^1 * 19^1 * 37^1
a(41) = 6401004214026240000 = 2^20 * 3^9 * 5^4 * 7^2 * 13^1 * 19^1 * 41^1
a(42) = 26884217698910208000 = 2^20 * 3^10 * 5^3 * 7^3 * 13^1 * 19^1 * 41^1
a(43) = 28195642952515584000 = 2^20 * 3^10 * 5^3 * 7^3 * 13^1 * 19^1 * 43^1
a(44) = 177229755701526528000 = 2^22 * 3^10 * 5^3 * 7^2 * 11^1 * 13^1 * 19^1 * 43^1
a(45) = 664611583880724480000 = 2^20 * 3^11 * 5^4 * 7^2 * 11^1 * 13^1 * 19^1 * 43^1
a(46) = 1609059624132280320000 = 2^21 * 3^11 * 5^4 * 7^2 * 11^1 * 13^1 * 23^1 * 43^1
a(47) = 1758739589167841280000 = 2^21 * 3^11 * 5^4 * 7^2 * 11^1 * 13^1 * 23^1 * 47^1
a(48) = 42209750140028190720000 = 2^24 * 3^12 * 5^4 * 7^2 * 11^1 * 13^1 * 23^1 * 47^1
a(49) = 82731110274455253811200 = 2^24 * 3^12 * 5^2 * 7^4 * 11^1 * 13^1 * 23^1 * 47^1
a(50) = 459617279302529187840000 = 2^25 * 3^10 * 5^4 * 7^4 * 11^1 * 13^1 * 23^1 * 47^1
a(51) = 901556970939576483840000 = 2^24 * 3^11 * 5^4 * 7^4 * 11^1 * 17^1 * 23^1 * 47^1
a(52) = 4261905680805270650880000 = 2^26 * 3^11 * 5^4 * 7^4 * 13^1 * 17^1 * 23^1 * 47^1
a(53) = 4805978746439986053120000 = 2^26 * 3^11 * 5^4 * 7^4 * 13^1 * 17^1 * 23^1 * 53^1
a(54) = 32440356538469905858560000 = 2^24 * 3^14 * 5^4 * 7^4 * 13^1 * 17^1 * 23^1 * 53^1
a(55) = 84962838553135467724800000 = 2^24 * 3^13 * 5^5 * 7^3 * 11^1 * 13^1 * 17^1 * 23^1 * 53^1
a(56) = 951583791795117238517760000 = 2^27 * 3^13 * 5^4 * 7^4 * 11^1 * 13^1 * 17^1 * 23^1 * 53^1
a(57) = 1595302239185931841044480000 = 2^26 * 3^14 * 5^4 * 7^4 * 11^1 * 13^1 * 19^1 * 23^1 * 53^1
a(58) = 4022936081425393338286080000 = 2^27 * 3^14 * 5^4 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 53^1
a(59) = 4478362807624494470922240000 = 2^27 * 3^14 * 5^4 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 59^1
a(60) = 44783628076244944709222400000 = 2^28 * 3^14 * 5^5 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 59^1
a(61) = 46301717163575281818009600000 = 2^28 * 3^14 * 5^5 * 7^4 * 11^1 * 13^1 * 19^1 * 29^1 * 61^1
a(62) = 98989878073850602507468800000 = 2^29 * 3^14 * 5^5 * 7^4 * 11^1 * 13^1 * 19^1 * 31^1 * 61^1
a(63) = 311818115932629397898526720000 = 2^27 * 3^16 * 5^4 * 7^5 * 11^1 * 13^1 * 19^1 * 31^1 * 61^1
a(64) = 19956359419688281465505710080000 = 2^33 * 3^16 * 5^4 * 7^5 * 11^1 * 13^1 * 19^1 * 31^1 * 61^1
a(65) = 39307980675143584704783974400000 = 2^33 * 3^15 * 5^5 * 7^5 * 13^2 * 19^1 * 31^1 * 61^1
a(66) = 185309051754248327893981593600000 = 2^33 * 3^16 * 5^5 * 7^4 * 11^1 * 13^2 * 19^1 * 31^1 * 61^1
a(67) = 203536171598928491293389619200000 = 2^33 * 3^16 * 5^5 * 7^4 * 11^1 * 13^2 * 19^1 * 31^1 * 67^1
a(68) = 1064650743748241339073114931200000 = 2^35 * 3^16 * 5^5 * 7^4 * 11^1 * 13^1 * 17^1 * 19^1 * 31^1 * 67^1
a(69) = 1933181613648122431474866585600000 = 2^34 * 3^17 * 5^5 * 7^4 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 67^1
a(70) = 9021514197024571346882710732800000 = 2^35 * 3^16 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 67^1
a(71) = 9560112059533500979532424806400000 = 2^35 * 3^16 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 71^1
a(72) = 172082017071603017631583646515200000 = 2^36 * 3^18 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 71^1
a(73) = 176929397834183384325431073177600000 = 2^36 * 3^18 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 31^1 * 73^1
a(74) = 422347594829986143228448368230400000 = 2^37 * 3^18 * 5^5 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 37^1 * 73^1
a(75) = 1759781645124942263451868200960000000 = 2^36 * 3^17 * 5^7 * 7^5 * 11^1 * 13^1 * 17^1 * 23^1 * 37^1 * 73^1
a(76) = 7867259119382094824843646074880000000 = 2^38 * 3^17 * 5^7 * 7^5 * 11^1 * 13^1 * 19^1 * 23^1 * 37^1 * 73^1
a(77) = 17307970062640608614656021364736000000 = 2^38 * 3^17 * 5^6 * 7^5 * 11^2 * 13^1 * 19^1 * 23^1 * 37^1 * 73^1
a(78) = 61364621131180339633780439384064000000 = 2^38 * 3^18 * 5^6 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 73^1
a(79) = 66408288621414340151625407004672000000 = 2^38 * 3^18 * 5^6 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 79^1
a(80) = 1770887696571049070710010853457920000000 = 2^42 * 3^17 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 79^1
a(81) = 8965118963890935920469429945630720000000 = 2^38 * 3^21 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 37^1 * 79^1
a(82) = 19868642028082614742661979879505920000000 = 2^39 * 3^21 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 41^1 * 79^1
a(83) = 20874649219377937008113219367075840000000 = 2^39 * 3^21 * 5^7 * 7^5 * 11^1 * 13^2 * 19^1 * 23^1 * 41^1 * 83^1
a(84) = 175347053442774670868151042683437056000000 = 2^40 * 3^22 * 5^6 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 41^1 * 83^1
a(85) = 382166654939380692917765093028003840000000 = 2^40 * 3^21 * 5^7 * 7^6 * 11^1 * 13^1 * 17^1 * 19^1 * 23^1 * 41^1 * 83^1
a(86) = 801617861580164380266531658546544640000000 = 2^41 * 3^21 * 5^7 * 7^6 * 11^1 * 13^1 * 17^1 * 19^1 * 23^1 * 43^1 * 83^1
a(87) = 1516103346901615240938875093338030080000000 = 2^40 * 3^22 * 5^7 * 7^6 * 11^1 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 83^1
a(88) = 19059584932477448743231572601963806720000000 = 2^43 * 3^22 * 5^7 * 7^5 * 11^2 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 83^1
a(89) = 20437386252897505278886867006925045760000000 = 2^43 * 3^22 * 5^7 * 7^5 * 11^2 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 89^1
a(90) = 153280396896731289591651502551937843200000000 = 2^42 * 3^23 * 5^8 * 7^5 * 11^2 * 13^1 * 17^1 * 19^1 * 29^1 * 43^1 * 89^1
a(91) = 253609383956409951869823395131388067840000000 = 2^42 * 3^23 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 19^1 * 29^1 * 43^1 * 89^1
a(92) = 1228003332841563977474934334320405381120000000 = 2^44 * 3^23 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 23^1 * 29^1 * 43^1 * 89^1
a(93) = 1969039826797680170778774018824098283520000000 = 2^43 * 3^24 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 23^1 * 31^1 * 43^1 * 89^1
a(94) = 4304412644627486884958250180685238108160000000 = 2^44 * 3^24 * 5^7 * 7^6 * 11^1 * 13^2 * 17^1 * 23^1 * 31^1 * 47^1 * 89^1
a(95) = 8018023553717867726883015042452894515200000000 = 2^44 * 3^23 * 5^8 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 89^1
a(96) = 384865130578457650890384722037738936729600000000 = 2^48 * 3^24 * 5^8 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 89^1
a(97) = 419459749057420136363677730760232324300800000000 = 2^48 * 3^24 * 5^8 * 7^6 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1
a(98) = 1644282216305086934545616704580110711259136000000 = 2^49 * 3^24 * 5^6 * 7^8 * 11^1 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1
a(99) = 5813712121935843090000573348336820014809088000000 = 2^47 * 3^26 * 5^6 * 7^7 * 11^2 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1
a(100) = 64596801354842701000006370537075777942323200000000 = 2^49 * 3^24 * 5^8 * 7^7 * 11^2 * 13^2 * 19^1 * 23^1 * 31^1 * 47^1 * 97^1


================================================
FILE: Math/factorial_from_trinomial_coefficients.pl
================================================
#!/usr/bin/perl

# An efficient algorithm for computing n! using trinomial coefficients.

# See also:
#   https://oeis.org/A056040
#   https://oeis.org/A000142/a000142.pdf

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use experimental qw(signatures);

sub trinomial ($m, $n, $o) {

    my $prod = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_bin_uiui($prod, $m + $n + $o, $o);

    if ($n) {
        my $t = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_bin_uiui($t, $m + $n, $n);
        Math::GMPz::Rmpz_mul($prod, $prod, $t);
    }

    return $prod;
}

sub Factorial($n) {
    return 1 if ($n < 2);
    Factorial($n >> 1)**2 * trinomial($n >> 1, $n % 2, $n >> 1);
}

foreach my $n (0 .. 30) {
    say "$n! = ", Factorial($n);
}


================================================
FILE: Math/factorial_in_half_steps.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 22 August 2015
# Website: https://github.com/trizen

# A new algorithm to compute n! in int(n/2) iterations, instead of n.

use 5.010;
use strict;
use warnings;

#----------------------------------------------
## The algorithm
#----------------------------------------------
# 6! = 1 * 2 * 3 * 4 * 5 * 6
#
#    = 1*6 * 2*5 * 3*4
#    =   6 *  10 *  12
#
#    = (7*1 - 1^2) * (7*2 - 2^2) * (7*3 - 3^2)
#    =     1*(7-1) *     2*(7-2) *     3*(7-3)
#----------------------------------------------

sub factorial {
    my ($n) = @_;

    use integer;

    my $p = 1;
    my $d = $n / 2;
    my $m = $n % 2;
    my $k = $n + 1;

    foreach my $i (1 .. $d) {
        $p *= $i * ($k - $i);
    }

    $m ? $p * ($k / 2) : $p;
}

foreach my $i (1 .. 15) {
    say "$i! = ", factorial($i);
}


================================================
FILE: Math/factorions_in_base_n.pl
================================================
#!/usr/bin/perl

# Find all the factorions in base n.

# See also:
#   https://oeis.org/A193163
#   https://rosettacode.org/wiki/Factorions

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);
use Algorithm::Combinatorics qw(combinations_with_repetition);

sub max_power ($base = 10) {
    my $m = 1;
    my $f = factorial($base-1);
    while ($m * $f >= $base**($m-1)) {
        $m += 1;
    }
    return $m-1;
}

sub factorions ($base = 10) {

    my @result;
    my @digits    = (0 .. $base-1);
    my @factorial = map { factorial($_) } @digits;

    foreach my $k (1 .. max_power($base)) {
        my $iter = combinations_with_repetition(\@digits, $k);
        while (my $comb = $iter->next) {
            my $n = vecsum(map { $factorial[$_] } @$comb);
            if (join(' ', sort { $a <=> $b } todigits($n, $base)) eq join(' ', @$comb)) {
                push @result, $n;
            }
        }
    }

    return @result;
}

foreach my $base (2 .. 14) {
    my @r = factorions($base);
    say "Factorions in base $base are (@r)";
}

__END__
Factorions in base 2 are (1 2)
Factorions in base 3 are (1 2)
Factorions in base 4 are (1 2 7)
Factorions in base 5 are (1 2 49)
Factorions in base 6 are (1 2 25 26)
Factorions in base 7 are (1 2)
Factorions in base 8 are (1 2)
Factorions in base 9 are (1 2 41282)
Factorions in base 10 are (1 2 145 40585)
Factorions in base 11 are (1 2 26 48 40472)
Factorions in base 12 are (1 2)
Factorions in base 13 are (1 2 519326767)
Factorions in base 14 are (1 2 12973363226)


================================================
FILE: Math/factorization_with_difference_of_prime_factors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 August 2017
# https://github.com/trizen

# Theorem:
#   If the absolute difference between the prime factors of a
#   semiprime `n` is known, then `n` can be factored in polynomial time.

# For example:
#   n = 97 * 43
#   n = 4171
#
#   d = 97 - 43
#   d = 54

# Then the factors of `n` are:
#   43 = abs((-54 + sqrt(54^2 + 4*4171)) / 2)
#   97 = abs((-54 - sqrt(54^2 + 4*4171)) / 2)

# In general:
#   n = p * q
#   d = abs(p - q)

# From which `n` can be factored as:
#   n = abs((-d + sqrt(d^2 + 4*n)) / 2) *
#       abs((-d - sqrt(d^2 + 4*n)) / 2)
#

# Based on the following quadratic equation:
#   x^2 + (a - b)*x - a*b = 0
#
# which has the solutions:
#   x₁ = -a
#   x₂ = +b

use 5.010;
use strict;
use warnings;

use ntheory qw(random_nbit_prime);
use Math::AnyNum qw(:overload isqrt);

my $p = Math::AnyNum->new(random_nbit_prime(100));
my $q = Math::AnyNum->new(random_nbit_prime(100));

my $d = abs($p - $q);
my $n = $p * $q;

say "n = $p * $q";
say "d = $d";

sub integer_quadratic_formula {
    my ($x, $y, $z) = @_;

    (
        ((-$y + isqrt($y**2 - 4 * $x * $z)) / (2 * $x)),
        ((-$y - isqrt($y**2 - 4 * $x * $z)) / (2 * $x)),
    );
}

my ($x1, $x2) = integer_quadratic_formula(1, $d, -$n);

printf("n = %s * %s\n", abs($x1), abs($x2));

if (abs($x1) * abs($x2) != $n) {
    die "error: $x1 * $x2 != $n\n";
}


================================================
FILE: Math/farey_rational_approximation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 February 2018
# https://github.com/trizen

# Farey rational approximation of a real number.

# See also:
#   https://en.wikipedia.org/wiki/Farey_sequence
#   https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload pi);

sub farey_approximation ($r, $eps = 1e-48) {

    my ($a, $b, $c, $d) = (0, 1, 1, 0);

    while (1) {
        my $m = ($a + $c) / ($b + $d);

        if ($m < $r) {
            ($a, $b) = $m->nude;
        }
        elsif ($m > $r) {
            ($c, $d) = $m->nude;
        }
        else {
            return $m;
        }

        if (abs($r - $m) <= $eps) {
            return $m;
        }
    }
}

say farey_approximation(pi);            #=> 2857198258041217165097342/909474452321624805685313
say farey_approximation(sqrt(2));       #=> 1572584048032918633353217/1111984844349868137938112


================================================
FILE: Math/faulhaber_s_formula.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 03 September 2015
# Website: https://github.com/trizen

# The formula for calculating the sum of consecutive
# numbers raised to a given power, such as:
#    1^p + 2^p + 3^p + ... + n^p
# where p is a positive integer.

# See also: https://en.wikipedia.org/wiki/Faulhaber%27s_formula

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload binomial);

# This function returns the nth Bernoulli number
# See: https://en.wikipedia.org/wiki/Bernoulli_number
sub bernoulli_number {
    my ($n) = @_;

    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1

    my @A;
    for my $m (0 .. $n) {
        $A[$m] = 1 / ($m + 1);

        for (my $j = $m ; $j > 0 ; $j--) {
            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);
        }
    }

    return $A[0];                    # which is Bn
}

# The Faulhaber's formula
# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula
sub faulhaber_s_formula {
    my ($p, $n) = @_;

    my $sum = 0;
    for my $j (0 .. $p) {
        $sum += binomial($p + 1, $j) * bernoulli_number($j) * ($n + 1)**($p + 1 - $j);
    }

    $sum / ($p + 1);
}

# Alternate expression using Bernoulli polynomials
# See: https://en.wikipedia.org/wiki/Faulhaber%27s_formula#Alternate_expressions
sub bernoulli_polynomials {
    my ($n, $x) = @_;

    my $sum = 0;
    for my $k (0 .. $n) {
        $sum += binomial($n, $k) * bernoulli_number($n - $k) * $x**$k;
    }

    $sum;
}

sub faulhaber_s_formula_2 {
    my ($p, $n) = @_;
    1 + (bernoulli_polynomials($p + 1, $n + 1) - bernoulli_polynomials($p + 1, 1)) / ($p + 1);
}

# Test for 1^4 + 2^4 + 3^4 + ... + 10^4
foreach my $i (0 .. 10) {
    say "$i: ", faulhaber_s_formula(4, $i);
    say "$i: ", faulhaber_s_formula_2(4, $i);
}


================================================
FILE: Math/fermat_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 March 2018
# https://github.com/trizen

# A simple implementation of Fermat's factorization method.

# See also:
#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use ntheory qw(is_prime vecprod);
use Math::AnyNum qw(:overload isqrt is_square valuation);

sub fermat_factorization ($n) {

    # Check for primes and negative numbers
    return ()   if ($n <= 1);
    return ($n) if is_prime($n);

    # Check for divisibility by 2
    if (!($n & 1)) {
        my $v = valuation($n, 2);
        return ((2) x $v, __SUB__->($n >> $v));
    }

    my $q = 2 * isqrt($n);

    while (!is_square($q * $q - 4 * $n)) {
        $q += 2;
    }

    my $p = ($q + isqrt($q * $q - 4 * $n)) >> 1;

    return sort { $a <=> $b } (
        __SUB__->($p),
        __SUB__->($n / $p),
    );
}

foreach my $n (160587846247027, 5040, 65127835124, 6469693230) {

    my @f = fermat_factorization($n);
    say join(' * ', @f), " = $n";

    die 'error' if vecprod(@f) != $n;
}


================================================
FILE: Math/fermat_factorization_method_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 13 September 2017
# https://github.com/trizen

# Fermat's factorization method.

# Theorem:
#   If the absolute difference between the prime factors of a
#   semiprime `n` is known, then `n` can be factored in polynomial time.

# Based on the following quadratic equation:
#   x^2 + (a - b)*x - a*b = 0
#
# which has the solutions:
#   x₁ = -a
#   x₂ = +b

# See also:
#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(vecprod sqrtint is_prime is_square valuation);

sub fermat_factorization ($n) {

    # Check for primes and negative numbers
    return ()   if ($n <= 1);
    return ($n) if is_prime($n);

    # Check for divisibility by 2
    if (!($n & 1)) {
        my $v = valuation($n, 2);
        return ((2) x $v, __SUB__->($n >> $v));
    }

    my $p = sqrtint($n);
    my $q = $p * $p - $n;

    until (is_square($q)) {
        $q += 2 * $p++ + 1;
    }

    my $s = sqrtint($q);

    my ($x1, $x2) = (
        ($p + $s),
        ($p - $s),
    );

    return sort { $a <=> $b } (
        __SUB__->($x1),
        __SUB__->($x2)
    );
}

foreach my $n (160587846247027, 5040, 65127835124, 6469693230) {

    my @f = fermat_factorization($n);
    say join(' * ', @f), " = $n";

    die 'error' if vecprod(@f) != $n;
}


================================================
FILE: Math/fermat_frobenius_quadratic_primality_test.pl
================================================
#!/usr/bin/perl

# A very strong primality test, with no counter-examples known.

# Similar to the Baillie–PSW primality test, but instead of performing a Lucas test, we perform a Frobenius quadratic test.

# Given an odd integer n, that is not a perfect power:
#   1. Perform a base-2 Fermat test.
#   2. Find the first D in the sequence 5, −7, 9, −11, 13, −15, ... for which the Jacobi symbol (D/n) is −1.
#      Set P = 1 and Q = (1 − D) / 4.
#   3. Perform a Frobenius quadratic test with x^2-Px+Q.

# See also:
#   https://oeis.org/A212424
#   https://en.wikipedia.org/wiki/Frobenius_pseudoprime
#   https://en.wikipedia.org/wiki/Quadratic_Frobenius_test
#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test

use 5.020;
use warnings;

use experimental qw(signatures);

use ntheory qw(
    kronecker is_power is_prime
    is_frobenius_pseudoprime powmod
);

sub strong_frobenius_primality_test ($n) {

    return 0 if ($n <= 1);
    return 1 if ($n == 2);
    return 0 if is_power($n);

    powmod(2, $n - 1, $n) == 1 or return 0;

    my ($P, $Q) = (1, 0);

    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);

        if (kronecker($D, $n) == -1) {
            $Q = (1 - $D) / 4;
            last;
        }
    }

    is_frobenius_pseudoprime($n, $P, $Q);
}

my $count = 0;
foreach my $n (1 .. 1e6) {
    if (strong_frobenius_primality_test($n)) {
        if (not is_prime($n)) {
            say "Counter-example: $n";
        }
        ++$count;
    }
    elsif (is_prime($n)) {
        say "Missed a prime: $n";
    }
}

say "There are $count primes below 10^6";


================================================
FILE: Math/fermat_overpseudoprimes_generation.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 28 January 2019
# Edit: 12 November 2022
# https://github.com/trizen

# A new algorithm for generating Fermat overpseudoprimes to multiple bases.

# See also:
#   https://oeis.org/A141232 -- Overpseudoprimes to base 2: composite k such that k = A137576((k-1)/2).
#   https://oeis.org/A140658 -- Overpseudoprimes to bases 2 and 3.

# See also:
#   https://en.wikipedia.org/wiki/Fermat_pseudoprime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);

sub fermat_overpseudoprimes ($bases, $prime_limit, $callback) {

    my %common_divisors;
    my $bases_lcm = lcm(@$bases);

    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {
        next if ($bases_lcm % $p == 0);
        my @orders = map { znorder($_, $p) } @$bases;
        my $sig    = join(' ', @orders);
        push @{$common_divisors{$sig}}, $p;
    }

    my %seen;

    foreach my $arr (values %common_divisors) {

        my $l = scalar(@$arr);

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = vecprod(@{$arr}[@_]);
                $callback->($n) if !$seen{$n}++;
            } $l, $k;
        }
    }
}

my @pseudoprimes;

my @bases       = (2, 3);    # generate overpseudoprime to these bases
my $prime_limit = 1e5;       # sieve primes up to this limit

fermat_overpseudoprimes(
    \@bases,                 # bases
    $prime_limit,            # prime limit
    sub ($n) {
        push @pseudoprimes, $n;
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
5173601, 13694761, 16070429, 27509653, 54029741, 66096253, 102690677, 117987841, 193949641, 206304961, 314184487, 390612221, 393611653, 717653129, 960946321, 1157839381, 1236313501, 1921309633, 2217879901, 2412172153, 2626783921, 4710862501


================================================
FILE: Math/fermat_overpseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 06 September 2022
# https://github.com/trizen

# Generate all the k-omega Fermat overpseudoprimes to a given base in a given range [a,b]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use ntheory 0.74 qw(:all);
use Memoize      qw(memoize);

memoize('inverse_znorder_primes');

sub inverse_znorder_primes ($base, $lambda) {
    my %seen;
    grep { !$seen{$_}++ } factor(subint(powint($base, $lambda), 1));
}

sub iterate_over_primes ($x, $y, $base, $lambda, $callback) {

    if ($lambda > 1 and $lambda <= 100) {
        foreach my $p (inverse_znorder_primes($base, $lambda)) {

            next if $p < $x;
            last if $p > $y;

            znorder($base, $p) == $lambda or next;

            $callback->($p);
        }
        return;
    }

    if ($lambda > 1) {
        for (my $w = $lambda * cdivint($x - 1, $lambda) ; $w <= $y ; $w += $lambda) {
            if (is_prime($w + 1) and powmod($base, $lambda, $w + 1) == 1) {
                $callback->($w + 1);
            }
        }
        return;
    }

    for (my $p = (is_prime($x) ? $x : next_prime($x)) ; $p <= $y ; $p = next_prime($p)) {
        $callback->($p);
    }
}

sub fermat_overpseudoprimes_in_range ($A, $B, $k, $base, $callback) {

    $A = vecmax($A, pn_primorial($k));

    my $F;
    $F = sub ($m, $lambda, $lo, $j) {

        my $hi = rootint(divint($B, $m), $j);

        $lo > $hi and return;

        iterate_over_primes($lo, $hi, $base, $lambda, sub ($p) {
            if ($base % $p != 0) {

                for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {

                    my $z = znorder($base, $q);
                    if ($lambda > 1) {
                        $lambda == $z or last;
                    }
                    gcd($v, $z) == 1 or last;

                    if ($j == 1) {
                        $v >= $A or next;
                        $k == 1 and is_prime($v) and next;
                        ($v - 1) % $z == 0 or next;
                        $callback->($v);
                        next;
                    }

                    $F->($v, $z, $p + 1, $j - 1);
                }
            }
        });
    };

    $F->(1, 1, 2, $k);
    undef $F;
}

# Generate all the Fermat overpseudoprimes to base 2 in the range [1, 1325843]

my $from = 1;
my $upto = 1325843;
my $base = 2;

my @arr;
foreach my $k (1 .. 100) {
    last if pn_primorial($k) > $upto;
    fermat_overpseudoprimes_in_range($from, $upto, $k, $base, sub ($n) { push @arr, $n });
}

say join(', ', sort { $a <=> $b } @arr);

__END__
2047, 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


================================================
FILE: Math/fermat_pseudoprimes_from_multiple.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2023
# https://github.com/trizen

# Generate Fermat pseudoprimes from a given multiple, to a given base.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use ntheory qw(:all);

sub fermat_pseudoprimes_from_multiple ($base, $m, $callback) {

    my $L = znorder($base, $m);
    my $v = invmod($m, $L) // return;

    for (my $p = $v ; ; $p += $L) {
        if (is_pseudoprime($m * $p, $base)) {
            $callback->($m * $p);
        }
    }
}

fermat_pseudoprimes_from_multiple(2, 341, sub ($n) { say $n });


================================================
FILE: Math/fermat_pseudoprimes_from_multiple_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2023
# https://github.com/trizen

# Generate Fermat pseudoprimes from a given multiple, to a given base.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub fermat_pseudoprimes_from_multiple ($base, $m, $callback) {

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();
    my $w = Math::GMPz::Rmpz_init_set_ui($base);

    my $L = znorder($base, $m);

    $m = Math::GMPz->new("$m");
    $L = Math::GMPz->new("$L");

    Math::GMPz::Rmpz_invert($v, $m, $L) || return;

    for (my $p = Math::GMPz::Rmpz_init_set($v) ; ; Math::GMPz::Rmpz_add($p, $p, $L)) {

        Math::GMPz::Rmpz_mul($v, $m, $p);
        Math::GMPz::Rmpz_sub_ui($u, $v, 1);
        Math::GMPz::Rmpz_powm($u, $w, $u, $v);

        if (Math::GMPz::Rmpz_cmp_ui($u, 1) == 0) {
            $callback->(Math::GMPz::Rmpz_init_set($v));
        }
    }
}

fermat_pseudoprimes_from_multiple(2, 341, sub ($n) { say $n });


================================================
FILE: Math/fermat_pseudoprimes_generation.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 06 May 2022
# Edit: 12 November 2022
# https://github.com/trizen

# A new algorithm for generating Fermat pseudoprimes to multiple bases.

# See also:
#   https://oeis.org/A001567 -- Fermat pseudoprimes to base 2, also called Sarrus numbers or Poulet numbers.
#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.

# See also:
#   https://en.wikipedia.org/wiki/Fermat_pseudoprime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);

sub fermat_pseudoprimes ($bases, $pm1_multiple, $prime_limit, $callback) {

    my %common_divisors;
    my $bases_lcm = lcm(@$bases);

    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {
        next if ($bases_lcm % $p == 0);
        my @orders = map { znorder($_, $p) } @$bases;
        for my $d (divisors($pm1_multiple * ($p - 1))) {
            if (vecall { $d % $_ == 0 } @orders) {
                push @{$common_divisors{$d}}, $p;
            }
        }
    }

    my %seen;

    foreach my $arr (values %common_divisors) {

        my $l = scalar(@$arr);

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = vecprod(@{$arr}[@_]);
                $callback->($n) if !$seen{$n}++;
            } $l, $k;
        }
    }
}

my @pseudoprimes;

my @bases        = (2, 3);    # generate Fermat pseudoprimes to these bases
my $pm1_multiple = 2 * 3;     # multiple of p-1
my $prime_limit  = 1000;      # sieve primes up to this limit

fermat_pseudoprimes(
    \@bases,                  # base
    $pm1_multiple,            # p-1 multiple
    $prime_limit,             # prime limit
    sub ($n) {
        if (is_pseudoprime($n, @bases)) {
            push @pseudoprimes, $n;
        }
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
1729, 2701, 18721, 31621, 49141, 63973, 83333, 90751, 104653, 126217, 226801, 282133, 294409, 4670029, 10802017, 12932989, 46045117, 56052361, 83083001, 118901521, 127479097, 172947529, 216821881


================================================
FILE: Math/fermat_pseudoprimes_generation_2.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 06 May 2022
# Edit: 12 November 2022
# https://github.com/trizen

# A new algorithm for generating Fermat pseudoprimes to multiple bases.

# See also:
#   https://oeis.org/A001567 -- Fermat pseudoprimes to base 2, also called Sarrus numbers or Poulet numbers.
#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.

# See also:
#   https://en.wikipedia.org/wiki/Fermat_pseudoprime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);

sub fermat_pseudoprimes ($bases, $k_limit, $prime_limit, $callback) {

    my %common_divisors;
    my $bases_lcm = lcm(@$bases);

    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {
        next if ($bases_lcm % $p == 0);
        my @orders = map { znorder($_, $p) } @$bases;
        for my $k (1 .. $k_limit) {
            foreach my $o (@orders) {
                push @{$common_divisors{$k * $o}}, $p;
            }
        }
    }

    my %seen;

    foreach my $arr (values %common_divisors) {

        my $l = scalar(@$arr);

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = vecprod(@{$arr}[@_]);
                $callback->($n) if !$seen{$n}++;
            } $l, $k;
        }
    }
}

my @pseudoprimes;

my @bases       = (2, 3);    # generate Fermat pseudoprimes to these bases
my $k_limit     = 10;        # largest k multiple of the znorder(base, p)
my $prime_limit = 500;       # sieve primes up to this limit

fermat_pseudoprimes(
    \@bases,                 # bases
    $k_limit,                # k limit
    $prime_limit,            # prime limit
    sub ($n) {
        if (is_pseudoprime($n, @bases)) {
            push @pseudoprimes, $n;
        }
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
341, 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


================================================
FILE: Math/fermat_pseudoprimes_generation_3.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 02 July 2022
# Edit: 12 November 2022
# https://github.com/trizen

# A new algorithm for generating Fermat pseudoprimes to multiple bases.

# See also:
#   https://oeis.org/A001567 -- Fermat pseudoprimes to base 2, also called Sarrus numbers or Poulet numbers.
#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.

# See also:
#   https://en.wikipedia.org/wiki/Fermat_pseudoprime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);

sub fermat_pseudoprimes ($bases, $k_limit, $prime_limit, $callback) {

    my %common_divisors;
    my $bases_lcm = lcm(@$bases);

    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {
        next if ($bases_lcm % $p == 0);
        my @orders     = map { znorder($_, $p) } @$bases;
        my $lcm_orders = lcm(@orders);
        for my $k (1 .. $k_limit) {
            if (is_prime($k * $lcm_orders + 1)) {
                push @{$common_divisors{$lcm_orders}}, $k * $lcm_orders + 1;
            }
        }
    }

    my %seen;

    foreach my $arr (values %common_divisors) {

        my $l = scalar(@$arr);

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = vecprod(@{$arr}[@_]);
                $callback->($n) if !$seen{$n}++;
            } $l, $k;
        }
    }
}

my @pseudoprimes;

my @bases       = (2, 3);    # generate Fermat pseudoprimes to these bases
my $k_limit     = 10;        # largest k multiple of the znorder(base, p)
my $prime_limit = 500;       # sieve primes up to this limit

fermat_pseudoprimes(
    \@bases,                 # bases
    $k_limit,                # k limit
    $prime_limit,            # prime limit
    sub ($n) {
        if (is_pseudoprime($n, @bases)) {
            push @pseudoprimes, $n;
        }
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
1105, 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


================================================
FILE: Math/fermat_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 31 August 2022
# https://github.com/trizen

# Generate all the k-omega Fermat pseudoprimes in range [a,b]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (slow):
#   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)));

# PARI/GP program (fast):
#   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)));

use 5.036;
use ntheory 0.74 qw(:all);

sub fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    my %seen;
    my @list;

    sub ($m, $L, $lo, $j) {

        my $hi = rootint(divint($B, $m), $j);

        if ($lo > $hi) {
            return;
        }

        if ($j == 1) {

            if ($L == 1) {    # optimization
                foreach my $p (@{primes($lo, $hi)}) {

                    $base % $p == 0 and next;

                    for (my $v = (($m == 1) ? ($p * $p) : ($m * $p)) ; $v <= $B ; $v *= $p) {
                        $v >= $A                       or next;
                        powmod($base, $v - 1, $v) == 1 or last;
                        push(@list, $v) if !$seen{$v}++;
                    }
                }
                return;
            }

            my $t = invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime_power($p) and gcd($m, $p) == 1 and gcd($base, $p) == 1) {

                    my $v = $m * $p;
                    $v >= $A                           or next;
                    ($v - 1) % znorder($base, $p) == 0 or next;

                    #powmod($base, $v-1, $v) == 1 or next;
                    push(@list, $v) if !$seen{$v}++;
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $z = znorder($base, $p);
            gcd($m, $z) == 1 or next;

            for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {

                if ($q > $p) {
                    powmod($base, $z, $q) == 1 or last;
                }

                __SUB__->($v, lcm($L, $z), $p + 1, $j - 1);
            }
        }
      }
      ->(1, 1, 2, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the Fermat pseudoprimes to base 3 in range [1, 10^5]

my $from = 1;
my $upto = 1e5;
my $base = 3;

my @arr;
foreach my $k (1 .. 100) {
    last if pn_primorial($k) > $upto;
    push @arr, fermat_pseudoprimes_in_range($from, $upto, $k, $base);
}

say join(', ', sort { $a <=> $b } @arr);

# Run some tests

if (0) {    # true to run some tests
    foreach my $k (1 .. 5) {

        say "Testing k = $k";

        my $lo           = pn_primorial($k);
        my $hi           = mulint($lo, 1000);
        my $omega_primes = omega_primes($k, $lo, $hi);

        foreach my $base (2 .. 100) {
            my @this = grep { is_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;
            my @that = fermat_pseudoprimes_in_range($lo, $hi, $k, $base);
            join(' ', @this) eq join(' ', @that)
              or die "Error for k = $k and base = $base with hi = $hi\n(@this) != (@that)";
        }
    }
}

__END__
91, 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


================================================
FILE: Math/fermat_pseudoprimes_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 February 2023
# https://github.com/trizen

# Generate all the k-omega Fermat pseudoprimes in range [a,b]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (slow):
#   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)));

# PARI/GP program (fast):
#   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)));

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    my %seen;
    my @list;

    sub ($m, $L, $lo, $j) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $j);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        if ($j == 1) {

            Math::GMPz::Rmpz_invert($v, $m, $L);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime_power($p) and Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p) == 1 and gcd($base, $p) == 1) {

                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);

                    if ($k == 1 and is_prime($p) and Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {
                        ## ok
                    }
                    elsif (Math::GMPz::Rmpz_cmp($v, $A) >= 0) {
                        Math::GMPz::Rmpz_sub_ui($u, $v, 1);
                        if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {
                            push(@list, Math::GMPz::Rmpz_init_set($v)) if !$seen{Math::GMPz::Rmpz_get_str($v, 10)}++;
                        }
                    }
                }
            }

            return;
        }

        my $u   = Math::GMPz::Rmpz_init();
        my $v   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $z = znorder($base, $p);
            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);

            Math::GMPz::Rmpz_set_ui($u, $p);

            for (Math::GMPz::Rmpz_mul_ui($v, $m, $p) ; Math::GMPz::Rmpz_cmp($v, $B) <= 0 ; Math::GMPz::Rmpz_mul_ui($v, $v, $p)) {
                __SUB__->($v, $lcm, $p + 1, $j - 1);
                Math::GMPz::Rmpz_mul_ui($u, $u, $p);
                powmod($base, $z, $u) == 1 or last;
            }
        }
      }
      ->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the Fermat pseudoprimes to base 3 in range [1, 10^5]

my $from = 1;
my $upto = 1e5;
my $base = 3;

my @arr;
foreach my $k (1 .. 100) {
    last if pn_primorial($k) > $upto;
    push @arr, fermat_pseudoprimes_in_range($from, $upto, $k, $base);
}

say join(', ', sort { $a <=> $b } @arr);

# Run some tests

if (0) {    # true to run some tests
    foreach my $k (1 .. 5) {

        say "Testing k = $k";

        my $lo           = pn_primorial($k) * 4;
        my $hi           = mulint($lo, 1000);
        my $omega_primes = omega_primes($k, $lo, $hi);

        foreach my $base (2 .. 100) {
            my @this = grep { is_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;
            my @that = fermat_pseudoprimes_in_range($lo, $hi, $k, $base);
            join(' ', @this) eq join(' ', @that)
              or die "Error for k = $k and base = $base with hi = $hi\n(@this) != (@that)";
        }
    }
}

__END__
91, 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


================================================
FILE: Math/fermat_superpseudoprimes_generation.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 28 January 2019
# Edit: 12 November 2022
# https://github.com/trizen

# A new algorithm for generating Fermat superpseudoprimes to multiple bases.

# See also:
#   https://oeis.org/A050217 -- Super-Poulet numbers: Poulet numbers whose divisors d all satisfy d|2^d-2.

# See also:
#   https://en.wikipedia.org/wiki/Fermat_pseudoprime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);

sub fermat_superpseudoprimes ($bases, $prime_limit, $callback) {

    my %common_divisors;
    my $bases_lcm = lcm(@$bases);

    for (my $p = 2 ; $p <= $prime_limit ; $p = next_prime($p)) {
        next if ($bases_lcm % $p == 0);
        my @orders = map { znorder($_, $p) } @$bases;
        foreach my $d (divisors($p - 1)) {
            if (vecall { $d % $_ == 0 } @orders) {
                push @{$common_divisors{$d}}, $p;
            }
        }
    }

    my %seen;

    foreach my $arr (values %common_divisors) {

        my $l = scalar(@$arr);

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = vecprod(@{$arr}[@_]);
                $callback->($n) if !$seen{$n}++;
            } $l, $k;
        }
    }
}

my @bases       = (2, 3, 5);    # superpseudoprimes to these bases
my $prime_limit = 1e4;          # prime limit

my @pseudoprimes;

fermat_superpseudoprimes(
    \@bases,                    # bases
    $prime_limit,               # prime limit
    sub ($n) {
        push @pseudoprimes, $n;
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
721801, 873181, 9006401, 9863461, 10403641, 12322133, 18736381, 20234341, 21397381, 22369621, 25696133, 36307981, 42702661, 46094401, 47253781


================================================
FILE: Math/fibonacci_closed_form.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 October 2015
# Website: https://github.com/trizen

# A simple closed-form to the Fibonacci sequence

use 5.010;
use strict;
use warnings;

sub fib {
    my ($n) = @_;

    state $S  = sqrt(5);
    state $T  = ((1 + $S) / 2);
    state $U  = (2 / (1 + $S));
    state $PI = atan2(0, -'inf');

    ($T**$n - ($U**$n * cos($PI * $n))) / $S;
}

for my $n (1 .. 20) {
    say "F($n) = ", fib($n);
}


================================================
FILE: Math/fibonacci_closed_form_2.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 October 2015
# Website: https://github.com/trizen

# A very simple and fast closed-form to the Fibonacci sequence

use 5.010;
use strict;
use warnings;

sub fib {
    my ($n) = @_;

    state $S = sqrt(1.25) + 0.5;
    state $T = sqrt(1.25) - 0.5;
    state $W = $S + $T;

    ($S**$n - (-$T)**($n)) / $W;
}

for my $n (1 .. 20) {
    say "F($n) = ", fib($n);
}


================================================
FILE: Math/fibonacci_encoding.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 January 2018
# https://github.com/trizen

# Encode positive integers in binary format, using the Fibonacci numbers.

# Example:
#   30 = 10100010 = 1×21 + 0×13 + 1×8 + 0×5 + 0×3 + 0×2 + 1×1 + 0×1

# See also:
#   https://projecteuler.net/problem=473
#   https://en.wikipedia.org/wiki/Fibonacci_coding
#   https://en.wikipedia.org/wiki/Zeckendorf%27s_theorem
#   https://en.wikipedia.org/wiki/Golden_ratio_base

use 5.010;
use strict;
use warnings;

use ntheory qw(lucasu);
use experimental qw(signatures);

sub fib ($n) {
    lucasu(1, -1, $n);
}

sub fibonacci_encoding ($n) {
    return '0' if ($n == 0);

    my $phi = sqrt(1.25) + 0.5;
    my $log = int((log($n) + log(5)/2) / log($phi));

    my ($f1, $f2) = (fib($log), fib($log - 1));

    if ($f1 + $f2 <= $n) {
        ($f1, $f2) = ($f1 + $f2, $f1);
    }

    my $enc = '';

    while ($f1 > 0) {

        if ($n >= $f1) {
            $n -= $f1;
            $enc .= '1';
        }
        else {
            $enc .= '0';
        }

        ($f1, $f2) = ($f2, $f1 - $f2);
    }

    return $enc;
}

sub fibonacci_decoding($enc) {

    my $len = length($enc);
    my ($f1, $f2) = (fib($len), fib($len - 1));

    my $dec = 0;

    foreach my $i (0 .. $len - 1) {
        my $bit = substr($enc, $i, 1);
        $dec += $f1 if $bit;
        ($f1, $f2) = ($f2, $f1 - $f2);
    }

    return $dec;
}

say fibonacci_encoding(30);            #=> 10100010
say fibonacci_decoding('10100010');    #=> 30

say fibonacci_decoding(fibonacci_encoding(144));        #=> 144
say fibonacci_decoding(fibonacci_encoding(144 - 1));    #=> 143
say fibonacci_decoding(fibonacci_encoding(144 + 1));    #=> 145

# Transparent support for arbitrary large integers
say fibonacci_decoding(fibonacci_encoding('81923489126412312421758612841248123'));

# Verify the encoding/decoding algorithm
foreach my $n (0 .. 10000) {
    if (fibonacci_decoding(fibonacci_encoding($n)) != $n) {
        die "Error for $n";
    }
}


================================================
FILE: Math/fibonacci_factorization_method.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 09 September 2018
# https://github.com/trizen

# A new integer factorization method, using the Fibonacci numbers.

# It uses the smallest divisor `d` of `p - legendre(p, 5)`, for which `Fibonacci(d) = 0 (mod p)`.

# By selecting a small bound B, we compute `k = lcm(1..B)`, hoping that `k` is a
# multiple of `d`, then `gcd(Fibonacci(k) (mod n), n)` in a non-trivial factor of `n`.

# This method is similar in flavor to Pollard's p-1 and Williams's p+1 methods.

use 5.020;
use warnings;

use experimental qw(signatures);

use Math::AnyNum qw(:overload gcd ilog2 is_prime);
use Math::Prime::Util::GMP qw(consecutive_integer_lcm random_prime lucas_sequence);

sub fibonacci_factorization ($n, $B = 10000) {

    my $k = consecutive_integer_lcm($B);            # lcm(1..B)
    my $F = (lucas_sequence($n, 1, -1, $k))[0];     # Fibonacci(k) (mod n)

    return gcd($F, $n);
}

say fibonacci_factorization(257221 * 470783,              700);     #=> 470783           (p+1 is  700-smooth)
say fibonacci_factorization(333732865481 * 1632480277613, 3000);    #=> 333732865481     (p-1 is 3000-smooth)

# Example of a larger number that can be factorized fast with this method
say fibonacci_factorization(203544696384073367670016326770637347800169508950125910682353, 19);    #=> 5741461760879844361

foreach my $k (1 .. 50) {

    my $n = Math::AnyNum->new(random_prime(1 << $k)) * random_prime(1 << $k);
    my $p = fibonacci_factorization($n, 2 * ilog2($n)**2);

    if (is_prime($p)) {
        say "$n = $p * ", $n / $p;
    }
}


================================================
FILE: Math/fibonacci_k-th_order.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 April 2018
# https://github.com/trizen

# Compute the k-th order Fibonacci numbers.

# See also:
#   https://oeis.org/A000045    (2-nd order: Fibonacci numbers)
#   https://oeis.org/A000073    (3-rd order: Tribonacci numbers)
#   https://oeis.org/A000078    (4-th order: Tetranacci numbers)
#   https://oeis.org/A001591    (5-th order: Pentanacci numbers)

use 5.020;
use strict;
use warnings;

use ntheory qw(vecsum);
use experimental qw(signatures);

sub kth_order_fibonacci ($n, $k = 2) {

    my @A = ((0) x ($k - 1), 1);

    for (1 .. $n) {
        @A = (@A[1 .. $k - 1], vecsum(@A[0 .. $k - 1]));
    }

    return $A[-1];
}

for my $n (0 .. 20) {
    say kth_order_fibonacci($n, 5);
}


================================================
FILE: Math/fibonacci_k-th_order_efficient_algorithm.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 January 2019
# https://github.com/trizen

# Generalized efficient formula for computing the k-th order Fibonacci numbers, using exponentiation by squaring.

# OEIS sequences:
#   https://oeis.org/A000045    (2-nd order: Fibonacci numbers)
#   https://oeis.org/A000073    (3-rd order: Tribonacci numbers)
#   https://oeis.org/A000078    (4-th order: Tetranacci numbers)
#   https://oeis.org/A001591    (5-th order: Pentanacci numbers)

# See also:
#   https://en.wikipedia.org/wiki/Generalizations_of_Fibonacci_numbers
#   https://en.wikipedia.org/wiki/Exponentiation_by_squaring

# Example of Fibonacci matrices for k=2..4:
#
#   A_2 = Matrix(
#           [0, 1],
#           [1, 1]
#         )
#
#   A_3 = Matrix(
#           [0, 1, 0],
#           [0, 0, 1],
#           [1, 1, 1]
#         )
#
#   A_4 = Matrix(
#           [0, 1, 0, 0],
#           [0, 0, 1, 0],
#           [0, 0, 0, 1],
#           [1, 1, 1, 1]
#         )

# Let R = (A_k)^n.
# The n-th k-th order Fibonacci number is the last term in the first row of R.

use 5.020;
use strict;
use warnings;

use Math::MatrixLUP;
use experimental qw(signatures);

sub fibonacci_matrix($k) {
    Math::MatrixLUP->build(
        $k, $k,
        sub ($i, $j) {
            (($i == $k - 1) || ($i == $j - 1)) ? 1 : 0;
        }
    );
}

sub modular_fibonacci_kth_order ($n, $k, $m) {
    my $A = fibonacci_matrix($k);
    ($A->powmod($n, $m))->[0][-1];
}

sub fibonacci_kth_order ($n, $k = 2) {
    my $A = fibonacci_matrix($k);
    ($A**$n)->[0][-1];
}

foreach my $k (2 .. 6) {
    say("Fibonacci of k=$k order: ", join(', ', map { fibonacci_kth_order($_, $k) } 0 .. 14 + $k));
}

say '';

foreach my $k (2 .. 6) {
    say("Last n digits of 10^n $k-order Fibonacci numbers: ",
        join(', ', map { modular_fibonacci_kth_order(10**$_, $k, 10**$_) } 0 .. 9));
}

__END__
Fibonacci of k=2 order: 0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987
Fibonacci of k=3 order: 0, 0, 1, 1, 2, 4, 7, 13, 24, 44, 81, 149, 274, 504, 927, 1705, 3136, 5768
Fibonacci of k=4 order: 0, 0, 0, 1, 1, 2, 4, 8, 15, 29, 56, 108, 208, 401, 773, 1490, 2872, 5536, 10671
Fibonacci of k=5 order: 0, 0, 0, 0, 1, 1, 2, 4, 8, 16, 31, 61, 120, 236, 464, 912, 1793, 3525, 6930, 13624
Fibonacci 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

Last n digits of 10^n 2-order Fibonacci numbers: 0, 5, 75, 875, 6875, 46875, 546875, 546875, 60546875, 560546875
Last n digits of 10^n 3-order Fibonacci numbers: 0, 1, 58, 384, 1984, 62976, 865536, 2429440, 86712832, 941792256
Last n digits of 10^n 4-order Fibonacci numbers: 0, 6, 96, 160, 1792, 92544, 348928, 6868608, 41256704, 824732160
Last n digits of 10^n 5-order Fibonacci numbers: 0, 1, 33, 385, 1025, 69921, 360833, 4117505, 34469121, 304605953
Last n digits of 10^n 6-order Fibonacci numbers: 0, 6, 4, 925, 3376, 93151, 642996, 3541264, 38339728, 425978989


================================================
FILE: Math/fibonacci_k-th_order_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 April 2018
# https://github.com/trizen

# Efficient algorithm for computing the k-th order Fibonacci numbers.

# See also:
#   https://oeis.org/A000045    (2-nd order: Fibonacci numbers)
#   https://oeis.org/A000073    (3-rd order: Tribonacci numbers)
#   https://oeis.org/A000078    (4-th order: Tetranacci numbers)
#   https://oeis.org/A001591    (5-th order: Pentanacci numbers)

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use experimental qw(signatures);

sub kth_order_fibonacci ($n, $k = 2) {

    # Algorithm due to M. F. Hasler
    # See: https://oeis.org/A302990

    if ($n < $k - 1) {
        return 0;
    }

    my @f = map {
        $_ < $k
          ? do {
            my $z = Math::GMPz::Rmpz_init();
            Math::GMPz::Rmpz_setbit($z, $_);
            $z;
          }
          : Math::GMPz::Rmpz_init_set_ui(1)
    } 1 .. ($k + 1);

    my $t = Math::GMPz::Rmpz_init();

    foreach my $i (2 * ++$k - 2 .. $n) {
        Math::GMPz::Rmpz_mul_2exp($t, $f[($i - 1) % $k], 1);
        Math::GMPz::Rmpz_sub($f[$i % $k], $t, $f[$i % $k]);
    }

    return $f[$n % $k];
}

say "Tribonacci: ", join(' ', map { kth_order_fibonacci($_, 3) } 0 .. 15);
say "Tetranacci: ", join(' ', map { kth_order_fibonacci($_, 4) } 0 .. 15);
say "Pentanacci: ", join(' ', map { kth_order_fibonacci($_, 5) } 0 .. 15);


================================================
FILE: Math/fibonacci_k-th_order_odd_primes_indices.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu and M. F. Hasler
# Date: 20 April 2018
# Edit: 23 April 2018
# https://github.com/trizen

# Find the first index of the odd prime number in the nth-order Fibonacci sequence.

# See also:
#   https://oeis.org/A302990

use 5.020;
use strict;
use warnings;

use Math::GMPz;

my $ONE = Math::GMPz->new(1);

use ntheory qw(is_prob_prime);
use experimental qw(signatures);

sub nth_order_prime_fibonacci_index ($n = 2, $min = 0) {

    # Algorithm after M. F. Hasler from https://oeis.org/A302990
    my @a = map { $_ < $n ? ($ONE << $_) : $ONE } 1 .. ($n + 1);

    for (my $i = 2 * ($n += 1) - 2 ; ; ++$i) {

        my $t  = $i % $n;
        $a[$t] = ($a[$t-1] << 1) - $a[$t];

        if ($i >= $min and Math::GMPz::Rmpz_odd_p($a[$t])) {
            #say "Testing: $i";

            if (is_prob_prime($a[$t])) {
                #say "\nFound: $t -> $i\n";
                return $i;
            }
        }
    }
}

# a(33) = 94246
# a(36) = ?
# a(37) = 758
# a(38) = ?
# a(39) = ?

# a(36)  > 170050       (M. F. Hasler)
# a(38)  > 40092
# a(41)  > 142000       (M. F. Hasler)
# a(100) > 48076

# Example for computing the terms a(2)-a(26):
say join ", ", map{ nth_order_prime_fibonacci_index($_) } 2..26;

# Searching for a(36)
# say nth_order_prime_fibonacci_index(36, 170051);


================================================
FILE: Math/fibonacci_number_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 June 2018
# https://github.com/trizen

# An efficient algorithm for computing the nth-Fibonacci number.

# See also:
#   https://github.com/trizen/perl-scripts/blob/master/Math/modular_fibonacci_cassini.pl
#   https://github.com/trizen/perl-scripts/blob/master/Math/modular_fibonacci_cassini_fast.pl

use 5.020;
use warnings;
use experimental qw(signatures);
use Math::AnyNum qw(:overload ilog2 getbit);

sub fibonacci_number($n) {

    my ($f, $g) = (0, 1);
    my ($a, $b) = (0, 1);

    foreach my $k (0 .. ilog2($n)||0) {
        ($f, $g) = ($f*$a + $g*$b, $f*$b + $g*($a+$b)) if getbit($n, $k);
        ($a, $b) = ($a*$a + $b*$b, $a*$b + $b*($a+$b));
    }

    return $f;
}

say fibonacci_number(100);                              #=> 354224848179261915075
say join(' ', map { fibonacci_number($_) } 0 .. 15);    #=> 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610


================================================
FILE: Math/fibonacci_polynomials_closed_form.pl
================================================
#!/usr/bin/perl

# Closed-form expression for Fibonacci polynomials:
#    Sum_{k=0..n} (fibonacci(k) * x^k)

# Formulas generated by Wolfram|Alpha.

# See also:
#   https://projecteuler.net/problem=435

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload);

sub F1 ($n, $x) {
    (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));
}

sub F2 ($n, $x) {
    -(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));
}

say F1(7, 11);      #=> 268357683
say F2(7, 11);      #=> =//=


================================================
FILE: Math/fibonacci_pseudoprimes_generation.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 22 September 2018
# https://github.com/trizen

# A new algorithm for generating Fibonacci pseudoprimes.

# OEIS:
#   https://oeis.org/A081264 -- Odd Fibonacci pseudoprimes.
#   https://oeis.org/A212424 -- Frobenius pseudoprimes with respect to Fibonacci polynomial x^2 - x - 1.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html
#   https://trizenx.blogspot.com/2018/08/investigating-fibonacci-numbers-modulo-m.html

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::AnyNum qw(prod powmod);
use ntheory qw(forcomb forprimes kronecker divisors lucas_sequence);

sub fibonacci_pseudoprimes ($limit, $callback) {

    my %common_divisors;

    forprimes {
        my $p = $_;
        foreach my $d (divisors($p - kronecker($p, 5))) {
            if ((lucas_sequence($p, 1, -1, $d))[0] == 0) {
                push @{$common_divisors{$d}}, $p;
            }
        }
    } 3, $limit;

    my %seen;

    foreach my $arr (values %common_divisors) {

        my $l = $#{$arr} + 1;

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = prod(@{$arr}[@_]);
                $callback->($n, @{$arr}[@_]) if !$seen{$n}++;
            } $l, $k;
        }
    }
}

sub is_fibonacci_pseudoprime($n) {
    (lucas_sequence($n, 1, -1, $n - kronecker($n, 5)))[0] == 0;
}

my @pseudoprimes;

fibonacci_pseudoprimes(
    10_000,
    sub ($n, @f) {

        is_fibonacci_pseudoprime($n)
            or die "Not a Fibonacci pseudoprime: $n";

        push @pseudoprimes, $n;

        if (kronecker($n, 5) == -1) {
            if (powmod(2, $n - 1, $n) == 1) {
                die "Found a special pseudoprime: $n = prod(@f)";
            }
        }
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
323, 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


================================================
FILE: Math/find_least_common_denominator.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 May 2016
# Website: https://github.com/trizen

# Find the least common denominator for a list of fractions and map each
# numerator to the ratio of the common denominator over the original denominator.

use 5.010;
use strict;
use warnings;

use ntheory qw(lcm);
use Math::AnyNum qw(:overload);

my @fractions = (
      19 / 6,
     160 / 51,
    1744 / 555,
     644 / 205,
    2529 / 805,
);

my $common_den = lcm(map { $_->denominator } @fractions);

my @numerators = map {
    $_->numerator * $common_den / $_->denominator
} @fractions;

say "=> Numerators:";
foreach my $n (@numerators) { say "\t$n" }

say "\n=> Common denominator: $common_den";


================================================
FILE: Math/floor_and_ceil_functions_fourier_series.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 November 2017
# https://github.com/trizen

# Floor and ceil functions, implemented using closed-form Fourier series.

# See also:
#   https://en.wikipedia.org/wiki/Floor_and_ceiling_functions#Continuity_and_series_expansions

use 5.020;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload tau pi e log2 ilog2);

sub floor ($x) {
    $x + (i * (log(1 - exp(tau * i * $x)) - log(exp(-tau * i * $x) * (-1 + exp(tau * i * $x))))) / tau - 1/2;
}

sub ceil ($x) {
    $x + (i * (log(1 - exp(tau * i * $x)) - log(exp(-tau * i * $x) * (-1 + exp(tau * i * $x))))) / tau + 1/2;
}

say floor(8.95);    #=> 8
say ceil(8.95);     #=> 9

say floor(18.3);    #=> 18
say ceil(18.3);     #=> 19

#
## Test with Vacca's formula for Euler-Mascheroni constant
#

# See also:
#   https://en.wikipedia.org/wiki/Euler%E2%80%93Mascheroni_constant#Series_expansions

my $sum0 = 0.0;
my $sum1 = 0.0;
my $sum2 = 0.0;
my $sum3 = 0.0;

foreach my $n (2 .. 10000) {
    $sum0 += (-1)**$n * ilog2($n) / $n;
    $sum1 += (-1)**$n * floor(log2($n + 1/2)) / $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);
    $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);
}

say $sum0;    #=> 0.577804596003519592136242513827950669265457764297
say $sum1;    #=> 0.577804596003519592136242513827950669265457764297-2.10816560532506695800025812910971220454909391515e-60i
say $sum2;    #=> 0.577804596003519592136242513827950669265457764297
say $sum3;    #=> 0.577804596003520848567920428074451834158559906352


================================================
FILE: Math/flt_factorization_method.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 02 August 2020
# Edit: 02 March 2026
# https://github.com/trizen

# A new factorization method for numbers that have all prime factors close to each other.

# Inpsired by Fermat's Little Theorem (FLT).

use 5.014;
use warnings;
use Math::GMPz;

use ntheory qw(:all);
use POSIX   qw(ULONG_MAX);

sub flt_factor {
    my ($n, $base, $reps) = @_;

    # base: a native integer <= sqrt(ULONG_MAX)
    # reps: how many tries before giving up

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    $base = 2   if (!defined($base) or $base < 2);
    $reps = 1e6 if (!defined($reps));

    my $z     = Math::GMPz::Rmpz_init();
    my $t     = Math::GMPz::Rmpz_init_set_ui($base);
    my $g     = Math::GMPz::Rmpz_init();
    my $accum = Math::GMPz::Rmpz_init_set_ui(1);

    Math::GMPz::Rmpz_powm($z, $t, $n, $n);

    Math::GMPz::Rmpz_sub($g, $z, $t);
    Math::GMPz::Rmpz_gcd($g, $g, $n);
    if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 && Math::GMPz::Rmpz_cmp($g, $n) < 0) {
        my $x = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_divexact($x, $n, $g);
        return sort { Math::GMPz::Rmpz_cmp($a, $b) } ($x, $g);
    }

    # Cannot factor Fermat pseudoprimes
    if (Math::GMPz::Rmpz_cmp_ui($z, $base) == 0) {
        return ($n);
    }

    my $multiplier = $base * $base;

    if ($multiplier > ULONG_MAX) {    # base is too large
        return ($n);
    }

    for (my $j = 1 ; $j <= $reps ; $j++) {
        Math::GMPz::Rmpz_mul_ui($t, $t, $multiplier);
        Math::GMPz::Rmpz_mod($t, $t, $n);

        Math::GMPz::Rmpz_sub($g, $z, $t);

        # Multiply into accumulator instead of GCD every time
        Math::GMPz::Rmpz_mul($accum, $accum, $g);
        Math::GMPz::Rmpz_mod($accum, $accum, $n);

        # Only run the expensive GCD operation every 50 iterations
        if ($j % 50 == 0) {
            Math::GMPz::Rmpz_gcd($g, $accum, $n);

            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
                if (Math::GMPz::Rmpz_cmp($g, $n) == 0) {
                    return $n;    # Collision, would need backtracking here
                }
                my $x = Math::GMPz::Rmpz_init();
                Math::GMPz::Rmpz_divexact($x, $n, $g);
                return sort { Math::GMPz::Rmpz_cmp($a, $b) } ($x, $g);
            }

            # Reset accumulator
            Math::GMPz::Rmpz_set_ui($accum, 1);
        }
    }

    return $n;
}

my $p = random_ndigit_prime(30);

say join ' * ', flt_factor("173315617708997561998574166143524347111328490824959334367069087");
say join ' * ', flt_factor("2425361208749736840354501506901183117777758034612345610725789878400467");

say join ' * ', flt_factor(vecprod($p, next_prime($p),      next_prime(next_prime($p))));
say join ' * ', flt_factor(vecprod($p, next_prime(13 * $p), next_prime(123 * $p)));
say join ' * ', flt_factor(vecprod($p, next_prime($p),      next_prime(next_prime($p)), powint(2, 128) + 1));


================================================
FILE: Math/fraction_approximation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 July 2017
# https://github.com/trizen

# Simple and efficient algorithm for finding the smallest fraction
# approximation to any given real number, using continued fractions.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Test::More;
plan tests => 11;

use Math::AnyNum qw(:overload float real round);

sub num2cfrac ($callback, $n) {
    while (1) {
        my $m = int(round($n));
        $callback->($m) && return 1;
        $n = 1 / (($n - $m) || last);
    }
}

sub cfrac2num (@f) {
    sub ($i) {
        $i < $#f ? ($f[$i] + 1 / __SUB__->($i + 1)) : $f[$i];
    }->(0);
}

sub fraction_approximation($dec) {

    $dec = real(float($dec));

    my ($rat, @nums);
    my $str = "$dec";

    num2cfrac(
        sub ($n) {
            push @nums, $n;
            $rat = cfrac2num(@nums);
            index($rat->as_dec, $str) == 0;
        }, $dec
    );

    return $rat;
}

is(fraction_approximation('0.6180339887'),    '260497/421493');
is(fraction_approximation('1.008155930329'),  '7293/7234');
is(fraction_approximation('1.0019891835756'), '524875/523833');
is(fraction_approximation('529.12424242424'), '174611/330');

is(fraction_approximation((1 / 6)->as_dec),  '1/6');
is(fraction_approximation((13 / 6)->as_dec), '13/6');
is(fraction_approximation((6 / 13)->as_dec), '6/13');

is(fraction_approximation('5.010893246187'), '2300/459');
is(fraction_approximation('5.054466230936'), '2320/459');

is(fraction_approximation(5.0108932461873638344226579520697167755991285403), '2300/459');
is(fraction_approximation(5.0544662309368191721132897603485838779956427015), '2320/459');


================================================
FILE: Math/fraction_to_decimal_expansion.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 November 2017
# https://github.com/trizen

# Conversion of a fraction to a decimal-expansion with an arbitrary number of decimals, using Math::AnyNum.

use 5.020;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(bernfrac ilog10);

sub frac2dec ($x, $p = 32) {
    my $size = ilog10(abs($x)) + 1;
    $x->as_dec($size + $p);
}

my $n = bernfrac(60);

say frac2dec($n);        #=> -21399949257225333665810744765191097.39267415116172387457421830769266
say frac2dec($n, 48);    #=> -21399949257225333665810744765191097.392674151161723874574218307692659887265915822235


================================================
FILE: Math/fractional_pi.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 May 2016
# Website: https://github.com/trizen

# Calculate PI by computing the numerator and the denominator fraction that approaches the value of PI.
# It's based on the continued fraction: n^2 / (2n+1)

# See: https://oeis.org/A054766
#      https://oeis.org/A054765

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);
use Math::AnyNum qw(:overload as_dec);

no warnings 'recursion';

memoize('pi_nu');
memoize('pi_de');

sub pi_nu {
    my ($n) = @_;
    $n < 2
      ? ($n == 0 ? 1 : 0)
      : (2 * $n - 1) * pi_nu($n - 1) + ($n - 1)**2 * pi_nu($n - 2);
}

sub pi_de {
    my ($n) = @_;
    $n < 2
      ? $n
      : (2 * $n - 1) * pi_de($n - 1) + ($n - 1)**2 * pi_de($n - 2);
}

my $prec = 1000;
my $pi = as_dec(4 / (1 + pi_nu($prec) / pi_de($prec)), int($prec / 1.32));
say $pi;


================================================
FILE: Math/frobenius_pseudoprimes_generation.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 07 October 2018
# Edit: 19 August 2020
# https://github.com/trizen

# A new algorithm for generating Frobenius pseudoprimes to Fibonacci polynomial x^2 - x - 1.

# See also:
#   https://oeis.org/A217120 -- Lucas pseudoprimes
#   https://oeis.org/A217255 -- Strong Lucas pseudoprimes
#   https://oeis.org/A177745 -- Semiprimes n such that n divides Fibonacci(n+1).
#   https://oeis.org/A212423 -- Frobenius pseudoprimes == 2,3 (mod 5) with respect to Fibonacci polynomial x^2 - x - 1.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);
use Math::AnyNum qw(prod);

sub frobenius_pseudoprimes ($limit, $callback, $P = 1, $Q = -1) {

    my %table;
    my $D = $P*$P - 4*$Q;

    forprimes {
        my $p = $_;
        foreach my $d (divisors($p - kronecker($D, $p))) {
            if ((lucas_sequence($p, $P, $Q, $d))[0] == 0) {
                push @{$table{$d}}, $p;
                last;
            }
        }
    } 3, $limit;

    foreach my $arr (values %table) {

        my $l = $#{$arr} + 1;

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = prod(@{$arr}[@_]);
                $callback->($n, @{$arr}[@_]);
            } $l, $k;
        }
    }
}

my @pseudoprimes;

frobenius_pseudoprimes(
    100_000,
    sub ($n, @f) {

        is_frobenius_pseudoprime($n, 1, -1) or die "error: $n";

        push @pseudoprimes, $n;

        if (kronecker(5, $n) == -1 and powmod(2, $n-1, $n) == 1) {
            die "Found a BPSW counter-example: $n = prod(@f)";
        }
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
4181, 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


================================================
FILE: Math/fubini_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 December 2017
# https://github.com/trizen

# A new algorithm for computing the Fubini numbers.

# See also:
#   https://oeis.org/A000670

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload factorial);

sub fubini_numbers {
    my ($n) = @_;

    my @F = (1);

    foreach my $i (1 .. $n) {
        foreach my $k (0 .. $i - 1) {
            $F[$i] += $F[$k] / factorial($i - $k);
        }
    }

    map { $F[$_] * factorial($_) } 0 .. $#F;
}

my @F = fubini_numbers(20);

foreach my $i (0 .. $#F) {
    say "F($i) = $F[$i]";
}

__END__
F(0) = 1
F(1) = 1
F(2) = 3
F(3) = 13
F(4) = 75
F(5) = 541
F(6) = 4683
F(7) = 47293
F(8) = 545835
F(9) = 7087261
F(10) = 102247563
F(11) = 1622632573
F(12) = 28091567595
F(13) = 526858348381
F(14) = 10641342970443
F(15) = 230283190977853
F(16) = 5315654681981355
F(17) = 130370767029135901
F(18) = 3385534663256845323
F(19) = 92801587319328411133
F(20) = 2677687796244384203115


================================================
FILE: Math/fubini_numbers_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 February 2023
# https://github.com/trizen

# A new algorithm for computing the first n Fubini numbers.

# See also:
#   https://oeis.org/A000670

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload binomial);

sub fubini_numbers {
    my ($n) = @_;

    my @F = (1);

    foreach my $i (1 .. $n) {
        foreach my $k (0 .. $i - 1) {
            $F[$i] += $F[$k] * binomial($i, $k);
        }
    }

    return @F;
}

my @F = fubini_numbers(20);

foreach my $i (0 .. $#F) {
    say "F($i) = $F[$i]";
}

__END__
F(0) = 1
F(1) = 1
F(2) = 3
F(3) = 13
F(4) = 75
F(5) = 541
F(6) = 4683
F(7) = 47293
F(8) = 545835
F(9) = 7087261
F(10) = 102247563
F(11) = 1622632573
F(12) = 28091567595
F(13) = 526858348381
F(14) = 10641342970443
F(15) = 230283190977853
F(16) = 5315654681981355
F(17) = 130370767029135901
F(18) = 3385534663256845323
F(19) = 92801587319328411133
F(20) = 2677687796244384203115


================================================
FILE: Math/fubini_numbers_recursive.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 January 2019
# https://github.com/trizen

# A recursive formula for computing the Fubini numbers.

# See also:
#   https://oeis.org/A000670

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);
use Math::AnyNum qw(:overload binomial sum);

memoize('nth_fubini_number');

sub nth_fubini_number {
    my ($n) = @_;
    return 1 if ($n == 0);
    sum(map { nth_fubini_number($_) * binomial($n, $_) } 0 .. $n-1);
}

foreach my $i (0 .. 20) {
    say "F($i) = ", nth_fubini_number($i);
}

__END__
F(0) = 1
F(1) = 1
F(2) = 3
F(3) = 13
F(4) = 75
F(5) = 541
F(6) = 4683
F(7) = 47293
F(8) = 545835
F(9) = 7087261
F(10) = 102247563
F(11) = 1622632573
F(12) = 28091567595
F(13) = 526858348381
F(14) = 10641342970443
F(15) = 230283190977853
F(16) = 5315654681981355
F(17) = 130370767029135901
F(18) = 3385534663256845323
F(19) = 92801587319328411133
F(20) = 2677687796244384203115


================================================
FILE: Math/function_graph.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 02 July 2014
# https://github.com/trizen

# Map a mathematical function on the xOy axis.

use 5.010;
use strict;
use warnings;

# Generic creation of a matrix
sub create_matrix {
    my ($size, $val) = @_;
    int($size / 2), [map { [($val) x ($size)] } 0 .. $size - 1];
}

# Create a matrix
my ($i, $matrix) = create_matrix(65, ' ');

# Assign the point inside the matrix
sub assign {
    my ($x, $y, $value) = @_;

    $x += $i;
    $y += $i + 1;

    $matrix->[-$y][$x] = $value;
}

# Map the function
foreach my $x (-5 .. 5) {
    my $fx = $x**2 + 1;    # this is the function
    say "($x, $fx)";       # this line prints the coordinates
    assign($x, $fx, 'o');  # this line maps the value of (x, f(x)) on the graph
}

# Display the graph
while (my ($k, $row) = each @{$matrix}) {
    while (my ($l, $col) = each @{$row}) {
        if ($col eq ' ') {
            if ($k == $i) {    # the 'x' line
                print '-';
            }
            elsif ($l == $i) {    # the 'y' line
                print '|';
            }
            else {                # space
                print $col;
            }
        }
        else {                    # everything else
            print $col;
        }
    }
    print "\n";                   # new line
}


================================================
FILE: Math/function_inverse_binary_search.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 July 2019
# https://github.com/trizen

# Compute the inverse of any function, using the binary search algorithm.

# See also:
#   https://en.wikipedia.org/wiki/Binary_search_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload approx_cmp float);

sub binary_inverse ($n, $f, $min = 0, $max = $n, $prec = 192) {

    local $Math::AnyNum::PREC = "$prec";

    ($min, $max) = ($max, $min) if ($min > $max);

    $min = float($min);
    $max = float($max);

    for (; ;) {
        my $m = ($min + $max) / 2;
        my $c = approx_cmp($f->($m), $n);

        if ($c < 0) {
            $min = $m;
        }
        elsif ($c > 0) {
            $max = $m;
        }
        else {
            return $m;
        }
    }
}

say binary_inverse(2,   sub ($x) { exp($x) });    # solution to x for: exp(x) =   2
say binary_inverse(43,  sub ($x) { $x**2 });      # solution to x for:    x^2 =  43
say binary_inverse(-43, sub ($x) { $x**3 });      # solution to x for:    x^3 = -43

# Find the value of x such that Li(x) = 100
say binary_inverse(100, sub ($x) { Math::AnyNum::Li($x) }, 1, 1e6);    #=> 488.871909852807531906050863920333348273780185564


================================================
FILE: Math/gamma_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 November 2015
# Website: https://github.com/trizen

# The gamma function implemented as an improper integral
# See: https://en.wikipedia.org/wiki/Gamma_function

use 5.010;
use strict;
use warnings;

sub gamma {
    my ($n) = @_;

    my $sum = 0;
    for my $t (0 .. 1000) {
        $sum += $t**($n - 1) * exp(-$t);
    }

    return $sum;
}

for my $n (1 .. 20) {
    printf "gamma(%2d) = %.24f\n", $n, gamma($n);
}


================================================
FILE: Math/gaussian_divisors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 June 2022
# https://github.com/trizen

# Find the factors and divisors of a Gaussian integer.

# See also:
#   https://oeis.org/A125271
#   https://oeis.org/A078930
#   https://oeis.org/A078910
#   https://oeis.org/A078911
#   https://projecteuler.net/problem=153
#   https://www.alpertron.com.ar/GAUSSIAN.HTM
#   https://en.wikipedia.org/wiki/Table_of_Gaussian_integer_factorizations

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub gaussian_mul ($xa, $xb, $ya, $yb) {
    ($xa * $ya - $xb * $yb, $xa * $yb + $xb * $ya)
}

sub gaussian_div ($xa, $xb, $ya, $yb) {    # floor division
    my $t = $ya * $ya + $yb * $yb;
    (
        divint($ya * $t * $xa - $t * -$yb * $xb, $t * $t),
        divint($ya * $t * $xb + $t * -$yb * $xa, $t * $t)
    );
}

sub gaussian_is_div ($xa, $xb, $ya, $yb) {
    my ($ta, $tb) = gaussian_mul($ya, $yb, gaussian_div($xa, $xb, $ya, $yb));
    $xa - $ta == 0 and $xb - $tb == 0;
}

sub primitive_sum_of_two_squares ($p) {

    if ($p == 2) {
        return (1, 1);
    }

    my $s = sqrtmod(-1, $p) || return;
    my $q = $p;

    while ($s * $s > $p) {
        ($s, $q) = ($q % $s, $s);
    }

    ($s, $q % $s);
}

sub gaussian_factors ($x, $y = 0) {

    return if ($x == 0 and $y == 0);

    my $n = ($x * $x + $y * $y);
    my @factors;

    foreach my $pe (factor_exp($n)) {
        my ($p, $e) = @$pe;

        if ($p == 2) {
            while (gaussian_is_div($x, $y, 1, 1)) {
                push @factors, [1, 1];
                ($x, $y) = gaussian_div($x, $y, 1, 1);
            }
        }
        elsif ($p % 4 == 3) {
            while (gaussian_is_div($x, $y, $p, 0)) {
                push @factors, [$p, 0];
                ($x, $y) = gaussian_div($x, $y, $p, 0);
            }
        }
        elsif ($p % 4 == 1) {
            my ($a, $b) = primitive_sum_of_two_squares($p);

            while (gaussian_is_div($x, $y, $a, $b)) {
                push @factors, [$a, $b];
                ($x, $y) = gaussian_div($x, $y, $a, $b);
            }

            while (gaussian_is_div($x, $y, $a, -$b)) {
                push @factors, [$a, -$b];
                ($x, $y) = gaussian_div($x, $y, $a, -$b);
            }
        }
    }

    if ($x == 1 and $y == 0) {
        ## ok
    }
    else {
        push @factors, [$x, $y];
    }

    @factors = sort {
        ($a->[0] <=> $b->[0]) ||
        ($a->[1] <=> $b->[1])
    } @factors;

    my %count;
    $count{join(' ', @$_)}++ for @factors;

    my %seen;
    my @factor_exp =
        map { [$_, $count{join(' ', @$_)}] }
        grep { !$seen{join(' ', @$_)}++ } @factors;

    return @factor_exp;
}

sub gaussian_divisors ($x, $y = 0) {

    my @d = ([1, 0], [-1, 0], [0, 1], [0, -1]);

    foreach my $pe (gaussian_factors($x, $y)) {
        my ($p,  $e)  = @$pe;
        my ($ra, $rb) = (1, 0);
        my @t;
        for (1 .. $e) {
            ($ra, $rb) = gaussian_mul($ra, $rb, $p->[0], $p->[1]);
            foreach my $u (@d) {
                push @t, [gaussian_mul($u->[0], $u->[1], $ra, $rb)];
            }
        }
        push @d, @t;
    }

    @d = sort {
        ($a->[0] <=> $b->[0]) ||
        ($a->[1] <=> $b->[1])
    } @d;

    my %seen;
    @d = grep { !$seen{join(' ', @$_)}++ } @d;

    return @d;
}

say scalar gaussian_divisors(440, -55);    #=> 96

say join ', ', map {
    scalar grep { $_->[0] > 0 } gaussian_divisors($_, 0)
} 0 .. 30;    # A125271

say join ', ', map {
    vecsum(map { $_->[0] } grep { $_->[0] > 0 } gaussian_divisors($_, 0))
} 0 .. 30;    # A078930

say join ', ', map {
    vecsum(map { $_->[0] } grep { $_->[0] > 0 and $_->[1] > 0 } gaussian_divisors($_, 0))
} 0 .. 30;    # A078911

say join ', ', map {
    vecsum(map { $_->[0] } grep { $_->[0] > 0 or $_->[1] > 0 } gaussian_divisors($_, 0))
} 0 .. 30;    # A078910

my $sum = 0;

foreach my $n (1 .. 1000) {
    $sum += vecsum(map { $_->[0] } grep { $_->[0] > 0 } gaussian_divisors($n, 0));
}

say $sum;     #=> 1752541


================================================
FILE: Math/gaussian_factors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 June 2022
# https://github.com/trizen

# Find the factors of a Gaussian integer.

# See also:
#   https://www.alpertron.com.ar/GAUSSIAN.HTM
#   https://en.wikipedia.org/wiki/Table_of_Gaussian_integer_factorizations

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub gaussian_mul ($xa, $xb, $ya, $yb) {
    ($xa * $ya - $xb * $yb, $xa * $yb + $xb * $ya)
}

sub gaussian_div ($xa, $xb, $ya, $yb) {    # floor division
    my $t = $ya * $ya + $yb * $yb;
    (
        divint($ya * $t * $xa - $t * -$yb * $xb, $t * $t),
        divint($ya * $t * $xb + $t * -$yb * $xa, $t * $t)
    );
}

sub gaussian_is_div ($xa, $xb, $ya, $yb) {
    my ($ta, $tb) = gaussian_mul($ya, $yb, gaussian_div($xa, $xb, $ya, $yb));
    $xa - $ta == 0 and $xb - $tb == 0;
}

sub primitive_sum_of_two_squares ($p) {

    if ($p == 2) {
        return (1, 1);
    }

    my $s = sqrtmod(-1, $p) || return;
    my $q = $p;

    while ($s * $s > $p) {
        ($s, $q) = ($q % $s, $s);
    }

    ($s, $q % $s);
}

sub gaussian_factors ($x, $y = 0) {

    return if ($x == 0 and $y == 0);

    my $n = ($x * $x + $y * $y);
    my @factors;

    foreach my $pe (factor_exp($n)) {
        my ($p, $e) = @$pe;

        if ($p == 2) {
            while (gaussian_is_div($x, $y, 1, 1)) {
                push @factors, [1, 1];
                ($x, $y) = gaussian_div($x, $y, 1, 1);
            }
        }
        elsif ($p % 4 == 3) {
            while (gaussian_is_div($x, $y, $p, 0)) {
                push @factors, [$p, 0];
                ($x, $y) = gaussian_div($x, $y, $p, 0);
            }
        }
        elsif ($p % 4 == 1) {
            my ($a, $b) = primitive_sum_of_two_squares($p);

            while (gaussian_is_div($x, $y, $a, $b)) {
                push @factors, [$a, $b];
                ($x, $y) = gaussian_div($x, $y, $a, $b);
            }

            while (gaussian_is_div($x, $y, $a, -$b)) {
                push @factors, [$a, -$b];
                ($x, $y) = gaussian_div($x, $y, $a, -$b);
            }
        }
    }

    if ($x == 1 and $y == 0) {
        ## ok
    }
    else {
        push @factors, [$x, $y];
    }

    @factors = sort {
        ($a->[0] <=> $b->[0]) ||
        ($a->[1] <=> $b->[1])
    } @factors;

    my %count;
    $count{join(' ', @$_)}++ for @factors;

    my %seen;
    my @factor_exp =
      map { [$_, $count{join(' ', @$_)}] }
      grep { !$seen{join(' ', @$_)}++ } @factors;

    return @factor_exp;
}

my $z       = [440, -55];
my @factors = gaussian_factors($z->[0], $z->[1]);

say join(' ', map { '[' . join(', ', @{$_->[0]}) . ']' . ($_->[1] > 1 ? ('^' . $_->[1]) : '') } @factors);

my ($x, $y) = (1, 0);
foreach my $pe (@factors) {
    my ($p, $e) = @$pe;
    for (1 .. $e) {
        ($x, $y) = gaussian_mul($x, $y, $p->[0], $p->[1]);
    }
}

say "Product of factors: [$x, $y]";

__END__
[2, -1] [2, 1]^2 [3, -2] [11, 0]
Product of factors: [440, -55]


================================================
FILE: Math/gaussian_integers_sum.pl
================================================
#!/usr/bin/perl

# Calculate the terms of the sequences A281964 (real part) and A282132 (imaginary part), using
# Math::AnyNum and Math::GComplex, but without doing any floating-point arithmetic operations.

# See also:
#   https://oeis.org/A281964
#   https://oeis.org/A282132
#   https://en.wikipedia.org/wiki/Gaussian_integer

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GComplex qw(cplx);
use Math::AnyNum qw(:overload factorial);

sub A281964_A282132 ($n) {

    my @i = (1, cplx(0, 1), -1, cplx(0, -1));

    my $sum = cplx(0, 0);

    foreach my $k (1 .. $n) {
        $sum += $i[($k - 1) % 4] / $k;
    }

    return $sum * factorial($n);
}

foreach my $n (1 .. 40) {
    printf("%50s %s\n", A281964_A282132($n)->reals);
}

__END__
                                                 1 0
                                                 2 1
                                                 4 3
                                                16 6
                                               104 30
                                               624 300
                                              3648 2100
                                             29184 11760
                                            302976 105840
                                           3029760 1421280
                                          29698560 15634080
                                         356382720 147692160
                                        5111976960 1919998080
                                       71567677440 33106993920
                                      986336870400 496604908800
                                    15781389926400 6638004172800
                                   289206418636800 112846070937600
                                  5205715535462400 2386916704972800
                                 92506221468057600 45351417394483200
                               1850124429361152000 785383247480832000
                              41285515024760832000 16493048197097472000
                             908281330544738304000 413938002507853824000
                           19766469874751373312000 9520574057680637952000
                          474395276994032959488000 202641760645450334208000
                        12480330326584063426560000 5066044016136258355200000
                       324488588491185649090560000 147228354462873703219200000
                      8357900428135406889861120000 3975165570497589986918400000
                    234021211987791392916111360000 100415766523514167472947200000
                   7091503492257664255068733440000 2912057229181910856715468800000
                 212745104767729927652062003200000 96203478869197027656007680000000
                6329845387987436698577613619200000 2982307844945107857336238080000000
              202555052415597974354483635814400000 87211012384065528617034055680000000
             6947447566648426683865177994035200000 2877963408674162444362123837440000000
           236213217266046507251416051797196800000 106534073513733409603830404874240000000
          7972229805272023612951943203258368000000 3728692572980669336134064170598400000000
        287000272989792850066269955317301248000000 123899784660917951171159658804019200000000
      10991003427412236669919987794890981376000000 4584292032453964193332907375748710400000000
     417658130241664993456959536205857292288000000 187966850324476984392966459860031897600000000
   15765644461958333633061414687928360108032000000 7330707162654602391325691934541244006400000000
  630625778478333345322456587517134404321280000000 272830404424986652294387395641746862899200000000


================================================
FILE: Math/general_binary_multiplier.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 07 August 2015
# Website: https://github.com/trizen

# A general binary multiplier.
# Derived from: https://en.wikipedia.org/wiki/Binary_multiplier#A_more_advanced_approach:_an_unsigned_example

use 5.010;
use strict;
use integer;
use warnings;

my $a = 4253;
my $b = 7149;

my @a = reverse(split(//, sprintf("%b", $a)));
my @b = split(//, sprintf("%b", $b));

say @a;
say @b;

say $a * $b;

my @p = (0) x (@a + @b);

my $k = 0;
foreach my $i (@a) {
    if ($i) {
        say @p;
        my $carry = 0;
        foreach my $j (0 .. $#b) {
            my $add = $b[$#b - $j] + $p[$#p - $j - $k] + $carry;
            $p[$#p - $j - $k] = $add % 2;
            $carry = $add / 2;
        }
        if ($carry) {
            foreach my $j ($#b + 1 .. $#p) {
                my $add = $carry + $p[$#p - $j - $k];
                $p[$#p - $j - $k] = $add % 2;
                $carry = ($add / 2) || last;
            }
        }
    }
    ++$k;
}

say @p;
say unpack("N", pack("B32", substr("0" x 32 . join('', @p), -32)));


================================================
FILE: Math/goldbach_conjecture_2n_prime.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 September 2015
# Website: https://github.com/trizen

# Goldbach conjecture as the sum of two primes
# with one prime being in the range of (n, 2n)

# Proving that always there is a prime number between
# n and 2n which can be added with a smaller prime
# such as the sum is 2n, would prove the conjecture.

use 5.010;
use strict;
use warnings;

use List::Util qw(sum);
use ntheory qw(random_prime is_prime);

my $max = 10000;

my @counts;
foreach my $i (2 .. $max) {
    my $n = 2 * $i;

    my $count = 0;
    while (1) {
        ++$count;
        last if is_prime($n - random_prime($i, $n));
    }

    push @counts, $count;
}

say "Expected: ", log($max) / 2;
say "Observed: ", sum(@counts) / @counts;

__END__
--------------------------
  Example for max=1000000
--------------------------
Expected: 6.90775527898214
Observed: 6.66289466289466


================================================
FILE: Math/goldbach_conjecture_increasing_primes.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 16 September 2016
# Website: https://github.com/trizen

# The smallest prime p such that (2n - p) is also a prime number,
# and the prime p is the largest prime seen so far.

# Analyzing this sequence, may give us an insight into the Golbach's conjecture.

use strict;
use warnings;

use ntheory qw(primes is_prime);

my $limit  = 1000000;
my @primes = @{primes($limit)};

my $max = 0;

OUTER: for (my $i = 4 ; $i <= $limit ; $i += 2) {
    foreach my $p (@primes) {
        if (is_prime($i - $p)) {

            if ($p > $max) {
                $max = $p;
                printf("%7s %7s\n", $i, $p);
            }

            next OUTER;
        }
    }
}

__END__

Output for 2n <= 10^7:

     n       p
   -----   -----
      4       2
      6       3
     12       5
     30       7
     98      19
    220      23
    308      31
    556      47
    992      73
   2642     103
   5372     139
   7426     173
  43532     211
  54244     233
  63274     293
 113672     313
 128168     331
 194428     359
 194470     383
 413572     389
 503222     523
1077422     601
3526958     727
3807404     751


================================================
FILE: Math/goldbach_conjecture_possibilities.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 July 2015
# Website: https://github.com/trizen

# Calculate the number of combinations for the Goldbach conjecture
# for all the numbers ranging between the two exponents of e.

# As it seems, the number of combinations increases,
# with each power and it seems to go towards infinity.

use 5.010;
use strict;
use warnings;

use ntheory qw(forprimes is_prime pn_primorial nth_prime);

my $primo = 2;
my $count = 1;

my %table;
foreach my $i (1 .. pn_primorial(5)) {
    my $n = 2 * $i;
    my $partition = $i <= $primo ? $primo : do {
        $primo *= nth_prime(++$count);
    };
    forprimes {
        is_prime($n - $_)
          && ++$table{$partition};
    }
    ($n - 2);
}

use Data::Dump qw(pp);
pp \%table;

__END__

Primorial partitions:
{
    2     => 1,
    6     => 8,
    30    => 149,
    210   => 3696,
    2310  => 218701,
    30030 => 20096631
}

Logarithmic:
{
  1  => 2,
  2  => 22,
  3  => 109,
  4  => 558,
  5  => 2883,
  6  => 15523,
  7  => 85590,
  8  => 484304,
  9  => 2819301,
  10 => 16797271,
  11 => 101959227,
}


================================================
FILE: Math/goldbach_conjecture_random_primes.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 September 2015
# Website: https://github.com/trizen

# Compute the average of choosing a random prime number
# in a given range such as the difference between 2n
# and a prime number to be another prime number.
#
# Example:
#   is_prime(2n - rand_prime(2, 2n-2))   # true
#
# This problem is related to Goldbach conjecture.
# It shows that we have to choose, on average,
# log(n)/2 times a random prime number to satisfy
# the above property. This is an important outcome!

use 5.010;
use strict;
use warnings;

use ntheory qw(
    vecsum
    is_prime
    random_prime
);

my $max = 100000;

my @counts;
foreach my $i (2 .. $max) {
    my $n = 2 * $i;

    my $count = 0;
    while (1) {
        ++$count;
        last if is_prime($n - random_prime(2, $n - 2));
    }

    push @counts, $count;
}

say "Expected: ", log($max) / 2;
say "Observed: ", vecsum(@counts) / @counts;

__END__
--------------------------
  Example for max=300000
--------------------------
Expected: 6.30576887681917
Observed: 6.3850079500265


================================================
FILE: Math/golomb_s_sequence.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 November 2016
# https://github.com/trizen

# A recursive function that represents the Golomb's sequence.

# See also:
#   https://oeis.org/A001462
#   https://projecteuler.net/problem=341
#   https://en.wikipedia.org/wiki/Golomb_sequence

use 5.020;
use strict;
use warnings;

no warnings qw(recursion);

use experimental qw(signatures);
use Memoize qw(memoize);

memoize('G');    # this will save time

sub G($n) {
    $n == 1 ? 1 : 1 + G($n - G(G($n - 1)));
}

say "G(1000) = ", G(1000);


================================================
FILE: Math/greatest_common_unitary_divisor.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 September 2023
# https://github.com/trizen

# Efficient algorithm for finding the greatest common unitary divisor of a list of integers.

use 5.036;
use ntheory qw(:all);

sub gcud (@list) {

    my $g = gcd(@list);

    foreach my $n (@list) {
        next if ($n == 0);
        while (1) {
            my $t = gcd($g, divint($n, $g));
            last if ($t == 1);
            $g = divint($g, $t);
        }
        last if ($g == 1);
    }

    return $g;
}

say gcud();                              #=> 0
say gcud(2);                             #=> 2
say gcud(10,           20);              #=> 5
say gcud(factorial(9), 5040);            #=> 35
say gcud(factorial(9), 5040, 120);       #=> 5
say gcud(factorial(9), 5040, 0, 120);    #=> 5
say gcud(factorial(9), 5040, 1234);      #=> 1


================================================
FILE: Math/hamming_numbers.pl
================================================
#!/usr/bin/perl

# Generate the generalized Hamming numbers below a certain limit, given a set of primes.

use 5.020;
use warnings;
use experimental qw(signatures);

sub hamming_numbers ($limit, $primes) {

    my @h = (1);
    foreach my $p (@$primes) {
        foreach my $n (@h) {
            if ($n * $p <= $limit) {
                push @h, $n * $p;
            }
        }
    }

    return \@h;
}

# Example: 5-smooth numbers below 100
my $h = hamming_numbers(100, [2, 3, 5]);
say join(', ', sort { $a <=> $b } @$h);


================================================
FILE: Math/harmonic_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 01 November 2016
# https://github.com/trizen

# Computing the nth-harmonic number as an exact fraction.

# See also:
#   https://en.wikipedia.org/wiki/Harmonic_series_(mathematics)

use 5.016;
use warnings;
use Math::AnyNum;

sub harmfrac {
    my ($ui) = @_;

    $ui = int($ui);
    $ui || return Math::AnyNum->zero;
    $ui < 0 and return Math::AnyNum->nan;

    # Use binary splitting for large values of n. (by Fredrik Johansson)
    # https://fredrik-j.blogspot.com/2009/02/how-not-to-compute-harmonic-numbers.html
    if ($ui > 7000) {
        my $num  = Math::GMPz::Rmpz_init_set_ui(1);
        my $den  = Math::GMPz::Rmpz_init_set_ui($ui + 1);
        my $temp = Math::GMPz::Rmpz_init();

        # Inspired by Dana Jacobsen's code from Math::Prime::Util::{PP,GMP}.
        #   https://metacpan.org/pod/Math::Prime::Util::PP
        #   https://metacpan.org/pod/Math::Prime::Util::GMP
        sub {
            my ($num, $den) = @_;
            Math::GMPz::Rmpz_sub($temp, $den, $num);

            if (Math::GMPz::Rmpz_cmp_ui($temp, 1) == 0) {
                Math::GMPz::Rmpz_set($den, $num);
                Math::GMPz::Rmpz_set_ui($num, 1);
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($temp, 2) == 0) {
                Math::GMPz::Rmpz_set($den, $num);
                Math::GMPz::Rmpz_mul_2exp($num, $num, 1);
                Math::GMPz::Rmpz_add_ui($num, $num, 1);
                Math::GMPz::Rmpz_addmul($den, $den, $den);
            }
            else {
                Math::GMPz::Rmpz_add($temp, $num, $den);
                Math::GMPz::Rmpz_tdiv_q_2exp($temp, $temp, 1);
                my $q = Math::GMPz::Rmpz_init_set($temp);
                my $r = Math::GMPz::Rmpz_init_set($temp);
                __SUB__->($num, $q);
                __SUB__->($r,   $den);
                Math::GMPz::Rmpz_mul($num,  $num, $den);
                Math::GMPz::Rmpz_mul($temp, $q,   $r);
                Math::GMPz::Rmpz_add($num, $num, $temp);
                Math::GMPz::Rmpz_mul($den, $den, $q);
            }
          }
          ->($num, $den);

        my $q = Math::GMPq::Rmpq_init();
        Math::GMPq::Rmpq_set_num($q, $num);
        Math::GMPq::Rmpq_set_den($q, $den);
        Math::GMPq::Rmpq_canonicalize($q);

        return Math::AnyNum->new($q);
    }

    my $num = Math::GMPz::Rmpz_init_set_ui(1);
    my $den = Math::GMPz::Rmpz_init_set_ui(1);

    for (my $k = 2 ; $k <= $ui ; ++$k) {
        Math::GMPz::Rmpz_mul_ui($num, $num, $k);    # num = num * k
        Math::GMPz::Rmpz_add($num, $num, $den);     # num = num + den
        Math::GMPz::Rmpz_mul_ui($den, $den, $k);    # den = den * k
    }

    my $r = Math::GMPq::Rmpq_init();
    Math::GMPq::Rmpq_set_num($r, $num);
    Math::GMPq::Rmpq_set_den($r, $den);
    Math::GMPq::Rmpq_canonicalize($r);

    Math::AnyNum->new($r);
}

foreach my $i (0 .. 30) {
    printf "%20s / %-20s\n", harmfrac($i)->nude;
}


================================================
FILE: Math/harmonic_numbers_from_digamma.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 May 2017
# Edit: 04 November 2023
# https://github.com/trizen

# Computation of the nth-harmonic number, using the digamma(x) function.

# See also:
#   https://en.wikipedia.org/wiki/Harmonic_number

use 5.010;
use strict;
use warnings;

use Math::GMPz             qw();
use Math::GMPq             qw();
use Math::MPFR             qw();
use Math::AnyNum           qw();
use Math::Prime::Util::GMP qw();

sub harmonic {
    my ($n) = @_;

    $n == 0 and return Math::AnyNum->zero;
    $n == 1 and return Math::AnyNum->one;

    state $tau   = 6.28318530717958647692528676655900576839433879875;
    state $gamma = 0.57721566490153286060651209008240243104215933594;

    #my $log2_Hn = (-$n + $n * log($n) + (log($tau) + log($n)) / 2 + log(log($n) + $gamma)) / log(2);
    my $log2_Hn = $n / log(2) + sqrt($n);

    my $prec  = int($log2_Hn + 3);
    my $round = Math::MPFR::MPFR_RNDN();

    my $r = Math::MPFR::Rmpfr_init2($prec);
    Math::MPFR::Rmpfr_set_ui($r, $n + 1, $round);
    Math::MPFR::Rmpfr_digamma($r, $r, $round);

    my $t = Math::MPFR::Rmpfr_init2($prec);
    Math::MPFR::Rmpfr_const_euler($t, $round);
    Math::MPFR::Rmpfr_add($r, $r, $t, $round);

    my $num = Math::GMPz::Rmpz_init();
    my $den = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_set_str($den, Math::Prime::Util::GMP::consecutive_integer_lcm($n), 10);
    Math::MPFR::Rmpfr_mul_z($r, $r, $den, $round);
    Math::MPFR::Rmpfr_round($r, $r);
    Math::MPFR::Rmpfr_get_z($num, $r, $round);

    my $q = Math::GMPq::Rmpq_init();
    Math::GMPq::Rmpq_set_num($q, $num);
    Math::GMPq::Rmpq_set_den($q, $den);
    Math::GMPq::Rmpq_canonicalize($q);
    Math::AnyNum->new($q);
}

foreach my $i (0 .. 30) {
    printf "%20s / %-20s\n", harmonic($i)->nude;
    harmonic($i) == Math::AnyNum::harmonic($i) or die "error";
}

foreach my $i (2863, 7000) {
    harmonic($i) == Math::AnyNum::harmonic($i) or die "error";
}

__END__
# Extra testing
foreach my $k (1 .. 20) {
    my $i = int(rand($k * 1e3));
    say "Testing: $i";
    harmonic($i) == Math::AnyNum::harmonic($i) or die "error";
}


================================================
FILE: Math/harmonic_numbers_from_powers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 July 2017
# https://github.com/trizen

# A high-level algorithm implementation for computing the nth-harmonic number, using perfect powers.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload idiv);

sub harmonic_numbers_from_powers {
    my ($n) = @_;

    my @seen;
    my $harm = $n <= 0 ? 0 : 1;

    foreach my $k (2 .. $n) {
        if (not exists $seen[$k]) {

            my $p = $k;

            do {
                $seen[$p] = undef;
            } while (($p *= $k) <= $n);

            my $g = idiv($p, $k);
            my $t = idiv($g - 1, $k - 1);

            $harm += $t / $g;
        }
    }

    return $harm;
}

foreach my $i (0 .. 30) {
    printf "%20s / %-20s\n", harmonic_numbers_from_powers($i)->nude;
}


================================================
FILE: Math/harmonic_numbers_from_powers_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 July 2017
# https://github.com/trizen

# Computation of the nth-harmonic number, using perfect powers.

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub harmonic_numbers_from_powers {
    my ($n) = @_;

    my @seen;

    my $num = Math::GMPz::Rmpz_init_set_ui($n <= 0 ? 0 : 1);
    my $den = Math::GMPz::Rmpz_init_set_ui(1);

    foreach my $k (2 .. $n) {
        if (not exists $seen[$k]) {

            my $p = $k;

            do {
                $seen[$p] = undef;
            } while (($p *= $k) <= $n);

            my $g = $p / $k;
            my $t = ($g - 1) / ($k - 1);

            Math::GMPz::Rmpz_mul_ui($num, $num, $g);

            $t == 1
              ? Math::GMPz::Rmpz_add($num, $num, $den)
              : Math::GMPz::Rmpz_addmul_ui($num, $den, $t);

            Math::GMPz::Rmpz_mul_ui($den, $den, $g);
        }
    }

    my $gcd = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_gcd($gcd, $num, $den);
    Math::GMPz::Rmpz_divexact($num, $num, $gcd);
    Math::GMPz::Rmpz_divexact($den, $den, $gcd);

    return ($num, $den);
}

foreach my $n (0 .. 30) {
    printf "%20s / %-20s\n", harmonic_numbers_from_powers($n);
}


================================================
FILE: Math/harmonic_prime_powers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 July 2017
# https://github.com/trizen

# Harmonic sum of prime powers <= n, defined as:
#
#    Sum_{p <= n} (Sum_{1 <= k <= floor(log(n)/log(p))} 1/p^k)
#
# where p runs over the prime number <= n.

# This is equivalent with:
#   Sum_{p <= n} (p^(floor(log(n)/log(p))) - 1) / (p^(floor(log(n)/log(p))) * (p-1))

use 5.010;
use strict;
use warnings;

use ntheory qw(forprimes);
use Math::AnyNum qw(:overload ilog);

sub harmonic_prime_powers {
    my ($n) = @_;

    my $sum = 0;

    forprimes {
        my $p = $_;
        my $k = $p**ilog($n, $p);
        $sum += ($k - 1) / ($k * ($p - 1));
    } $n;

    return $sum;
}

foreach my $n (1 .. 30) {
    say harmonic_prime_powers($n);
}

__END__
0
1/2
5/6
13/12
77/60
77/60
599/420
1303/840
4189/2520
4189/2520
48599/27720
48599/27720
659507/360360
659507/360360
659507/360360
1364059/720720
23909723/12252240
23909723/12252240
466536977/232792560
466536977/232792560
466536977/232792560
466536977/232792560
10963143031/5354228880
10963143031/5354228880
55886560931/26771144400
55886560931/26771144400
170634254393/80313433200
170634254393/80313433200
5028706810597/2329089562800
5028706810597/2329089562800


================================================
FILE: Math/hybrid_prime_factorization.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2018
# https://github.com/trizen

# A hybrid factorization algorithm, using:
#   * Pollard's p-1 algorithm
#   * Pollard's rho algorithm
#   * A simple version of the continued-fraction factorization method
#   * Fermat's factorization method

# See also:
#   https://en.wikipedia.org/wiki/Quadratic_sieve
#   https://en.wikipedia.org/wiki/Dixon%27s_factorization_method
#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method
#   https://en.wikipedia.org/wiki/Pollard%27s_p_%E2%88%92_1_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use ntheory qw(is_prime random_prime vecprod);

use Math::AnyNum qw(
    gcd valuation powmod irand ipow
    isqrt idiv is_square next_prime
);

sub fermat_hybrid_factorization ($n) {

    return ()   if $n <= 1;
    return ($n) if is_prime($n);

    # Test for divisibility by 2
    if (!($n & 1)) {

        my $v = valuation($n, 2);
        my $t = $n >> $v;

        my @factors = (2) x $v;

        if ($t > 1) {
            push @factors, __SUB__->($t);
        }

        return @factors;
    }

    my $p = isqrt($n);
    my $x = $p;
    my $q = ($p * $p - $n);

    my $t = 1;
    my $h = 1;
    my $z = Math::AnyNum->new(random_prime($n));

    my $g = 1;
    my $c = $q + $p;

    my $a0 = 1;
    my $a1 = ($a0 * $a0 + $c);
    my $a2 = ($a1 * $a1 + $c);

    my $c1 = $p;
    my $c2 = 1;

    my $r = $p + $p;

    my ($e1, $e2) = (1, 0);
    my ($f1, $f2) = (0, 1);

    while (not is_square($q)) {

        $q += 2 * $p++ + 1;

        # Pollard's rho algorithm
        $g = gcd($n, $a2 - $a1);

        if ($g > 1 and $g < $n) {
            return sort { $a <=> $b } (
                __SUB__->($g),
                __SUB__->($n / $g),
            );
        }

        $a1 = (($a1 * $a1 + $c) % $n);
        $a2 = (($a2 * $a2 + $c) % $n);
        $a2 = (($a2 * $a2 + $c) % $n);

        # Simple version of the continued-fraction factorization method.
        # Efficient for numbers that have factors relatively close to sqrt(n)
        $c1 = $r * $c2 - $c1;
        $c2 = idiv($n - $c1 * $c1, $c2);

        my $x1 = ($x * $f2 + $e2) % $n;
        my $y1 = ($x1 * $x1) % $n;

        if (is_square($y1)) {
            $g = gcd($x1 - isqrt($y1), $n);

            if ($g > 1 and $g < $n) {
                return sort { $a <=> $b } (
                    __SUB__->($g),
                    __SUB__->($n / $g),
                );
            }
        }

        $r = idiv($x + $c1, $c2);

        ($f1, $f2) = ($f2, ($r * $f2 + $f1) % $n);
        ($e1, $e2) = ($e2, ($r * $e2 + $e1) % $n);

        # Pollard's p-a algorithm (random variation)
        $t = $z;
        $h = next_prime($h);
        $z = powmod($z, $h, $n);
        $g = gcd($z * powmod($t, irand($n), $n) - 1, $n);

        if ($g > 1) {

            if ($g == $n) {
                $h = 1;
                $z = Math::AnyNum->new(random_prime($n));
                next;
            }

            return sort { $a <=> $b } (
                __SUB__->($g),
                __SUB__->($n / $g),
            );
        }
    }

    # Fermat's method
    my $s = isqrt($q);

    return sort { $a <=> $b } (
        __SUB__->($p + $s),
        __SUB__->($p - $s),
    );
}

my @tests = map { Math::AnyNum->new($_) } qw(
     160587846247027 5040 65127835124 6469693230
     12129569695640600539 38568900844635025971879799293495379321
     5057557777500469647488909553014309710588182149566739774380944488183531188525863600127265768146701283
);

foreach my $n (@tests) {

    my @f = fermat_hybrid_factorization($n);

    say "$n = ", join(' * ', @f);
    die 'error' if vecprod(@f) != $n;
    die 'error' if grep { !is_prime($_) } @f;
}

say "\n=> Factoring 2^k+1";

foreach my $k (1 .. 100) {

    my $n = ipow(2, $k) + 1;
    my @f = fermat_hybrid_factorization($n);

    say "2^$k + 1 = ", join(' * ', @f);
    die 'error' if vecprod(@f) != $n;
    die 'error' if grep { !is_prime($_) } @f;
}

# Test the continued-fraction method with factors relatively close to sqrt(n)
foreach my $k (1 .. 100) {

    my $p = random_prime(ipow(2, 100 + $k));
    my $n = next_prime($p + irand(10**15)) * $p;
    my @f = fermat_hybrid_factorization($n);

    #say join(' * ', @f), " = $n";
    die 'error' if vecprod(@f) != $n;
    die 'error' if grep { !is_prime($_) } @f;
}

# Test for small numbers
for my $n (1 .. 1000) {

    my @f = fermat_hybrid_factorization($n);

    die 'error' if vecprod(@f) != $n;
    die 'error' if grep { !is_prime($_) } @f;
}


================================================
FILE: Math/infinitary_divisors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 September 2023
# https://github.com/trizen

# Generate the infinitary divisors (or i-divisors) of n.

# See also:
#   https://oeis.org/A049417
#   https://oeis.org/A077609

use 5.036;
use ntheory qw(:all);

sub infinitary_divisors ($n) {

    my @d = (1);

    foreach my $pp (factor_exp($n)) {
        my ($p, $e) = @$pp;

        my @t;
        my $r = 1;
        foreach my $j (1 .. $e) {
            $r = mulint($r, $p);
            if (($e & $j) == $j) {
                push @t, map { mulint($r, $_) } @d;
            }
        }
        push @d, @t;
    }

    return sort { $a <=> $b } @d;
}

foreach my $n (1 .. 20) {
    my @idivisors = infinitary_divisors($n);
    say "i-divisors of $n: [@idivisors]";
}

__END__
i-divisors of 1: [1]
i-divisors of 2: [1 2]
i-divisors of 3: [1 3]
i-divisors of 4: [1 4]
i-divisors of 5: [1 5]
i-divisors of 6: [1 2 3 6]
i-divisors of 7: [1 7]
i-divisors of 8: [1 2 4 8]
i-divisors of 9: [1 9]
i-divisors of 10: [1 2 5 10]
i-divisors of 11: [1 11]
i-divisors of 12: [1 3 4 12]
i-divisors of 13: [1 13]
i-divisors of 14: [1 2 7 14]
i-divisors of 15: [1 3 5 15]
i-divisors of 16: [1 16]
i-divisors of 17: [1 17]
i-divisors of 18: [1 2 9 18]
i-divisors of 19: [1 19]
i-divisors of 20: [1 4 5 20]


================================================
FILE: Math/inverse_of_bernoulli_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 June 2017
# Edit: 28 August 2023
# https://github.com/trizen

# Inverse of Bernoulli numbers, based on the inverse of the following asymptotic formula:
#   |Bn| ~ 2 / (2*pi)^n * n!

# Using Stirling's approximation for n!, we have:
#   |Bn| ~ 2 / (2*pi)^n * sqrt(2*pi*n) * (n/e)^n

# This gives us the following inverse formula:
#   n ~ lgrt((|Bn| / (4*pi))^(1/(2*pi*e))) * 2*pi*e - 1/2

# Where `lgrt(n)` is defined as:
#   lgrt(x^x) = x

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload tau e LambertW lgrt log bernreal);

sub inv_bern_W ($n) {
    my $L = log($n / 2) - log(tau);
    $L / LambertW($L / (tau * e)) - 1 / 2;
}

sub inv_bern_lgrt ($n) {
    lgrt(($n / (2 * tau))**(1 / (e * tau))) * e * tau - 1 / 2;
}

my $x = abs(bernreal(1000000));

say inv_bern_W($x);       #=> 999999.999999996521295786570230337488233833193417
say inv_bern_lgrt($x);    #=> 999999.999999996521295786570230337488233833193417


================================================
FILE: Math/inverse_of_euler_totient.pl
================================================
#!/usr/bin/perl

# Given a positive integer `n`, this algorithm finds all the numbers k such that φ(k) = n.

use utf8;
use 5.010;
use strict;
use warnings;

use ntheory qw(is_prime divisors valuation);

binmode(STDOUT, ':utf8');

# Based on Dana Jacobsen's code from Math::Prime::Util,
# which in turn is based on invphi.gp v1.3 by Max Alekseyev.

# See also:
#   https://projecteuler.net/problem=248
#   https://en.wikipedia.org/wiki/Euler%27s_totient_function
#   https://github.com/danaj/Math-Prime-Util/blob/master/examples/inverse_totient.pl

sub inverse_euler_phi {
    my ($n) = @_;

    my %r = (1 => [1]);

    foreach my $d (divisors($n)) {

        is_prime($d + 1) || next;

        my %temp;
        foreach my $k (1 .. (valuation($n, $d + 1) + 1)) {

            my $u = $d * ($d + 1)**($k - 1);
            my $v = ($d + 1)**$k;

            foreach my $f (divisors($n / $u)) {
                if (exists $r{$f}) {
                    push @{$temp{$f * $u}}, map { $v * $_ } @{$r{$f}};
                }
            }
        }

        while (my ($i, $v) = each(%temp)) {
            push @{$r{$i}}, @$v;
        }
    }

    return if not exists $r{$n};
    return sort { $a <=> $b } @{$r{$n}};
}

foreach my $n(1..70) {
    if (my @inv = inverse_euler_phi($n)) {
        say "φ−¹($n) = [", join(', ', @inv), "]";
    }
}


================================================
FILE: Math/inverse_of_factorial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 July 2016
# Edit: 23 October 2017
# https://github.com/trizen

# Compute the inverse of n-factorial.
# The function is defined only for factorial numbers.
# It may return non-sense for non-factorials.

# See also:
#   https://oeis.org/A090368

use 5.010;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(valuation factor factorial);

sub factorial_prime_pow ($n, $p) {

    my $count = 0;
    my $ppow  = $p;

    while ($ppow <= $n) {
        $count += int($n / $ppow);
        $ppow *= $p;
    }

    return $count;
}

sub p_adic_inverse ($p, $k) {

    my $n = $k * ($p - 1);
    while (factorial_prime_pow($n, $p) < $k) {
        $n -= $n % $p;
        $n += $p;
    }

    return $n;
}

sub inverse_of_factorial ($f) {

    return 1 if $f == 1;

    my $t = valuation($f, 2);         # largest power of 2 in f
    my $z = p_adic_inverse(2, $t);    # smallest number z such that 2^t divides z!
    my $d = (factor($z + 1))[-1];     # largest factor of z+1

    if (valuation($f, $d) != factorial_prime_pow($z + 1, $d)) {
        return $z;
    }

    return $z + 1;
}

foreach my $n (1 .. 30) {

    my $f = factorial($n);
    my $i = inverse_of_factorial($f);

    say "$i! = $f";

    if ($i != $n) {
        die "error: $i != $n";
    }
}


================================================
FILE: Math/inverse_of_factorial_stirling.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 18 September 2016
# Website: https://github.com/trizen

# The inverse of n factorial, based on the inverse of Stirling approximation.

# Formula from:
#   https://math.stackexchange.com/questions/430167/is-there-an-inverse-to-stirlings-approximation

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload tau e factorial);

use constant S => tau->sqrt->log;
use constant T => tau->root(-2.0 * e);

sub inverse_factorial_W {
    my ($n) = @_;
    my $L = log($n) - S;
    $L / ($L / e)->LambertW - 0.5;
}

sub inverse_factorial_lgrt {
    my ($n) = @_;
    (T * $n**(1 / e))->lgrt * e - 0.5;
}

for my $n (1 .. 100) {

    my $f = factorial($n);
    my $i = inverse_factorial_W($f);
    my $j = inverse_factorial_lgrt($f);

    printf("F(%2s!) =~ %s\n", $n, $i);

    if ($i->round(-20) != $j->round(-20)) {
        die "$i != $j";
    }

    if ($i->round != $n) {
        die "However that is incorrect! (expected: $n -- got ", $i->round, ")";
    }
}


================================================
FILE: Math/inverse_of_fibonacci.pl
================================================
#!/usr/bin/perl

# Find the position of a Fibonacci number in the Fibonacci sequence.

# See also:
#   https://en.wikipedia.org/wiki/Fibonacci_number#Recognizing_Fibonacci_numbers

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload fibonacci is_square isqrt phi);

sub fibonacci_inverse ($n) {

    my $m = 5 * $n * $n;

    if (is_square($m - 4)) {
        $m = isqrt($m - 4);
    }
    elsif (is_square($m + 4)) {
        $m = isqrt($m + 4);
    }
    else {
        return -1;    # not a Fibonacci number
    }

    log(($n * sqrt(5) + $m) / 2) / log(phi);
}

say fibonacci_inverse(fibonacci(100));    #=> 100
say fibonacci_inverse(fibonacci(101));    #=> 101


================================================
FILE: Math/inverse_of_multiplicative_functions.pl
================================================
#!/usr/bin/perl

# Computing the inverse of some multiplicative functions.
# Translation of invphi.gp ver. 2.1 by Max Alekseyev.

# See also:
#   https://home.gwu.edu/~maxal/gpscripts/

use utf8;
use 5.020;
use strict;
use warnings;

use ntheory      qw(:all);
use experimental qw(signatures);

sub dynamicPreimage ($N, $L, %opt) {

    # Phase 1: Determine which intermediate values are actually needed
    my %needed = ($N => undef);
    my @operations;

    foreach my $l (@$L) {
        my @current_ops;

        foreach my $pair (@$l) {
            my ($x, $y) = @$pair;

            foreach my $d (divisors(divint($N, $x))) {
                my $F = mulint($x, $d);

                # Only track operations that lead to needed values
                if (exists $needed{$F}) {
                    undef $needed{$d};
                    push @current_ops, [$d, $y, $F];
                }
            }
        }
        unshift @operations, \@current_ops if @current_ops;
    }

    undef %needed;

    # Phase 2: Process operations, keeping only needed intermediate results
    my %r = (1 => [1]);

    foreach my $ops (@operations) {
        my %t;

        foreach my $op (@$ops) {
            my ($d, $y, $F) = @$op;

            if (exists $r{$d}) {
                my @list = @{$r{$d}};
                if ($opt{unitary}) {
                    @list = grep { gcd($_, $y) == 1 } @list;
                }
                push @{$t{$F}}, map { mulint($_, $y) } @list;
            }
        }

        while (my ($k, $v) = each %t) {
            push @{$r{$k}}, @$v;
        }
    }

    return if !exists $r{$N};
    sort { $a <=> $b } @{$r{$N}};
}

sub dynamicLen ($N, $L) {

    my %r = (1 => 1);

    foreach my $l (@$L) {
        my %t;

        foreach my $pair (@$l) {
            my ($x, $y) = @$pair;

            foreach my $d (divisors(divint($N, $x))) {
                if (exists $r{$d}) {
                    $t{mulint($x, $d)} += $r{$d};
                }
            }
        }
        while (my ($k, $v) = each %t) {
            $r{$k} += $v;
        }
    }

    $r{$N} // 0;
}

sub dynamicMin ($N, $L) {

    my %r = (1 => 1);

    foreach my $l (@$L) {
        my %t;

        foreach my $pair (@$l) {
            my ($x, $y) = @$pair;

            foreach my $d (divisors(divint($N, $x))) {
                if (exists $r{$d}) {

                    my $k = mulint($x, $d);
                    my $v = mulint($r{$d}, $y);

                    if (not defined($t{$k})) {
                        $t{$k} = $v;
                    }
                    else {
                        $t{$k} = $v if ($v < $t{$k});
                    }
                }
            }
        }
        while (my ($k, $v) = each %t) {
            if (not defined($r{$k})) {
                $r{$k} = $v;
            }
            else {
                $r{$k} = $v if ($v < $r{$k});
            }
        }
    }

    $r{$N};
}

sub dynamicMax ($N, $L) {

    my %r = (1 => 1);

    foreach my $l (@$L) {
        my %t;

        foreach my $pair (@$l) {
            my ($x, $y) = @$pair;

            foreach my $d (divisors(divint($N, $x))) {
                if (exists $r{$d}) {

                    my $k = mulint($x, $d);
                    my $v = mulint($r{$d}, $y);

                    if (not defined($t{$k})) {
                        $t{$k} = $v;
                    }
                    else {
                        $t{$k} = $v if ($v > $t{$k});
                    }
                }
            }
        }
        while (my ($k, $v) = each %t) {
            if (not defined($r{$k})) {
                $r{$k} = $v;
            }
            else {
                $r{$k} = $v if ($v > $r{$k});
            }
        }
    }

    $r{$N};
}

sub cook_sigma ($N, $k) {
    my %L;

    foreach my $d (divisors($N)) {

        next if ($d == 1);

        foreach my $p (map { $_->[0] } factor_exp(subint($d, 1))) {

            my $q = addint(mulint($d, subint(powint($p, $k), 1)), 1);
            my $t = valuation($q, $p);

            next if ($t <= $k or ($t % $k) or $q != powint($p, $t));

            push @{$L{$p}}, [$d, powint($p, subint(divint($t, $k), 1))];
        }
    }

    [values %L];
}

sub cook_phi ($N) {
    my %L;

    foreach my $d (divisors($N)) {
        my $p = addint($d, 1);
        is_prime($p) || next;
        my $v = valuation($N, $p);
        push @{$L{$p}}, map { [mulint($d, powint($p, $_ - 1)), powint($p, $_)] } 1 .. $v + 1;
    }

    [values %L];
}

sub cook_psi ($N) {
    my %L;

    foreach my $d (divisors($N)) {
        my $p = subint($d, 1);
        is_prime($p) || next;
        my $v = valuation($N, $p);
        push @{$L{$p}}, map { [mulint($d, powint($p, $_ - 1)), powint($p, $_)] } 1 .. $v + 1;
    }

    [values %L];
}

sub cook_usigma ($N) {
    my @list;
    foreach my $d (divisors($N)) {
        if (is_prime_power(subint($d, 1))) {
            push @list, [[$d, subint($d, 1)]];
        }
    }
    return \@list;
}

sub cook_uphi ($N) {
    my @list;
    foreach my $d (divisors($N)) {
        if (is_prime_power(addint($d, 1))) {
            push @list, [[$d, addint($d, 1)]];
        }
    }
    return \@list;
}

# Inverse of sigma function

sub inverse_sigma ($N, $k = 1) {
    dynamicPreimage($N, cook_sigma($N, $k));
}

sub inverse_sigma_min ($N, $k = 1) {
    dynamicMin($N, cook_sigma($N, $k));
}

sub inverse_sigma_max ($N, $k = 1) {
    dynamicMax($N, cook_sigma($N, $k));
}

sub inverse_sigma_len ($N, $k = 1) {
    dynamicLen($N, cook_sigma($N, $k));
}

# Inverse of Euler phi function

sub inverse_phi ($N) {
    dynamicPreimage($N, cook_phi($N));
}

sub inverse_phi_min ($N) {
    dynamicMin($N, cook_phi($N));
}

sub inverse_phi_max ($N) {
    dynamicMax($N, cook_phi($N));
}

sub inverse_phi_len ($N) {
    dynamicLen($N, cook_phi($N));
}

# Inverse of Dedekind psi function

sub inverse_psi ($N) {
    dynamicPreimage($N, cook_psi($N));
}

sub inverse_psi_min ($N) {
    dynamicMin($N, cook_psi($N));
}

sub inverse_psi_max ($N) {
    dynamicMax($N, cook_psi($N));
}

sub inverse_psi_len ($N) {
    dynamicLen($N, cook_psi($N));
}

# Inverse of unitary sigma function

sub inverse_usigma ($N) {
    dynamicPreimage($N, cook_usigma($N), unitary => 1);
}

# Inverse of unitary phi function

sub inverse_uphi ($N) {
    dynamicPreimage($N, cook_uphi($N), unitary => 1);
}

## Usage example

say join ', ', inverse_sigma(120);         #=> [54, 56, 87, 95]
say join ', ', inverse_usigma(120);        #=> [60, 87, 92, 95, 99]
say join ', ', inverse_uphi(120);          #=> [121, 143, 144, 155, 164, 183, 220, 231, 240, 242, 286, 310, 366, 462]
say join ', ', inverse_phi(120);           #=> [143, 155, 175, 183, 225, 231, 244, 248, 286, 308, 310, 350, 366, 372, 396, 450, 462]
say join ', ', inverse_psi(120);           #=> [75, 76, 87, 95]
say join ', ', inverse_sigma(22100, 2);    #=> [120, 130, 141]

say '';

say inverse_sigma_min(factorial(10));      #=> 876960
say inverse_sigma_max(factorial(10));      #=> 3624941
say inverse_sigma_len(factorial(10));      #=> 1195

say '';

say inverse_phi_min(factorial(10));        #=> 3632617
say inverse_phi_max(factorial(10));        #=> 19969950
say inverse_phi_len(factorial(10));        #=> 3802

say '';

say inverse_psi_min(factorial(10));        #=> 1160250
say inverse_psi_max(factorial(10));        #=> 3624941
say inverse_psi_len(factorial(10));        #=> 1793

say '';


================================================
FILE: Math/inverse_of_p_adic_valuation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 September 2017
# https://github.com/trizen

# Find the smallest number `n` such that `n!` has at least `k` factors of prime `p`.

# See also:
#   https://projecteuler.net/problem=320
#   https://en.wikipedia.org/wiki/Legendre%27s_formula

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(vecsum todigits);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub p_adic_inverse ($p, $k) {

    my $n = $k * ($p - 1);
    while (factorial_power($n, $p) < $k) {
        $n -= $n % $p;
        $n += $p;
    }

    return $n;
}

say p_adic_inverse(2,  100);           #=> 104
say p_adic_inverse(3,  51);            #=> 108
say p_adic_inverse(2,  992);           #=> 1000
say p_adic_inverse(13, 83333329);      #=> 999999988
say p_adic_inverse(97, 1234567890);    #=> 118518517733

say factorial_power(p_adic_inverse(7,  1234567890), 7);     #=> 1234567890
say factorial_power(p_adic_inverse(23, 1234567890), 23);    #=> 1234567890
say factorial_power(p_adic_inverse(97, 1234567890), 97);    #=> 1234567890


================================================
FILE: Math/inverse_of_sigma_function.pl
================================================
#!/usr/bin/perl

# Given a positive integer `n`, this algorithm finds all the numbers k
# such that sigma(k) = n, where `sigma(k)` is the sum of divisors of `k`.

# Based on "invphi.gp" code by Max Alekseyev.

# See also:
#   https://home.gwu.edu/~maxal/gpscripts/

use utf8;
use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);
use List::Util qw(uniq);
#use Math::AnyNum qw(:overload);

binmode(STDOUT, ':utf8');

sub inverse_sigma ($n, $m = 3) {

    return (1) if ($n == 1);

    my @R;
    foreach my $d (grep { $_ >= $m } divisors($n)) {
        foreach my $p (map { $_->[0] } factor_exp($d - 1)) {
            my $P = $d * ($p - 1) + 1;
            my $k = valuation($P, $p) - 1;
            next if (($k < 1) || ($P != $p**($k + 1)));
            push @R, map { $_ * $p**$k } grep { $_ % $p != 0; } __SUB__->($n/$d, $d);
        }
    }

    sort { $a <=> $b } uniq(@R);
}

foreach my $n (1 .. 70) {
    (my @inv = inverse_sigma($n)) || next;
    say "σ−¹($n) = [", join(', ', @inv), ']';
}

__END__
σ−¹(1) = [1]
σ−¹(3) = [2]
σ−¹(4) = [3]
σ−¹(6) = [5]
σ−¹(7) = [4]
σ−¹(8) = [7]
σ−¹(12) = [6, 11]
σ−¹(13) = [9]
σ−¹(14) = [13]
σ−¹(15) = [8]
σ−¹(18) = [10, 17]
σ−¹(20) = [19]
σ−¹(24) = [14, 15, 23]
σ−¹(28) = [12]
σ−¹(30) = [29]
σ−¹(31) = [16, 25]
σ−¹(32) = [21, 31]
σ−¹(36) = [22]
σ−¹(38) = [37]
σ−¹(39) = [18]
σ−¹(40) = [27]
σ−¹(42) = [26, 20, 41]
σ−¹(44) = [43]
σ−¹(48) = [33, 35, 47]


================================================
FILE: Math/inverse_of_sigma_function_fast.pl
================================================
#!/usr/bin/perl

# Given a positive integer `n`, this algorithm finds all the numbers k
# such that sigma(k) = n, where `sigma(k)` is the sum of divisors of `k`.

# Based on "invphi.gp" code by Max Alekseyev.

# See also:
#   https://home.gwu.edu/~maxal/gpscripts/

use utf8;
use 5.020;
use strict;
use warnings;

use Math::Prime::Util::GMP qw(:all);
use List::Util qw(uniq);
use experimental qw(signatures);

binmode(STDOUT, ':utf8');

sub inverse_sigma {
    my ($n) = @_;

    my %cache;
    my %factor_cache;
    my %divisor_cache;

    my $results = sub ($n, $m) {

        return [1] if ($n == 1);

        my $key = "$n $m";
        if (exists $cache{$key}) {
            return $cache{$key};
        }

        my (@R, @D);
        $divisor_cache{$n} //= [divisors($n)];

        foreach my $d (@{$divisor_cache{$n}}) {
            if ($d >= $m) {

                push @D, $d;

                $factor_cache{$d} //= do {
                    my %factors;
                    @factors{factor(subint($D[-1], 1))} = ();
                    [keys %factors];
                };
            }
        }

        foreach my $d (@D) {
            foreach my $p (@{$factor_cache{$d}}) {

                my $r = addint(mulint($d, subint($p, 1)), 1);
                my $k = valuation($r, $p) - 1;
                next if ($k < 1);

                my $s = powint($p, $k + 1);
                next if ("$r" ne "$s");
                my $z = powint($p, $k);

                my $u   = divint($n, $d);
                my $arr = __SUB__->($u, $d);

                foreach my $v (@$arr) {
                    if (modint($v, $p) != 0) {
                        push @R, mulint($v, $z);
                    }
                }
            }
        }

        $cache{$key} = \@R;
    }->($n, 3);

    sort { $a <=> $b } uniq(@$results);
}

my %tests = (
     6 => 6187272, 10 => 196602,  11 => 8105688, 16 => 2031554,
    25 => 1355816, 31 => 8880128, 80 => 11532,   97 => 5488,
);

while (my ($n, $k) = each %tests) {
    my @inverse = inverse_sigma($k);
    say "σ−¹($k) = [@inverse]";
    if (gcd(@inverse) != $n) {
        die "Error for k = $k";
    }
}

use Test::More;
plan tests => 4;

is(join(' ', inverse_sigma(42)), join(' ', 20, 26, 41));
is(join(' ', inverse_sigma(7688)), join(' ', 2800, 2928, 4575, 7687));
is(join(' ', inverse_sigma("110680464442257309690")), "46116860184273879040");
is(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");

__END__
σ−¹(6187272) = [2855646 2651676]
σ−¹(196602) = [105650 81920]
σ−¹(8105688) = [4953454 4947723]
σ−¹(2031554) = [845200 999424]
σ−¹(8880128) = [6389751 7527079]
σ−¹(5488) = [3783 2716]
σ−¹(11532) = [4880 4400]
σ−¹(1355816) = [457500 390000 811875 624700]


================================================
FILE: Math/inverse_of_sigma_function_generalized.pl
================================================
#!/usr/bin/perl

# Computing the inverse of the sigma_k(n) function, for any k >= 1.
# Translation of invphi.gp ver. 2.1 by Max Alekseyev.

# See also:
#   https://home.gwu.edu/~maxal/gpscripts/

use utf8;
use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub dynamicPreimage ($N, $L) {

    my %r = (1 => [1]);

    foreach my $l (@$L) {
        my %t;

        foreach my $pair (@$l) {
            my ($x, $y) = @$pair;

            foreach my $d (divisors(divint($N, $x))) {
                if (exists $r{$d}) {
                    push @{$t{mulint($x, $d)}}, map { mulint($_, $y) } @{$r{$d}};
                }
            }
        }
        while (my ($k, $v) = each %t) {
            push @{$r{$k}}, @$v;
        }
    }

    return if !exists $r{$N};
    sort { $a <=> $b } @{$r{$N}};
}

sub cook_sigma ($N, $k) {
    my %L;

    foreach my $d (divisors($N)) {

        next if ($d == 1);

        foreach my $p (map { $_->[0] } factor_exp(subint($d, 1))) {

            my $q = addint(mulint($d, subint(powint($p, $k), 1)), 1);
            my $t = valuation($q, $p);

            next if ($t <= $k or ($t % $k) or $q != powint($p, $t));

            push @{$L{$p}}, [$d, powint($p, subint(divint($t, $k), 1))];
        }
    }

    [values %L];
}

sub inverse_sigma ($N, $k = 1) {
    dynamicPreimage($N, cook_sigma($N, $k));
}

say join ', ', inverse_sigma(120);         #=> [54, 56, 87, 95]
say join ', ', inverse_sigma(22100, 2);    #=> [120, 130, 141]


================================================
FILE: Math/inverse_of_usigma_function.pl
================================================
#!/usr/bin/perl

# Given a positive integer `n`, this algorithm finds all the numbers k
# such that usigma(k) = n, where `usigma(k)` is the sum of the unitary divisors of `k`.

# usigma(n) is multiplicative with usigma(p^k) = p^k + 1.

# See also:
#   https://oeis.org/A034448 -- usigma(n)
#   https://home.gwu.edu/~maxal/gpscripts/

use utf8;
use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub inverse_usigma ($n) {

    my %r = (1 => [1]);

    foreach my $d (divisors($n)) {

        my $D = subint($d, 1);
        is_prime_power($D) || next;

        my %temp;

        foreach my $f (divisors(divint($n, $d))) {
            if (exists $r{$f}) {
                push @{$temp{mulint($f, $d)}}, map { mulint($D, $_) }
                  grep { gcd($D, $_) == 1 } @{$r{$f}};
            }
        }

        while (my ($key, $value) = each(%temp)) {
            push @{$r{$key}}, @$value;
        }
    }

    return if not exists $r{$n};
    return sort { $a <=> $b } @{$r{$n}};
}

my $n = 186960;

say "Solutions for usigma(x) = $n: ", join(' ', inverse_usigma($n));

__END__
Solutions 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


================================================
FILE: Math/inverse_tau_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 May 2026
# https://github.com/trizen

# Generate all the numbers in a given range [A,B] that have exactly `n` divisors.

use 5.036;
use ntheory 0.74 qw(:all);

sub rootint_ceil($n, $k) {
    rootint($n, $k) + (is_power($n, $k) ? 0 : 1);
}

sub unique_permutations($array, $callback) {
    sub ($items, $current_perm) {

        if (!@$items) {
            $callback->($current_perm);
            return;
        }

        my %level_seen;
        for my $i (0 .. $#$items) {
            my $item = $items->[$i];

            # Skip iterations for duplicate elements in the same level
            next if $level_seen{$item}++;

            my @new_items = @$items;
            splice(@new_items, $i, 1);

            my @new_perm = (@$current_perm, $item);
            __SUB__->(\@new_items, \@new_perm);
        }
    }->($array, []);
}

sub prime_signature_numbers_in_range($A, $B, $prime_signature) {

    my @list;
    my $k = scalar(@$prime_signature);

    if ($k == 0) {
        push(@list, 1) if ($A <= 1 and 1 <= $B);
        return @list;
    }

    # The smallest possible number with k distinct prime factors
    $A = vecmax(pn_primorial($k), $A);

    my $generate = sub ($m, $lo, $k, $P, $sum_e) {

        my $e  = $P->[$k - 1];
        my $hi = rootint(divint($B, $m), $sum_e);

        if ($lo > $hi) {
            return;
        }

        # Base case
        if ($k == 1) {

            # Tighten the lower bound based on A
            my $lo_tight = vecmax($lo, rootint_ceil(cdivint($A, $m), $e));

            foreach my $p (@{primes($lo_tight, $hi)}) {
                push @list, mulint($m, powint($p, $e));
            }

            return;
        }

        for (my $p = $lo ; $p <= $hi ;) {
            my $t = mulint($m, powint($p, $e));
            my $r = next_prime($p);
            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e);
            $p = $r;
        }
    };

    my $sum_e = vecsum(@$prime_signature) || return;

    if ($sum_e > logint($B, 2)) {
        return;
    }

    unique_permutations(
        $prime_signature,
        sub ($perm) {
            $generate->(1, 2, scalar(@$perm), $perm, $sum_e);
        }
    );

    return @list;
}

sub multiplicative_partitions($n, $max_value = $n) {

    my @results;
    my @divs = divisors($n);

    shift(@divs);   # remove divisor '1'

    my $end = $#divs;
    sub ($target, $min_idx, $path) {

        if ($target == 1) {
            push @results, $path;
            return;
        }

        for my $i ($min_idx .. $end) {
            my $d = $divs[$i];

            # Prune branch if the divisor exceeds the remaining target
            last if $d > $target;
            last if $d > $max_value;

            if ($target % $d == 0) {
                __SUB__->(divint($target, $d), $i, [@$path, $d]);
            }
        }
    }->($n, 0, []);

    return @results;
}

sub inverse_tau($A, $B, $n) {

    my @signatures = map {
        [map { $_ - 1 } @$_]
    } multiplicative_partitions($n, logint($B, 2) + 1);

    my @list;
    foreach my $sig (@signatures) {
        push @list, prime_signature_numbers_in_range($A, $B, $sig);
    }

    @list = sort { $a <=> $b } @list;

    return @list;
}

scalar(inverse_tau(1, 462, 16)) == 16 or die "error";
scalar(inverse_tau(1, powint(2, 9), 10)) == 13 or die "error";
scalar(inverse_tau(1, powint(2, 40), 5040)) == 103 or die "error";

my @arr = inverse_tau(1e5, 1e5 + 500, 48);
say "@arr";    #=> 100050 100128 100152 100200 100254 100296 100380 100386 100485 100500


================================================
FILE: Math/invert_transform_of_factorials.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 December 2017
# https://github.com/trizen

# A new algorithm for computing the invert transform of factorial numbers.

# See also:
#   https://oeis.org/A051296

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload factorial binomial);

sub invert_transform_of_factorials {
    my ($n) = @_;

    my @F = (1);

    foreach my $i (1 .. $n) {
        foreach my $k (0 .. $i - 1) {
            $F[$i] += $F[$k] / binomial($i, $k);
        }
    }

    map { $F[$_] * factorial($_) } 0 .. $#F;
}

my @F = invert_transform_of_factorials(20);

foreach my $i (0 .. $#F) {
    say "F($i) = $F[$i]";
}

__END__
F(0) = 1
F(1) = 1
F(2) = 3
F(3) = 11
F(4) = 47
F(5) = 231
F(6) = 1303
F(7) = 8431
F(8) = 62391
F(9) = 524495
F(10) = 4960775
F(11) = 52223775
F(12) = 605595319
F(13) = 7664578639
F(14) = 105046841127
F(15) = 1548880173119
F(16) = 24434511267863
F(17) = 410503693136559
F(18) = 7315133279097607
F(19) = 137787834979031839
F(20) = 2734998201208351479


================================================
FILE: Math/is_absolute_euler_pseudoprime.pl
================================================
#!/usr/bin/perl

# Check if a given number is an absolute Euler pseudoprime.

# These are composite n such that abs(a^((n-1)/2) mod n) = 1 for all a with gcd(a,n) = 1.

# See also:
#   https://oeis.org/A033181 -- Absolute Euler pseudoprimes
#   https://en.wikipedia.org/wiki/Euler_pseudoprime

use 5.014;
use ntheory qw(:all);
use experimental qw(signatures);

sub is_absolute_euler_pseudoprime ($n) {
    is_carmichael($n)
        and vecall { (($n-1)>>1) % ($_-1) == 0 } factor($n);
}

foroddcomposites {
    say $_ if is_absolute_euler_pseudoprime($_);
} 1e6;


================================================
FILE: Math/is_almost_prime.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 17 February 2023
# https://github.com/trizen

# A simple and fast method for checking if a given integer n has exactly k prime factors (i.e.: bigomega(n) = k).

use 5.020;
use warnings;

use ntheory      qw(:all);
use experimental qw(signatures);

use Math::GMPz;
use Math::Prime::Util::GMP;

use constant {
              TRIAL_LIMIT        => 1e3,
              HAS_NEW_PRIME_UTIL => defined(&Math::Prime::Util::is_almost_prime),
             };

my @SMALL_PRIMES = @{primes(TRIAL_LIMIT)};

sub mpz_is_almost_prime ($n, $k) {

    state $z = Math::GMPz::Rmpz_init();
    state $t = Math::GMPz::Rmpz_init();

    if ($n == 0) {
        return 0;
    }

    Math::GMPz::Rmpz_set_str($z, "$n", 10);
    Math::GMPz::Rmpz_root($t, $z, $k);

    my $trial_limit = Math::GMPz::Rmpz_get_ui($t);

    if ($trial_limit > TRIAL_LIMIT or !Math::GMPz::Rmpz_fits_ulong_p($t)) {
        $trial_limit = TRIAL_LIMIT;
    }

    foreach my $p (@SMALL_PRIMES) {

        last if ($p > $trial_limit);

        if (Math::GMPz::Rmpz_divisible_ui_p($z, $p)) {
            Math::GMPz::Rmpz_set_ui($t, $p);
            $k -= Math::GMPz::Rmpz_remove($z, $z, $t);
        }

        ($k > 0) or last;

        if (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z)) {
            return Math::Prime::Util::is_almost_prime($k, Math::GMPz::Rmpz_get_ui($z));
        }
    }

    if ($k < 0) {
        return 0;
    }

    if (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0) {
        return ($k == 0);
    }

    if ($k == 0) {
        return (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);
    }

    if ($k == 1) {

        if (Math::GMPz::Rmpz_fits_ulong_p($z)) {
            return is_prime(Math::GMPz::Rmpz_get_ui($z));
        }

        return Math::Prime::Util::GMP::is_prime(Math::GMPz::Rmpz_get_str($z, 10));
    }

    Math::GMPz::Rmpz_ui_pow_ui($t, next_prime($trial_limit), $k);

    if (Math::GMPz::Rmpz_cmp($z, $t) < 0) {
        return 0;
    }

    (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z))
      ? Math::Prime::Util::is_almost_prime($k, Math::GMPz::Rmpz_get_ui($z))
      : (factor(Math::GMPz::Rmpz_get_str($z, 10)) == $k);
}

foreach my $n (1 .. 100) {
    my $t = urandomb($n) + 1;

    say "Testing: $t";

    foreach my $k (1 .. 20) {
        if (HAS_NEW_PRIME_UTIL ? Math::Prime::Util::is_almost_prime($k, $t) : (factor($t) == $k)) {
            mpz_is_almost_prime($t, $k) || die "error for: ($t, $k)";
        }
        elsif (mpz_is_almost_prime($t, $k)) {
            die "counter-example: ($t, $k)";
        }
    }
}


================================================
FILE: Math/is_bfsw_pseudoprime.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 31 October 2023
# https://github.com/trizen

# A new primality test, using only the Lucas V sequence.

# This test is a simplification of the strengthen BPSW test:
# https://arxiv.org/abs/2006.14425

use 5.036;
use Math::GMPz;

use constant {
              USE_METHOD_A_STAR => 0,    # true to use the A* method in finding (P,Q)
             };

sub check_lucasV ($P, $Q, $m) {

    state $t = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_add_ui($t, $m, 1);

    my $s = Math::GMPz::Rmpz_scan1($t, 0);
    Math::GMPz::Rmpz_div_2exp($t, $t, $s + 1);

    my $V1 = Math::GMPz::Rmpz_init_set_ui(2);
    my $V2 = Math::GMPz::Rmpz_init_set_ui($P);

    my $Q1 = Math::GMPz::Rmpz_init_set_ui(1);
    my $Q2 = Math::GMPz::Rmpz_init_set_ui(1);

    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($t, 2))) {

        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);

        if ($bit) {
            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);
            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);
            Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);
            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);
            Math::GMPz::Rmpz_mod($V1, $V1, $m);
        }
        else {
            Math::GMPz::Rmpz_set($Q2, $Q1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
            Math::GMPz::Rmpz_submul_ui($V2, $Q1, $P);
            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);
            Math::GMPz::Rmpz_mod($V2, $V2, $m);
        }
    }

    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
    Math::GMPz::Rmpz_mod($Q1, $Q1, $m);

    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
    Math::GMPz::Rmpz_mul($V1, $V1, $V2);
    Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);
    Math::GMPz::Rmpz_mul($Q2, $Q2, $Q1);

    for (1 .. $s) {
        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
        Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);
        Math::GMPz::Rmpz_powm_ui($Q2, $Q2, 2, $m);
    }

    Math::GMPz::Rmpz_mod($V1, $V1, $m);

    Math::GMPz::Rmpz_set_si($t, 2 * $Q);
    Math::GMPz::Rmpz_congruent_p($V1, $t, $m) || return 0;

    Math::GMPz::Rmpz_set_si($t, $Q * $Q);
    Math::GMPz::Rmpz_congruent_p($Q2, $t, $m) || return 0;

    return 1;
}

sub findQ ($n) {
    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);

        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);

        if ($K == -1) {
            return ((1 - $D) / 4);
        }
        elsif ($K == 0 and abs($D) < $n) {
            return undef;
        }
        elsif ($k == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {
            return undef;
        }
    }
}

sub findP ($n, $Q) {
    for (my $P = 2 ; ; ++$P) {
        my $D = $P * $P - 4 * $Q;

        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);

        if ($K == -1) {
            return $P;
        }
        elsif ($K == 0 and abs($D) < $n) {
            return undef;
        }
        elsif ($P == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {
            return undef;
        }
    }
}

sub is_bfsw_psp ($n) {

    $n = Math::GMPz::Rmpz_init_set_str($n, 10) if ref($n) ne 'Math::GMPz';

    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;
    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;
    return 0 if Math::GMPz::Rmpz_even_p($n);

    my ($P, $Q);

    if (USE_METHOD_A_STAR) {
        $P = 1;
        $Q = findQ($n) // return 0;

        if ($Q == -1) {
            $P = 5;
            $Q = 5;
        }
    }
    else {
        $Q = -2;
        $P = findP($n, $Q) // return 0;
    }

    check_lucasV($P, $Q, $n);
}

my @strong_lucas_psp = (
                        5459,   5777,   10877,  16109,  18971,  22499,  24569,  25199,  40309,  58519,  75077,  97439,
                        100127, 113573, 115639, 130139, 155819, 158399, 161027, 162133, 176399, 176471, 189419, 192509,
                        197801, 224369, 230691, 231703, 243629, 253259, 268349, 288919, 313499, 324899
                       );
my @extra_strong_lucas_psp = (
                              989,    3239,   5777,   10877,  27971,  29681,  30739,  31631,  39059,  72389,  73919,  75077,
                              100127, 113573, 125249, 137549, 137801, 153931, 155819, 161027, 162133, 189419, 218321, 231703,
                              249331, 370229, 429479, 430127, 459191, 473891, 480689, 600059, 621781, 632249, 635627
                             );

foreach my $n (913, 150267335403, 430558874533, 14760229232131, 936916995253453, @strong_lucas_psp, @extra_strong_lucas_psp) {
    if (is_bfsw_psp($n)) {
        say "Counter-example: $n";
    }
}

use ntheory qw(is_prime);

my $from  = 1;
my $to    = 1e5;
my $count = 0;

foreach my $n ($from .. $to) {
    if (is_bfsw_psp($n)) {
        if (not is_prime($n)) {
            say "Counter-example: $n";
        }
        ++$count;
    }
    elsif (is_prime($n)) {
        say "Missed a prime: $n";
    }
}

say "There are $count primes between $from and $to.";

is_bfsw_psp(3 * Math::GMPz->new("2")**5134 - 1) or die "error";
is_bfsw_psp(Math::GMPz->new(10)**2000 + 4561)   or die "error";

__END__
Inspired 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.

The first observation was that none of the 5 vpsp terms < 10^15 satisfy:

Q^(n+1) == Q^2 (mod n)

This gives us a simple test:

V_{n+1}(P,Q) == 2*Q (mod n)
Q^(n+1) == Q^2 (mod n)

where (P,Q) are selected using Method A*.


================================================
FILE: Math/is_chernick_carmichael_number.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 21 July 2018
# https://github.com/trizen

# Efficient algorithm for factoring (and identifying) an extended Chernick-Carmichael number.

# The first few extended Chernick-Carmichael numbers are:
#   1729, 63973, 294409, 56052361, 118901521, 172947529, 216821881

# See also:
#   https://oeis.org/A317126
#   https://projecteuclid.org/euclid.bams/1183501763
#   https://oeis.org/wiki/Carmichael_numbers
#   https://en.wikipedia.org/wiki/Carmichael_number

use 5.024;
use warnings;
use experimental qw(signatures);

use List::Util qw(all);
use ntheory qw(is_prob_prime);
use Math::AnyNum qw(bsearch iroot ipow2 ilog2 is_div prod);

sub chernick_carmichael_factors ($k, $r) {
    (6 * $k + 1, 12 * $k + 1, 18 * $k + 1, (map { ipow2($_ - 2) * 9 * $k + 1 } 4 .. $r));
}

sub is_chernick_number ($n) {

    foreach my $r (3 .. ilog2($n)) {

        return 0 if (prod(chernick_carmichael_factors(1, $r)) > $n);

        my $k = bsearch(1, iroot($n, $r), sub {
            prod(chernick_carmichael_factors($_, $r)) <=> $n;
        });

        if (defined($k)) {
            if (all { is_prob_prime($_) } chernick_carmichael_factors($k, $r)) {
                return [$r, $k];
            }
        }
    }

    return 0;
}

sub is_chernick_carmichael_number ($n) {
    if (my $indices = is_chernick_number($n)) {
        my ($r, $k) = @$indices;
        is_div($k, Math::AnyNum->new(2)**($r-4)) || return 0;
        return $indices;
    }
    return 0;
}

while (defined(my $n = )) {

    $n =~ /\S/ or do { say ''; next };
    $n = Math::AnyNum->new($n);

    if (my $indices = is_chernick_number($n)) {
        my ($r, $k) = @$indices;
        say "C($r, $k) = $n" . (is_chernick_carmichael_number($n) ? '' : ' -- not a Carmichael number');
    }
    else {
        say "Not a Chernick-Carmichael number: $n";
    }
}

__DATA__
8325544586081174440728309072452661246289
1486602098904402652768057938393756060862115780408050129
3378179316469672624194241840042044950902156938854178152235606615241
499363105138762800665090830700779256789861194424677603719907844311565991734904219234049
1052541934726120302251454117065809600311128515412938768050107822597914636735491079562159895572772335029969

179888061095822220624012979873
63295903488856146099776074891976628857941
1724903525088632276776203991973751571437217198753
125987992642689799129021757759222604492631818017403553
74630998863011672833530378836051056508973606035192155974373
150807169001103453136788769176330405141656863663445656308543366854744067292801145941
21481148526108486207494916467772828869885661326738699922267375224852562302202790454088898856458273

521635331852681575100906881
115062400756082746082903913434881
328163039680360319939589778453584981903661
11870677991315757722817424115344135399200189518509
694757711287970946444438020864958912321095838203403981194280844652135041
222047766292417414109702829403660230521393563058846142752440148661965564062512001
2149862240504463136613099818734059855038070454228745908492682225005023324481983560300180977379301646829
8708697287275863064616447198348134859079135616902774104816953554105827536430199092250104748403143942843541581649
837766669080429652091578576905732301415513036087717526534117797730213142822067681852966424142891732971385451048036269

261398323061911176816691559756701
3783580131711518790634677710442261470580569797344541
435371627429039040724001132527124473123288702163349741876813423106621
14719770617180585920139917829493719272506560558845969856660560241654606362030081
8639174282669715206025361687559030161351650277392264712967444363592650828493196768893181
5626560312723043583857755308221019825156276365042073078860543702210734827773374603314058575101

24556868549786120178074590558386520603888321
6039952244643618043250948311869286217356083814166356276064323543587107521
67237835600056002507521755422513656134639570320064261052894337496662546902793661
9812486963666228314195838164491424691687915196563926066688165613493816842244920774774301
16734371894003494165203863331927626808333173646940855138811711887045893525137741919908066470621


================================================
FILE: Math/is_even_perfect.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 September 2016
# Website: https://github.com/trizen

# A very fast function that returns true when a given number is even-perfect. False otherwise.

# See also:
#   https://en.wikipedia.org/wiki/Perfect_number

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload is_power isqrt);
use ntheory qw(is_mersenne_prime is_prime_power);

sub is_even_perfect {
    my ($n) = @_;

    $n % 2 == 0 || return 0;

    my $square = 8 * $n + 1;
    is_power($square, 2) || return 0;

    my $tp = (isqrt($square) + 1) / 2;
    my $k = is_prime_power($tp, \my $base) || return 0;

    defined($base) && ($base == 2) && is_mersenne_prime($k) ? 1 : 0;
}

say is_even_perfect(191561942608236107294793378084303638130997321548169216);                           # true
say is_even_perfect(191561942608236107294793378084303638130997321548169214);                           # false
say is_even_perfect(191561942608236107294793378084303638130997321548169218);                           # false
say is_even_perfect(14474011154664524427946373126085988481573677491474835889066354349131199152128);    # true

# A much larger perfect number
say is_even_perfect(Math::AnyNum->new('141053783706712069063207958086063189881486743514715667838838675999954867742652380114104193329037690251561950568709829327164087724366370087116731268159313652487450652439805877296207297446723295166658228846926807786652870188920867879451478364569313922060370695064736073572378695176473055266826253284886383715072974324463835300053138429460296575143368065570759537328128'));

# Search test
say "=> Perfect numbers below 10^4:";
for my $n (1 .. 10000) {
    is_even_perfect($n) && say $n;
}


================================================
FILE: Math/is_even_perfect_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 September 2016
# Website: https://github.com/trizen

# A very fast function that returns true when a given number is even-perfect. False otherwise.

# See also:
#   https://en.wikipedia.org/wiki/Perfect_number

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload is_square isqrt valuation);
use ntheory qw(is_mersenne_prime);

sub is_even_perfect {
    my ($n) = @_;

    $n % 2 == 0 || return 0;

    my $square = 8 * $n + 1;
    is_square($square) || return 0;

    my $k = (isqrt($square) + 1) / 2;
    ($k & ($k - 1)) == 0 && is_mersenne_prime(valuation($k, 2)) ? 1 : 0;
}

say is_even_perfect(191561942608236107294793378084303638130997321548169216);                           # true
say is_even_perfect(191561942608236107294793378084303638130997321548169214);                           # false
say is_even_perfect(191561942608236107294793378084303638130997321548169218);                           # false
say is_even_perfect(14474011154664524427946373126085988481573677491474835889066354349131199152128);    # true

# A much larger perfect number
say is_even_perfect(Math::AnyNum->new('141053783706712069063207958086063189881486743514715667838838675999954867742652380114104193329037690251561950568709829327164087724366370087116731268159313652487450652439805877296207297446723295166658228846926807786652870188920867879451478364569313922060370695064736073572378695176473055266826253284886383715072974324463835300053138429460296575143368065570759537328128'));

# Search test
say "=> Perfect numbers below 10^4:";
for my $n (1 .. 10000) {
    is_even_perfect($n) && say $n;
}


================================================
FILE: Math/is_even_perfect_3.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 12 December 2016
# https://github.com/trizen

# An efficient verification for an even perfect number.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload valuation);
use ntheory qw(is_mersenne_prime);

sub is_even_perfect {
    my ($n) = @_;
    my $v = valuation($n, 2) || return 0;
    my $m = ($n >> $v);
    ($m & ($m+1))            && return 0;
    ($m >> $v) == 1          || return 0;
    is_mersenne_prime($v+1);
}

say is_even_perfect(191561942608236107294793378084303638130997321548169216);                           # true
say is_even_perfect(191561942608236107294793378084303638130997321548169214);                           # false
say is_even_perfect(191561942608236107294793378084303638130997321548169218);                           # false
say is_even_perfect(14474011154664524427946373126085988481573677491474835889066354349131199152128);    # true

# A much larger perfect number
say is_even_perfect(Math::AnyNum->new('141053783706712069063207958086063189881486743514715667838838675999954867742652380114104193329037690251561950568709829327164087724366370087116731268159313652487450652439805877296207297446723295166658228846926807786652870188920867879451478364569313922060370695064736073572378695176473055266826253284886383715072974324463835300053138429460296575143368065570759537328128'));

# Search test
say "=> Perfect numbers below 10^4:";
for my $n (1 .. 10000) {
    is_even_perfect($n) && say $n;
}


================================================
FILE: Math/is_extra_bfsw_pseudoprime.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 31 October 2023
# https://github.com/trizen

# A new primality test, using only the Lucas V sequence.

# This test is a simplification of the strengthen BPSW test:
# https://arxiv.org/abs/2006.14425

use 5.036;
use Math::GMPz;

use constant {
              USE_METHOD_A_STAR => 0,    # true to use the A* method in finding (P,Q)
             };

sub partial_lucasVmod_pow2 ($P, $Q, $two_val, $m, $V1, $V2, $Q1, $Q2) {

    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
    Math::GMPz::Rmpz_mod($Q1, $Q1, $m);

    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
    Math::GMPz::Rmpz_mul($V1, $V1, $V2);
    Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);
    Math::GMPz::Rmpz_mul($Q2, $Q2, $Q1);

    for (1 .. $two_val) {
        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
        Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);
        Math::GMPz::Rmpz_powm_ui($Q2, $Q2, 2, $m);
    }

    Math::GMPz::Rmpz_mod($V1, $V1, $m);
    return ($V1, $Q2);
}

sub partial_lucasVmod ($P, $Q, $bits, $m, $V1 = undef, $V2 = undef, $Q1 = undef, $Q2 = undef) {

    $V1 //= Math::GMPz::Rmpz_init_set_ui(2);
    $V2 //= Math::GMPz::Rmpz_init_set_ui($P);

    $Q1 //= Math::GMPz::Rmpz_init_set_ui(1);
    $Q2 //= Math::GMPz::Rmpz_init_set_ui(1);

    foreach my $bit (@$bits) {

        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);

        if ($bit) {
            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);
            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);
            Math::GMPz::Rmpz_submul_ui($V1, $Q1, $P);
            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);
            Math::GMPz::Rmpz_mod($V1, $V1, $m);
        }
        else {
            Math::GMPz::Rmpz_set($Q2, $Q1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
            Math::GMPz::Rmpz_submul_ui($V2, $Q1, $P);
            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);
            Math::GMPz::Rmpz_mod($V2, $V2, $m);
        }
    }

    Math::GMPz::Rmpz_mod($V1, $V1, $m);
    return ($V1, $V2, $Q1, $Q2);
}

sub check_lucasV ($P, $Q, $m) {

    state $t = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_add_ui($t, $m, 1);

    my @b1 = split //, Math::GMPz::Rmpz_get_str($m, 2);
    my @b2 = split //, Math::GMPz::Rmpz_get_str($t, 2);

    my $k = 0;

    if ($#b1 == $#b2) {
        for my $i (0 .. $#b1) {
            if ($b1[$i] != $b2[$i]) { $k = $i; last }
        }
    }

    my @overlap = @b1[0 .. $k - 1];
    my ($V1, $V2, $Q1, $Q2) = partial_lucasVmod($P, $Q, \@overlap, $m);

    my $two_val = $#b2 - $k;
    my ($V1_a, $Q2_a) = partial_lucasVmod_pow2($P, $Q, $two_val, $m, map { Math::GMPz::Rmpz_init_set($_) } ($V1, $V2, $Q1, $Q2));

    Math::GMPz::Rmpz_set_si($t, 2 * $Q);
    Math::GMPz::Rmpz_congruent_p($V1_a, $t, $m) || return 0;

    Math::GMPz::Rmpz_set_si($t, $Q * $Q);
    Math::GMPz::Rmpz_congruent_p($Q2_a, $t, $m) || return 0;

    my ($V1_b, undef, undef, $Q2_b) = partial_lucasVmod($P, $Q, [@b1[$k .. $#b1]], $m, $V1, $V2, $Q1, $Q2);

    Math::GMPz::Rmpz_set_si($t, $P);
    Math::GMPz::Rmpz_congruent_p($V1_b, $t, $m) || return 0;

    Math::GMPz::Rmpz_set_si($t, Math::GMPz::Rmpz_si_kronecker($Q, $m) * $Q);
    Math::GMPz::Rmpz_congruent_p($Q2_b, $t, $m) || return 0;

    return 1;
}

sub findQ ($n) {
    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);

        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);

        if ($K == -1) {
            return ((1 - $D) / 4);
        }
        elsif ($K == 0 and abs($D) < $n) {
            return undef;
        }
        elsif ($k == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {
            return undef;
        }
    }
}

sub findP ($n, $Q) {
    for (my $P = 2 ; ; ++$P) {
        my $D = $P * $P - 4 * $Q;

        my $K = Math::GMPz::Rmpz_si_kronecker($D, $n);

        if ($K == -1) {
            return $P;
        }
        elsif ($K == 0 and abs($D) < $n) {
            return undef;
        }
        elsif ($P == 20 and Math::GMPz::Rmpz_perfect_square_p($n)) {
            return undef;
        }
    }
}

sub is_extra_bfsw_psp ($n) {

    $n = Math::GMPz::Rmpz_init_set_str($n, 10) if ref($n) ne 'Math::GMPz';

    return 0 if Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0;
    return 1 if Math::GMPz::Rmpz_cmp_ui($n, 2) == 0;
    return 0 if Math::GMPz::Rmpz_even_p($n);

    my ($P, $Q);

    if (USE_METHOD_A_STAR) {
        $P = 1;
        $Q = findQ($n) // return 0;

        if ($Q == -1) {
            $P = 5;
            $Q = 5;
        }
    }
    else {
        $Q = -2;
        $P = findP($n, $Q) // return 0;
    }

    check_lucasV($P, $Q, $n);
}

my @strong_lucas_psp = (
                        5459,   5777,   10877,  16109,  18971,  22499,  24569,  25199,  40309,  58519,  75077,  97439,
                        100127, 113573, 115639, 130139, 155819, 158399, 161027, 162133, 176399, 176471, 189419, 192509,
                        197801, 224369, 230691, 231703, 243629, 253259, 268349, 288919, 313499, 324899
                       );
my @extra_strong_lucas_psp = (
                              989,    3239,   5777,   10877,  27971,  29681,  30739,  31631,  39059,  72389,  73919,  75077,
                              100127, 113573, 125249, 137549, 137801, 153931, 155819, 161027, 162133, 189419, 218321, 231703,
                              249331, 370229, 429479, 430127, 459191, 473891, 480689, 600059, 621781, 632249, 635627
                             );

foreach my $n (913, 150267335403, 430558874533, 14760229232131, 936916995253453, @strong_lucas_psp, @extra_strong_lucas_psp) {
    if (is_extra_bfsw_psp($n)) {
        say "Counter-example: $n";
    }
}

use ntheory qw(is_prime);

my $from  = 1;
my $to    = 1e5;
my $count = 0;

foreach my $n ($from .. $to) {
    if (is_extra_bfsw_psp($n)) {
        if (not is_prime($n)) {
            say "Counter-example: $n";
        }
        ++$count;
    }
    elsif (is_prime($n)) {
        say "Missed a prime: $n";
    }
}

say "There are $count primes between $from and $to.";

is_extra_bfsw_psp(3 * Math::GMPz->new("2")**5134 - 1) or die "error";
is_extra_bfsw_psp(Math::GMPz->new(10)**2000 + 4561)   or die "error";

__END__
Inspired 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.

The first observation was that none of the 5 vpsp terms < 10^15 satisfy:

Q^(n+1) == Q^2 (mod n)

This gives us a simple test:

V_{n+1}(P,Q) == 2*Q (mod n)
Q^(n+1) == Q^2 (mod n)

where (P,Q) are selected using Method A*.

At very little additional computational cost (on average), we can make the test even stronger, by also checking:

V_n(P,Q) == P (mod n)

Notice that also none of the 5 vpsp terms < 10^15 satisfy the above congruence.

The 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.

First we compute:

V_d(P,Q) mod n

where d is the "most significant overlapping binary part" of n and n+1.

For example, if n = 43, we have:

n   = 101011_2
n+1 = 101100_2

The most significant overlapping bits of n and n+1 are: "101", therefore d = 101_2 = 5.

From V_d(P,Q) mod n, we compute V_{n+1}(P,Q) mod n, using the remaining bits of n+1: "100".

Notice 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.

At this stage, we check the necessary congruences trying to return early:

V_{n+1}(P,Q) == 2*Q (mod n)
Q^(n+1) == Q^2 (mod n)

If 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:

V_n(P,Q) == P (mod n)
Q^((n+1)/2) == Q*(Q|n) (mod n)

Finally, we return true if the number satisfied all the congruences, indicating that it is probably prime.

There are no known counter-examples to the presented test.

Remarks:

- 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.
- 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.
- 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.

Optimization ideas:

- 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.
- 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.
- 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.


================================================
FILE: Math/is_omega_prime.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 17 February 2023
# https://github.com/trizen

# A simple and fast method for checking if a given integer n has exactly k distinct prime factors (i.e.: omega(n) = k).

use 5.020;
use warnings;

use ntheory      qw(:all);
use experimental qw(signatures);

use Math::GMPz;
use Math::Prime::Util::GMP;

use constant {
              TRIAL_LIMIT        => 1e3,
              HAS_NEW_PRIME_UTIL => defined(&Math::Prime::Util::is_omega_prime),
             };

my @SMALL_PRIMES = @{primes(TRIAL_LIMIT)};

sub mpz_is_omega_prime ($n, $k) {

    state $z = Math::GMPz::Rmpz_init();
    state $t = Math::GMPz::Rmpz_init();

    if ($n == 0) {
        return 0;
    }

    Math::GMPz::Rmpz_set_str($z, "$n", 10);
    Math::GMPz::Rmpz_root($t, $z, $k);

    my $trial_limit = Math::GMPz::Rmpz_get_ui($t);

    if ($trial_limit > TRIAL_LIMIT or !Math::GMPz::Rmpz_fits_ulong_p($t)) {
        $trial_limit = TRIAL_LIMIT;
    }

    foreach my $p (@SMALL_PRIMES) {

        last if ($p > $trial_limit);

        if (Math::GMPz::Rmpz_divisible_ui_p($z, $p)) {
            --$k;
            Math::GMPz::Rmpz_set_ui($t, $p);
            Math::GMPz::Rmpz_remove($z, $z, $t);
        }

        ($k > 0) or last;

        if (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z)) {
            return Math::Prime::Util::is_omega_prime($k, Math::GMPz::Rmpz_get_ui($z));
        }
    }

    if (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0) {
        return ($k == 0);
    }

    if ($k == 0) {
        return (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);
    }

    if ($k == 1) {

        if (Math::GMPz::Rmpz_fits_ulong_p($z)) {
            return is_prime_power(Math::GMPz::Rmpz_get_ui($z));
        }

        return Math::Prime::Util::GMP::is_prime_power(Math::GMPz::Rmpz_get_str($z, 10));
    }

    Math::GMPz::Rmpz_ui_pow_ui($t, next_prime($trial_limit), $k);

    if (Math::GMPz::Rmpz_cmp($z, $t) < 0) {
        return 0;
    }

    (HAS_NEW_PRIME_UTIL and Math::GMPz::Rmpz_fits_ulong_p($z))
      ? Math::Prime::Util::is_omega_prime($k, Math::GMPz::Rmpz_get_ui($z))
      : (factor_exp(Math::GMPz::Rmpz_get_str($z, 10)) == $k);
}

foreach my $n (1 .. 100) {
    my $t = urandomb($n) + 1;

    say "Testing: $t";

    foreach my $k (1 .. 20) {
        if (HAS_NEW_PRIME_UTIL ? Math::Prime::Util::is_omega_prime($k, $t) : (factor_exp($t) == $k)) {
            mpz_is_omega_prime($t, $k) || die "error for: ($t, $k)";
        }
        elsif (mpz_is_omega_prime($t, $k)) {
            die "counter-example: ($t, $k)";
        }
    }
}


================================================
FILE: Math/is_perfect_power.pl
================================================
#!/usr/bin/perl

# Algorithm for testing if a given number `n` is a perfect
# power (i.e. can be expressed as: n = a^k with k > 1).

# The value of k is returned when n is an exact k-th power, 1 otherwise.

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#
use 5.010;
use strict;
use warnings;

use ntheory qw(logint rootint powint);
use experimental qw(signatures);

sub is_perfect_power ($n) {

    for (my $k = logint($n, 2) ; $k >= 2 ; --$k) {
        if (powint(rootint($n, $k), $k) == $n) {
            return $k;
        }
    }

    return 1;
}

say is_perfect_power(powint(1234, 14));    #=> 14


================================================
FILE: Math/is_smooth_over_product.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 25 October 2018
# https://github.com/trizen

# A new algorithm for testing N for B-smoothness, given the product of a subset of primes <= B.
# Returns a true value when N is the product of a subset of prime factors of B.
# This algorithm can be useful in some modern integer factorization algorithms.

# Algorithm:
#     1. Let n be the number to be tested.
#     2. Let k be the product of the primes in the factor base.
#     3. Compute the greatest common divisor: g = gcd(n, k)
#     4. If g is greater than 1, then n = r * g^e, for some e >= 1.
#        - If r = 1, then n is smooth over the factor base.
#        - Otherwise, set n = r and go to step 3.
#     5. If this step is reached, then n is not smooth over the factor base.

use 5.020;
use warnings;

use experimental qw(signatures);
use ntheory qw(gcd valuation primorial factor);

sub is_smooth_over_prod ($n, $k) {

    for (my $g = gcd($n, $k) ; $g > 1 ; $g = gcd($n, $k)) {
        $n /= $g;                         # remove one divisor g
        $n /= $g while ($n % $g == 0);    # remove any divisibility by g
        return 1 if ($n == 1);            # smooth if n == 1
    }

    return 0;
}

# Example for identifying 19-smooth numbers
my $k = primorial(19);                    # product of primes <= 19

for my $n (1 .. 1000) {
    say($n, " = prod(", join(', ', factor($n)), ")") if is_smooth_over_prod($n, $k);
}


================================================
FILE: Math/is_squarefree_over_product.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 16 March 2019
# https://github.com/trizen

# Efficient algorithm for determinining if a given number is squarefree over a squarefree product.

# Algorithm:
#     1. Let n be the number to be tested.
#     2. Let k be the product of the primes <= B.
#     3. Compute the greatest common divisor: g = gcd(n, k)
#     4. If g is greater than 1, then n = r*g.
#        - If r = 1, then n is B-smooth and squarefree.
#        - Otherwise, if gcd(r, k) > 1, then n is not squarefree.
#     5. If this step is reached, then n is not B-smooth.

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(primorial factor);
use experimental qw(signatures);

sub is_squarefree_over_prod ($n, $k) {

    state $g = Math::GMPz::Rmpz_init_nobless();
    state $t = Math::GMPz::Rmpz_init_nobless();

    # Compute the greatest common divisor: g = gcd(n, k)
    Math::GMPz::Rmpz_set($t, $n);
    Math::GMPz::Rmpz_gcd($g, $t, $k);

    if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {

        # If g is greater than 1, then n = r*g.
        Math::GMPz::Rmpz_divexact($t, $t, $g);

        # If r = 1, then n is squarefree.
        return 1 if Math::GMPz::Rmpz_cmp_ui($t, 1) == 0;

        # Otherwise, if gcd(r, k) > 1, then n is not squarefree.
        Math::GMPz::Rmpz_gcd($g, $t, $k);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return 0;
        }
    }

    # If this step is reached, then n is not B-smooth.
    return 0;
}

my $k = Math::GMPz->new(primorial(19));    # product of primes <= 19

foreach my $n (1 .. 100) {
    if (is_squarefree_over_prod(Math::GMPz->new($n), $k)) {
        say "$n is 19-squarefree: prod(", join(', ', factor($n)), ")";
    }
}


================================================
FILE: Math/is_sum_of_two_cubes.pl
================================================
#!/usr/bin/perl

# Determine if a given integer can be represented as a sum of two nonnegative cubes.

# See also:
#   https://oeis.org/A004999 -- Sums of two nonnegative cubes.
#   https://cs.uwaterloo.ca/journals/JIS/VOL6/Broughan/broughan25.pdf

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub is_sum_of_two_cubes($n) {

    my $L = rootint($n-1, 3) + 1;
    my $U = rootint(4*$n, 3);

    foreach my $m (divisors($n)) {
        if ($L <= $m and $m <= $U) {
            my $l = $m*$m - $n/$m;
            $l % 3 == 0 or next;
            $l /= 3;
            is_square($m*$m - 4*$l) && return 1;
        }
    }

    return;
}

foreach my $n (1 .. 1000) {
    if (is_sum_of_two_cubes($n)) {
        print($n, ", ");
    }
}


================================================
FILE: Math/is_sum_of_two_squares.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 May 2016
# https://github.com/trizen

# Determine if a given number can be written as the sum of two squares.

# See also:
#   https://wstein.org/edu/Fall2001/124/lectures/lecture21/lecture21/node2.html

use 5.010;
use strict;
use warnings;

use ntheory qw(factor_exp is_prime);

sub is_sum_of_2_squares {
    my ($n) = @_;

    if (is_prime($n)) {
        return 1 if $n == 2;
        return $n % 4 == 1;
    }

    foreach my $p (factor_exp($n)) {
            $p->[0] % 4 == 3
        and $p->[1] % 2 != 0
        and return 0;
    }

    return 1;
}

for my $i (0 .. 50) {
    if (is_sum_of_2_squares($i)) {
        say $i;
    }
}


================================================
FILE: Math/iterative_difference_of_central_divisors_to_reach_zero.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 March 2019
# https://github.com/trizen

# 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).
# Let g(n) be the number of iterations of f(n) required to reach zero.

# 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.

# This sequence provides upper-bounds for:
#   https://oeis.org/A324921

# Example:
#   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))))))))))))))))))))))))))))))

# OEIS sequences:
#   https://oeis.org/A324921 -- Index of first occurrence of n in A324920.
#   https://oeis.org/A056737 -- Minimum nonnegative integer m such that n = k*(k+m) for some positive integer k.
#   https://oeis.org/A324920 -- a(n) is the number of iterations of the integer splitting function (A056737) necessary to reach zero.

use 5.020;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub f($n) {
    if (is_square($n)) {
        0;
    }
    else {
        my @d = divisors($n);
        Math::GMPz->new($d[(1 + $#d) >> 1]) - $d[($#d) >> 1];
    }
}

sub g($n) {

    my $t     = f($n);
    my $count = 1;

    while ($t) {
        $t = f($t);
        ++$count;
    }

    $count;
}

my $n = Math::GMPz->new(0);

for my $j (1 .. 30) {

    for (my $x = 1 ; ; ++$x) {

        my $k = $x * ($n + $x);
        my $t = g($k);

        if ($t == $j) {
            $n = $k;
            say "a($j) = $k";
            last;
        }
    }
}

__END__
a(1)  = 1
a(2)  = 2
a(3)  = 3
a(4)  = 10
a(5)  = 11
a(6)  = 26
a(7)  = 87
a(8)  = 178
a(9)  = 179
a(10) = 362
a(11) = 1835
a(12) = 22164
a(13) = 155197
a(14) = 620804
a(15) = 5587317
a(16) = 55873270
a(17) = 167619819
a(18) = 1340958616
a(19) = 57661222337
a(20) = 345967334058
a(21) = 25255615391563
a(22) = 858690923314298
a(23) = 4293454616571515
a(24) = 60108364632001406
a(25) = 3185743325496077327
a(26) = 178401626227780333448
a(27) = 1605614636050023001113
a(28) = 109181795251401564080308
a(29) = 22382268026537320636505165
a(30) = 940055257114567466733218694
a(31) = 102466023025487853873920849527
a(32) = 3688776828917562739461150584268
a(33) = 217637832906136201628207884475293
a(34) = 10011340313682265274897562685865594
a(35) = 830941246035628017816497702926851191
a(36) = 74784712143206521603484793263416615290
a(37) = 9946366715046467373263477504034409851259
a(38) = 1233349472665761954284671210500266821571492
a(39) = 11100145253991857588562040894502401394143509
a(40) = 155402033555886006239868572523033619518009322
a(41) = 6060679308679554243354874328398311161202365079
a(42) = 12121358617359108486709748656796622322404730162
a(43) = 1321228089292142825051362603590831833142115599539
a(44) = 295955092001439992811505223204346330623833894346912
a(45) = 3255506012015839920926557455247809636862172837816153
a(46) = 97665180360475197627796723657434289105865185134485490
a(47) = 8887531412803242984129501852826520308633731847238187871
a(48) = 106650376953638915809554022233918243703604782166858254596
a(49) = 23143131798939644730673222824760258883682237730208241294421
a(50) = 2036595598306688736299243608578902781764036920258325233916792


================================================
FILE: Math/k-imperfect_numbers.pl
================================================
#!/usr/bin/perl

# Generate all the k-imperfect numbers less than or equal to n.
# Based on Michel Marcus's algorithm from A328860.

# k-imperfect numbers, are numbers n such that:
#   n = k * Sum_{d|n} d * (-1)^Ω(n/d)

# See also:
#   https://oeis.org/A206369 -- rho function.
#   https://oeis.org/A127724 -- k-imperfect numbers for some k >= 1.
#   https://oeis.org/A127725 -- Numbers that are 2-imperfect.
#   https://oeis.org/A127726 -- Numbers that are 3-imperfect.
#   https://oeis.org/A328860 -- Numbers that are 4-imperfect.

use 5.020;
use warnings;

use ntheory qw(:all);
use List::Util qw(uniq);
use experimental qw(signatures);

sub rho_prime_power ($p, $e) {
    my $x = addint(powint($p, $e + 1), $p >> 1);
    my $y = $p + 1;
    divint($x, $y);
}

sub rho_factors(@F) {
    vecprod(map { rho_prime_power($_->[0], $_->[1]) } @F);
}

sub k_imperfect_numbers ($limit, $A, $B = 1) {

    my @sol;
    my $g = gcd($A, $B);

    $A = divint($A, $g);
    $B = divint($B, $g);

    if ($A == 1) {
        return (1) if ($B == 1);
        return ();
    }

    my @f   = factor_exp($A);
    my $rho = rho_factors(@f);
    my ($p, $n) = @{$f[-1]};

    my $r = rho_prime_power($p, $n);

    for (my $pn = powint($p, $n) ; $pn <= $limit ; $pn = mulint($pn, $p)) {
        foreach my $k (__SUB__->(divint($limit, $pn), mulint($A, $r), mulint($B, $pn))) {
            push @sol, mulint($pn, $k) if (gcd($pn, $k) == 1);
        }
        $r = rho_prime_power($p, ++$n);
    }

    if ($rho == $B) {
        push @sol, $A;
    }

    @sol = grep { $_ <= $limit } @sol;
    @sol = sort { $a <=> $b } @sol;
    uniq(@sol);
}

say join ', ', k_imperfect_numbers(10**15, 2);    # 2-imperfect numbers
say join ', ', k_imperfect_numbers(10**15, 3);    # 3-imperfect numbers

__END__
2, 12, 40, 252, 880, 10880, 75852, 715816960, 62549517598720
6, 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


================================================
FILE: Math/k-odd-powerful_numbers.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 11 February 2020
# Edit: 23 February 2024
# https://github.com/trizen

# Fast recursive algorithm for generating all the odd k-powerful numbers <= n.
# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.

# Example:
#   2-powerful = a^2 * b^3,             for a,b >= 1
#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1
#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1

# See also:
#   https://oeis.org/A062739

use 5.036;
use ntheory qw(:all);

sub odd_powerful_numbers ($n, $k = 2) {

    my @odd_powerful;

    sub ($m, $r) {

        if ($r < $k) {
            push @odd_powerful, $m;
            return;
        }

        foreach my $v (1 .. rootint(divint($n, $m), $r)) {

            next if ($v % 2 == 0);

            if ($r > $k) {
                gcd($m, $v) == 1   or next;
                is_square_free($v) or next;
            }

            __SUB__->(mulint($m, powint($v, $r)), $r - 1);
        }
      }
      ->(1, 2 * $k - 1);

    sort { $a <=> $b } @odd_powerful;
}

foreach my $k (1 .. 10) {
    printf("%2d-odd-powerful: %s, ...\n", $k, join(", ", odd_powerful_numbers(powint(10, $k), $k)));
}

__END__
 1-odd-powerful: 1, 3, 5, 7, 9, ...
 2-odd-powerful: 1, 9, 25, 27, 49, 81, ...
 3-odd-powerful: 1, 27, 81, 125, 243, 343, 625, 729, ...
 4-odd-powerful: 1, 81, 243, 625, 729, 2187, 2401, 3125, 6561, ...
 5-odd-powerful: 1, 243, 729, 2187, 3125, 6561, 15625, 16807, 19683, 59049, 78125, ...
 6-odd-powerful: 1, 729, 2187, 6561, 15625, 19683, 59049, 78125, 117649, 177147, 390625, 531441, 823543, ...
 7-odd-powerful: 1, 2187, 6561, 19683, 59049, 78125, 177147, 390625, 531441, 823543, 1594323, 1953125, 4782969, 5764801, 9765625, ...
 8-odd-powerful: 1, 6561, 19683, 59049, 177147, 390625, 531441, 1594323, 1953125, 4782969, 5764801, 9765625, 14348907, 40353607, 43046721, 48828125, ...
 9-odd-powerful: 1, 19683, 59049, 177147, 531441, 1594323, 1953125, 4782969, 9765625, 14348907, 40353607, 43046721, 48828125, 129140163, 244140625, 282475249, 387420489, ...
10-odd-powerful: 1, 59049, 177147, 531441, 1594323, 4782969, 9765625, 14348907, 43046721, 48828125, 129140163, 244140625, 282475249, 387420489, 1162261467, 1220703125, 1977326743, 3486784401, 6103515625, ...


================================================
FILE: Math/k-powerful_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 February 2020
# https://github.com/trizen

# Fast recursive algorithm for generating all the k-powerful numbers <= n.
# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.

# Example:
#   2-powerful = a^2 * b^3,             for a,b >= 1
#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1
#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1

# OEIS:
#   https://oeis.org/A001694 -- 2-powerful numbers
#   https://oeis.org/A036966 -- 3-powerful numbers
#   https://oeis.org/A036967 -- 4-powerful numbers
#   https://oeis.org/A069492 -- 5-powerful numbers
#   https://oeis.org/A069493 -- 6-powerful numbers

use 5.020;
use warnings;

use ntheory      qw(:all);
use experimental qw(signatures);

sub powerful_numbers ($n, $k = 2) {

    my @powerful;

    sub ($m, $r) {

        if ($r < $k) {
            push @powerful, $m;
            return;
        }

        foreach my $v (1 .. rootint(divint($n, $m), $r)) {

            if ($r > $k) {
                gcd($m, $v) == 1   or next;
                is_square_free($v) or next;
            }

            __SUB__->(mulint($m, powint($v, $r)), $r - 1);
        }

      }
      ->(1, 2 * $k - 1);

    sort { $a <=> $b } @powerful;
}

foreach my $k (1 .. 10) {
    printf("%2d-powerful: %s, ...\n", $k, join(", ", powerful_numbers(5**$k, $k)));
}

__END__
 1-powerful: 1, 2, 3, 4, 5, ...
 2-powerful: 1, 4, 8, 9, 16, 25, ...
 3-powerful: 1, 8, 16, 27, 32, 64, 81, 125, ...
 4-powerful: 1, 16, 32, 64, 81, 128, 243, 256, 512, 625, ...
 5-powerful: 1, 32, 64, 128, 243, 256, 512, 729, 1024, 2048, 2187, 3125, ...
 6-powerful: 1, 64, 128, 256, 512, 729, 1024, 2048, 2187, 4096, 6561, 8192, 15625, ...
 7-powerful: 1, 128, 256, 512, 1024, 2048, 2187, 4096, 6561, 8192, 16384, 19683, 32768, 59049, 65536, 78125, ...
 8-powerful: 1, 256, 512, 1024, 2048, 4096, 6561, 8192, 16384, 19683, 32768, 59049, 65536, 131072, 177147, 262144, 390625, ...
 9-powerful: 1, 512, 1024, 2048, 4096, 8192, 16384, 19683, 32768, 59049, 65536, 131072, 177147, 262144, 524288, 531441, 1048576, 1594323, 1953125, ...
10-powerful: 1, 1024, 2048, 4096, 8192, 16384, 32768, 59049, 65536, 131072, 177147, 262144, 524288, 531441, 1048576, 1594323, 2097152, 4194304, 4782969, 8388608, 9765625, ...


================================================
FILE: Math/k-powerful_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 28 February 2021
# Edit: 11 April 2024
# https://github.com/trizen

# Fast recursive algorithm for generating all the k-powerful numbers in a given range [A,B].
# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.

# Example:
#   2-powerful = a^2 * b^3,             for a,b >= 1
#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1
#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1

# OEIS:
#   https://oeis.org/A001694 -- 2-powerful numbers
#   https://oeis.org/A036966 -- 3-powerful numbers
#   https://oeis.org/A036967 -- 4-powerful numbers
#   https://oeis.org/A069492 -- 5-powerful numbers
#   https://oeis.org/A069493 -- 6-powerful numbers

use 5.036;
use ntheory 0.74 qw(:all);

sub my_powerful_numbers ($A, $B, $k = 2) {

    my @powerful;

    sub ($m, $r) {

        my $from = 1;
        my $upto = rootint(divint($B, $m), $r);

        if ($r <= $k) {

            if ($A > $m) {

                # Optimization by Dana Jacobsen (from Math::Prime::Util::PP)
                my $l = cdivint($A, $m);
                if (($l >> $r) == 0) {
                    $from = 2;
                }
                else {
                    $from = rootint($l, $r);
                    $from++ if (powint($from, $r) != $l);
                }
            }

            foreach my $j ($from .. $upto) {
                push @powerful, mulint($m, powint($j, $r));
            }

            return;
        }

        foreach my $v ($from .. $upto) {

            gcd($m, $v) == 1   or next;
            is_square_free($v) or next;

            __SUB__->(mulint($m, powint($v, $r)), $r - 1);
        }
      }
      ->(1, 2 * $k - 1);

    sort { $a <=> $b } @powerful;
}

my $A = int rand 1e5;
my $B = int rand 1e7;

foreach my $k (2 .. 5) {
    say "Testing: k = $k";
    my @a1 = my_powerful_numbers($A, $B, $k);
    my @a2 = @{powerful_numbers($A, $B, $k)};
    my @a3 = grep { $_ >= $A } my_powerful_numbers(1, $B, $k);
    "@a1" eq "@a2" or die "error for: powerful_numbers($A, $B, $k)";
    "@a1" eq "@a3" or die "error for: powerful_numbers($A, $B, $k)";
}

say join(', ', my_powerful_numbers(1e6 - 1e4, 1e6, 2));    #=> 990025, 990125, 990584, 991232, 992016, 994009, 995328, 996004, 996872, 998001, 998784, 1000000


================================================
FILE: Math/karatsuba_multiplication.pl
================================================
#!/usr/bin/perl

# A simple implementation of the Karatsuba multiplication.

# See also:
#   https://en.wikipedia.org/wiki/Karatsuba_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::AnyNum qw(:overload);
use Math::AnyNum qw(divmod);

sub karatsuba_multiplication ($x, $y, $n = 8) {

    if ($n <= 1) {
        return $x * $y;
    }

    my $m = ($n % 2 == 0) ? ($n >> 1) : (($n >> 1) + 1);

    my ($a, $b) = divmod($x, 1 << $m);
    my ($c, $d) = divmod($y, 1 << $m);

    my $e = __SUB__->($a,      $c,      $m);
    my $f = __SUB__->($b,      $d,      $m);
    my $g = __SUB__->($a - $b, $c - $d, $m);

    ($e << (2*$m)) + (($e + $f - $g) << $m) + $f;
}

say karatsuba_multiplication(122, 422);    # 122 * 422 = 51484


================================================
FILE: Math/kempner_binomial_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 January 2019
# https://github.com/trizen

# a(n) = smallest positive integer k such that n divides binomial(n+k, k).

# Sequence inspired by the Kempner numbers:
#   https://oeis.org/A002034

# Prime power identity:
#   a(p^k) = p^k * (p^k - 1), for p^k a prime power.

# Lower bound formula for a(n). Let:
#   f(n, p^k) = p^k * (p^k - n/p^k)

# if n = p1^e1 * p2^e2 * ... * pu^eu,
# then a(n) >= max( f(n,p1^e1), f(n,p2^e2), ..., f(n,pu^eu) ).

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(factor_exp);
use Math::AnyNum qw(binomial is_div ipow max);

sub f ($n) {
    for (my $k = 1 ; ; ++$k) {
        if (is_div(binomial($n + $k, $k), $n)) {
            return $k;
        }
    }
}

sub g($n) {    # g(n) <= f(n)
    max(map {
        my $pk = ipow($_->[0], $_->[1]);
        $pk * ($pk - $n / $pk)
    } factor_exp($n));
}

say "f(n) = [", join(", ", map { f($_) } 2 .. 31), "]";
say "g(n) = [", join(", ", map { g($_) } 2 .. 31), "]";

__END__
f(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]
g(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]


================================================
FILE: Math/klein_J_invariant_and_modular_lambda.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 October 2017
# https://github.com/trizen

# Implementation of the `modular_lambda(x)` and `klein_invariant_j(x)` functions.

# See also:
#   https://oeis.org/A115977
#   https://en.wikipedia.org/wiki/J-invariant
#   https://en.wikipedia.org/wiki/Modular_lambda_function

use 5.014;
use warnings;

use Math::AnyNum qw(:overload pi);

my @A115977 = map { Math::AnyNum->new((split(' '))[-1]) } ;

sub modular_lambda {
    my ($x) = @_;

    my $sum  = 0;
    my $prev = 0;

    my $q = exp(pi * i * $x);

    $q = $q->real if $q->is_real;

    foreach my $i (0 .. $#A115977) {
        $sum += $A115977[$i] * $q**($i + 1);
        $sum->approx_cmp($prev) || last;
        $prev = $sum;
    }

    return $sum;
}

sub klein_invariant_j {
    my ($x) = @_;

#<<<
    ( 4 * (1 - modular_lambda($x)     + modular_lambda($x)**2)**3) /
    (27 * (1 - modular_lambda($x))**2 * modular_lambda($x)**2);
#>>>

}

say klein_invariant_j(2 * i);                               # (11/2)^3
say klein_invariant_j(sqrt(-2))->round(-40);                # (5/3)^3
say klein_invariant_j((1 + sqrt(-163)) / 2)->round(-40);    # -53360^3

__END__
1 16
2 -128
3 704
4 -3072
5 11488
6 -38400
7 117632
8 -335872
9 904784
10 -2320128
11 5702208
12 -13504512
13 30952544
14 -68901888
15 149403264
16 -316342272
17 655445792
18 -1331327616
19 2655115712
20 -5206288384
21 10049485312
22 -19115905536
23 35867019904
24 -66437873664
25 121587699568
26 -219997823744
27 393799671680
28 -697765502976
29 1224470430560
30 -2129120769024
31 3669925002752
32 -6273295187968
33 10638472274688
34 -17904375855360
35 29914108051712
36 -49631878364160
37 81796581923552
38 -133940954877440
39 217972711694464
40 -352615521042432
41 567159563764128
42 -907197891465216
43 1443361173729344
44 -2284561115754496
45 3597986508088416
46 -5639173569598464
47 8797049785486592
48 -13661151873466368
49 21121565013141648
50 -32516981110373248
51 49853282901399936
52 -76125157989107712
53 115787750395675104
54 -175446129968544768
55 264860028797210496
56 -398403552976764928
57 597179610339831040
58 -892073853566196480
59 1328153150761957184
60 -1970983069740490752
61 2915677205543637344


================================================
FILE: Math/lambert_W_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 December 2016
# https://github.com/trizen

# A simple implementation of Lambert's W function.

# Example: x^x = 100
#            x = exp(lambert_w(log(100)))
#            x =~ 3.5972850235404...

# See also:
#   https://en.wikipedia.org/wiki/Lambert_W_function

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload approx_cmp);

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

    my $x = sqrt($c) + 1;
    my $y = 0;

    while (approx_cmp(abs($x - $y), 0)) {
        $y = $x;
        $x = ($x + $c) / (1 + log($x));
    }

    log($x);
}

say exp(lambert_w(log(100)));    # 3.59728502354041750549765225178228606913554305489
say exp(lambert_w(log(-100)));   # 3.70202936660214594290193962952737102802777010583+1.34823128471151901327831464969872480416292147614i


================================================
FILE: Math/lambert_W_function_complex.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 December 2016
# https://github.com/trizen

# Implementation of the Lambert-W function in complex numbers.

# Example: x^x = 100
#            x = exp(lambert_w(log(100)))
#            x =~ 3.59728502354042

# See also:
#   https://en.wikipedia.org/wiki/Lambert_W_function

use 5.010;
use strict;
use warnings;

use Math::MPC;
use Math::MPFR;

my $PREC  = 128;                      # can be tweaked
my $ROUND = Math::MPC::MPC_RNDNN();

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

    if (ref($c) ne 'Math::MPC') {
        my $n = Math::MPC::Rmpc_init2($PREC);
        Math::MPC::Rmpc_set_str($n, "$c", 10, $ROUND);
        $c = $n;
    }

    my $p = Math::MPFR::Rmpfr_init2($PREC);
    Math::MPFR::Rmpfr_ui_pow_ui($p, 10, int($PREC / 4), $ROUND);
    Math::MPFR::Rmpfr_ui_div($p, 1, $p, $ROUND);

    my $x = Math::MPC::Rmpc_init2($PREC);
    Math::MPC::Rmpc_set($x, $c, $ROUND);
    Math::MPC::Rmpc_sqrt($x, $x, $ROUND);
    Math::MPC::Rmpc_add_ui($x, $x, 1, $ROUND);

    my $y = Math::MPC::Rmpc_init2($PREC);
    Math::MPC::Rmpc_set_ui($y, 0, $ROUND);

    my $tmp = Math::MPC::Rmpc_init2($PREC);
    my $abs = Math::MPFR::Rmpfr_init2($PREC);

    my $count = 0;
    while (1) {
        Math::MPC::Rmpc_sub($tmp, $x, $y, $ROUND);

        Math::MPC::Rmpc_abs($abs, $tmp, $ROUND);
        Math::MPFR::Rmpfr_cmp($abs, $p) <= 0 and last;

        Math::MPC::Rmpc_set($y, $x, $ROUND);

        Math::MPC::Rmpc_log($tmp, $x, $ROUND);
        Math::MPC::Rmpc_add_ui($tmp, $tmp, 1, $ROUND);

        Math::MPC::Rmpc_add($x, $x, $c, $ROUND);
        Math::MPC::Rmpc_div($x, $x, $tmp, $ROUND);
        last if ++$count > $PREC;
    }

    Math::MPC::Rmpc_log($x, $x, $ROUND);
    $x;
}

say lambert_w(100);     #  3.385630140290050184888244364529726867493
say lambert_w(-100);    #  3.205380786307449372155918213968303847481  + 2.482590531815923582117041287234452276982i
say lambert_w(-0.5);    # -0.7940236323446893679630153219005898091005 + 0.770111750510379109681313077405028929402i


================================================
FILE: Math/lanczos_approximation.pl
================================================
#!/usr/bin/perl

# Algorithm from Wikipedia:
#   https://en.wikipedia.org/wiki/Lanczos_approximation#Simple_implementation

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(:overload pi real imag);
use experimental qw(signatures lexical_subs);

sub gamma($z) {
    my $epsilon = 0.0000001;

    my sub withinepsilon($x) {
        abs($x - abs($x)) <= $epsilon;
    }

    state $p = [
        676.5203681218851,     -1259.1392167224028,
        771.32342877765313,    -176.61502916214059,
        12.507343278686905,    -0.13857109526572012,
        9.9843695780195716e-6,  1.5056327351493116e-7,
    ];

    my $result;
    if (real($z) < 0.5) {
        $result = (pi / (sin(pi * $z) * gamma(1 - $z)));
    }
    else {
        $z -= 1;
        my $x = 0.99999999999980993;

        while (my ($i, $pval) = each @$p) {
            $x += $pval / ($z + $i + 1);
        }

        my $t = ($z + @$p - 0.5);
        $result = (sqrt(pi * 2) * $t**($z + 0.5) * exp(-$t) * $x);
    }

    withinepsilon(imag($result)) ? real($result) : $result;
}

foreach my $i (0.5, 4, 5, 6, 30, 40, 50) {
    printf("gamma(%3s) =~ %s\n", $i, gamma($i));
}

__END__
gamma(0.5) =~ 1.77245385090551659496855986697771284175944211142
gamma(  4) =~ 6.00000000000000628999184513591742545418327380194
gamma(  5) =~ 24.0000000000000308599507225303222574058679398028
gamma(  6) =~ 120.000000000000178632999163000072600390777175518
gamma( 30) =~ 8841761993739669928012342097034.15093049782426111
gamma( 40) =~ 20397882081197200259694400837033107505429486392
gamma( 50) =~ 6.08281864034254395430563164837656389765153447987e62


================================================
FILE: Math/least_k_such_that_k_times_k-th_prime_is_greater_than_10_to_the_n.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 26 February 2019
# https://github.com/trizen

# Given a positive integer n, find the smallest integer `k` such that `k*prime(k) > 10^n`.

# See also:
#   https://oeis.org/A090977 -- Least k such that k*prime(k) > 10^n.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload bsearch_ge);
use ntheory qw(nth_prime nth_prime_lower nth_prime_upper);

sub a {
    my ($n) = @_;

    my $lim = 10**$n;

    my $min_approx = int(sqrt($lim / log($lim+1)));
    my $max_approx = 2*$min_approx;

    my $min = bsearch_ge($min_approx, $max_approx, sub {
        nth_prime_upper($_) * $_ <=> $lim
    });

    my $max = bsearch_ge($min, $max_approx, sub {
        nth_prime_lower($_) * $_ <=> $lim
    });

    bsearch_ge($min, $max, sub {
        nth_prime($_) * $_ <=> $lim
    });
}

foreach my $n(0..22) {
    say "a($n) = ", a($n);
}

__END__
a(0) = 1
a(1) = 3
a(2) = 7
a(3) = 17
a(4) = 48
a(5) = 134
a(6) = 382
a(7) = 1115
a(8) = 3287
a(9) = 9786
a(10) = 29296
a(11) = 88181
a(12) = 266694
a(13) = 809599
a(14) = 2465574
a(15) = 7528976
a(16) = 23045352
a(17) = 70684657
a(18) = 217196605
a(19) = 668461874
a(20) = 2060257099
a(21) = 6358076827
a(22) = 19644205359


================================================
FILE: Math/least_nonresidue.pl
================================================
#!/usr/bin/perl

# Find the least nonresidue of n.

# See also:
#   https://oeis.org/A020649 -- Least nonresidue of n.
#   https://oeis.org/A307809 -- Smallest "non-residue" pseudoprime to base prime(n).
#   https://mathworld.wolfram.com/QuadraticNonresidue.html

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub least_nonresidue_odd ($n) {    # for odd n

    my @factors = map { $_->[0] } factor_exp($n);

    for (my $p = 2 ; ; $p = next_prime($p)) {
        (vecall { kronecker($p, $_) == 1 } @factors) || return $p;
    }
}

sub least_nonresidue_sqrtmod ($n) {    # for any n
    for (my $p = 2 ; ; $p = next_prime($p)) {
        sqrtmod($p, $n) // return $p;
    }
}

my @tests = (
             3277,          3281,           121463,          491209,
             11530801,      512330281,      15656266201,     139309114031,
             7947339136801, 72054898434289, 334152420730129, 17676352761153241,
             172138573277896681
            );

say join ', ', map { least_nonresidue_odd($_) } @tests;        #=> 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41
say join ', ', map { least_nonresidue_sqrtmod($_) } @tests;    #=> 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41


================================================
FILE: Math/legendary_question_six.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 June 2019
# https://github.com/trizen

# The problem:
#   Let "a" and "b" be positive integers such that a*b + 1 divides a^2 + b^2.
#   Show that (a^2 + b^2) / (a*b + 1) is the square of an integer.

# This program presents an efficient method for computing non-trivial solutions to the legendary question six.

# The Legend of Question Six - Numberphile
# https://www.youtube.com/watch?v=Y30VF3cSIYQ

# The Return of the Legend of Question Six - Numberphile
# https://www.youtube.com/watch?v=L0Vj_7Y2-xY

# Solutions for (a^2 + b^2) / (1 + ab) = 4, are given by consecutive values of A052530 = { 2, 8, 30, 112, 418, 1560, 5822, ... }.

# Example:
#   (  2^2 +   8^2) / (    2*8 + 1) = 4
#   (  8^2 +  30^2) / (   8*30 + 1) = 4
#   ( 30^2 + 112^2) / ( 30*112 + 1) = 4
#   (112^2 + 418^2) / (112*418 + 1) = 4

# Similar sequences provide solutions for other values:

# For 3^2: A065100 = { 3, 27, 240, 2133, 18957, 168480, ... }
# For 4^2: A154021 = { 4, 64, 1020, 16256, 259076, 4128960, ... }
# For 5^2: A154022 = { 5, 125, 3120, 77875, 1943755, 48516000, ... }
# For 6^2: A154023 = { 6, 216, 7770, 279504, 10054374, 361677960, ... }

# 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:
#
#   a = m * U(n, m^2 / 2)
#   b = m * U(n+1, m^2 / 2)
#
# for any given positive integer m.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload chebyshevU);

sub lq6_solutions ($m, $how_many = 5) {
    map {
        [$m * chebyshevU($_, $m*$m / 2), $m * chebyshevU($_ + 1, $m*$m / 2)]
    } 0 .. $how_many-1;
}

foreach my $k (2 .. 10) {
    my @S = lq6_solutions($k);
    say "(a^2 + b^2) / (1 + ab) = $k^2 has solutions: ", join(', ', map { "[@$_]" } @S);
}

__END__
(a^2 + b^2) / (1 + ab) = 2^2 has solutions: [2 8], [8 30], [30 112], [112 418], [418 1560]
(a^2 + b^2) / (1 + ab) = 3^2 has solutions: [3 27], [27 240], [240 2133], [2133 18957], [18957 168480]
(a^2 + b^2) / (1 + ab) = 4^2 has solutions: [4 64], [64 1020], [1020 16256], [16256 259076], [259076 4128960]
(a^2 + b^2) / (1 + ab) = 5^2 has solutions: [5 125], [125 3120], [3120 77875], [77875 1943755], [1943755 48516000]
(a^2 + b^2) / (1 + ab) = 6^2 has solutions: [6 216], [216 7770], [7770 279504], [279504 10054374], [10054374 361677960]
(a^2 + b^2) / (1 + ab) = 7^2 has solutions: [7 343], [343 16800], [16800 822857], [822857 40303193], [40303193 1974033600]
(a^2 + b^2) / (1 + ab) = 8^2 has solutions: [8 512], [512 32760], [32760 2096128], [2096128 134119432], [134119432 8581547520]
(a^2 + b^2) / (1 + ab) = 9^2 has solutions: [9 729], [729 59040], [59040 4781511], [4781511 387243351], [387243351 31361929920]
(a^2 + b^2) / (1 + ab) = 10^2 has solutions: [10 1000], [1000 99990], [99990 9998000], [9998000 999700010], [999700010 99960003000]


================================================
FILE: Math/length_of_shortest_addition_chain.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 August 2016
# Website: https://github.com/trizen

# Length of shortest addition chain for n.
# Equivalently, the minimal number of multiplications required to compute n-th power.

# See also: https://oeis.org/A003313
#           https://projecteuler.net/problem=122

# (this algorithm is not efficient for n >= 35)

use 5.010;
use strict;
use warnings;

use List::Util qw(min);

sub mk {
    my ($n, $k, $pos, @nums) = @_;

    return 'inf'  if $n > $k;
    return 'inf'  if $pos > $#nums;
    return $#nums if $n == $k;

    min(
        mk($n, $k, $pos + 1, @nums),
        mk($n + $nums[$pos], $k, $pos, @nums, $n + $nums[$pos])
    );
}

for my $k (1 .. 10) {
    my $r = mk(1, $k, 0, 1);
    say "mk($k) = ", $r;
}


================================================
FILE: Math/lerch_zeta_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 January 2018
# https://github.com/trizen

# Simple implementation of the Lerch zeta function Φ(z, s, t), for real(z) < 1/2.

# Formula due to Guillera and Sondow (2005).

# See also:
#   https://mathworld.wolfram.com/LerchTranscendent.html
#   https://en.wikipedia.org/wiki/Lerch_zeta_function

use 5.020;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload pi binomial factorial);

sub lerch ($z, $s, $t, $reps = 100) {
    my $sum = 0.0;

    my $r = (-$z) / (1 - $z);

    foreach my $n (0 .. $reps) {

        my $temp = 0.0;

        foreach my $k (0 .. $n) {
            $temp += (-1)**$k * binomial($n, $k) * ($t + $k)**(-$s);
        }

        $sum += $r**$n * $temp;
    }

    $sum / (1 - $z);
}

say "zeta(2)/2 =~ ", lerch(-1, 2, 1);        # 0.822467033424113...
say "4*catalan =~ ", lerch(-1, 2, 1 / 2);    # 3.663862376708876...

say '';

sub A281964 ($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;
}

foreach my $n (1 .. 10) {
    printf("a(%2d) = %s\n", $n, A281964($n));
}


================================================
FILE: Math/logarithmic_integral_asymptotic_formula.pl
================================================
#!/usr/bin/perl

# Very good asymptotic formula for Li(x), due to Cesaro.

use 5.010;
use strict;
use warnings;

use ntheory qw(factorial);

my $x = 1e9;

my $sum = 0;
foreach my $n (1 .. log($x)) {
    $sum += factorial($n - 1) * $x / log($x)**$n;
}
say $sum;    #=> 50849234.742179


================================================
FILE: Math/logarithmic_root.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 July 2016
# Website: https://github.com/trizen

# Logarithmic root of n.

# Solves c = x^x, where "c" is known.
# (based on Newton's method for the nth-root)

# Example: 100 = x^x
#          x = lgrt(100)
#          x =~ 3.59728502354042

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload);

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

    my $p = 1 / 10**($Math::AnyNum::PREC >> 2);
    my $d = log($c);

    my $x = 1;
    my $y = 0;

    while (abs($x - $y) > $p) {
        $y = $x;
        $x = ($x + $d) / (1 + log($x));
    }

    $x;
}

say lgrt( 100);   # 3.59728502354041750549765225178228606913554305489
say lgrt(-100);   # 3.70202936660214594290193962952737102802777010583+1.34823128471151901327831464969872480416292147614i


================================================
FILE: Math/logarithmic_root_complex.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 September 2016
# Website: https://github.com/trizen

# Logarithmic root of n.
# Solves c = x^x, where "c" is known.
# (based on Newton's method for nth-root)

# Example: 100 = x^x
#          x = lgrt(100)
#          x =~ 3.59728502354042

# The function is defined in complex numbers for any value != 0.

use 5.010;
use strict;
use warnings;

use Math::MPC;
use Math::MPFR;

my $PREC  = 128;                      # can be tweaked
my $ROUND = Math::MPC::MPC_RNDNN();

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

    if (ref($c) ne 'Math::MPC') {
        my $n = Math::MPC::Rmpc_init2($PREC);
        Math::MPC::Rmpc_set_str($n, "$c", 10, $ROUND);
        $c = $n;
    }

    my $p = Math::MPFR::Rmpfr_init2($PREC);
    Math::MPFR::Rmpfr_ui_pow_ui($p, 10, $PREC >> 2, $ROUND);
    Math::MPFR::Rmpfr_ui_div($p, 1, $p, $ROUND);

    my $d = Math::MPC::Rmpc_init2($PREC);
    Math::MPC::Rmpc_log($d, $c, $ROUND);

    my $x = Math::MPC::Rmpc_init2($PREC);
    Math::MPC::Rmpc_set($x, $c, $ROUND);
    Math::MPC::Rmpc_sqrt($x, $x, $ROUND);
    Math::MPC::Rmpc_add_ui($x, $x, 1, $ROUND);
    Math::MPC::Rmpc_log($x, $x, $ROUND);

    my $y = Math::MPC::Rmpc_init2($PREC);
    Math::MPC::Rmpc_set_ui($y, 0, $ROUND);

    my $tmp = Math::MPC::Rmpc_init2($PREC);
    my $abs = Math::MPFR::Rmpfr_init2($PREC);

    my $count = 0;
    while (1) {
        Math::MPC::Rmpc_sub($tmp, $x, $y, $ROUND);
        Math::MPC::Rmpc_abs($abs, $tmp, $ROUND);
        Math::MPFR::Rmpfr_cmp($abs, $p) <= 0 and last;

        Math::MPC::Rmpc_set($y, $x, $ROUND);

        Math::MPC::Rmpc_log($tmp, $x, $ROUND);
        Math::MPC::Rmpc_add_ui($tmp, $tmp, 1, $ROUND);

        Math::MPC::Rmpc_add($x, $x, $d, $ROUND);
        Math::MPC::Rmpc_div($x, $x, $tmp, $ROUND);
        last if ++$count > $PREC;
    }

    $x;
}

say lgrt(100);     # (3.597285023540417505497652251782286069146 0)
say lgrt(-100);    # (3.702029366602145942901939629527371028025 1.34823128471151901327831464969872480416)
say lgrt(-1);      # (1.690386757163589211290419139332364873691 1.869907964026775775222799239924290781916)


================================================
FILE: Math/logarithmic_root_in_two_variables.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 July 2017
# https://github.com/trizen

# An interesting function: logarithmic root in two variables.

# For certain values of x, it has the following identity:
#   lgrt2(x, x) = lgrt(x)

# such that:
#   exp(log(lgrt(x)) * lgrt(x)) = x

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload pi e EulerGamma);

sub lgrt2 {
    my ($n, $k) = @_;

    my $f = log($n);
    my $d = log($k);

    my $r = sqrt($f * $d);

    for (1 .. 200) {

        my $x = exp($f / $r);
        my $y = $d / log($x);

        $r = sqrt($x * $y);
    }

    return $r;
}

say lgrt2(pi, e);                     # 1.70771856994915347630915983730048900477178427941
say lgrt2(e,  pi);                    # 1.92464943796370515962751401131903762619866583525

say lgrt2(exp(EulerGamma), e);             # 2.24133450569957655907533525796185668012280055007
say lgrt2(e,          exp(EulerGamma));    # 1.26917997775582192005119311046938840265836794516

say lgrt2(exp(EulerGamma), pi);            # 2.49858594291645763243658930518886102264912661091
say lgrt2(pi,         exp(EulerGamma));    # 1.25519152681721226553799617023948749426608115087

say lgrt2(100, 100);                  # 3.59728502354041750549765225178228606913554305489

say lgrt2(i,  -1);                    # 2.32604988653472423641885139636547364864085030537+1.30957380904696411943253549742370685112065954665i
say lgrt2(-1, i);                     # 1.10679171296146730411561900792354747210041425159+1.55699997420064988554089005455614440858763281837i


================================================
FILE: Math/logarithmic_root_mpfr.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 September 2016
# Website: https://github.com/trizen

# Logarithmic root of n.
# Solves c = x^x, where "c" is known.
# (based on Newton's method for nth-root)

# Example: 100 = x^x
#          x = lgrt(100)
#          x =~ 3.59728502354042

# The function is defined in real numbers for any value >= 0.7

use 5.010;
use strict;
use warnings;

use Math::MPFR;

my $PREC  = 128;                       # can be tweaked
my $ROUND = Math::MPFR::MPFR_RNDN();

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

    if (ref($c) ne 'Math::MPFR') {
        my $n = Math::MPFR::Rmpfr_init2($PREC);
        Math::MPFR::Rmpfr_set_str($n, "$c", 10, $ROUND);
        $c = $n;
    }

    my $p = Math::MPFR::Rmpfr_init2($PREC);
    Math::MPFR::Rmpfr_ui_pow_ui($p, 10, $PREC >> 2, $ROUND);
    Math::MPFR::Rmpfr_ui_div($p, 1, $p, $ROUND);

    my $d = Math::MPFR::Rmpfr_init2($PREC);
    Math::MPFR::Rmpfr_log($d, $c, $ROUND);

    my $x = Math::MPFR::Rmpfr_init2($PREC);
    Math::MPFR::Rmpfr_set_ui($x, 1, $ROUND);

    my $y = Math::MPFR::Rmpfr_init2($PREC);
    Math::MPFR::Rmpfr_set_ui($y, 0, $ROUND);

    my $tmp = Math::MPFR::Rmpfr_init2($PREC);

    while (1) {
        Math::MPFR::Rmpfr_sub($tmp, $x, $y, $ROUND);
        Math::MPFR::Rmpfr_cmpabs($tmp, $p) <= 0 and last;

        Math::MPFR::Rmpfr_set($y, $x, $ROUND);

        Math::MPFR::Rmpfr_log($tmp, $x, $ROUND);
        Math::MPFR::Rmpfr_add_ui($tmp, $tmp, 1, $ROUND);

        Math::MPFR::Rmpfr_add($x, $x, $d, $ROUND);
        Math::MPFR::Rmpfr_div($x, $x, $tmp, $ROUND);
    }

    $x;
}

say lgrt(100);    # 3.597285023540417505497652251782286069146


================================================
FILE: Math/long_division.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 24 December 2012
# https://github.com/trizen

# Long division with arbitrary precision.

use 5.016;
use strict;
use warnings;

sub divide ($$$) {
    my ($x, $y, $f, $z) = @_;

    my $c = 0;
    sub {
        my $i = int($x / $y);

        $z .= $i;
        $x -= $y * $i;

        my $s = -1;
        until ($x >= $y) { $x *= 10; ++$s; $x || last }

        $z .= '.' if !$c;
        $z .= '0' x $s;
        $c += $s + 1;

        __SUB__->() if $c <= $f;
      }
      ->();

    return $z;
}

say divide(634,  212,   64);
say divide(9,    379,   64);
say divide(42.5, 232.7, 64);

say divide(7246,8743,64);


================================================
FILE: Math/long_multiplication.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 July 2015
# Website: https://github.com/trizen

# A creative algorithm for arbitrary long integer multiplication.

use 5.010;
use strict;
use warnings;

use integer;
use List::Util qw(sum);

sub long_multiplication {
    my ($x, $y) = @_;

    use integer;
    if (length($x) < length($y)) {
        ($y, $x) = ($x, $y);
    }

    if ($x eq '0' or $y eq '0') {
        return '0';
    }

    my @x = reverse split //, $x;
    my @y = reverse split //, $y;

    my $xlen = $#x;
    my $ylen = $#y;

    my @map;
    my $mem = 0;

    foreach my $j (0 .. $ylen) {
        foreach my $i (0 .. $xlen) {
            my $n = $x[$i] * $y[$j] + $mem;

            if ($i == $xlen) {
                push @{$map[$j]}, $n % 10, $n / 10;
                $mem = 0;
            }
            else {
                push @{$map[$j]}, $n % 10;
                $mem = $n / 10;
            }
        }

        my $n = $ylen - $j;
        if ($n > 0) {
            push @{$map[$j]}, ((0) x $n);
        }

        my $m = $ylen - $n;
        if ($m > 0) {
            unshift @{$map[$j]}, ((0) x $m);
        }
    }

    my @result;
    my @mrange = (0 .. $#map);
    my $end    = $xlen + $ylen + 1;

    foreach my $i (0 .. $end) {
        my $n = sum(map { $map[$_][$i] } @mrange) + $mem;

        if ($i == $end) {
            push @result, $n if $n != 0;
        }
        else {
            push @result, $n % 10;
            $mem = $n / 10;
        }
    }

    return join('', reverse @result);
}

say long_multiplication('37975227936943673922808872755445627854565536638199',
                        '40094690950920881030683735292761468389214899724061');


================================================
FILE: Math/lucas-carmichael_numbers_from_multiple.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2023
# https://github.com/trizen

# Generate Lucas-Carmichael numbers from a given multiple.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub lucas_carmichael_from_multiple ($m, $callback) {

    is_square_free($m) || return;

    my $L = lcm(map { addint($_, 1) } factor($m));
    my $v = mulmod(invmod($m, $L) // (return), -1, $L);

    for (my $p = $v ; ; $p += $L) {

        gcd($m, $p) == 1 or next;

        my @factors = factor_exp($p);
        (vecall { $_->[1] == 1 } @factors) || next;

        my $n = $m * $p;
        my $l = lcm(map { addint($_->[0], 1) } @factors);

        if (($n + 1) % $l == 0) {
            $callback->($n);
        }
    }
}

lucas_carmichael_from_multiple(11 * 17, sub ($n) { say $n });


================================================
FILE: Math/lucas-carmichael_numbers_from_multiple_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2023
# https://github.com/trizen

# Generate Lucas-Carmichael numbers from a given multiple.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub lucas_carmichael_from_multiple ($m, $callback) {

    my $t = Math::GMPz::Rmpz_init();
    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    is_square_free($m) || return;

    my $L = lcm(map { addint($_, 1) } factor($m));

    $m = Math::GMPz->new("$m");
    $L = Math::GMPz->new("$L");

    Math::GMPz::Rmpz_invert($v, $m, $L) || return;
    Math::GMPz::Rmpz_sub($v, $L, $v);

    for (my $p = Math::GMPz::Rmpz_init_set($v) ; ; Math::GMPz::Rmpz_add($p, $p, $L)) {

        Math::GMPz::Rmpz_gcd($t, $m, $p);
        Math::GMPz::Rmpz_cmp_ui($t, 1) == 0 or next;

        my @factors = factor_exp($p);
        (vecall { $_->[1] == 1 } @factors) || next;

        Math::GMPz::Rmpz_mul($v, $m, $p);
        Math::GMPz::Rmpz_add_ui($u, $v, 1);

        Math::GMPz::Rmpz_set_str($t, lcm(map { addint($_->[0], 1) } @factors), 10);

        if (Math::GMPz::Rmpz_divisible_p($u, $t)) {
            $callback->(Math::GMPz::Rmpz_init_set($v));
        }
    }
}

lucas_carmichael_from_multiple(11 * 17, sub ($n) { say $n });


================================================
FILE: Math/lucas-carmichael_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 August 2022
# https://github.com/trizen

# Generate all the Lucas-Carmichael numbers with n prime factors in a given range [a,b]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (in range [A,B]) (simple):
#   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)));

# PARI/GP program (in range [A, B]) (fast):
#   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)));

# PARI/GP program to generate all the Lucas-Carmichael numbers <= n (fast):
#   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);
#   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));

use 5.036;
use ntheory 0.74 qw(:all);

sub lucas_carmichael_numbers_in_range ($A, $B, $k) {

    $A = vecmax($A, pn_primorial($k));

    # Largest possisble prime factor for Lucas-Carmichael numbers <= B
    my $max_p = sqrtint($B);

    my @list;

    sub ($m, $L, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $hi = $max_p if ($hi > $max_p);
            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            my $t = $L - invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (($m * $p + 1) % ($p + 1) == 0 and is_prime($p)) {
                    push @list, $m * $p;
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {
            if (gcd($m, $p + 1) == 1) {
                __SUB__->($m * $p, lcm($L, $p + 1), $p + 1, $k - 1);
            }
        }
      }
      ->(1, 1, 3, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the Lucas-Carmichael numbers with 5 prime factors in the range [100, 10^8]

my $k    = 5;
my $from = 100;
my $upto = 1e8;

my @arr = lucas_carmichael_numbers_in_range($from, $upto, $k);
say join(', ', @arr);

__END__
588455, 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


================================================
FILE: Math/lucas-carmichael_numbers_in_range_from_prime_factors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 September 2022
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use ntheory 0.74 qw(:all);
use List::Util qw(uniq);

sub lucas_carmichael_numbers_in_range ($A, $B, $k, $primes, $callback) {

    $A = vecmax($A, pn_primorial($k));

    # Largest possisble prime factor for Lucas-Carmichael numbers <= B
    my $max_p = sqrtint($B);

    my @P   = sort { $a <=> $b } grep { $_ <= $max_p } uniq(@$primes);
    my $end = $#P;

    sub ($m, $lambda, $j, $k) {

        my $y = vecmin($max_p, rootint(divint($B, $m), $k));

        if ($k == 1) {

            my $x = cdivint($A, $m);

            if ($P[-1] < $x) {
                return;
            }

            foreach my $i ($j .. $end) {
                my $p = $P[$i];

                last if ($p > $y);
                next if ($p < $x);

                my $t = $m * $p;

                if (($t + 1) % $lambda == 0 and ($t + 1) % ($p + 1) == 0) {
                    $callback->($t);
                }
            }

            return;
        }

        foreach my $i ($j .. $end) {
            my $p = $P[$i];
            last if ($p > $y);

            gcd($m, $p + 1) == 1 or next;

            # gcd($m*$p, divisor_sum($m*$p)) == 1 or die "$m*$p: not Lucas-cyclic";

            __SUB__->($m * $p, lcm($lambda, $p + 1), $i + 1, $k - 1);
        }
      }
      ->(1, 1, 0, $k);
}

my $lambda = 5040;
my @primes = grep { $_ > 2 and $lambda % $_ != 0 and is_prime($_) } map { $_ - 1 } divisors($lambda);

foreach my $k (3 .. 6) {
    my @arr;
    lucas_carmichael_numbers_in_range(1, 10**(2 * $k), $k, \@primes, sub ($n) { push @arr, $n });
    say "$k: ", join(', ', sort { $a <=> $b } @arr);
}

__END__
3: 20999, 46079, 63503, 76751, 88559, 152279, 155819, 230159, 388079, 761039
4: 81719, 357599, 895679, 1097459, 2150819, 2193119, 2581319, 3228119, 6023039, 8159759, 9349919, 12791519, 14800799, 18119519, 21490919, 38534327, 64585079
5: 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
6: 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


================================================
FILE: Math/lucas-carmichael_numbers_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 February 2023
# https://github.com/trizen

# Generate all the Lucas-Carmichael numbers with n prime factors in a given range [a,b]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (up to 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)));

# PARI/GP program (in range [A, B]):
#   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)));

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub lucas_carmichael_numbers_in_range ($A, $B, $k) {

    $A = vecmax($A, pn_primorial($k + 1) >> 1);

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    # max_p = floor(sqrt(B))
    my $max_p = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_sqrt($max_p, $B);
    $max_p = Math::GMPz::Rmpz_get_ui($max_p) if Math::GMPz::Rmpz_fits_ulong_p($max_p);

    my @list;

    sub ($m, $L, $lo, $k) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        Math::GMPz::Rmpz_fits_ulong_p($u) || die "Too large value!";

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $hi = $max_p if ($max_p < $hi);
            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            Math::GMPz::Rmpz_invert($v, $m, $L);
            Math::GMPz::Rmpz_sub($v, $L, $v);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime($p)) {
                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                    Math::GMPz::Rmpz_add_ui($u, $v, 1);
                    if (Math::GMPz::Rmpz_divisible_ui_p($u, $p + 1)) {
                        push @list, Math::GMPz::Rmpz_init_set($v);
                    }
                }
            }

            return;
        }

        my $z   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p + 1) == 1 or next;
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $p + 1);
            Math::GMPz::Rmpz_mul_ui($z, $m, $p);

            __SUB__->($z, $lcm, $p + 1, $k - 1);
        }
      }
      ->(Math::GMPz->new(1), Math::GMPz->new(1), 3, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the Lucas-Carmichael numbers with 5 prime factors in the range [100, 10^8]

my $k    = 5;
my $from = 100;
my $upto = 1e8;

my @arr = lucas_carmichael_numbers_in_range($from, $upto, $k);
say join(', ', @arr);

__END__
588455, 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


================================================
FILE: Math/lucas-miller_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 07 January 2020
# https://github.com/trizen

# A simple factorization method, using the Lucas `U_n(P,Q)` sequences.
# Inspired by the Miller-Rabin factorization method.

# Works best on Lucas pseudoprimes.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_pseudoprime
#   https://en.wikipedia.org/wiki/Miller-Rabin_primality_test

use 5.020;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub lucas_miller_factor ($n, $j = 1, $k = 100) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $D = $n + $j;
    my $s = valuation($D, 2);
    my $r = $s - 1;
    my $d = $D >> $s;

    foreach my $i (1 .. $k) {

        my $P = vecmin(1 + int(rand(1e6)), urandomm($n));
        my $Q = vecmin(1 + int(rand(1e6)), urandomm($n));

        $Q *= -1 if (rand(1) < 0.5);

        next if is_square($P * $P - 4 * $Q);

        my ($U, $V, $T) = lucas_sequence($n, $P, $Q, $d);

        foreach my $z (0 .. $r) {

            foreach my $g (gcd($U, $n), gcd($V, $n), gcd(subint($V, $P), $n)) {
                if ($g > 1 and $g < $n) {
                    return $g;
                }
            }

            $U = mulmod($U, $V, $n);
            $V = mulmod($V, $V, $n);
            $V = submod($V, addint($T, $T), $n);
            $T = mulmod($T, $T, $n);
        }
    }

    return 1;
}

say lucas_miller_factor("16641689036184776955112478816668559");
say lucas_miller_factor("17350074279723825442829581112345759");
say lucas_miller_factor("61881629277526932459093227009982733523969186747");
say lucas_miller_factor("122738580838512721992324860157572874494433031849", -1);
say lucas_miller_factor("181490268975016506576033519670430436718066889008242598463521");
say lucas_miller_factor("173315617708997561998574166143524347111328490824959334367069087");
say lucas_miller_factor("57981220983721718930050466285761618141354457135475808219583649146881");
say lucas_miller_factor("2425361208749736840354501506901183117777758034612345610725789878400467");
say lucas_miller_factor("131754870930495356465893439278330079857810087607720627102926770417203664110488210785830750894645370240615968198960237761");


================================================
FILE: Math/lucas-pocklington_primality_proving.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 January 2020
# https://github.com/trizen

# 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).

# See also:
#   https://en.wikipedia.org/wiki/Pocklington_primality_test
#   https://en.wikipedia.org/wiki/Primality_certificate
#   https://mathworld.wolfram.com/PrattCertificate.html
#   https://math.stackexchange.com/questions/663341/n1-primality-proving-is-slow

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

use List::Util qw(uniq);
use ntheory qw(is_prime is_prob_prime);
use Math::Prime::Util::GMP qw(ecm_factor is_strong_pseudoprime);

use Math::AnyNum qw(
  :overload prod primorial is_coprime powmod
  irand min is_square lucasUmod gcd kronecker
  );

my $TRIAL_LIMIT = 10**6;
my $primorial   = primorial($TRIAL_LIMIT);

sub trial_factor ($n) {

    my @f;
    my $g = gcd($primorial, $n);

    if ($g > 1) {
        my @primes = ntheory::factor($g);
        foreach my $p (@primes) {
            while ($n % $p == 0) {
                push @f, $p;
                $n /= $p;
            }
        }
    }

    return ($n, @f);
}

sub lucas_pocklington_primality_proving ($n, $lim = 2**64) {

    if ($n <= $lim or $n <= 2) {
        return is_prime($n);    # fast deterministic test for small n
    }

    is_prob_prime($n) || return 0;

    if (ref($n) ne 'Math::AnyNum') {
        $n = Math::AnyNum->new("$n");
    }

    my $nm1 = $n - 1;
    my $np1 = $n + 1;

    my ($B1, @f1) = trial_factor($nm1);
    my ($B2, @f2) = trial_factor($np1);

    if (prod(@f1) < $B1 and prod(@f2) < $B2) {
        if ($B1 < $B2) {
            if (__SUB__->($B1)) {
                push @f1, $B1;
                $B1 = 1;
            }
            elsif (__SUB__->($B2)) {
                push @f2, $B2;
                $B2 = 1;
            }
        }
        else {
            if (__SUB__->($B2)) {
                push @f2, $B2;
                $B2 = 1;
            }
            elsif (__SUB__->($B1)) {
                push @f1, $B1;
                $B1 = 1;
            }
        }
    }

    my $pocklington_primality_proving = sub {

        foreach my $p (uniq(@f1)) {
            for (; ;) {
                my $a = irand(2, $nm1);
                is_strong_pseudoprime($n, $a) || return 0;
                if (is_coprime(powmod($a, $nm1 / $p, $n) - 1, $n)) {
                    say "a = $a ; p = $p";
                    last;
                }
            }
        }

        return 1;
    };

    my $find_PQD = sub {

        my $l = min(10**9, $n - 1);

        for (; ;) {
            my $P = (irand(1, $l));
            my $Q = (irand(1, $l) * ((rand(1) < 0.5) ? 1 : -1));
            my $D = ($P * $P - 4 * $Q);

            next if is_square($D % $n);
            next if ($P >= $n);
            next if ($Q >= $n);
            next if (kronecker($D, $n) != -1);

            return ($P, $Q, $D);
        }
    };

    my $lucas_primality_proving = sub {
        my ($P, $Q, $D) = $find_PQD->();

        is_strong_pseudoprime($n, $P + 1) or return 0;
        lucasUmod($P, $Q, $np1, $n) == 0  or return 0;

        foreach my $p (uniq(@f2)) {
            for (; ;) {
                $D == ($P * $P - 4 * $Q) or die "error: $P^2 - 4*$Q != $D";

                if ($P >= $n or $Q >= $n) {
                    return __SUB__->();
                }

                if (is_coprime(lucasUmod($P, $Q, $np1 / $p, $n), $n)) {
                    say "P = $P ; Q = $Q ; p = $p";
                    last;
                }

                ($P, $Q) = ($P + 2, $P + $Q + 1);
                is_strong_pseudoprime($n, $P) || return 0;
            }
        }

        return 1;
    };

    for (; ;) {
        my $A1 = prod(@f1);
        my $A2 = prod(@f2);

        if ($A1 > $B1 and is_coprime($A1, $B1)) {
            say "\n:: N-1 primality proving of: $n";
            return $pocklington_primality_proving->();
        }

        if ($A2 > $B2 and is_coprime($A2, $B2)) {
            say "\n:: N+1 primality proving of: $n";
            return $lucas_primality_proving->();
        }

        my @ecm_factors = map { Math::AnyNum->new($_) } ecm_factor($B1 * $B2);

        foreach my $p (@ecm_factors) {

            if ($B1 % $p == 0 and __SUB__->($p, $lim)) {
                while ($B1 % $p == 0) {
                    push @f1, $p;
                    $A1 *= $p;
                    $B1 /= $p;
                }
                if (__SUB__->($B1, $lim)) {
                    push @f1, $B1;
                    $A1 *= $B1;
                    $B1 /= $B1;
                }
                last if ($A1 > $B1);
            }

            if ($B2 % $p == 0 and __SUB__->($p, $lim)) {
                while ($B2 % $p == 0) {
                    push @f2, $p;
                    $A2 *= $p;
                    $B2 /= $p;
                }
                if (__SUB__->($B2, $lim)) {
                    push @f2, $B2;
                    $A2 *= $B2;
                    $B2 /= $B2;
                }
                last if ($A2 > $B2);
            }
        }
    }
}

say "Is prime: ",
  lucas_pocklington_primality_proving(115792089237316195423570985008687907853269984665640564039457584007913129603823);

__END__
:: N+1 primality proving of: 924116845936603030416149
P = 446779227 ; Q = -570813692 ; p = 2
P = 446779229 ; Q = -124034464 ; p = 3
P = 446779229 ; Q = -124034464 ; p = 5
P = 446779229 ; Q = -124034464 ; p = 23
P = 446779229 ; Q = -124034464 ; p = 839
P = 446779229 ; Q = -124034464 ; p = 319260971804461153

:: N-1 primality proving of: 145206169609764066844927343258645146513471
a = 65398207550754611976310922745879907064270 ; p = 2
a = 4798691037244889621933820261318904161487 ; p = 3
a = 116906491330255234184370825424228431344076 ; p = 5
a = 136169406264815751493129123529048530997722 ; p = 13
a = 135944141295463967893304597786628217140508 ; p = 37
a = 97262888879650744356761188900815226887264 ; p = 5419
a = 2902916905620381183086755524953265942224 ; p = 2009429159
a = 107195181666607031025002747775812085643863 ; p = 924116845936603030416149

:: N-1 primality proving of: 767990784468614637092681680819989903265059687929
a = 603854703399300341344639520448381233631361828843 ; p = 2
a = 107195257716196052909052603688672743914499334958 ; p = 661121
a = 138452952948919213705556701864021372614716309358 ; p = 145206169609764066844927343258645146513471

:: N+1 primality proving of: 1893865274499603695070553024902095101451637190432913
P = 903800454 ; Q = 701295878 ; p = 2
P = 903800454 ; Q = 701295878 ; p = 3
P = 903800454 ; Q = 701295878 ; p = 137
P = 903800454 ; Q = 701295878 ; p = 767990784468614637092681680819989903265059687929

:: N+1 primality proving of: 57896044618658097711785492504343953926634992332820282019728792003956564801911
P = 263931529 ; Q = -357766694 ; p = 2
P = 263931529 ; Q = -357766694 ; p = 3
P = 263931529 ; Q = -357766694 ; p = 1669
P = 263931529 ; Q = -357766694 ; p = 14083
P = 263931529 ; Q = -357766694 ; p = 1857767
P = 263931529 ; Q = -357766694 ; p = 29170630189
P = 263931529 ; Q = -357766694 ; p = 1893865274499603695070553024902095101451637190432913

:: N-1 primality proving of: 115792089237316195423570985008687907853269984665640564039457584007913129603823
a = 4029039168562415669306341971162211721541916673211300492678829534769579647404 ; p = 2
a = 56569963885874630697971498050698415523204083445143349658260796401052158770186 ; p = 57896044618658097711785492504343953926634992332820282019728792003956564801911
Is prime: 1


================================================
FILE: Math/lucas-pratt_primality_proving.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 January 2020
# https://github.com/trizen

# Prove the primality of a number, using the Lucas `U` sequence, recursively factoring N+1.

# Choose P and Q such that D = P^2 - 4*Q is not a square modulo N.
# Let N+1 = F*R with F > R, where R is odd and the prime factorization of F is known.
# 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;
# 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).

# See also:
#   https://en.wikipedia.org/wiki/Primality_certificate
#   https://math.stackexchange.com/questions/663341/n1-primality-proving-is-slow

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

use List::Util qw(uniq);
use ntheory qw(is_prime is_prob_prime);
use Math::Prime::Util::GMP qw(ecm_factor is_strong_pseudoprime);

use Math::AnyNum qw(
  :overload prod primorial is_coprime
  irand min is_square lucasUmod gcd kronecker
  );

my $primorial = primorial(10**6);

sub trial_factor ($n) {

    my @f;
    my $g = gcd($primorial, $n);

    if ($g > 1) {
        my @primes = ntheory::factor($g);
        foreach my $p (@primes) {
            while ($n % $p == 0) {
                push @f, $p;
                $n /= $p;
            }
        }
    }

    return ($n, @f);
}

sub lucas_primality_proving ($n, $lim = 2**64) {

    if ($n <= $lim or $n <= 2) {
        return is_prime($n);    # fast deterministic test for small n
    }

    is_prob_prime($n) || return 0;

    if (ref($n) ne 'Math::AnyNum') {
        $n = Math::AnyNum->new("$n");
    }

    my $d = $n + 1;
    my ($B, @f) = trial_factor($d);

    if ($B > 1 and __SUB__->($B, $lim)) {
        push @f, $B;
        $B = 1;
    }

    my $find_PQD = sub {

        my $l = min(10**9, $n - 1);

        for (; ;) {
            my $P = (irand(1, $l));
            my $Q = (irand(1, $l) * ((rand(1) < 0.5) ? 1 : -1));
            my $D = ($P * $P - 4 * $Q);

            next if is_square($D % $n);
            next if ($P >= $n);
            next if ($Q >= $n);
            next if (kronecker($D, $n) != -1);

            return ($P, $Q, $D);
        }
    };

    my $primality_proving = sub {
        my ($P, $Q, $D) = $find_PQD->();

        is_strong_pseudoprime($n, $P + 1)  or return 0;
        lucasUmod($P, $Q, $n + 1, $n) == 0 or return 0;

        foreach my $p (uniq(@f)) {
            for (; ;) {
                $D == ($P * $P - 4 * $Q) or die "error: $P^2 - 4*$Q != $D";

                if ($P >= $n or $Q >= $n) {
                    return __SUB__->();
                }

                if (is_coprime(lucasUmod($P, $Q, $d / $p, $n), $n)) {
                    say "P = $P ; Q = $Q ; p = $p";
                    last;
                }

                ($P, $Q) = ($P + 2, $P + $Q + 1);
                is_strong_pseudoprime($n, $P) || return 0;
            }
        }

        return 1;
    };

    for (; ;) {
        my $A = prod(@f);

        if ($A > $B and is_coprime($A, $B)) {
            say "\n:: Proving primality of: $n";
            return $primality_proving->();
        }

        my @ecm_factors = map { Math::AnyNum->new($_) } ecm_factor($B);

        foreach my $p (@ecm_factors) {
            if (__SUB__->($p, $lim)) {
                while ($B % $p == 0) {
                    $B /= $p;
                    $A *= $p;
                    push @f, $p;
                }
            }
            if ($A > $B) {
                say ":: Stopping early with A = $A and B = $B" if ($B > 1);
                last;
            }
        }
    }
}

say "Is prime: ", lucas_primality_proving(115792089237316195423570985008687907853269984665640564039457584007913129603823);

__END__
:: Proving primality of: 160667761273563902473
P = 637005555 ; Q = -759408520 ; p = 2
P = 637005555 ; Q = -759408520 ; p = 23
P = 637005555 ; Q = -759408520 ; p = 137
P = 637005555 ; Q = -759408520 ; p = 2591
P = 637005555 ; Q = -759408520 ; p = 77261
P = 637005555 ; Q = -759408520 ; p = 127356937

:: Proving primality of: 84919921767502888050045396989
P = 154974193 ; Q = -225311358 ; p = 2
P = 154974199 ; Q = 239611230 ; p = 3
P = 154974199 ; Q = 239611230 ; p = 5
P = 154974199 ; Q = 239611230 ; p = 257
P = 154974199 ; Q = 239611230 ; p = 2539
P = 154974199 ; Q = 239611230 ; p = 160667761273563902473

:: Proving primality of: 767990784468614637092681680819989903265059687929
P = 339178992 ; Q = 3659163746 ; p = 2
P = 339178992 ; Q = 3659163746 ; p = 3
P = 339178994 ; Q = 3998342739 ; p = 5
P = 339178994 ; Q = 3998342739 ; p = 7
P = 339178994 ; Q = 3998342739 ; p = 56737
P = 339178994 ; Q = 3998342739 ; p = 190097
P = 339178994 ; Q = 3998342739 ; p = 3992873
P = 339178994 ; Q = 3998342739 ; p = 84919921767502888050045396989

:: Proving primality of: 1893865274499603695070553024902095101451637190432913
P = 699534120 ; Q = -225663681 ; p = 2
P = 699534120 ; Q = -225663681 ; p = 3
P = 699534120 ; Q = -225663681 ; p = 137
P = 699534120 ; Q = -225663681 ; p = 767990784468614637092681680819989903265059687929

:: Proving primality of: 115792089237316195423570985008687907853269984665640564039457584007913129603823
P = 753451984 ; Q = 491391542 ; p = 2
P = 753451984 ; Q = 491391542 ; p = 3
P = 753451984 ; Q = 491391542 ; p = 1669
P = 753451984 ; Q = 491391542 ; p = 14083
P = 753451984 ; Q = 491391542 ; p = 1857767
P = 753451984 ; Q = 491391542 ; p = 29170630189
P = 753451984 ; Q = 491391542 ; p = 1893865274499603695070553024902095101451637190432913
Is prime: 1


================================================
FILE: Math/lucas-pratt_prime_records.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 12 May 2019
# https://github.com/trizen

# Count the number of nodes in the Lucas-Pratt primality tree, rooted at a given prime.

# See also:
#   https://oeis.org/A037231 -- Primes which set a new record for length of Pratt certificate.
#   https://oeis.org/A130790 -- Number of nodes in the Lucas-Pratt primality tree rooted at prime(n).

use 5.020;
use warnings;

use ntheory qw(:all);
use Memoize qw(memoize);
use experimental qw(signatures);

memoize('lucas_pratt_primality_tree_count');

sub lucas_pratt_primality_tree_count ($p, $r = -1) {

    return 0 if ($p <= 1);
    return 1 if ($p == 2);

    vecsum(map { __SUB__->($_->[0], $r) } factor_exp($p + $r));
}

sub lucas_pratt_prime_records ($r = -1, $upto = 1e6) {

    my $max = 0;
    my @primes;

    forprimes {
        my $t = lucas_pratt_primality_tree_count($_, $r);
        if ($t > $max) {
            $max = $t;
            push @primes, $_;
        }
    } $upto;

    return @primes;
}

say "p-1: ", join(', ', lucas_pratt_prime_records(-1, 1e6));     # A037231
say "p+1: ", join(', ', lucas_pratt_prime_records(+1, 1e6));

__END__
p-1: 2, 7, 23, 43, 139, 283, 659, 1319, 5179, 9227, 23159, 55399, 148439, 366683, 793439, 1953839, 4875119, 9750239
p+1: 2, 5, 19, 29, 73, 173, 569, 1109, 2917, 5189, 10729, 21169, 42337, 84673, 254021, 508037, 1287457, 3787969, 7575937


================================================
FILE: Math/lucas_factorization_method.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 13 October 2018
# https://github.com/trizen

# A new integer factorization method, using the Lucas U and V sequences.

# Inspired by the BPSW primality test.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_sequence
#   https://en.wikipedia.org/wiki/Lucas_pseudoprime
#   https://en.wikipedia.org/wiki/Baillie%E2%80%93PSW_primality_test

use 5.020;
use warnings;

use experimental qw(signatures);

use Math::AnyNum qw(:overload bit_scan1 is_power kronecker gcd prod);
use Math::Prime::Util::GMP qw(lucas_sequence consecutive_integer_lcm random_nbit_prime);

sub lucas_factorization ($n, $B) {

    return 1 if $n <= 2;
    return 1 if is_power($n);

    my ($P, $Q) = (1, 0);

    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);

        if (kronecker($D, $n) == -1) {
            $Q = (1 - $D) / 4;
            last;
        }
    }

    my $d = consecutive_integer_lcm($B);
    my ($U, $V) = lucas_sequence($n, $P, $Q, $d);

    foreach my $f (sub { gcd($U, $n) }, sub { gcd($V - 2, $n) }) {
        my $g = $f->();
        return $g if ($g > 1 and $g < $n);
    }

    return 1;
}

say lucas_factorization(257221 * 470783,               700);     #=> 470783           (p+1 is  700-smooth)
say lucas_factorization(333732865481 * 1632480277613,  3000);    #=> 333732865481     (p-1 is 3000-smooth)
say lucas_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)
say lucas_factorization(6555457852399 * 7864885571993, 700);     #=> 6555457852399    (p-1 is  700-smooth)
say lucas_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)

# Example of a larger number that can be factorized fast with this method
say lucas_factorization(203544696384073367670016326770637347800169508950125910682353, 19);      #=> 5741461760879844361

say "\n=> More tests:";

foreach my $k (10 .. 50) {

    my $n = prod(map { random_nbit_prime($k) } 1 .. 2);
    my $p = lucas_factorization($n, 2 * $n->ilog2**2);

    if ($p > 1 and $p < $n) {
        say "$n = $p * ", $n / $p;
    }
}

__END__
36815861 = 6199 * 5939
748527379 = 31151 * 24029
2205610861 = 46279 * 47659
6464972083 = 72623 * 89021
42908134667 = 165037 * 259991
144064607993 = 324589 * 443837
14055375555899 = 3773629 * 3724631
34326163013579 = 4942513 * 6945083
635676232543327 = 28513789 * 22293643
4228743692662373 = 64463821 * 65598713
44525895097265171 = 211263823 * 210759677
88671631232856109 = 269999071 * 328414579
8445394419907066249 = 3185955247 * 2650820167
508484280918603770621 = 17377315313 * 29261383117
12301305131668154065127 = 91341582047 * 134673659641
8834277945256453860289739 = 2536339835969 * 3483081336331


================================================
FILE: Math/lucas_factorization_method_generalized.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 18 May 2019
# https://github.com/trizen

# A new integer factorization method, using the modular Lucas U sequence.

# It uses the smallest divisor `d` of `p - kronecker(P*P - 4*Q, n)`, such that `U_d(P,Q) = 0 (mod p)`.

# By selecting a small bound B, we compute `k = lcm(1..B)`, hoping that `k` is a
# multiple of `d`, then `gcd(U_k(P,Q) (mod n), n)` in a non-trivial factor of `n`.

# This method is similar in flavor to Pollard's p-1 and Williams's p+1 methods.

use 5.020;
use warnings;

use experimental qw(signatures);

use Math::AnyNum qw(:overload irand gcd prod);
use Math::Prime::Util::GMP qw(lucas_sequence logint consecutive_integer_lcm random_nbit_prime);

sub lucas_factorization ($n, $B = logint($n, 2)**2, $a = 1, $b = 10) {

    my $L = consecutive_integer_lcm($B);

    foreach my $P ($a .. $b) {    # P > 0, P < n

        my $Q = irand(-$n, $n - 1);    # Q < n
        my $D = ($P * $P - 4 * $Q);    # D != 0

        $D || next;

        my $F = eval { (lucas_sequence($n, $P, $Q, $L))[0] } // next;
        my $g = gcd($F, $n);

        if ($g > 1 and $g < $n) {
            return $g;
        }
    }

    return 1;
}

say lucas_factorization(257221 * 470783,               700);     #=> 470783           (p+1 is  700-smooth)
say lucas_factorization(333732865481 * 1632480277613,  3000);    #=> 333732865481     (p-1 is 3000-smooth)
say lucas_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)
say lucas_factorization(6555457852399 * 7864885571993, 700);     #=> 6555457852399    (p-1 is  700-smooth)
say lucas_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)

say "\n=> More factorizations:";

foreach my $k (10 .. 50) {

    my $n = prod(map { random_nbit_prime($k) } 1 .. 2);
    my $B = int(log($n) * exp(sqrt(log($n) * log(log($n))) / 2));
    my $p = lucas_factorization($n, $B);

    if ($p > 1) {
        printf("%s = %s * %s\n", $n, $p, $n / $p);
    }
}

__END__
544553 = 631 * 863
1676989 = 1301 * 1289
40928003 = 7159 * 5717
152309891 = 14557 * 10463
2300268811 = 64627 * 35593
11952132373 = 108079 * 110587
88750630231 = 289253 * 306827
405912740881 = 560089 * 724729
2327770162243 = 1690309 * 1377127
12499479778633 = 4032971 * 3099323
52190728874299 = 6665017 * 7830547
169450380817337 = 14835001 * 11422337
413120763604271 = 17965499 * 22995229
1991077071146719 = 36803257 * 54100567
7717232903949787 = 92283913 * 83624899
36847896737907319 = 181428361 * 203098879
638608157008243187 = 698497087 * 914260301
3416003128355302301 = 1773283703 * 1926371467
8189756908298548657 = 3749794309 * 2184054973
38364912094936082309 = 5629836997 * 6814568897
114226553742226158113 = 10915936417 * 10464201089
670007250188746144573 = 30739321757 * 21796422689
7304335218402627970339 = 84180973361 * 86769431699
157099299692502309409753 = 432342208787 * 363367944419
2303492941061419264300001 = 1191794882419 * 1932793113179
14246977176399484087089437 = 4078455141589 * 3493228853033
54462337363308569263306589 = 7154666227601 * 7612142290189
187314575021720258442926711 = 11541166852097 * 16230124511863
2109644814216084799800489451 = 49099874983879 * 42966398894269
10333250426104069265111817281 = 97051714715701 * 106471590495581
42849869010641243828199370319 = 173690504530247 * 246702426977977


================================================
FILE: Math/lucas_pseudoprimes_generation.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 07 October 2018
# Edit: 19 August 2020
# https://github.com/trizen

# A new algorithm for generating super-Lucas pseudoprimes.

# See also:
#   https://oeis.org/A217120 -- Lucas pseudoprimes
#   https://oeis.org/A217255 -- Strong Lucas pseudoprimes
#   https://oeis.org/A177745 -- Semiprimes n such that n divides Fibonacci(n+1).
#   https://oeis.org/A212423 -- Frobenius pseudoprimes == 2,3 (mod 5) with respect to Fibonacci polynomial x^2 - x - 1.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);
use Math::AnyNum qw(prod);

sub lucas_pseudoprimes ($limit, $callback, $P = 1, $Q = -1) {

    my %table;
    my $D = $P*$P - 4*$Q;

    forprimes {
        my $p = $_;
        foreach my $d (divisors($p - kronecker($D, $p))) {
            if ((lucas_sequence($p, $P, $Q, $d))[0] == 0) {
                push @{$table{$d}}, $p;
            }
        }
    } 3, $limit;

    foreach my $arr (values %table) {

        my $l = $#{$arr} + 1;

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = prod(@{$arr}[@_]);
                $callback->($n, @{$arr}[@_]);
            } $l, $k;
        }
    }
}

sub is_weak_lucas_pseudoprime ($n, $P = 1, $Q = -1) {

    my $D = ($P*$P - 4*$Q);
    my $k = kronecker($D, $n);

    (lucas_sequence($n, $P, $Q, $n - $k))[0] == 0;
}

my @pseudoprimes;

lucas_pseudoprimes(
    10_000,
    sub ($n, @f) {

        is_weak_lucas_pseudoprime($n, 1, -1) or die "error: $n";

        push @pseudoprimes, $n;

        if (kronecker(5, $n) == -1 and powmod(2, $n-1, $n) == 1) {
            die "Found a BPSW counter-example: $n = prod(@f)";
        }
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
323, 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


================================================
FILE: Math/lucas_pseudoprimes_generation_erdos_method.pl
================================================
#!/usr/bin/perl

# Erdos construction method for Lucas D-pseudoprimes, for discriminant D = P^2-4Q:
#   1. Choose an even integer L with many divisors.
#   2. Let P be the set of primes p such that p-kronecker(D,p) divides L and p does not divide L.
#   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.

# Alternatively:
#   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.

use 5.020;
use warnings;

use ntheory qw(:all);
use List::Util qw(uniq);
use experimental qw(signatures);

sub lambda_primes ($L, $D) {

    # Primes p such that `p - kronecker(D,p)` divides L and p does not divide L.

    my @divisors = divisors($L);

    my @A = grep { ($_ > 2) and is_prime($_) and ($L % $_ != 0) and kronecker($D, $_) == -1 } map { $_ - 1 } @divisors;
    my @B = grep { ($_ > 2) and is_prime($_) and ($L % $_ != 0) and kronecker($D, $_) == +1 } map { $_ + 1 } @divisors;

    sort { $a <=> $b } uniq(@A, @B);
}

sub lucas_pseudoprimes ($L, $P = 1, $Q = -1) {

    my $D = ($P * $P - 4 * $Q);
    my @P = lambda_primes($L, $D);

    foreach my $k (2 .. @P) {
        forcomb {

            my $n = vecprod(@P[@_]);
            my $k = kronecker($D, $n);

            if ((lucas_sequence($n, $P, $Q, $n - $k))[0] == 0) {
                say $n;
            }
        } scalar(@P), $k;
    }
}

lucas_pseudoprimes(720, 1, -1);

__END__
323
1891
6601
13981
342271
1590841
852841
3348961
9937081
16778881
72881641
10756801
154364221
205534681
609865201
807099601
1438048801
7692170761
921921121
32252538601
222182990161
2051541911881
2217716806743361


================================================
FILE: Math/lucas_sequences_U_V.pl
================================================
#!/usr/bin/perl

# Algorithm due to Aleksey Koval for computing the Lucas U and V sequences.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_sequence

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::AnyNum qw(:overload digits);

sub lucasUV ($n, $P, $Q) {

    my ($V1, $V2) = (2, $P);
    my ($Q1, $Q2) = (1, 1);

    my @bits = digits($n, 2);

    while (@bits) {

        $Q1 *= $Q2;

        if (pop @bits) {
            $Q2 = ($Q1 * $Q);
            $V1 = ($V2 * $V1 - $P * $Q1);
            $V2 = ($V2 * $V2 - 2 * $Q2);
        }
        else {
            $Q2 = $Q1;
            $V2 = ($V2 * $V1 - $P * $Q1);
            $V1 = ($V1 * $V1 - 2 * $Q2);
        }
    }

    my $Uk = (2 * $V2 - $P * $V1) / ($P * $P - 4 * $Q);

    return ($Uk, $V1);
}

foreach my $n (1 .. 20) {
    say "[", join(', ', lucasUV($n, 1, -1)), "]";
}

__END__
[1, 1]
[1, 3]
[2, 4]
[3, 7]
[5, 11]
[8, 18]
[13, 29]
[21, 47]
[34, 76]
[55, 123]
[89, 199]
[144, 322]
[233, 521]
[377, 843]
[610, 1364]
[987, 2207]
[1597, 3571]
[2584, 5778]
[4181, 9349]
[6765, 15127]


================================================
FILE: Math/lucas_sequences_U_V_mpz.pl
================================================
#!/usr/bin/perl

# Algorithm due to Aleksey Koval for computing the Lucas U and V sequences.

# See also:
#   https://en.wikipedia.org/wiki/Lucas_sequence

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;

sub lucasUV ($n, $P, $Q) {

    $n = Math::GMPz->new("$n");
    $P = Math::GMPz->new("$P");
    $Q = Math::GMPz->new("$Q");

    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));
    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));

    my $t = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($n, 2))) {

        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);

        if ($bit) {
            Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);
            Math::GMPz::Rmpz_mul($t,  $P,  $Q1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V2);
            Math::GMPz::Rmpz_sub($V1, $V1, $t);
            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);
        }
        else {
            Math::GMPz::Rmpz_set($Q2, $Q1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_mul($t,  $P,  $Q1);
            Math::GMPz::Rmpz_mul($V1, $V1, $V1);
            Math::GMPz::Rmpz_sub($V2, $V2, $t);
            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);
        }
    }

    Math::GMPz::Rmpz_mul_2exp($t, $V2, 1);
    Math::GMPz::Rmpz_submul($t, $P, $V1);
    Math::GMPz::Rmpz_mul($v, $P, $P);
    Math::GMPz::Rmpz_submul_ui($v, $Q, 4);
    Math::GMPz::Rmpz_divexact($t, $t, $v);

    return ($t, $V1);
}

foreach my $n (1 .. 20) {
    say "[", join(', ', lucasUV($n, 1, -1)), "]";
}

__END__
[1, 1]
[1, 3]
[2, 4]
[3, 7]
[5, 11]
[8, 18]
[13, 29]
[21, 47]
[34, 76]
[55, 123]
[89, 199]
[144, 322]
[233, 521]
[377, 843]
[610, 1364]
[987, 2207]
[1597, 3571]
[2584, 5778]
[4181, 9349]
[6765, 15127]


================================================
FILE: Math/lucas_theorem.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date 04 September 2020
# https://github.com/trizen

# Simple implementation of Lucas's theorem, for computing binomial(n,k) mod p, for some prime p.

# See also:
#   https://en.wikipedia.org/wiki/Lucas%27s_theorem

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(:all);

sub factorial_valuation ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub modular_binomial ($n, $k, $m) {    # fast for small n

    my $j    = $n - $k;
    my $prod = 1;

    forprimes {
        my $p = factorial_valuation($n, $_);

        if ($_ <= $k) {
            $p -= factorial_valuation($k, $_);
        }

        if ($_ <= $j) {
            $p -= factorial_valuation($j, $_);
        }

        if ($p > 0) {
            $prod *= ($p == 1) ? ($_ % $m) : powmod($_, $p, $m);
            $prod %= $m;
        }
    } $n;

    return $prod;
}

sub lucas_theorem ($n, $k, $p) {

    if ($n < $k) {
        return 0;
    }

    my $res = 1;

    while ($k > 0) {
        my ($Nr, $Kr) = ($n % $p, $k % $p);

        if ($Nr < $Kr) {
            return 0;
        }

        ($n, $k) = (divint($n, $p), divint($k, $p));
        $res = mulmod($res, modular_binomial($Nr, $Kr, $p), $p);
    }

    return $res;
}

sub lucas_theorem_alt ($n, $k, $p) {    # alternative implementation

    if ($n < $k) {
        return 0;
    }

    my @Nd = reverse todigits($n, $p);
    my @Kd = reverse todigits($k, $p);

    my $res = 1;

    foreach my $i (0 .. $#Kd) {

        my $Nr = $Nd[$i];
        my $Kr = $Kd[$i];

        if ($Nr < $Kr) {
            return 0;
        }

        $res = mulmod($res, modular_binomial($Nr, $Kr, $p), $p);
    }

    return $res;
}

say lucas_theorem(1e10,           1e5,           1009);    #=> 559
say lucas_theorem(powint(10, 18), powint(10, 9), 2957);    #=> 2049

say '';

say lucas_theorem_alt(1e10,           1e5,           1009);    #=> 559
say lucas_theorem_alt(powint(10, 18), powint(10, 9), 2957);    #=> 2049


================================================
FILE: Math/magic_3-gon_ring.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 August 2016
# Website: https://github.com/trizen

# Solve a magic 3-gon ring.
# See: https://projecteuler.net/problem=68

use 5.014;
use ntheory qw(forperm);

my @nums = (1 .. 6);

forperm {
    my @d = @nums[@_];
    my $n = $d[0] + $d[1] + $d[2];

    if (    $d[0] < $d[3]
        and $d[0] < $d[5]
        and $n == $d[3] + $d[2] + $d[4]
        and $n == $d[5] + $d[4] + $d[1]) {
        say "($d[0] $d[1] $d[2] | $d[3] $d[2] $d[4] | $d[5] $d[4] $d[1]) = $n";
    }
} scalar(@nums);


================================================
FILE: Math/magic_5-gon_ring.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 August 2016
# Website: https://github.com/trizen

# Solve a magic 5-gon ring.
# See: https://projecteuler.net/problem=68

use 5.014;
use ntheory qw(forperm);

my $max  = '';
my @nums = (1 .. 10);

forperm {
    my @d = @nums[@_];

    my $i = $d[0] + $d[1] + $d[2];
    my $j = $d[3] + $d[2] + $d[4];
    my $k = $d[5] + $d[4] + $d[6];
    my $l = $d[7] + $d[6] + $d[8];
    my $m = $d[9] + $d[8] + $d[1];

    if (    $d[0] < $d[3]
        and $d[0] < $d[5]
        and $d[0] < $d[7]
        and $d[0] < $d[9]
        and $i == $j
        and $i == $k
        and $i == $l
        and $i == $m
    ) {
        printf(
            "(%2d %2d %2d | %2d %2d %2d | %2d %2d %2d | %2d %2d %2d | %2d %2d %2d) = %2d\n",

            $d[0], $d[1], $d[2],
            $d[3], $d[2], $d[4],
            $d[5], $d[4], $d[6],
            $d[7], $d[6], $d[8],
            $d[9], $d[8], $d[1],

            $i
        );
    }
} scalar(@nums);


================================================
FILE: Math/map_num.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# License: GPLv3
# Date: 08th October 2013
# https://trizenx.blogspot.com

# Map an amount of numbers in a given interval

use 5.010;
use strict;
use warnings;

sub map_num {
    my ($amount, $from, $to) = @_;

    my $diff = $to - $from;
    my $step = $diff / $amount;

    return if $step == 0;

    my @nums;
    for (my $i = $from ; $i <= $to ; $i += $step) {
        push @nums, $i;
    }

    return @nums;
}

say join "\n", map_num(10, 4, 5);


================================================
FILE: Math/matrix_determinant_bareiss.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 November 2016
# https://github.com/trizen

# The Bareiss algorithm for computing the determinant of a (square) matrix.

# Algorithm from:
#   https://apidock.com/ruby/v1_9_3_125/Matrix/determinant_bareiss

# See also:
#   https://en.wikipedia.org/wiki/Bareiss_algorithm

use 5.010;
use strict;
use warnings;

use List::Util qw(first);

sub det {
    my ($m) = @_;

    my @m = map { [@$_] } @$m;

    my $sign  = +1;
    my $pivot = 1;
    my $end   = $#m;

    foreach my $k (0 .. $end) {
        my @r = ($k + 1 .. $end);

        my $prev_pivot = $pivot;
        $pivot = $m[$k][$k];

        if ($pivot == 0) {
            my $i = (first { $m[$_][$k] } @r) // return 0;
            @m[$i, $k] = @m[$k, $i];
            $pivot = $m[$k][$k];
            $sign  = -$sign;
        }

        foreach my $i (@r) {
            foreach my $j (@r) {
                (($m[$i][$j] *= $pivot) -= $m[$i][$k] * $m[$k][$j]) /= $prev_pivot;
            }
        }
    }

    $sign * $pivot;
}

my $matrix = [
    [2, -1,  5,  1],
    [3,  2,  2, -6],
    [1,  3,  3, -1],
    [5, -2, -3,  3],
];

say det($matrix);       #=> 684


================================================
FILE: Math/matrix_path_2-ways_best.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 August 2016
# Website: https://github.com/trizen

# Find the best-minimum path-sum from the top-left of a matrix, to the bottom-right.
# Inspired by: https://projecteuler.net/problem=81

# The path moves only right and down.

use 5.010;
use strict;
use warnings;

use List::Util qw(min);
use Memoize qw(memoize);

memoize('path');

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

my $end = $#matrix;

sub path {
    my ($i, $j) = @_;

    if ($i < $end and $j < $end) {
        return $matrix[$i][$j] + min(path($i + 1, $j), path($i, $j + 1));
    }

    if ($i < $end) {
        return $matrix[$i][$j] + path($i + 1, $j);
    }

    if ($j < $end) {
        return $matrix[$i][$j] + path($i, $j + 1);
    }

    $matrix[$i][$j];
}

say path(0, 0);


================================================
FILE: Math/matrix_path_2-ways_greedy.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 August 2016
# Website: https://github.com/trizen

# Find the greedy-minimum path from each end of a square matrix.
# Inspired by: https://projecteuler.net/problem=81

# "Path 1" is from the top-left of the matrix, to the bottom-right.
# "Path 2" is from the bottom-right of the matrix, to the top-left.

# "Path 1" moves only right and down.
# "Path 2" moves only left and up.

use 5.010;
use strict;
use warnings;

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

my $end = $#matrix;

my @path_1;
my @path_2;

{
    my $i = 0;
    my $j = 0;

    push @path_1, $matrix[$i][$j];

    while (1) {

        if (    exists($matrix[$i][$j + 1])
            and exists($matrix[$i + 1])
            and $matrix[$i][$j + 1] < $matrix[$i + 1][$j]) {
            ++$j;
        }
        else {
            ++$i;
        }

        push @path_1, $matrix[$i][$j];

        if ($i == $end and $j == $end) { last }
    }
}

{

    my $i = $end;
    my $j = $end;

    push @path_2, $matrix[$i][$j];

    while (1) {

        if (    $j - 1 >= 0
            and $i - 1 >= 0
            and exists($matrix[$i][$j - 1])
            and exists($matrix[$i - 1])
            and $matrix[$i][$j - 1] < $matrix[$i - 1][$j]) {
            --$j;
        }
        else {
            --$i;
        }

        push @path_2, $matrix[$i][$j];

        if ($i == 0 and $j == 0) { last }
    }

}

say "Path 1: [@path_1]";
say "Path 2: [@path_2]";


================================================
FILE: Math/matrix_path_3-ways_best.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# The minimal path sum in the 5 by 5 matrix below, by starting in any cell
# in the left column and finishing in any cell in the right column, and only
# moving up, down, and right; the sum is equal to 994.

# This algorithm finds the best possible path.
# The problem was taken from: https://projecteuler.net/problem=82

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

use List::Util qw(min);
use Memoize qw(memoize);

memoize('path');

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

my $end = $#matrix;

sub path {
    my ($i, $j, $last) = @_;

    $j >= $end && return $matrix[$i][$j];

    my @paths;
    if ($i > 0 and $last ne 'down') {
        push @paths, path($i - 1, $j, 'up');
    }

    push @paths, path($i, $j + 1, 'ok');

    if ($i < $end and $last ne 'up') {
        push @paths, path($i + 1, $j, 'down');
    }

    my $min = 'inf';

    foreach my $sum (@paths) {
        $min = $sum if $sum < $min;
    }

    $min + $matrix[$i][$j];
}

my @sums;
foreach my $i (0 .. $end) {
    push @sums, path($i, 0, 'ok');
}

say min(@sums);


================================================
FILE: Math/matrix_path_3-ways_diagonal_best.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 August 2017
# https://github.com/trizen

# Find the lowest-cost possible path in a matrix, by starting
# in the top-left corner of the matrix and finishing in the
# bottom-right corner, and only moving up, down, and right.

# Problem closely related to:
#   https://projecteuler.net/problem=82

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

use List::Util qw(min);
use Memoize qw(memoize);

memoize('path');

my @matrix = (
              [131, 673,   4, 103,  18],
              [ 21,  96, 342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121,  56],
              [805, 732, 524,  37, 331],
             );

my $end = $#matrix;

sub path {
    my ($i, $j, $last, @path) = @_;

    if ($i == $end and $j == $end) {
        return ($matrix[$i][$j], @path, $matrix[$i][$j]);
    }
    elsif ($j > $end) {
        return ('inf', @path);
    }

    my $item = $matrix[$i][$j];

    my @paths;
    if ($i > 0 and $last ne 'down') {
        push @paths, [path($i - 1, $j, 'up', @path, $item)];
    }

    push @paths, [path($i, $j + 1, 'ok', @path, $item)];

    if ($i < $end and $last ne 'up') {
        push @paths, [path($i + 1, $j, 'down', @path, $item)];
    }

    my $min = 'inf';

    foreach my $group (@paths) {
        my ($sum, @p) = @{$group};

        if ($sum < $min) {
            $min  = $sum;
            @path = @p;
        }
    }

    ($min + $item, @path);
}

my ($sum, @path) = path(0, 0, 'ok');

say "Cost: $sum";       #=> Cost: 1363
say "Path: [@path]";    #=> Path: [131 21 96 342 4 103 18 150 111 56 331]


================================================
FILE: Math/matrix_path_3-ways_greedy.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# The minimal path sum in the 5 by 5 matrix below, by starting in any cell
# in the left column and finishing in any cell in the right column, and only
# moving up, down, and right; the sum is equal to 994.

# This is a greedy algorithm.
# The problem was taken from: https://projecteuler.net/problem=82

use 5.010;
use strict;
use warnings;

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

my $end = $#matrix;
my $min = 'inf';

foreach my $i (0 .. $#matrix) {
    my $sum = $matrix[$i][0];

    my $j    = 0;
    my $last = 'ok';

    while (1) {
        my @ways;

        if ($i > 0 and $last ne 'down') {
            push @ways, [-1, 0, $matrix[$i - 1][$j], 'up'];
        }

        if ($j < $end) {
            push @ways, [0, 1, $matrix[$i][$j + 1], 'ok'];
        }

        if ($i < $end and $last ne 'up') {
            push @ways, [1, 0, $matrix[$i + 1][$j], 'down'];
        }

        my $m = [0, 0, 'inf', 'ok'];

        foreach my $way (@ways) {
            $m = $way if $way->[2] < $m->[2];
        }

        $i   += $m->[0];
        $j   += $m->[1];
        $sum += $m->[2];
        $last = $m->[3];

        last if $j >= $end;
    }

    $min = $sum if $sum < $min;
}

say $min;


================================================
FILE: Math/matrix_path_4-ways_best.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 August 2016
# Website: https://github.com/trizen

# In the 5 by 5 matrix below, the minimal path sum from the top left
# to the bottom right, by moving left, right, up, and down, is equal to 2297.

# Problem from: https://projecteuler.net/problem=83

# (this algorithm is not scalable for matrices beyond 5x5)

use 5.010;
use strict;
use warnings;

use List::Util qw(min);

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

my %seen;
my $end = $#matrix;

sub rec {
    my ($i, $j, @vecs) = @_;

    @vecs = (
             grep { not exists $seen{"@{$_}"} }
             map { [$_->[0] + $i, $_->[1] + $j] } @vecs
            );

    @vecs || return 'inf';

    undef $seen{"$i $j"};
    my $res = $matrix[$i][$j] + min(map { path(@{$_}) } @vecs);
    delete $seen{"$i $j"};

    return $res;
}

sub path {
    my ($i, $j) = @_;

    if ($i == 0 and $j == 0) {
        return rec($i, $j, [1, 0], [0, 1]);
    }

    if ($i == 0 and $j == $end) {
        return rec($i, $j, [0, -1], [1, 0]);
    }

    if ($i == $end and $j == 0) {
        return rec($i, $j, [-1, 0], [0, 1]);
    }

    if ($i == 0 and $j > 0 and $j < $end) {
        return rec($i, $j, [1, 0], [0, 1], [0, -1]);
    }

    if ($i == $end and $j > 0 and $j < $end) {
        return rec($i, $j, [-1, 0], [0, -1], [0, 1]);
    }

    if ($j == 0 and $i > 0 and $i < $end) {
        return rec($i, $j, [-1, 0], [1, 0], [0, 1]);
    }

    if ($j == $end and $i > 0 and $i < $end) {
        return rec($i, $j, [-1, 0], [1, 0], [0, -1]);
    }

    if ($i > 0 and $j > 0 and $i < $end and $j < $end) {
        return rec($i, $j, [1, 0], [0, 1], [-1, 0], [0, -1]);
    }

    $matrix[$i][$j];
}

say path(0, 0);


================================================
FILE: Math/matrix_path_4-ways_best_2.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# In the 5 by 5 matrix below, the minimal path sum from the top left
# to the bottom right, by moving left, right, up, and down, is equal to 2297.

# Problem from: https://projecteuler.net/problem=83

# (this algorithm is scalable only up to 7x7 matrices)

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

memoize('path');
my $end = $#matrix;

sub path {
    my ($i, $j, $seen) = @_;

    my @seen = split(' ', $seen);

    my $valid = sub {
        my %seen;
        @seen{@seen} = ();
        not exists $seen{"$_[0]:$_[1]"};
    };

    if ($i >= $end and $j >= $end) {
        return $matrix[$i][$j];
    }

    my @points;

    if ($j < $end and $valid->($i, $j + 1)) {
        push @points, [$i, $j + 1];
    }

    if ($i > 0 and $valid->($i - 1, $j)) {
        push @points, [$i - 1, $j];
    }

    if ($j > 0 and $valid->($i, $j - 1)) {
        push @points, [$i, $j - 1];
    }

    if ($i < $end and $valid->($i + 1, $j)) {
        push @points, [$i + 1, $j];
    }

    my $min = 'inf';
    my $snn = join(' ', sort (@seen, map { join(':', @$_) } @points));

    foreach my $point (@points) {
        my $sum = path(@$point, $snn);
        $min = $sum if $sum < $min;
    }

    $min + $matrix[$i][$j];
}

say path(0, 0, '');


================================================
FILE: Math/matrix_path_4-ways_best_3.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 August 2016
# Website: https://github.com/trizen

# Problem from: https://projecteuler.net/problem=83

# (this algorithm is scalable up to matrices of size 80x80)

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

use List::Util qw(min max);
use Term::ANSIColor qw(colored);

my @matrix = map {
    [map { int rand 10_000 } 1 .. 15]
} 1 .. 15;

sub draw {
    my ($path) = @_;

    print "\e[H\e[J\e[H";
    my @screen = map {
        [map { sprintf "%4s", $_ } @{$_}]
    } @matrix;

    foreach my $p (@$path) {
        my ($i, $j) = @$p;
        $screen[$i][$j] = colored($screen[$i][$j], 'red');
    }

    foreach my $row (@screen) {
        say join(' ', @{$row});
    }
}

my %seen;

sub valid {
    not exists $seen{"@_"};
}

my %two_way_cache;
my $end = $#matrix;

sub two_way_path {
    my ($i, $j, $k, $l) = @_;

    my $key = "$i $j $k $l";
    if (exists $two_way_cache{$key}) {
        return $two_way_cache{$key};
    }

    my @paths;

    if ($i < $k) {
        push @paths, two_way_path($i + 1, $j, $k, $l);
    }

    if ($j < $l) {
        push @paths, two_way_path($i, $j + 1, $k, $l);
    }

    $two_way_cache{$key} = $matrix[$i][$j] + (min(@paths) || 0);
}

my @stack;
my $sum = 0;
my ($i, $j) = (0, 0);
my $limit = two_way_path(0, 0, $end, $end);
my $max = max(map { @$_ } @matrix);

my %min = (sum => 'inf');

while (1) {
    undef $seen{"$i $j"};
    $sum += $matrix[$i][$j];

    my @points;

    if ($i >= $end and $j >= $end) {
        if ($sum < $min{sum}) {
            $min{sum}  = $sum;
            $min{path} = [keys %seen];
        }
        @stack ? goto STACK: last;
    }

    # Skip invalid starting paths
    if (not($sum <= $limit) or not($sum <= two_way_path(0, 0, $i, $j))) {
        goto STACK if @stack;
    }

    # Skip invalid ending paths (this is a HUGE optimization)
    if (not($sum - $matrix[$i][$j] + two_way_path($i, $j, $end, $end) <= $limit + $max)) {
        goto STACK if @stack;
    }

    if ($i > 0 and valid($i - 1, $j)) {
        push @points, [$i - 1, $j];
    }

    if ($j > 0 and valid($i, $j - 1)) {
        push @points, [$i, $j - 1];
    }

    if ($i < $end and valid($i + 1, $j)) {
        push @points, [$i + 1, $j];
    }

    if ($j < $end and valid($i, $j + 1)) {
        push @points, [$i, $j + 1];
    }

  STACK: if (!@points) {
        if (@stack) {
            my ($s_sum, $s_seen, $s_pos, $s_points) = @{pop @stack};
            $sum = $s_sum;
            undef %seen;
            @seen{@$s_seen} = ();
            @points = @$s_points;
            ($i, $j) = @$s_pos;
        }
        else {
            last;
        }
    }

    my $min = splice(@points, int(rand(@points)), 1);

    if (@points) {

        my @ok = (
            grep {
                my $s = ($sum + $matrix[$_->[0]][$_->[1]]);
                $s <= $limit
                  and ($s <= two_way_path(0, 0, $_->[0], $_->[1]))
                  and ($sum + two_way_path($_->[0], $_->[1], $end, $end) <= $limit + $max)
              } @points
        );

        if (@ok) {
            push @stack, [$sum, [keys %seen], [$i, $j], \@ok];
        }
    }

    ($i, $j) = @$min;
}

my @path = map { [split ' '] } @{$min{path}};
draw(\@path);

say "\nMinimum path-sum is: $min{sum}\n";


================================================
FILE: Math/matrix_path_4-ways_greedy.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# In the 5 by 5 matrix below, the minimal path sum from the top left
# to the bottom right, by moving left, right, up, and down, is equal to 2297.

# Problem from: https://projecteuler.net/problem=83

# (this algorithm works only with matrices that are guaranteed to have a greedy path available)

use 5.010;
use strict;
use warnings;

use List::UtilsBy qw(min_by);

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

my @seen = "0 0";

sub valid {
    my %seen;
    @seen{@seen} = ();
    not exists $seen{"@_"};
}

my $sum = 0;
my $end = $#matrix;

my ($i, $j) = (0, 0);

while (1) {
    say $matrix[$i][$j];
    $sum += $matrix[$i][$j];

    if ($i >= $end and $j >= $end) {
        last;
    }

    my @points;

    if ($i > 0 and valid($i - 1, $j)) {
        push @points, [$i - 1, $j];
    }

    if ($j > 0 and valid($i, $j - 1)) {
        push @points, [$i, $j - 1];
    }

    if ($i < $end and valid($i + 1, $j)) {
        push @points, [$i + 1, $j];
    }

    if ($j < $end and valid($i, $j + 1)) {
        push @points, [$i, $j + 1];
    }

    @points || do {
        say "Stuck at value: $sum";
        last;
    };

    my $min = min_by { $matrix[$_->[0]][$_->[1]] } @points;

    ($i, $j) = @{$min};
    push @seen, "$i $j";
}

say "Minimum path-sum is: $sum";


================================================
FILE: Math/maximum_product_of_parts_bisection.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 October 2017
# https://github.com/trizen

# Finds the value of `k` such that:
#   (x/(k-1))^(k-1) < (x/k)^k > (x/(k+1))^(k+1)

# Closed-form expression would be:
#   f(x) = round(x/exp(1))

# See also:
#   https://projecteuler.net/problem=183

use 5.010;
use strict;
use warnings;

sub maximum_split {
    my ($n) = @_;

    my $min = 1;
    my $max = $n;

    while ($min < $max) {
        my $mid = ($min + $max) >> 1;

        my $x_prev = ($mid - 1) * (log($n) - log($mid - 1));
        my $x_curr = ($mid + 0) * (log($n) - log($mid + 0));
        my $x_next = ($mid + 1) * (log($n) - log($mid + 1));

        if ($x_prev < $x_curr and $x_curr > $x_next) {
            return $mid;
        }

        if ($x_prev < $x_curr and $x_curr < $x_next) {
            ++$min;
        }
        else {
            --$max;
        }
    }

    return $min;
}

say maximum_split(8);       #=> 3
say maximum_split(11);      #=> 4
say maximum_split(24);      #=> 9
say maximum_split(5040);    #=> 1854


================================================
FILE: Math/maximum_square_remainder.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 31 August 2016
# https://github.com/trizen

# Find the maximum remainder of (a-1)^n + (a+1)^n when divided by a^2, for any positive integer n.

# Example with a=7 and n=3:
#
#      (7-1)^3 + (7+1)^3 = 42  (mod 7^2)
#
# In turns out that 42 is the maximum remainder when a=7.

# See also:
#   https://oeis.org/A159469
#   https://projecteuler.net/problem=120

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub max_square_remainder($n) {
    $n * ($n - (2 - ($n % 2)));
}

foreach my $n (3 .. 20) {
    say "R($n) = ", max_square_remainder($n);
}

__END__
R(3) = 6
R(4) = 8
R(5) = 20
R(6) = 24
R(7) = 42
R(8) = 48
R(9) = 72
R(10) = 80
R(11) = 110
R(12) = 120
R(13) = 156
R(14) = 168
R(15) = 210
R(16) = 224
R(17) = 272
R(18) = 288
R(19) = 342
R(20) = 360


================================================
FILE: Math/meissel_lehmer_prime_count.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# 04 September 2025
# https://github.com/trizen

# Basic implementation of the Meissel–Lehmer algorithm for counting the number of primes <= n in sublinear time.

# See also:
#   https://en.wikipedia.org/wiki/Meissel%E2%80%93Lehmer_algorithm

use 5.036;
use ntheory qw(:all);

no warnings 'recursion';

# Memoization
my %phi_cache;
my %pi_cache;

# Recursive φ(n, a): numbers <= n not divisible by first a primes
sub recursive_rough_count ($n, $P) {

    sub ($n, $a) {

        my $key = "$n,$a";

        return $phi_cache{$key}
          if exists $phi_cache{$key};

        my $count = $n - ($n >> 1);

        foreach my $j (1 .. $a - 1) {
            my $np = divint($n, $P->[$j]);
            last if ($np == 0);
            $count -= __SUB__->($np, $j);
        }

        $phi_cache{$key} = $count;
      }
      ->($n, scalar @$P);
}

# P2 correction term
sub P2($n, $a, $p_a) {

    my $j     = $a;
    my $lo    = $p_a + 1;
    my $hi    = sqrtint($n);
    my $count = 0;

    foreach my $p (@{primes($lo, $hi)}) {
        $count += meissel_lehmer_prime_count(divint($n, $p)) - $j++;
    }

    return $count;
}

# Meissel-Lehmer prime-counting function
sub meissel_lehmer_prime_count($n) {

    return $pi_cache{$n}
      if exists $pi_cache{$n};

    if ($n <= 10) {
        return $pi_cache{$n} = (0, 0, 1, 2, 2, 3, 3, 4, 4, 4, 4)[$n];
    }

    my $cbrt = rootint($n, 3) + 1;
    my @P    = @{primes($cbrt)};
    my $a    = scalar @P;
    my $p_a  = $P[-1];

    my $phi = recursive_rough_count($n, \@P);
    my $p2  = P2($n, $a, $p_a);

    my $result = $phi + $a - 1 - $p2;
    $pi_cache{$n} = $result;
}

# --- Testing Loop ---
for my $n (1 .. 9) {

    my $ten_pow_n = powint(10, $n);
    my $pi_est    = meissel_lehmer_prime_count($ten_pow_n);
    say "pi(10^$n) = $pi_est";

    my $x   = int(rand($ten_pow_n));
    my $ref = prime_count($x);                  # MPU's built-in π(x)
    my $cmp = meissel_lehmer_prime_count($x);

    die "Mismatch at x=$x: $cmp != $ref" unless $cmp == $ref;
}

__END__
pi(10^1) = 4
pi(10^2) = 25
pi(10^3) = 168
pi(10^4) = 1229
pi(10^5) = 9592
pi(10^6) = 78498
pi(10^7) = 664579
pi(10^8) = 5761455
pi(10^9) = 50847534


================================================
FILE: Math/mertens_function.pl
================================================
#!/usr/bin/perl

# A simple implementation of a nice algorithm for computing the Mertens function:
#   M(x) = Sum_{k=1..n} moebius(k)

# Algorithm due to Marc Deleglise and Joel Rivat:
#   https://projecteuclid.org/euclid.em/1047565447

# This implementation is not particularly optimized.

# See also:
#   https://oeis.org/A002321
#   https://oeis.org/A084237
#   https://en.wikipedia.org/wiki/Mertens_function
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function

use 5.016;
use ntheory qw(sqrtint moebius);
use experimental qw(signatures);

sub mertens_function ($x) {

    my $u = sqrtint($x);

    my @M  = (0);
    my @mu = moebius(0, $u);        # list of Moebius(k) for k=0..floor(sqrt(n))

    # Partial sums of the Moebius function:
    #   M[n] = Sum_{k=1..n} moebius(k)

    for my $i (1 .. $#mu) {
        $M[$i] += $M[$i - 1] + $mu[$i];
    }

    my $sum = $M[$u];

    foreach my $m (1 .. $u) {

        $mu[$m] || next;

        my $S1_t = 0;
        foreach my $n (int($u / $m) + 1 .. sqrtint(int($x / $m))) {
            $S1_t += $M[int($x / ($m * $n))];
        }

        my $S2_t = 0;
        foreach my $n (sqrtint(int($x / $m)) + 1 .. int($x / $m)) {
            $S2_t += $M[int($x / ($m * $n))];
        }

        $sum -= $mu[$m] * ($S1_t + $S2_t);
    }

    return $sum;
}

foreach my $n (1 .. 6) {
    say "M(10^$n) = ", mertens_function(10**$n);
}

__END__
M(10^1) = -1
M(10^2) = 1
M(10^3) = 2
M(10^4) = -23
M(10^5) = -48
M(10^6) = 212
M(10^7) = 1037
M(10^8) = 1928
M(10^9) = -222


================================================
FILE: Math/mertens_function_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 February 2019
# https://github.com/trizen

# A sublinear algorithm for computing the Mertens function (partial sums of the Möbius function).

# Defined as:
#
#   M(n) = Sum_{k=1..n} μ(k)
#
# where μ(k) is the Möbius function.

# Example:
#   M(10^1) = -1
#   M(10^2) = 1
#   M(10^3) = 2
#   M(10^4) = -23
#   M(10^5) = -48
#   M(10^6) = 212
#   M(10^7) = 1037
#   M(10^8) = 1928
#   M(10^9) = -222

# OEIS sequences:
#   https://oeis.org/A008683 -- Möbius (or Moebius) function mu(n).
#   https://oeis.org/A084237 -- M(10^n), where M(n) is Mertens's function.

# See also:
#   https://en.wikipedia.org/wiki/Mertens_function
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(moebius sqrtint rootint);

sub mertens_function($n) {

    my $lookup_size = 2 * rootint($n, 3)**2;

    my @moebius_lookup = moebius(0, $lookup_size);
    my @mertens_lookup = (0);

    foreach my $i (1 .. $lookup_size) {
        $mertens_lookup[$i] = $mertens_lookup[$i - 1] + $moebius_lookup[$i];
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $mertens_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $M = 1;

        foreach my $k (2 .. int($n / ($s + 1))) {
            $M -= __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $M -= $mertens_lookup[$k] * (int($n / $k) - int($n / ($k + 1)));
        }

        $seen{$n} = $M;

    }->($n);
}

foreach my $n (1 .. 9) {    # takes ~1.6 seconds
    say "M(10^$n) = ", mertens_function(10**$n);
}


================================================
FILE: Math/miller-rabin_deterministic_primality_test.pl
================================================
#!/usr/bin/perl

# Miller-Rabin deterministic primality test.

# Theorem (Miller, 1976):
#   If the Generalized Riemann hypothesis is true, then there is a constant C such that
#   primality of `n` is the same as every a <= C*(log(n))^2 being a Miller-Rabin witness for `n`.

# Bach (1984) showed that we can use C = 2.

# Assuming the GRH, this primality test runs in polynomial time.

# See also:
#   https://en.wikipedia.org/wiki/Miller%E2%80%93Rabin_primality_test

use 5.010;
use strict;
use warnings;

use List::Util qw(min);
use ntheory qw(valuation powmod);

sub is_provable_prime {
    my ($n) = @_;

    return 1 if $n == 2;
    return 0 if $n < 2 or $n % 2 == 0;

    my $d = $n - 1;
    my $s = valuation($d, 2);

    $d >>= $s;

  LOOP: for my $k (2 .. min($n-1, 2*log($n)**2)) {

        my $x = powmod($k, $d, $n);
        next if $x == 1 or $x == $n - 1;

        for (1 .. $s - 1) {
            $x = ($x * $x) % $n;
            return 0  if $x == 1;
            next LOOP if $x == $n - 1;
        }
        return 0;
    }
    return 1;
}

my $count = 0;
my $limit = 100000;

foreach my $n (1 .. $limit) {
    if (is_provable_prime($n)) {
        ++$count;
    }
}

say "There are $count primes <= $limit";


================================================
FILE: Math/miller-rabin_deterministic_primality_test_mpz.pl
================================================
#!/usr/bin/perl

# Miller-Rabin deterministic primality test.

# Theorem (Miller, 1976):
#   If the Generalized Riemann hypothesis is true, then there is a constant C such that
#   primality of `n` is the same as every a <= C*(log(n))^2 being a Miller-Rabin witness for `n`.

# Eric Bach (1984) showed that we can use C = 2.

# See also:
#   https://rosettacode.org/wiki/Miller%E2%80%93Rabin_primality_test#Perl

use 5.010;
use strict;
use warnings;

use ntheory qw(valuation powmod);

use Math::GMPz;
use Math::MPFR;

sub is_provable_prime {
    my ($n) = @_;

    return 1 if $n == 2;
    return 0 if $n < 2 or $n % 2 == 0;

    return 1 if $n == 5;
    return 1 if $n == 7;
    return 1 if $n == 11;
    return 1 if $n == 13;

    my $d = $n - 1;
    my $s = valuation($d, 2);

    $d >>= $s;

    my $bound = ref($n) eq 'Math::GMPz' ? do {
        my $r = Math::MPFR::Rmpfr_init2(64);
        Math::MPFR::Rmpfr_set_z($r, $n, 0);
        Math::MPFR::Rmpfr_log($r, $r, 0);
        2 * Math::MPFR::Rmpfr_get_d($r, 0)**2;
    } : 2 * log($n)**2;

  LOOP: for my $k (1 .. $bound) {

        my $x = powmod($k, $d, $n);

        if (ref($x) or $x >= (~0 >> 1)) {
            $x = Math::GMPz->new("$x");
        }

        next if $x == 1 or $x == $n - 1;

        for (1 .. $s - 1) {
            $x = ($x * $x) % $n;
            return 0  if $x == 1;
            next LOOP if $x == $n - 1;
        }
        return 0;
    }
    return 1;
}

# Primes
say is_provable_prime(Math::GMPz->new(2)**89 - 1)  ? 'prime' : 'error';
say is_provable_prime(Math::GMPz->new(2)**107 - 1) ? 'prime' : 'error';
say is_provable_prime(Math::GMPz->new(2)**127 - 1) ? 'prime' : 'error';
say is_provable_prime(Math::GMPz->new('115547929908077082437116944109458314609946651910092587495187962466088019331251')) ? 'prime' : 'error';

# Composites
say is_provable_prime(Math::GMPz->new('142899381901'))                                       ? 'error' : 'composite';
say is_provable_prime(Math::GMPz->new('92737632541325090700295531'))                         ? 'error' : 'composite';
say is_provable_prime(Math::GMPz->new('200000000135062271492802271468294969951'))            ? 'error' : 'composite';
say is_provable_prime(Math::GMPz->new('48793204382746801501446610630739608190006929723969')) ? 'error' : 'composite';
say is_provable_prime(Math::GMPz->new('25195908475657893494027183240048398571429282126204032027777137836043662020707595556264018525880784406918290641249515082189298559149176184502808489120072844992687392807287776735971418347270261896375014971824691165077613379859095700097330459748808428401797429100642458691817195118746121515172654632282216869987549182422433637259085141865462043576798423387184774447920739934236584823824281198163815010674810451660377306056201619676256133844143603833904414952634432190114657544454178424020924616515723350778707749817125772467962926386356373289912154831438167899885040445364023527381951378636564391212010397122822120720357')) ? 'error' : 'composite';


================================================
FILE: Math/miller-rabin_factorization_method.pl
================================================
#!/usr/bin/perl

# Factorization method, based on the Miller-Rabin primality test.
# Described in the book "Elementary Number Theory", by Peter Hackman.

# Works best on Carmichael numbers.

# Example:
#   N   = 1729
#   N-1 = 2^6 * 27

# Then, we find that:
#       2^(2*27) == 1065 != -1 (mod N)
# and
#       2^(4*27) == 1 (mod N)

# This proves that N is composite and gives the following factorization:
#   x = 2^(2*27) (mod N)
#   N = gcd(x+1, N) * gcd(x-1, N)
#   N = gcd(1065+1, N) * gcd(1065-1, N)
#   N = 13 * 133

# See also:
#   https://www.math.waikato.ac.nz/~kab/509/bigbook.pdf
#   https://en.wikipedia.org/wiki/Miller-Rabin_primality_test

use 5.020;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub miller_rabin_factor ($n, $tries = 100) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $D = $n - 1;
    my $s = valuation($D, 2);
    my $r = $s - 1;
    my $d = $D >> $s;

    for (1 .. $tries) {

        my $p = random_prime(1e7);
        my $x = powmod($p, $d, $n);

        for (0 .. $r) {

            last if (($x == 1) || ($x == $D));

            foreach my $i (1, -1) {
                my $g = gcd($x + $i, $n);
                if ($g > 1 and $g < $n) {
                    return $g;
                }
            }

            $x = mulmod($x, $x, $n);
        }
    }

    return 1;
}

say miller_rabin_factor("1729");
say miller_rabin_factor("335603208601");
say miller_rabin_factor("30459888232201");
say miller_rabin_factor("162021627721801");
say miller_rabin_factor("1372144392322327801");
say miller_rabin_factor("7520940423059310542039581");
say miller_rabin_factor("8325544586081174440728309072452661246289");
say miller_rabin_factor("181490268975016506576033519670430436718066889008242598463521");
say miller_rabin_factor("57981220983721718930050466285761618141354457135475808219583649146881");
say miller_rabin_factor("131754870930495356465893439278330079857810087607720627102926770417203664110488210785830750894645370240615968198960237761");


================================================
FILE: Math/modular_bell_numbers.pl
================================================
#!/usr/bin/perl

# A fast algorithm for computing the n-th Bell number modulo a native integer.

# See also:
#   https://oeis.org/A325630 -- Numbers k such that Bell(k) == 0 (mod k).
#   https://en.wikipedia.org/wiki/Bell_number

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(addmod);
use experimental qw(signatures);

sub bell_number ($n, $m) {

    my @acc;

    my $t    = 0;
    my $bell = 1;

    foreach my $k (1 .. $n) {

        $t = $bell;

        foreach my $j (@acc) {
            $t = addmod($t, $j, $m);
            $j = $t;
        }

        unshift @acc, $bell;
        $bell = $acc[-1];
    }

    $bell;
}

say bell_number(35,  35);      #=> 0
say bell_number(35,  1234);    #=> 852
say bell_number(123, 4171);    #=> 3567


================================================
FILE: Math/modular_bell_numbers_mpz.pl
================================================
#!/usr/bin/perl

# A fast algorithm for computing the n-th Bell number modulo a native integer.

# See also:
#   https://oeis.org/A325630 -- Numbers k such that Bell(k) == 0 (mod k).
#   https://en.wikipedia.org/wiki/Bell_number

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use experimental qw(signatures);

sub bell_number ($n, $m) {

    my @acc;

    my $t    = Math::GMPz::Rmpz_init();
    my $bell = Math::GMPz::Rmpz_init_set_ui(1);

    foreach my $k (1 .. $n) {

        Math::GMPz::Rmpz_set($t, $bell);

        foreach my $item (@acc) {
            Math::GMPz::Rmpz_add($t, $t, $item);
            Math::GMPz::Rmpz_mod_ui($t, $t, $m);
            Math::GMPz::Rmpz_set($item, $t);
        }

        unshift @acc, Math::GMPz::Rmpz_init_set($bell);
        $bell = Math::GMPz::Rmpz_init_set($acc[-1]);
    }

    $bell;
}

say bell_number(35,  35);      #=> 0
say bell_number(35,  1234);    #=> 852
say bell_number(123, 4171);    #=> 3567


================================================
FILE: Math/modular_binomial.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 February 2017
# Website: https://github.com/trizen

# Algorithm for binomial(n, k) mod m.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(forprimes powmod vecsum todigits);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub modular_binomial ($n, $k, $m) {

    my $j    = $n - $k;
    my $prod = 1;

    forprimes {
        my $p = factorial_power($n, $_);

        if ($_ <= $k) {
            $p -= factorial_power($k, $_);
        }

        if ($_ <= $j) {
            $p -= factorial_power($j, $_);
        }

        if ($p > 0) {
            $prod *= ($p == 1) ? ($_ % $m) : powmod($_, $p, $m);
            $prod %= $m;
        }
    } $n;

    return $prod;
}

say modular_binomial(100, 50, 139);        #=> 71
say modular_binomial(124, 42, 1234567);    #=> 395154


================================================
FILE: Math/modular_binomial_fast.pl
================================================
#!/usr/bin/perl

# Efficient algorithm for computing `binomial(n, k) mod m`, based on the factorization of `m`.

# Algorithm by Andrew Granville:
#     https://www.scribd.com/document/344759427/BinCoeff-pdf

# Algorithm translated from (+some optimizations):
#   https://github.com/hellman/libnum/blob/master/libnum/modular.py

# Translated by: Trizen
# Date: 29 September 2017
# Edit: 28 April 2022
# https://github.com/trizen

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub modular_binomial ($n, $k, $m) {

    if ($m == 0) {
        return undef;
    }

    if ($m == 1) {
        return 0;
    }

    if ($k < 0) {
        $k = subint($n, $k);
    }

    if ($k < 0) {
        return 0;
    }

    if ($n < 0) {
        return modint(mulint(powint(-1, $k), __SUB__->(subint($k, $n) - 1, $k, $m)), $m);
    }

    if ($k > $n) {
        return 0;
    }

    if ($k == 0 or $k == $n) {
        return modint(1, $m);
    }

    if ($k == 1 or $k == subint($n, 1)) {
        return modint($n, $m);
    }

    my @congruences;

    foreach my $pair (factor_exp(absint($m))) {
        my ($p, $e) = @$pair;

        if ($e == 1) {
            push @congruences, [lucas_theorem($n, $k, $p), $p];
        }
        else {
            push @congruences, [modular_binomial_prime_power($n, $k, $p, $e), powint($p, $e)];
        }
    }

    modint(chinese(@congruences), $m);
}

#<<<
#~ sub factorial_prime_pow ($n, $p) {
    #~ divint(subint($n, sumdigits($n, $p)), subint($p, 1));
#~ }
#>>>

sub factorial_prime_pow ($n, $p) {
    my $count = 0;
    my $ppow  = $p;
    while ($ppow <= $n) {
        $count = addint($count, divint($n, $ppow));
        $ppow  = mulint($ppow, $p);
    }
    return $count;
}

sub binomial_prime_pow ($n, $k, $p) {
#<<<
      factorial_prime_pow($n,      $p)
    - factorial_prime_pow($k,      $p)
    - factorial_prime_pow(subint($n, $k), $p);
#>>>
}

sub factorial_without_prime ($n, $p, $pk) {
    return 1 if ($n <= 1);

    if ($p > $n) {
        return factorialmod($n, $pk);
    }

    my $r = 1;
    my $t = 0;

    foreach my $v (1 .. $n) {
        if (++$t == $p) {
            $t = 0;
        }
        else {
            $r = mulmod($r, $v, $pk);
        }
    }

    return $r;
}

sub lucas_theorem ($n, $k, $p) {    # p is prime

    my $r = 1;

    while ($k) {

        my $np = modint($n, $p);
        my $kp = modint($k, $p);

        if ($kp > $np) { return 0 }

        my $rp = subint($np, $kp);

        my $x = factorialmod($np, $p);
        my $y = factorialmod($kp, $p);
        my $z = factorialmod($rp, $p);

        $y = mulmod($y, $z, $p);
        $x = divmod($x, $y, $p);

        $r = mulmod($r, $x, $p);

        $n = divint($n, $p);
        $k = divint($k, $p);
    }

    return $r;
}

sub binomial_non_prime_part ($n, $k, $p, $e) {

    my $pe = powint($p, $e);
    my $r  = subint($n, $k);

    my $acc     = 1;
    my @fact_pe = (1);

    if ($pe < ~0 and $p < $n) {
        my $count = 0;
        foreach my $x (1 .. vecmin(1e4, $pe - 1)) {
            if (++$count == $p) {
                $count = 0;
            }
            else {
                $acc = mulmod($acc, $x, $pe);
            }
            push @fact_pe, $acc;
        }
    }

    my $top         = 1;
    my $bottom      = 1;
    my $is_negative = 0;
    my $digits      = 0;

    while ($n) {

        if ($digits >= $e) {
            $is_negative ^= modint($n, 2);
            $is_negative ^= modint($r, 2);
            $is_negative ^= modint($k, 2);
        }

        my $np = modint($n, $pe);
        my $rp = modint($r, $pe);
        my $kp = modint($k, $pe);

#<<<
        $top    = mulmod($top,    ($fact_pe[$np] // factorial_without_prime($np, $p, $pe)), $pe);
        $bottom = mulmod($bottom, ($fact_pe[$rp] // factorial_without_prime($rp, $p, $pe)), $pe);
        $bottom = mulmod($bottom, ($fact_pe[$kp] // factorial_without_prime($kp, $p, $pe)), $pe);
#>>>

        $n = divint($n, $p);
        $r = divint($r, $p);
        $k = divint($k, $p);

        ++$digits;
    }

    my $res = divmod($top, $bottom, $pe);

    if ($is_negative and ($p != 2 or $e < 3)) {
        $res = subint($pe, $res);
    }

    return $res;
}

sub modular_binomial_prime_power ($n, $k, $p, $e) {
    my $pow = binomial_prime_pow($n, $k, $p);

    if ($pow >= $e) {
        return 0;
    }

    my $er = $e - $pow;
    my $r  = modint(binomial_non_prime_part($n, $k, $p, $er), powint($p, $er));

    my $pe = powint($p, $e);
    return mulmod(powmod($p, $pow, $pe), $r, $pe);
}

use Test::More tests => 44;

is(modular_binomial(10, 2, 43), 2);
is(modular_binomial(10, 8, 43), 2);

is(modular_binomial(10, 2, 24), 21);
is(modular_binomial(10, 8, 24), 21);

is(modular_binomial(100, 42, -127), binomial(100, 42) % -127);

is(modular_binomial(12,   5,   100000),  792);
is(modular_binomial(16,   4,   100000),  1820);
is(modular_binomial(100,  50,  139),     71);
is(modular_binomial(1000, 10,  1243),    848);
is(modular_binomial(124,  42,  1234567), 395154);
is(modular_binomial(1e9,  1e4, 1234567), 833120);
is(modular_binomial(1e10, 1e5, 1234567), 589372);

is(modular_binomial(1e10,  1e5, 4233330243), 3403056024);
is(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);

is(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);
is(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);
is(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);

is(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);
is(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);
is(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);

is(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);
is(modular_binomial(4, 1, 16), binomial(4, 1) % 16);

is(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);
is(modular_binomial(1e9,  1e6, 5041689707),            15262431);
is(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);
is(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);
is(modular_binomial(1e9,  1e5, 12345678910),           4517333900);
is(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);
is(modular_binomial(1e10, 1e5, 1234567),               589372);

is(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);
is(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));
is(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));
is(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));
is(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);
is(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));
is(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));
is(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));
is(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));
is(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));

is(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));
is(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));

is(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));
is(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));
is(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);

say("binomial(10^10, 10^5) mod 13! = ", modular_binomial(1e10, 1e5, factorial(13)));

say modular_binomial(12,   5,   100000);     #=> 792
say modular_binomial(16,   4,   100000);     #=> 1820
say modular_binomial(100,  50,  139);        #=> 71
say modular_binomial(1000, 10,  1243);       #=> 848
say modular_binomial(124,  42,  1234567);    #=> 395154
say modular_binomial(1e9,  1e4, 1234567);    #=> 833120
say modular_binomial(1e10, 1e5, 1234567);    #=> 589372

__END__
my $upto = 10;
foreach my $n (-$upto .. $upto) {
    foreach my $k (-$upto .. $upto) {
        foreach my $m (-$upto .. $upto) {
            next if ($m == 0);
            say "Testing: binomial($n, $k, $m)";
            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);
        }
    }
}


================================================
FILE: Math/modular_binomial_faster.pl
================================================
#!/usr/bin/perl

# Translated by: Trizen
# Date: 27 April 2022
# https://github.com/trizen

# Fast algorithm for computing the binomial coefficient modulo some integer m.

# The implementation is based on Lucas' Theorem and its generalization given in the paper
# Andrew Granville "The Arithmetic Properties of Binomial Coefficients", In Proceedings of
# the Organic Mathematics Workshop, Simon Fraser University, December 12-14, 1995.

# Translation of binomod.gp v1.5 by Max Alekseyev, with some minor optimizations.

# See also:
#   https://home.gwu.edu/~maxal/gpscripts/

use 5.036;
use ntheory 0.74 qw(:all);

sub factorial_without_prime ($n, $p, $pk, $from, $count, $res) {
    return 1 if ($n <= 1);

    if ($p > $n) {
        return factorialmod($n, $pk);
    }

    if ($$from == $n) {
        return $$res;
    }

    if ($$from > $n) {
        $$from  = 0;
        $$count = 0;
        $$res   = 1;
    }

    my $r = $$res;
    my $t = $$count;

    foreach my $v ($$from + 1 .. $n) {
        if (++$t == $p) {
            $t = 0;
        }
        else {
            $r = mulmod($r, $v, $pk);
        }
    }

    $$res   = $r;
    $$count = $t;
    $$from  = $n;

    return $r;
}

sub lucas_theorem ($n, $k, $p) {    # p is prime

    my $r = 1;

    while ($k) {

        my $np = modint($n, $p);
        my $kp = modint($k, $p);

        if ($kp > $np) { return 0 }

        my $rp = subint($np, $kp);

        my $x = factorialmod($np, $p);
        my $y = factorialmod($kp, $p);
        my $z = factorialmod($rp, $p);

        $y = mulmod($y, $z, $p);
        $x = divmod($x, $y, $p);

        $r = mulmod($r, $x, $p);

        $n = divint($n, $p);
        $k = divint($k, $p);
    }

    return $r;
}

sub modular_binomial ($n, $k, $m) {

    if ($m == 0) {
        return undef;
    }

    if ($m == 1) {
        return 0;
    }

    if ($k < 0) {
        $k = subint($n, $k);
    }

    if ($k < 0) {
        return 0;
    }

    if ($n < 0) {
        return modint(mulint(powint(-1, $k), __SUB__->(subint($k, $n) - 1, $k, $m)), $m);
    }

    if ($k > $n) {
        return 0;
    }

    if ($k == 0 or $k == $n) {
        return modint(1, $m);
    }

    if ($k == 1 or $k == subint($n, 1)) {
        return modint($n, $m);
    }

    my @F;

    foreach my $pp (factor_exp(absint($m))) {
        my ($p, $q) = @$pp;

        if ($q == 1) {
            push @F, [lucas_theorem($n, $k, $p), $p];
            next;
        }

        my $d = logint($n, $p) + 1;

        my (@np, @kp);

        do {
            my $pi = 1;
            foreach my $i (0 .. $d) {
                push @np, modint(divint($n, $pi), $p);
                push @kp, modint(divint($k, $pi), $p);
                $pi = mulint($pi, $p);
            }
        };

        my @e;

        foreach my $i (0 .. $d) {
            $e[$i] = ($np[$i] < ($kp[$i] + (($i > 0) ? $e[$i - 1] : 0))) ? 1 : 0;
        }

        for (my $i = $d - 1 ; $i >= 0 ; --$i) {
            $e[$i] += $e[$i + 1];
        }

        if ($e[0] >= $q) {
            push @F, [0, powint($p, $q)];
            next;
        }

        my $rq = $q - $e[0];

        my $pq  = powint($p, $q);
        my $prq = powint($p, $rq);

        my (@N, @K, @R);

        do {
            my $pi = 1;
            my $r  = subint($n, $k);
            foreach my $i (0 .. $d) {
                push @N, modint(divint($n, $pi), $prq);
                push @K, modint(divint($k, $pi), $prq);
                push @R, modint(divint($r, $pi), $prq);
                $pi = mulint($pi, $p);
            }
        };

        my @NKR = (
                   sort { $a->[3] <=> $b->[3] }
                   map  { [$N[$_], $K[$_], $R[$_], $N[$_] + $K[$_] + $R[$_]] } 0 .. $#N
                  );

        @N = map { $_->[0] } @NKR;
        @K = map { $_->[1] } @NKR;
        @R = map { $_->[2] } @NKR;

        my %acc  = (0 => 1);
        my $nfac = 1;

        if ($prq < ~0 and $p < $n) {
            my $count = 0;
            foreach my $k (1 .. vecmin(vecmax(@N, @K, @R), 1e4)) {
                if (++$count == $p) {
                    $count = 0;
                }
                else {
                    $nfac = mulmod($nfac, $k, $prq);
                }
                $acc{$k} = $nfac;
            }
        }

        my $v = powmod($p, $e[0], $pq);

        do {
            my $from  = 0;
            my $count = 0;
            my $res   = 1;

            foreach my $j (0 .. $d) {

                my @pairs;
                my ($x, $y, $z);

                ($x = $acc{$N[$j]}) // push(@pairs, [\$x, $N[$j]]);
                ($y = $acc{$K[$j]}) // push(@pairs, [\$y, $K[$j]]);
                ($z = $acc{$R[$j]}) // push(@pairs, [\$z, $R[$j]]);

                foreach my $pair (sort { $a->[1] <=> $b->[1] } @pairs) {
                    ${$pair->[0]} = factorial_without_prime($pair->[1], $p, $prq, \$from, \$count, \$res);
                }

                $v = mulmod($v, divmod($x, mulmod($y, $z, $pq), $pq), $pq);
            }
        };

        if (($p > 2 or $rq < 3) and $rq <= scalar(@e)) {
            $v = mulmod($v, powint(-1, $e[$rq - 1]), $pq);
        }

        push @F, [$v, $pq];
    }

    modint(chinese(@F), $m);
}

#
## Run some tests
#

use Test::More tests => 44;

is(modular_binomial(10, 2, 43), 2);
is(modular_binomial(10, 8, 43), 2);

is(modular_binomial(10, 2, 24), 21);
is(modular_binomial(10, 8, 24), 21);

is(modular_binomial(100, 42, -127), binomial(100, 42) % -127);

is(modular_binomial(12,   5,   100000),  792);
is(modular_binomial(16,   4,   100000),  1820);
is(modular_binomial(100,  50,  139),     71);
is(modular_binomial(1000, 10,  1243),    848);
is(modular_binomial(124,  42,  1234567), 395154);
is(modular_binomial(1e9,  1e4, 1234567), 833120);
is(modular_binomial(1e10, 1e5, 1234567), 589372);

is(modular_binomial(1e10,  1e5, 4233330243), 3403056024);
is(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);

is(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);
is(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);
is(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);

is(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);
is(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);
is(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);

is(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);
is(modular_binomial(4, 1, 16), binomial(4, 1) % 16);

is(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);
is(modular_binomial(1e9,  1e6, 5041689707),            15262431);
is(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);
is(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);
is(modular_binomial(1e9,  1e5, 12345678910),           4517333900);
is(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);
is(modular_binomial(1e10, 1e5, 1234567),               589372);

is(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);
is(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));
is(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));
is(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));
is(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);
is(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));
is(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));
is(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));
is(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));
is(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));

is(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));
is(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));

is(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));
is(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));
is(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);

say("binomial(10^10, 10^5) mod 13! = ", modular_binomial(1e10, 1e5, factorial(13)));

__END__
my $upto = 10;
foreach my $n (-$upto .. $upto) {
    foreach my $k (-$upto .. $upto) {
        foreach my $m (-$upto .. $upto) {
            next if ($m == 0);
            say "Testing: binomial($n, $k, $m)";
            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);
        }
    }
}


================================================
FILE: Math/modular_binomial_faster_mpz.pl
================================================
#!/usr/bin/perl

# Translated by: Trizen
# Date: 18 March 2026
# https://github.com/trizen

# Fast algorithm for computing the binomial coefficient modulo some integer m.

# The implementation is based on Lucas' Theorem and its generalization given in the paper
# Andrew Granville "The Arithmetic Properties of Binomial Coefficients", In Proceedings of
# the Organic Mathematics Workshop, Simon Fraser University, December 12-14, 1995.

# Translation of binomod.gp v1.5 by Max Alekseyev, with some minor optimizations.

# See also:
#   https://home.gwu.edu/~maxal/gpscripts/

use 5.036;
use Math::GMPz;
use ntheory 0.74           qw(:all);
use Math::Prime::Util::GMP qw();
use Math::Sidef            qw();

prime_set_config(bigint => "Math::BigInt");

sub test_binomialmod($n, $k, $m) {
    Math::Sidef::binomialmod($n, $k, $m);
}

sub _factorial_without_prime {
    my ($n, $p, $pk, $from, $count, $res) = @_;

    return 1 if ($n <= 1);

    if ($p > $n) {
        return factorialmod($n, $pk);
    }

    if ($$from == $n) {
        return $$res;
    }

    if ($$from > $n) {
        $$from  = 0;
        $$count = 0;
        $$res   = 1;
    }

    my $r = $$res;
    my $t = $$count;

    foreach my $v ($$from + 1 .. $n) {
        if (++$t == $p) {
            $t = 0;
        }
        else {
            $r = mulmod($r, $v, $pk);
        }
    }

    $$res   = $r;
    $$count = $t;
    $$from  = $n;

    return $r;
}

sub _small_k_binomialmod {
    my ($n_val, $k_val, $m_val, $p) = @_;

    $n_val = Math::GMPz::Rmpz_init_set_str($n_val, 10) if ref($n_val) ne 'Math::GMPz';
    $m_val = Math::GMPz::Rmpz_init_set_str($m_val, 10) if ref($m_val) ne 'Math::GMPz';

    if (!$p or $k_val <= 1e5) {
        my $bin = Math::GMPz::Rmpz_init();
        if (Math::GMPz::Rmpz_fits_ulong_p($n_val) and Math::GMPz::Rmpz_cmp_ui($n_val, 1e5) <= 0) {
            Math::GMPz::Rmpz_bin_uiui($bin, Math::GMPz::Rmpz_get_ui($n_val), $k_val);
        }
        else {
            Math::GMPz::Rmpz_bin_ui($bin, $n_val, $k_val);
        }
        Math::GMPz::Rmpz_mod($bin, $bin, $m_val);
        return $bin;
    }

    my $v = 0;
    state $num_mult = Math::GMPz::Rmpz_init_nobless();
    state $den_mult = Math::GMPz::Rmpz_init_nobless();
    state $temp     = Math::GMPz::Rmpz_init_nobless();

    Math::GMPz::Rmpz_set_ui($num_mult, 1);
    Math::GMPz::Rmpz_set_ui($den_mult, 1);

    for my $i (0 .. $k_val - 1) {
        Math::GMPz::Rmpz_sub_ui($temp, $n_val, $i);
        while (Math::GMPz::Rmpz_divisible_ui_p($temp, $p)) {
            Math::GMPz::Rmpz_divexact_ui($temp, $temp, $p);
            ++$v;
        }
        Math::GMPz::Rmpz_mul($num_mult, $num_mult, $temp);
        Math::GMPz::Rmpz_mod($num_mult, $num_mult, $m_val);

        my $den = $i + 1;
        while ($den % $p == 0) {
            $den = Math::Prime::Util::divint($den, $p);
            --$v;
        }

        Math::GMPz::Rmpz_mul_ui($den_mult, $den_mult, $den);
        Math::GMPz::Rmpz_mod($den_mult, $den_mult, $m_val);
    }

    Math::GMPz::Rmpz_invert($temp, $den_mult, $m_val);

    my $ans = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul($ans, $num_mult, $temp);
    Math::GMPz::Rmpz_mod($ans, $ans, $m_val);

    if ($v > 0) {
        Math::GMPz::Rmpz_ui_pow_ui($temp, $p, $v);
        Math::GMPz::Rmpz_mul($ans, $ans, $temp);
        Math::GMPz::Rmpz_mod($ans, $ans, $m_val);
    }

    return $ans;
}

sub _is_small_k_binomialmod {
    my ($n, $k, $m) = @_;

    $n >= 1e6 or return;

    ## say "Small k check: binomial($n, $k, $m)";

    if ($m >= 1e7 and $n >= 1e7 and $k <= 1e6) {
        return 1;
    }

    my $new_k = Math::Prime::Util::GMP::subint($n, $k);

    if ($new_k > 0 and $new_k < $k) {
        $k = $new_k;
    }

    $k <= 1e7 or return;

    my $sqrt_m   = Math::Prime::Util::GMP::sqrtint($m);
    my $m_over_n = Math::Prime::Util::GMP::divint($m, $n);

    $k < $sqrt_m and $k < $m_over_n;
}

sub _lucas_theorem {    # p is prime
    my ($n, $k, $p) = @_;

    my $r = 1;
    my (@nd, @kd);

    while ($k) {
        my $np = Math::Prime::Util::GMP::modint($n, $p);
        my $kp = Math::Prime::Util::GMP::modint($k, $p);

        push @nd, $np;
        push @kd, $kp;

        if ($kp > $np) { return 0 }

        $n = Math::Prime::Util::GMP::divint($n, $p);
        $k = Math::Prime::Util::GMP::divint($k, $p);
    }

    foreach my $i (0 .. $#nd) {

        my $np = $nd[$i];
        my $kp = $kd[$i];
        my $rp = Math::Prime::Util::GMP::subint($np, $kp);

        ## say "Lucas theorem: ($np, $kp, $p)";

        if (_is_small_k_binomialmod($np, $kp, $p)) {
            ## say "Optimization: ($np, $kp, $p)";
            my $bin = _small_k_binomialmod($np, $kp, $p);
            $r = Math::Prime::Util::GMP::mulmod($r, $bin, $p);
            next;
        }

        my $x = Math::Prime::Util::GMP::factorialmod($np, $p);
        my $y = Math::Prime::Util::GMP::factorialmod($kp, $p);
        my $z = Math::Prime::Util::GMP::factorialmod($rp, $p);

        $y = Math::Prime::Util::GMP::mulmod($y, $z, $p);
        $x = Math::Prime::Util::GMP::divmod($x, $y, $p) if ($y ne '1');
        $r = Math::Prime::Util::GMP::mulmod($r, $x, $p);
    }

    return $r;
}

sub _modular_binomial {
    my ($n, $k, $m) = @_;

    # Translation of binomod.gp v1.5 by Max Alekseyev, with some extra optimizations.

    # m == 1
    if (Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {
        return 0;
    }

    # k < 0
    if (Math::GMPz::Rmpz_sgn($k) < 0) {
        $k = $n - $k;
    }

    # k < n-k < 0
    if (Math::GMPz::Rmpz_sgn($k) < 0) {
        return 0;
    }

    # n < 0
    if (Math::GMPz::Rmpz_sgn($n) < 0) {
        my $x = Math::GMPz::Rmpz_even_p($k) ? 1 : -1;
        $x = Math::Prime::Util::GMP::mulint($x, __SUB__->(-$n + $k - 1, $k, $m));
        return Math::Prime::Util::GMP::modint($x, $m);
    }

    # k > n
    if (Math::GMPz::Rmpz_cmp($k, $n) > 0) {
        return 0;
    }

    # k == 0 or k == n
    if (Math::GMPz::Rmpz_sgn($k) == 0 or Math::GMPz::Rmpz_cmp($k, $n) == 0) {
        return Math::Prime::Util::GMP::modint(1, $m);
    }

    # k == 1 or k == n-1
    if (Math::GMPz::Rmpz_cmp_ui($k, 1) == 0 or $k == $n - 1) {
        return Math::Prime::Util::GMP::modint($n, $m);
    }

    # n-k > 0 and n-k < k
    if (Math::GMPz::Rmpz_cmp($n - $k, $k) < 0) {
        $k = $n - $k;
    }

    # k <= 10^4
    if (Math::GMPz::Rmpz_cmp_ui($k, 1e4) <= 0) {
        return Math::Prime::Util::GMP::modint(_small_k_binomialmod($n, $k, $m), $m);
    }

    my @F;

    foreach my $pp (factor_exp(Math::Prime::Util::GMP::absint($m))) {
        my ($p, $q) = @$pp;

        if ($q == 1) {
            push @F, [_lucas_theorem($n, $k, $p), $p];
            next;
        }

        my $pq = Math::Prime::Util::GMP::powint($p, $q);

        # If $n is smaller than the prime power, we can use the small_k algorithm directly
        if (Math::Prime::Util::GMP::cmpint($pq, $n) > 0) {
            push @F, [_small_k_binomialmod($n, $k, $pq, $p), $pq];
            next;
        }

        my $d = logint($n, $p) + 1;

        my (@np, @kp);

        do {
            my $pi = 1;
            foreach my $i (0 .. $d) {
                push @np, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($n, $pi), $p);
                push @kp, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($k, $pi), $p);
                $pi = Math::Prime::Util::GMP::mulint($pi, $p);
            }
        };

        my @e;

        foreach my $i (0 .. $d) {
            $e[$i] = ($np[$i] < ($kp[$i] + (($i > 0) ? $e[$i - 1] : 0))) ? 1 : 0;
        }

        for (my $i = $d - 1 ; $i >= 0 ; --$i) {
            $e[$i] += $e[$i + 1];
        }

        if ($e[0] >= $q) {
            push @F, [0, Math::Prime::Util::GMP::powint($p, $q)];
            next;
        }

        my $rq  = $q - $e[0];
        my $prq = Math::Prime::Util::GMP::powint($p, $rq);

        if (_is_small_k_binomialmod($n, $k, $pq)) {
            ## say "Optimization prime power: ($n, $k, $p, $pq)";
            my $bin = _small_k_binomialmod($n, $k, $pq);
            push @F, [$bin, $pq];
            next;
        }

        my (@N, @K, @R);

        do {
            my $pi = 1;
            my $r  = Math::Prime::Util::GMP::subint($n, $k);
            foreach my $i (0 .. $d) {
                push @N, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($n, $pi), $prq);
                push @K, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($k, $pi), $prq);
                push @R, Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::divint($r, $pi), $prq);
                $pi = Math::Prime::Util::GMP::mulint($pi, $p);
            }
        };

        my @NKR = (
                   sort { $a->[3] <=> $b->[3] }
                   map  { [$N[$_], $K[$_], $R[$_], $N[$_] + $K[$_] + $R[$_]] } 0 .. $#N
                  );

        @N = map { $_->[0] } @NKR;
        @K = map { $_->[1] } @NKR;
        @R = map { $_->[2] } @NKR;

        my %acc  = (0 => 1);
        my $nfac = 1;

        if ($prq < ~0 and $p < $n) {
            my $count = 0;
            foreach my $k (1 .. vecmin(vecmax(@N, @K, @R), 1e3)) {
                if (++$count == $p) {
                    $count = 0;
                }
                else {
                    $nfac = mulmod($nfac, $k, $prq);
                }
                $acc{$k} = $nfac;
            }
        }

        my $v = Math::Prime::Util::GMP::powmod($p, $e[0], $pq);

        do {
            my $from  = 0;
            my $count = 0;
            my $res   = 1;

            foreach my $j (0 .. $d) {

                my @pairs;
                my ($x, $y, $z);

                ($x = $acc{$N[$j]}) // push(@pairs, [\$x, $N[$j]]);
                ($y = $acc{$K[$j]}) // push(@pairs, [\$y, $K[$j]]);
                ($z = $acc{$R[$j]}) // push(@pairs, [\$z, $R[$j]]);

                foreach my $pair (sort { $a->[1] <=> $b->[1] } @pairs) {
                    ## say "Factorial($pair->[1]) mod $prq with p = $p";
                    ${$pair->[0]} = _factorial_without_prime($pair->[1], $p, $prq, \$from, \$count, \$res);
                }

                $y = Math::Prime::Util::GMP::mulmod($y, $z, $pq);
                $x = Math::Prime::Util::GMP::divmod($x, $y, $pq) if ($y ne '1');
                $v = Math::Prime::Util::GMP::mulmod($v, $x, $pq);
            }
        };

        if (($p > 2 or $rq < 3) and $rq <= scalar(@e)) {
            $v = Math::Prime::Util::GMP::mulmod($v, (($e[$rq - 1] % 2 == 0) ? 1 : -1), $pq);
        }

        push @F, [$v, $pq];
    }

    Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::chinese(@F), $m);
}

sub modular_binomial {
    my ($n, $k, $m) = @_;

    $n = Math::GMPz->new("$n");
    $k = Math::GMPz->new("$k");
    $m = Math::GMPz->new("$m");

    Math::GMPz::Rmpz_sgn($m) || return undef;

    _modular_binomial($n, $k, $m);
}

#
## Run some tests
#

use Test::More tests => 65;

is(modular_binomial(10, 2, 43), 2);
is(modular_binomial(10, 8, 43), 2);

is(modular_binomial(10, 2, 24), 21);
is(modular_binomial(10, 8, 24), 21);

is(modular_binomial(100, 42, -127), binomial(100, 42) % -127);

is(modular_binomial(12,   5,   100000),  792);
is(modular_binomial(16,   4,   100000),  1820);
is(modular_binomial(100,  50,  139),     71);
is(modular_binomial(1000, 10,  1243),    848);
is(modular_binomial(124,  42,  1234567), 395154);
is(modular_binomial(1e9,  1e4, 1234567), 833120);
is(modular_binomial(1e10, 1e5, 1234567), 589372);

is(modular_binomial(1e10,  1e5, 4233330243), 3403056024);
is(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);

is(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);
is(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);
is(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);

is(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);
is(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);
is(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);

is(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);
is(modular_binomial(4, 1, 16), binomial(4, 1) % 16);

is(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);
is(modular_binomial(1e9,  1e6, 5041689707),            15262431);
is(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);
is(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);
is(modular_binomial(1e9,  1e5, 12345678910),           4517333900);
is(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);
is(modular_binomial(1e10, 1e5, 1234567),               589372);

is(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);
is(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));
is(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));
is(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));
is(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);
is(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));
is(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));
is(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));
is(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));
is(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));

is(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));
is(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));

is(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));
is(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));
is(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);

is(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));
is(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));

is(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));
is(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));

is(modular_binomial(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)), test_binomialmod(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)));
is(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))**2),         test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))**2));

is(modular_binomial(1e10, 1e4, prev_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, prev_prime(powint(2, 64))));
is(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))));

is(modular_binomial(1e10, 1e3, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e3, powint(2, 127) + 1));
is(modular_binomial(1e10, 1e3, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e3, powint(2, 127) - 1));
is(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));
is(modular_binomial(1e10, 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));

is(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));
is(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));
is(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) + 1)**2));

is(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) - 1)**2));
is(modular_binomial(1e10, 1e4, (powint(2, 128) - 1)**2), test_binomialmod(1e10, 1e4, (powint(2, 128) - 1)**2));
is(modular_binomial(1e7,  1e5, (powint(2, 128) - 1)**2), test_binomialmod(1e7,  1e5, (powint(2, 128) - 1)**2));

is(modular_binomial(4294967291 + 1, 1e5, powint(4294967291, 2)), test_binomialmod(4294967291 + 1, 1e5, powint(4294967291, 2)));
is(modular_binomial(powint(2, 60) - 99, 1e5, prev_prime(1e9)),           test_binomialmod(powint(2, 60) - 99, 1e5, prev_prime(1e9)));
is(modular_binomial(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))), test_binomialmod(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))));

say("binomial(10^10, 10^5) mod 13! = ", modular_binomial(1e10, 1e5, factorial(13)));

__END__
my $upto = 10;
foreach my $n (-$upto .. $upto) {
    foreach my $k (-$upto .. $upto) {
        foreach my $m (-$upto .. $upto) {
            next if ($m == 0);
            say "Testing: binomial($n, $k, $m)";
            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);
        }
    }
}


================================================
FILE: Math/modular_binomial_faster_mpz_2.pl
================================================
#!/usr/bin/perl

# Fast algorithm for computing the binomial coefficient modulo some integer m.
# Based on Lucas' Theorem and Granville's generalization:
#   Andrew Granville, "The Arithmetic Properties of Binomial Coefficients",
#   Proceedings of the Organic Mathematics Workshop, SFU, December 12-14, 1995.

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);
use Math::Prime::Util::GMP qw();

prime_set_config(bigint => "Math::BigInt");

#--------------------------------------------------------------------------
# Polynomial helpers (coefficients kept mod pk, degree truncated to < e)
#--------------------------------------------------------------------------

# Multiply two polynomials mod pk, dropping all terms of degree >= e.
sub _poly_mul {
    my ($A, $B, $pk, $e) = @_;
    my @C = (0) x $e;
    for my $i (0 .. $e - 1) {
        next unless $A->[$i];
        for my $j (0 .. $e - 1 - $i) {
            next unless $B->[$j];
            $C[$i + $j] = addmod($C[$i + $j], mulmod($A->[$i], $B->[$j], $pk), $pk);
        }
    }
    return \@C;
}

# Compute B(x) = A(x + h) mod pk, dropping all terms of degree >= e.
sub _poly_shift {
    my ($A, $h_gz, $pk, $e) = @_;
    my @B = (0) x $e;
    for my $j (0 .. $e - 1) {
        next unless $A->[$j];
        my $h_pow = Math::GMPz->new(1);
        for my $i (reverse 0 .. $j) {
            my $term = mulmod(mulmod(binomial($j, $i), $h_pow, $pk), $A->[$j], $pk);
            $B[$i] = addmod($B[$i], $term, $pk);
            $h_pow = mulmod($h_pow, $h_gz, $pk) if $i > 0;
        }
    }
    return \@B;
}

# Compute P(x, q) = product_{i=0}^{q-1} Poly(x + i) mod pk (degree < e),
# using divide-and-conquer in q.
sub _get_P {
    my ($q_gz, $Poly, $pk, $e) = @_;

    return do { my @r = (0) x $e; $r[0] = 1; \@r } if Math::GMPz::Rmpz_cmp_ui($q_gz, 0) == 0;
    return $Poly                                   if Math::GMPz::Rmpz_cmp_ui($q_gz, 1) == 0;

    my $h_gz = Math::GMPz->new(0);
    Math::GMPz::Rmpz_fdiv_q_2exp($h_gz, $q_gz, 1);    # h = floor(q/2)

    my $P_h  = _get_P($h_gz, $Poly, $pk, $e);
    my $P_2h = _poly_mul($P_h, _poly_shift($P_h, $h_gz, $pk, $e), $pk, $e);

    # If q is odd (q = 2h+1), multiply by the extra factor Poly(x + 2h)
    if (Math::GMPz::Rmpz_odd_p($q_gz)) {
        return _poly_mul($P_2h, _poly_shift($Poly, 2 * $h_gz, $pk, $e), $pk, $e);
    }

    return $P_2h;
}

#--------------------------------------------------------------------------
# Factorial-without-prime helpers
#--------------------------------------------------------------------------

# Compute n!_p mod pk (= product of 1..n with multiples of p removed),
# where pk = p^e.  Uses Granville's polynomial method (fast for large n).
sub _factorial_without_prime_pe {
    my ($n, $p, $e, $pk) = @_;

    # Small-n shortcut: direct product
    if (cmpint($n, $p) < 0) {
        my $res = 1;
        $res = mulmod($res, $_, $pk) for 1 .. $n;
        return $res;
    }

    # Step 1: Build Poly(X) mod pk.
    # Start from the expansion log(prod_{j=1}^{p-1}(1 + X/j)), collecting
    # coefficients c[k] of X^k, then scale to Poly[k] = c[k] * (p-1)! * p^k.
    my @c    = (1, (0) x ($e - 1));
    my $fact = 1;                     # accumulates (p-1)! mod pk

    for my $j (1 .. subint($p, 1)) {
        $fact = mulmod($fact, $j, $pk);
        my $inv = invmod($j, $pk);
        for my $k (reverse 1 .. $e - 1) {
            $c[$k] = addmod($c[$k], mulmod($c[$k - 1], $inv, $pk), $pk) if $c[$k - 1];
        }
    }

    my @Poly  = (0) x $e;
    my $p_pow = 1;
    for my $k (0 .. $e - 1) {
        $Poly[$k] = mulmod(mulmod($c[$k], $fact, $pk), $p_pow, $pk);
        $p_pow = mulmod($p_pow, $p, $pk);
    }

    my $q = divint($n, $p);
    my $r = modint($n, $p);

    # Step 2: The constant term of P(0, q) gives the main factor.
    my $q_gz = Math::GMPz::Rmpz_init_set_str("$q", 10);
    my $res  = _get_P($q_gz, \@Poly, $pk, $e)->[0];

    # Step 3: Multiply by the tail (pq+1)(pq+2)...(pq+r).
    if ("$r") {
        my $pq = mulint($q, $p);
        $res = mulmod($res, addint($pq, $_), $pk) for 1 .. "$r";
    }

    return $res;
}

# Compute n!_p mod pk, with an incremental cache ($from, $res) that lets
# successive calls reuse partial products when endpoints are non-decreasing.
sub _factorial_without_prime {
    my ($n, $p, $pk, $from, $res) = @_;

    return 1                     if $n <= 1;
    return factorialmod($n, $pk) if $p > $n;
    return $$res                 if $$from == $n;

    ($$from, $$res) = (0, 1) if $$from > $n;    # cache unusable; reset

    # Fast path for pk = p^2: Harmonic-number expansion, O(p) cost
    # instead of the naive O(p^2).
    if ($p > 2 && cmpint($pk, mulint($p, $p)) == 0) {
        my $a = divint($n, $p);
        my $b = modint($n, $p);

        # H_b = sum_{j=1}^{b} 1/j  mod p
        my $Hb = 0;
        if ($b > 0) {
            $Hb = addmod($Hb, invmod($_, $p), $p) for 1 .. $b;
        }

        my $r = mulmod(powmod(factorialmod(subint($p, 1), $pk), $a, $pk), factorialmod($b, $pk), $pk);

        # Correction term: multiply by (1 + a*p*H_b) mod pk
        if ($a > 0 && $Hb) {
            $r = mulmod($r, addmod(1, mulmod(mulmod($a, $p, $pk), $Hb, $pk), $pk), $pk);
        }

        ($$from, $$res) = ($n, $r);
        return $r;
    }

    # Fast path for pk = p^e, e >= 3: Granville polynomial method
    {
        my $e = valuation($pk, $p);
        if ($e >= 3) {
            my $r = _factorial_without_prime_pe($n, $p, $e, $pk);
            ($$from, $$res) = ($n, $r);
            return $r;
        }
    }

    # O(n) fallback: direct product (only reached when pk is not a prime power)
    my $r = $$res;
    for my $v ($$from + 1 .. $n) {
        $r = mulmod($r, $v, $pk) if $v % $p;
    }
    ($$from, $$res) = ($n, $r);
    return $r;
}

# ---------------------------------------------------------------------------
# Binomial-coefficient helpers
# ---------------------------------------------------------------------------

# Compute C(n, k) mod m via direct numerator/denominator product.
# Tracks p-adic valuation of the result to handle the p-part separately.
sub _small_k_binomialmod {
    my ($n_val, $k_val, $m_val, $p) = @_;

    $n_val = Math::GMPz::Rmpz_init_set_str("$n_val", 10) unless ref($n_val) eq 'Math::GMPz';
    $m_val = Math::GMPz::Rmpz_init_set_str("$m_val", 10) unless ref($m_val) eq 'Math::GMPz';

    # For small k or no prime to track, let GMP compute it directly
    if (!$p or $k_val <= 1e5) {
        my $bin = Math::GMPz::Rmpz_init();
        if (Math::GMPz::Rmpz_fits_ulong_p($n_val) && Math::GMPz::Rmpz_cmp_ui($n_val, 1e5) <= 0) {
            Math::GMPz::Rmpz_bin_uiui($bin, Math::GMPz::Rmpz_get_ui($n_val), $k_val);
        }
        else {
            Math::GMPz::Rmpz_bin_ui($bin, $n_val, $k_val);
        }
        Math::GMPz::Rmpz_mod($bin, $bin, $m_val);
        return $bin;
    }

    # Track the net p-adic valuation v across numerator and denominator,
    # keeping running products reduced mod m to avoid huge intermediate values.
    my $v = 0;
    state $num_mult = Math::GMPz::Rmpz_init_nobless();
    state $den_mult = Math::GMPz::Rmpz_init_nobless();
    state $temp     = Math::GMPz::Rmpz_init_nobless();
    state $p_z      = Math::GMPz::Rmpz_init_nobless();

    Math::GMPz::Rmpz_set_ui($num_mult, 1);
    Math::GMPz::Rmpz_set_ui($den_mult, 1);
    Math::GMPz::Rmpz_set_ui($p_z,      $p);

    for my $i (0 .. $k_val - 1) {
        Math::GMPz::Rmpz_sub_ui($temp, $n_val, $i);

        if (Math::GMPz::Rmpz_divisible_ui_p($temp, $p)) {
            $v += Math::GMPz::Rmpz_remove($temp, $temp, $p_z);
        }

        Math::GMPz::Rmpz_mul($num_mult, $num_mult, $temp);
        Math::GMPz::Rmpz_mod($num_mult, $num_mult, $m_val);

        my $den = $i + 1;
        if ($den % $p == 0) {
            Math::GMPz::Rmpz_set_ui($temp, $den);
            $v -= Math::GMPz::Rmpz_remove($temp, $temp, $p_z);
            $den = Math::GMPz::Rmpz_get_ui($temp);
        }

        Math::GMPz::Rmpz_mul_ui($den_mult, $den_mult, $den);
        Math::GMPz::Rmpz_mod($den_mult, $den_mult, $m_val);
    }

    Math::GMPz::Rmpz_invert($temp, $den_mult, $m_val);
    my $ans = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul($ans, $num_mult, $temp);
    Math::GMPz::Rmpz_mod($ans, $ans, $m_val);

    if ($v > 0) {
        Math::GMPz::Rmpz_powm_ui($temp, $p_z, $v, $m_val);
        Math::GMPz::Rmpz_mul($ans, $ans, $temp);
        Math::GMPz::Rmpz_mod($ans, $ans, $m_val);
    }

    return $ans;
}

# Heuristic: is computing C(n, k) mod m via direct product likely cheaper
# than going through the full Granville machinery?
sub _is_small_k_binomialmod {
    my ($n, $k, $m) = @_;

    $n >= 1e6 or return;
    return 1 if $m >= 1e7 && $n >= 1e7 && $k <= 1e6;

    my $sym_k = subint($n, $k);
    $k = $sym_k if $sym_k > 0 && $sym_k < $k;

    $k <= 1e7 or return;

    sqrtint($m) > $k
      && divint($m, $n) > $k;
}

# Lucas' theorem: C(n, k) mod p for prime p, evaluated digit by digit in base p.
sub _lucas_theorem {
    my ($n, $k, $p) = @_;
    my $r = 1;

    while ($k) {
        my $np = modint($n, $p);
        my $kp = modint($k, $p);

        return 0 if $kp > $np;

        if ($kp > 0) {
            if (_is_small_k_binomialmod($np, $kp, $p)) {
                $r = mulmod($r, _small_k_binomialmod($np, $kp, $p), $p);
            }
            else {
                my $nf = factorialmod($np, $p);
                my $df =
                  mulmod(factorialmod($kp, $p), factorialmod($np - $kp, $p), $p);
                $r = mulmod($r, ($df ne '1' ? divmod($nf, $df, $p) : $nf), $p);
            }
        }

        $n = divint($n, $p);
        $k = divint($k, $p);
    }

    return $r;
}

# ---------------------------------------------------------------------------
# Core implementation
# ---------------------------------------------------------------------------

sub _modular_binomial {
    my ($n, $k, $m) = @_;

    return 0 if Math::GMPz::Rmpz_cmp_ui($m, 1) == 0;

    # Negative k: apply upper-negation identity C(n,k) = C(n, n-k) when k < 0
    if (Math::GMPz::Rmpz_sgn($k) < 0) {
        my $tmp = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_sub($tmp, $n, $k);
        Math::GMPz::Rmpz_set($k, $tmp);
    }
    return 0 if Math::GMPz::Rmpz_sgn($k) < 0;

    # Negative n: C(n,k) = (-1)^k * C(-n+k-1, k)
    if (Math::GMPz::Rmpz_sgn($n) < 0) {
        my $sign  = Math::GMPz::Rmpz_even_p($k) ? 1 : -1;
        my $abs_n = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_neg($abs_n, $n);
        Math::GMPz::Rmpz_add($abs_n, $abs_n, $k);
        Math::GMPz::Rmpz_sub_ui($abs_n, $abs_n, 1);
        return modint(mulint($sign, __SUB__->($abs_n, $k, $m)), $m);
    }

    return 0 if Math::GMPz::Rmpz_cmp($k, $n) > 0;

    # Trivial boundary cases
    return modint(1, $m)
      if Math::GMPz::Rmpz_sgn($k) == 0 || Math::GMPz::Rmpz_cmp($k, $n) == 0;

    {
        my $n1 = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_sub_ui($n1, $n, 1);
        return modint($n, $m)
          if Math::GMPz::Rmpz_cmp_ui($k, 1) == 0 || Math::GMPz::Rmpz_cmp($k, $n1) == 0;
    }

    # Exploit symmetry C(n,k) = C(n, n-k) to keep k <= n/2
    {
        my $n_minus_k = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_sub($n_minus_k, $n, $k);
        Math::GMPz::Rmpz_set($k, $n_minus_k) if Math::GMPz::Rmpz_cmp($n_minus_k, $k) < 0;
    }

    return modint(_small_k_binomialmod($n, $k, $m), $m)
      if Math::GMPz::Rmpz_cmp_ui($k, 1e4) <= 0;

    # General case: factor m into prime powers, solve each via Granville's
    # method, then combine with CRT.
    my @F;
    for my $pp (factor_exp(absint($m))) {
        my ($p, $q) = @$pp;

        if ($q == 1) {
            push @F, [_lucas_theorem($n, $k, $p), $p];
            next;
        }

        my $pq = powint($p, $q);

        if (cmpint($p, $n) > 0) {
            push @F, [_small_k_binomialmod($n, $k, $pq, $p), $pq];
            next;
        }

        my $d = logint($n, $p) + 1;

        # Base-p digits of n and k (one digit per level, accumulated mod p)
        my (@np, @kp);
        {
            my $pi = 1;
            for my $i (0 .. $d) {
                push @np, modint(divint($n, $pi), $p);
                push @kp, modint(divint($k, $pi), $p);
                $pi = mulint($pi, $p);
            }
        }

        # Kummer's theorem: e[i] = number of carries at position i and above
        # when adding k and (n-k) in base p.
        my @e;
        for my $i (0 .. $d) {
            $e[$i] = ($np[$i] < ($kp[$i] + ($i > 0 ? $e[$i - 1] : 0))) ? 1 : 0;
        }
        for (my $i = $d - 1 ; $i >= 0 ; --$i) {
            $e[$i] += $e[$i + 1];
        }

        # If total carries >= q, the result is divisible by p^q, i.e., 0 mod p^q
        if ($e[0] >= $q) {
            push @F, [0, $pq];
            next;
        }

        my $rq  = $q - $e[0];
        my $prq = powint($p, $rq);

        if (_is_small_k_binomialmod($n, $k, mulint($p, $q))) {
            push @F, [_small_k_binomialmod($n, $k, $pq), $pq];
            next;
        }

        # Digits of n, k, r = n-k mod p^rq at each level
        my (@N, @K, @R);
        {
            my $pi = 1;
            my $r  = subint($n, $k);
            for my $i (0 .. $d) {
                push @N, modint(divint($n, $pi), $prq);
                push @K, modint(divint($k, $pi), $prq);
                push @R, modint(divint($r, $pi), $prq);
                $pi = mulint($pi, $p);
            }
        }

        # Sort triples by N+K+R so _factorial_without_prime's cache is maximally reused
        {
            my @idx = sort { ($N[$a] + $K[$a] + $R[$a]) <=> ($N[$b] + $K[$b] + $R[$b]) } 0 .. $#N;
            @N = @N[@idx];
            @K = @K[@idx];
            @R = @R[@idx];
        }

        # Precompute small factorial-without-p values into a lookup table
        my %acc  = ('0' => 1);
        my $nfac = 1;
        if ($prq < ~0 && $p < $n) {
            for my $v (1 .. vecmin(vecmax(@N, @K, @R), 1e3)) {
                $nfac = mulmod($nfac, $v, $prq) if $v % $p;
                $acc{$v} = $nfac;
            }
        }

        my $v = powmod($p, $e[0], $pq);

        {
            my ($from, $res_cache) = (0, 1);

            for my $j (0 .. $d) {
                my @pairs;
                my ($x, $y, $z);

                ($x = $acc{$N[$j]}) // push @pairs, [\$x, $N[$j]];
                ($y = $acc{$K[$j]}) // push @pairs, [\$y, $K[$j]];
                ($z = $acc{$R[$j]}) // push @pairs, [\$z, $R[$j]];

                # Process missing entries in ascending order to benefit the cache
                for my $pair (sort { $a->[1] <=> $b->[1] } @pairs) {
                    ${$pair->[0]} = _factorial_without_prime($pair->[1], $p, $prq, \$from, \$res_cache);
                }

                $y = mulmod($y, $z, $pq);
                $x = divmod($x, $y, $pq) if $y ne '1';
                $v = mulmod($v, $x, $pq);
            }
        }

        # Wilson's theorem sign correction
        if (($p > 2 || $rq < 3) && $rq <= scalar(@e)) {
            $v = mulmod($v, $e[$rq - 1] % 2 == 0 ? 1 : -1, $pq);
        }

        push @F, [$v, $pq];
    }

    Math::Prime::Util::GMP::modint(Math::Prime::Util::GMP::chinese(@F), $m);
}

# ---------------------------------------------------------------------------
# Public interface
# ---------------------------------------------------------------------------

sub modular_binomial {
    my ($n, $k, $m) = @_;

    $n = Math::GMPz->new("$n");
    $k = Math::GMPz->new("$k");
    $m = Math::GMPz->new("$m");

    return undef unless Math::GMPz::Rmpz_sgn($m);

    _modular_binomial($n, $k, $m);
}

use Math::Sidef qw();

sub test_binomialmod($n, $k, $m) {
    Math::Sidef::binomialmod($n, $k, $m);
}

#
## Run some tests
#

use Test::More tests => 103;

for my $e (1 .. 5) {
    my $n = powint(2,                33) + int rand 1234;
    my $k = powint(2,                32) - int rand 1234;
    my $m = powint(2 + int rand 100, $e);
    say "binomialmod($n,$k,$m) = ", modular_binomial($n, $k, $m);
    is(modular_binomial($n, $k, $m), test_binomialmod($n, $k, $m));
}

is(modular_binomial(8589934703, 4294966460, 4182119424),          4133348352);
is(modular_binomial(8589934823, 4294966769, 52521875),            26643750);
is(modular_binomial(8589935272, 429496,     "97656250000000000"), "57900778336640000");
is(modular_binomial(8589935272, 4294965,    "97656250000000000"), "96886205280000000");
is(modular_binomial(8589935272, 4294966820, "97656250000000000"), "55077260000000000");
is(modular_binomial(8589935272, 42949658,   "97656250000000000"), "46773145040000000");

is(modular_binomial(10, 2, 43), 2);
is(modular_binomial(10, 8, 43), 2);

is(modular_binomial(10, 2, 24), 21);
is(modular_binomial(10, 8, 24), 21);

is(modular_binomial(100, 42, -127), binomial(100, 42) % -127);

is(modular_binomial(12,   5,   100000),  792);
is(modular_binomial(16,   4,   100000),  1820);
is(modular_binomial(100,  50,  139),     71);
is(modular_binomial(1000, 10,  1243),    848);
is(modular_binomial(124,  42,  1234567), 395154);
is(modular_binomial(1e9,  1e4, 1234567), 833120);
is(modular_binomial(1e10, 1e5, 1234567), 589372);

is(modular_binomial(1e10,  1e5, 4233330243), 3403056024);
is(modular_binomial(-1e10, 1e5, 4233330243), 2865877173);

is(modular_binomial(1e10, 1e4, factorial(13)), 1845043200);
is(modular_binomial(1e10, 1e5, factorial(13)), 1556755200);
is(modular_binomial(1e10, 1e6, factorial(13)), 5748019200);

is(modular_binomial(-1e10, 1e4, factorial(13)), 4151347200);
is(modular_binomial(-1e10, 1e5, factorial(13)), 1037836800);
is(modular_binomial(-1e10, 1e6, factorial(13)), 2075673600);

is(modular_binomial(3, 1, 9),  binomial(3, 1) % 9);
is(modular_binomial(4, 1, 16), binomial(4, 1) % 16);

is(modular_binomial(1e9,  1e5, 43 * 97 * 503),         585492);
is(modular_binomial(1e9,  1e6, 5041689707),            15262431);
is(modular_binomial(1e7,  1e5, 43**2 * 97**3 * 13**4), 1778017500428);
is(modular_binomial(1e7,  1e5, 42**2 * 97**3 * 13**4), 10015143223176);
is(modular_binomial(1e9,  1e5, 12345678910),           4517333900);
is(modular_binomial(1e9,  1e6, 13**2 * 5**6),          2598375);
is(modular_binomial(1e10, 1e5, 1234567),               589372);

is(modular_binomial(1e5,     1e3, 43),                 binomial(1e5,     1e3) % 43);
is(modular_binomial(1e5,     1e3, 43 * 97),            binomial(1e5,     1e3) % (43 * 97));
is(modular_binomial(1e5,     1e3, 43 * 97 * 43),       binomial(1e5,     1e3) % (43 * 97 * 43));
is(modular_binomial(1e5,     1e3, 43 * 97 * (5**5)),   binomial(1e5,     1e3) % (43 * 97 * (5**5)));
is(modular_binomial(1e5,     1e3, next_prime(1e4)**2), binomial(1e5,     1e3) % next_prime(1e4)**2);
is(modular_binomial(1e5,     1e3, next_prime(1e4)),    binomial(1e5,     1e3) % next_prime(1e4));
is(modular_binomial(1e6,     1e3, next_prime(1e5)),    binomial(1e6,     1e3) % next_prime(1e5));
is(modular_binomial(1e6,     1e3, next_prime(1e7)),    binomial(1e6,     1e3) % next_prime(1e7));
is(modular_binomial(1234567, 1e3, factorial(20)),      binomial(1234567, 1e3) % factorial(20));
is(modular_binomial(1234567, 1e4, factorial(20)),      binomial(1234567, 1e4) % factorial(20));

is(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));
is(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));

is(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));
is(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));
is(modular_binomial(-10, -9,  -10), binomial(-10, -9) % -10);

is(modular_binomial(1e6, 1e3, powint(2, 128) + 1), binomial(1e6, 1e3) % (powint(2, 128) + 1));
is(modular_binomial(1e6, 1e3, powint(2, 128) - 1), binomial(1e6, 1e3) % (powint(2, 128) - 1));

is(modular_binomial(1e6, 1e4, (powint(2, 128) + 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) + 1)**2));
is(modular_binomial(1e6, 1e4, (powint(2, 128) - 1)**2), binomial(1e6, 1e4) % ((powint(2, 128) - 1)**2));

is(modular_binomial(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)), test_binomialmod(1e10, 1e4, powint(prev_prime(powint(2, 64)), 2)));
is(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))**2),         test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))**2));

is(modular_binomial(1e10, 1e4, prev_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, prev_prime(powint(2, 64))));
is(modular_binomial(1e10, 1e4, next_prime(powint(2, 64))), test_binomialmod(1e10, 1e4, next_prime(powint(2, 64))));

is(modular_binomial(1e10, 1e3, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e3, powint(2, 127) + 1));
is(modular_binomial(1e10, 1e3, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e3, powint(2, 127) - 1));
is(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));
is(modular_binomial(1e10, 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));

is(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) - 1)), test_binomialmod(1e10, 1e5, powint(2, 127) - 1));
is(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)), test_binomialmod(1e10, 1e5, powint(2, 127) + 1));
is(modular_binomial(1e10, 1e10 - 1e5, (powint(2, 127) + 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) + 1)**2));

is(modular_binomial(1e10, 1e5, (powint(2, 127) - 1)**2), test_binomialmod(1e10, 1e5, (powint(2, 127) - 1)**2));
is(modular_binomial(1e10, 1e4, (powint(2, 128) - 1)**2), test_binomialmod(1e10, 1e4, (powint(2, 128) - 1)**2));
is(modular_binomial(1e7,  1e5, (powint(2, 128) - 1)**2), test_binomialmod(1e7,  1e5, (powint(2, 128) - 1)**2));

is(modular_binomial(4294967291 + 1, 1e5, powint(4294967291, 2)), test_binomialmod(4294967291 + 1, 1e5, powint(4294967291, 2)));
is(modular_binomial(powint(2, 60) - 99, 1e5, prev_prime(1e9)),           test_binomialmod(powint(2, 60) - 99, 1e5, prev_prime(1e9)));
is(modular_binomial(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))), test_binomialmod(powint(2, 60) - 99, 1e5, next_prime(powint(2, 64))));

is(binomialmod(0, 0, 7), 1);
is(modular_binomial(0,         1,        7),          0);
is(modular_binomial(0,         2,        7),          0);
is(modular_binomial(3,         0,        7),          1);
is(modular_binomial(7,         5,        11),         10);
is(modular_binomial(950,       100,      123456),     24942);
is(modular_binomial(950,       100,      7),          2);
is(modular_binomial(8100,      4000,     1155),       924);
is(modular_binomial(950,       100,      1000000007), 640644226);
is(modular_binomial(189,       34,       877),        81);
is(modular_binomial(189,       34,       253009),     47560);
is(modular_binomial(189,       34,       36481),      14169);
is(modular_binomial(1900,      17,       41),         0);
is(modular_binomial(5000,      654,      101223721),  59171352);
is(modular_binomial(-112,      5,        351),        313);
is(modular_binomial(-189,      34,       877),        141);
is(modular_binomial(-23,       -29,      377),        117);
is(modular_binomial(189,       -34,      877),        0);
is(modular_binomial(100000000, 87654321, 1005973),    937361);
is(modular_binomial(100000000, 7654321,  1299709),    582708);
is(modular_binomial(100000000, 7654321,  12345678),   4152168);
is(modular_binomial(100000,    7654,     32768),      12288);
is(modular_binomial(100000,    7654,     196608),     110592);
is(modular_binomial(100000,    7654,     101223721),  5918452);
is(modular_binomial(100000000, 7654321,  32768),      24576);
is(modular_binomial(100000000, 7654321,  196608),     122880);
is(modular_binomial(100000000, 7654321,  101223721),  5463123);

say("binomial(10^10, 10^5) mod 13! = ", modular_binomial(1e10, 1e5, factorial(13)));


================================================
FILE: Math/modular_binomial_ntheory.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 September 2017
# https://github.com/trizen

# Compute `binomial(n, k) % m`, using the `factorialmod(n, m)` function from ntheory.

use 5.010;
use strict;
use warnings;

use ntheory qw(divmod factorialmod);

sub modular_binomial {
    my ($n, $k, $m) = @_;
    divmod(divmod(factorialmod($n, $m), factorialmod($k, $m), $m), factorialmod($n - $k, $m), $m);
}

say modular_binomial(100, 50, 139);        #=> 71
say modular_binomial(124, 42, 1234567);    #=> 395154


================================================
FILE: Math/modular_binomial_small_k.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 September 2017
# Website: https://github.com/trizen

# A decently efficient algorithm for computing `binomial(n, k) mod m`, where `k` is small (<~ 10^6).

# Implemented using the identity:
#    binomial(n, k) = Product_{r = n-k+1..n}(r) / k!

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use List::Util qw(uniq);
use experimental qw(signatures);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub modular_binomial ($n, $k, $m) {

    my %kp;
    my $prod = 1;

    forfactored {

        my $r       = $_;
        my @factors = uniq(@_);

        foreach my $p (@factors) {

            if ($p <= $k) {
                next if ((my $t = ($kp{$p} //= factorial_power($k, $p))) == 0);

                my $v = valuation($r, $p);

                if ($v >= $t) {
                    $v = $t;
                    $kp{$p} = 0;
                }
                else {
                    $kp{$p} -= $v;
                }

                last if (($r /= $p**$v) <= 1);
            }
            else {
                last;
            }
        }

        $prod = mulmod($prod, $r, $m);
    } $n - $k + 1, $n;

    return $prod;
}

say modular_binomial(12,   5,   100000);     #=> 792
say modular_binomial(16,   4,   100000);     #=> 1820
say modular_binomial(100,  50,  139);        #=> 71
say modular_binomial(1000, 10,  1243);       #=> 848
say modular_binomial(124,  42,  1234567);    #=> 395154
say modular_binomial(1e9,  1e4, 1234567);    #=> 833120
say modular_binomial(1e10, 1e5, 1234567);    #=> 589372


================================================
FILE: Math/modular_binomial_small_k_faster.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 27 April 2022
# https://github.com/trizen

# A decently efficient algorithm for computing `binomial(n, k) mod m`, where `k` is small (<~ 10^6).

# Implemented using the identity:
#    binomial(n, k) = Product_{r = n-k+1..n}(r) / k!

# And also using the identitiy:
#   binomial(n, k) = Prod_{j=0..k-1} (n-j)/(j+1)

# See also:
#   https://en.wikipedia.org/wiki/Lucas%27s_theorem

use 5.020;
use strict;
use warnings;

use ntheory      qw(:all);
use List::Util   qw(uniq);
use experimental qw(signatures);

sub factorial_power ($n, $p) {
    divint($n - vecsum(todigits($n, $p)), $p - 1);
}

sub modular_binomial_small_k ($n, $k, $m) {

    my %kp;
    my $prod = 1;

    if ($n - $k < $k) {
        $k = $n - $k;
    }

    if (is_prime($m)) {

        foreach my $j (0 .. $k - 1) {
            $prod = mulmod($prod, $n - $j, $m);
            $prod = divmod($prod, $j + 1, $m);
        }

        return $prod;
    }

    forfactored {

        my $r       = $_;
        my @factors = uniq(@_);

        foreach my $p (@factors) {

            if ($p <= $k) {
                next if ((my $t = ($kp{$p} //= factorial_power($k, $p))) == 0);

                my $v = valuation($r, $p);

                if ($v >= $t) {
                    $v = $t;
                    $kp{$p} = 0;
                }
                else {
                    $kp{$p} -= $v;
                }

                $r = divint($r, powint($p, $v));
                last if ($r == 1);
            }
            else {
                last;
            }
        }

        $prod = mulmod($prod, $r, $m);
    } $n - $k + 1, $n;

    return $prod;
}

sub lucas_theorem ($n, $k, $p) {

    if ($n < $k) {
        return 0;
    }

    my $res = 1;

    while ($k > 0) {
        my ($Nr, $Kr) = (modint($n, $p), modint($k, $p));

        if ($Nr < $Kr) {
            return 0;
        }

        ($n, $k) = (divint($n, $p), divint($k, $p));
        $res = mulmod($res, modular_binomial_small_k($Nr, $Kr, $p), $p);
    }

    return $res;
}

sub modular_binomial ($n, $k, $m) {

    if ($m == 0) {
        return undef;
    }

    if ($m == 1) {
        return 0;
    }

    if ($k < 0) {
        $k = subint($n, $k);
    }

    if ($k < 0) {
        return 0;
    }

    if ($n < 0) {
        return modint(mulint(powint(-1, $k), __SUB__->(subint($k, $n) - 1, $k, $m)), $m);
    }

    if ($k > $n) {
        return 0;
    }

    if ($k == 0 or $k == $n) {
        return modint(1, $m);
    }

    if ($n - $k < $k) {
        $k = $n - $k;
    }

    is_square_free(absint($m))
      || return modint(modular_binomial_small_k($n, $k, absint($m)), $m);

    my @congruences;

    foreach my $pp (factor_exp(absint($m))) {
        my ($p, $e) = @$pp;

        my $pk = powint($p, $e);

        if ($e == 1) {
            push @congruences, [lucas_theorem($n, $k, $p), $p];
        }
        else {
            push @congruences, [modular_binomial_small_k($n, $k, $pk), $pk];
        }
    }

    modint(chinese(@congruences), $m);
}

say modular_binomial(12,   5,   100000);       #=> 792
say modular_binomial(16,   4,   100000);       #=> 1820
say modular_binomial(100,  50,  139);          #=> 71
say modular_binomial(1000, 10,  1243);         #=> 848
say modular_binomial(124,  42,  1234567);      #=> 395154
say modular_binomial(1e9,  1e4, 1234567);      #=> 833120
say modular_binomial(1e10, 1e5, 1234567);      #=> 589372
say modular_binomial(1e10, 1e6, 1234567);      #=> 456887
say modular_binomial(1e9,  1e4, 123456791);    #=> 106271399
say modular_binomial(1e10, 1e5, 123456791);    #=> 20609240

__END__
use Test::More tests => 8820;

my $upto = 10;
foreach my $n (-$upto .. $upto) {
    foreach my $k (-$upto .. $upto) {
        foreach my $m (-$upto .. $upto) {
            next if ($m == 0);
            say "Testing: binomial($n, $k, $m)";
            is(modular_binomial($n, $k, $m), binomial($n, $k) % $m);
        }
    }
}


================================================
FILE: Math/modular_cyclotomic_polynomial.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 08 May 2022
# https://github.com/trizen

# Efficiently compute the n-th Cyclotomic polynomial modulo m, evaluated at x.

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub cyclotomicmod ($n, $x, $m) {

    $n = Math::GMPz->new("$n");
    $x = Math::GMPz->new("$x");
    $m = Math::GMPz->new("$m");

    Math::GMPz::Rmpz_sgn($m) || return;

    # n must be >= 0
    (Math::GMPz::Rmpz_sgn($n) || return 0) > 0
      or return;

    return 0 if (Math::GMPz::Rmpz_cmp_ui($m, 1) == 0);

    return (($x - 1) % $m) if (Math::GMPz::Rmpz_cmp_ui($n, 1) == 0);
    return (($x + 1) % $m) if (Math::GMPz::Rmpz_cmp_ui($n, 2) == 0);

    # Special case for x = 1: cyclotomic(n, 1) is A020500.
    if (Math::GMPz::Rmpz_cmp_ui($x, 1) == 0) {
        my $k = is_prime_power($n) || return 1;
        my $p = rootint($n, $k);
        return modint($p, $m);
    }

    # Special case for x = -1: cyclotomic(n, -1) is A020513.
    if (Math::GMPz::Rmpz_cmp_si($x, -1) == 0) {
        Math::GMPz::Rmpz_even_p($n) || return 1;
        my $o = $n >> 1;
        my $k = is_prime_power($o) || return 1;
        my $p = rootint($o, $k);
        return modint($p, $m);
    }

    my @factor_exp = factor_exp($n);

    # Generate the squarefree divisors of n, along
    # with the number of prime factors of each divisor
    my @sd;
    foreach my $pe (@factor_exp) {
        my ($p) = @$pe;

        $p =
          ($p < ~0)
          ? Math::GMPz::Rmpz_init_set_ui($p)
          : Math::GMPz::Rmpz_init_set_str("$p", 10);

        push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;
        push @sd, [$p, 1];
    }

    push @sd, [Math::GMPz::Rmpz_init_set_ui(1), 0];

    my $prod = Math::GMPz::Rmpz_init_set_ui(1);

    foreach my $pair (@sd) {
        my ($d, $c) = @$pair;

        my $base = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_divexact($base, $n, $d);
        Math::GMPz::Rmpz_powm($base, $x, $base, $m);    # x^(n/d) mod m
        Math::GMPz::Rmpz_sub_ui($base, $base, 1);

        if ($c % 2 == 1) {
            Math::GMPz::Rmpz_invert($base, $base, $m) || return;
        }

        Math::GMPz::Rmpz_mul($prod, $prod, $base);
        Math::GMPz::Rmpz_mod($prod, $prod, $m);
    }

    return $prod;
}

say cyclotomicmod(factorial(30), 5040,                        Math::GMPz->new(2)**128 + 1);
say cyclotomicmod(factorial(20), Math::GMPz->new(2)**127 - 1, Math::GMPz->new(2)**128 + 1);

__END__
40675970320518606495224484019728682382
194349103384996189019641296094415725728


================================================
FILE: Math/modular_factorial.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 21 August 2016
# Edit: 15 April 2026
# Website: https://github.com/trizen

# An efficient algorithm for computing factorial of a large number, modulo a larger number.

use 5.036;
use ntheory 0.74 qw(
    invmod powmod forprimes random_prime
    todigits vecsum divint mulmod addmod vecprod
);

sub factorial_power ($n, $p) {
    divint($n - vecsum(todigits($n, $p)), $p - 1);
}

# This algorithm uses powers of primes to efficiently
# compute `n! mod k`. It works correctly in all cases.

sub facmod2 ($n, $mod) {

    my $p = 0;
    my $f = 1;

    forprimes {
        if ($p == 1) {
            $f = mulmod($f, $_, $mod);
        }
        else {
            $p = factorial_power($n, $_);
            $f = mulmod($f, powmod($_, $p, $mod), $mod);
        }
    } $n;

    return $f;
}

# This algorithm is fast and correct only when `mod`
# is larger than `n`, but no more than twice as large.

# Algorithm from:
#   https://stackoverflow.com/questions/9727962/fast-way-to-calculate-n-mod-m-where-m-is-prime

sub facmod1 ($n, $mod) {

    if ($n <= divint($mod, 2) or $mod <= $n) {
        return facmod2($n, $mod);
    }

    my $f = 1;
    foreach my $k ($n + 1 .. $mod - 1) {
        $f = mulmod($f, $k, $mod);
    }

    addmod(mulmod(-1, (invmod($f, $mod) // 0), $mod), $mod, $mod);
}

my $n = 1000000;
my $m = vecprod(503, 503, 863, 1000000007);
say facmod2($n, $m);           #=> 51017729998226472

foreach my $n (100000 .. 100000 + 10) {
    my $p = random_prime($n, $n * 2 - 1);
    my $f1 = facmod1($n, $p);
    my $f2 = facmod2($n, $p);

    if ($f1 != $f2) {
        warn "ERROR: returned values ($f1, $f2) don't agree for ($n, $p)\n";
    }

    printf("%5d! mod %5d = %5d\n", $n, $p, $f1);
}

__END__
100000! mod 124783 = 118955
100001! mod 169987 = 155308
100002! mod 188431 = 22741
100003! mod 100747 = 92927
100004! mod 164251 = 42227
100005! mod 117191 = 65606
100006! mod 121327 = 119432
100007! mod 172259 = 152151
100008! mod 176927 = 39009
100009! mod 135571 = 28311
100010! mod 164093 = 36407


================================================
FILE: Math/modular_factorial_crt.pl
================================================
#!/usr/bin/perl

# A simple O(n) algorithm for computing n! mod m, by factoring m and combining with CRT.

use 5.036;
use ntheory 0.74 qw(
    factor_exp chinese vecsum todigits
    powint divint mulmod forprimes powmod vecprod
);

# Legendre's Formula: Computes the exponent of highest power of p dividing n!
# Runs in O(log_p(n)) time.
sub _legendre_valuation ($n, $p) {
    divint($n - vecsum(todigits($n, $p)), $p - 1);
}

sub _facmod ($n, $mod) {

    my $p = 0;
    my $f = 1;

    forprimes {
        if ($p == 1) {
            $f = mulmod($f, $_, $mod);
        }
        else {
            $p = _legendre_valuation($n, $_);
            $f = mulmod($f, powmod($_, $p, $mod), $mod);
        }
    } $n;

    return $f;
}

sub factorialmod_crt ($n, $m) {

    # Trivial base cases
    if ($n >= $m or $m == 1) {
        return 0;
    }
    if ($n <= 1) {
        return 1;
    }

    # Factor m into prime powers [ [p1, e1], [p2, e2], ... ]
    my @factors = factor_exp($m);

    my @residues;
    for my $factor_ref (@factors) {
        my ($p, $e) = @$factor_ref;

        # Calculate p^e
        my $pe = powint($p, $e);

        # Get the power of p dividing n!
        my $valuation = _legendre_valuation($n, $p);

        # If the power of p in n! is >= e, then n! is divisible by p^e.
        # This is where we save O(n) computations!
        if ($valuation >= $e) {
            push @residues, [0, $pe];
            next;
        }

        # If we reach here, n! is NOT perfectly divisible by p^e.
        # This means n is quite small relative to p^e. We compute it directly.
        my $res = _facmod($n, $pe);

        push @residues, [$res, $pe];
    }

    # Recombine using Chinese Remainder Theorem
    chinese(@residues);
}

# --- Example Usage ---

my $n = 1000000;
my $m = vecprod(503, 503, 863, 1000000007);
say factorialmod_crt($n, $m);           #=> 51017729998226472


================================================
FILE: Math/modular_factorial_crt_mpz.pl
================================================
#!/usr/bin/perl

# A simple O(n) algorithm for computing n! mod m, by factoring m and combining with CRT.

use 5.036;
use Math::GMPz;
use ntheory qw(
    factor_exp chinese forprimes
    divint vecsum todigits vecprod
);

# Legendre's Formula: Computes the exponent of highest power of p dividing n!
# Runs in O(log_p(n)) time.
sub _legendre_valuation ($n, $p) {
    divint($n - vecsum(todigits($n, $p)), $p - 1);
}

sub _facmod ($n, $mod) {

    my $p = 0;
    my $f = Math::GMPz::Rmpz_init_set_ui(1);

    state $t = Math::GMPz::Rmpz_init_nobless();

    forprimes {
        if ($p == 1) {
            Math::GMPz::Rmpz_mul_ui($f, $f, $_);
            Math::GMPz::Rmpz_mod($f, $f, $mod);
        }
        else {
            $p = _legendre_valuation($n, $_);
            Math::GMPz::Rmpz_set_ui($t, $_);
            Math::GMPz::Rmpz_powm_ui($t, $t, $p, $mod);
            Math::GMPz::Rmpz_mul($f, $f, $t);
            Math::GMPz::Rmpz_mod($f, $f, $mod);
        }
    } $n;

    return $f;
}

sub factorialmod_crt ($n_scalar, $m_scalar) {

    my $n = Math::GMPz->new($n_scalar);
    my $m = Math::GMPz->new($m_scalar);

    # Trivial base cases
    if (Math::GMPz::Rmpz_cmp($n, $m) >= 0 or Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {
        return Math::GMPz->new(0);
    }
    if (Math::GMPz::Rmpz_cmp_ui($n, 1) <= 0) {
        return Math::GMPz->new(1);
    }

    # Factor m into prime powers [ [p1, e1], [p2, e2], ... ]
    my @factors = factor_exp($m_scalar);

    my $p_z  = Math::GMPz::Rmpz_init();
    my $pe_z = Math::GMPz::Rmpz_init();

    my @residues;
    for my $factor_ref (@factors) {
        my ($p, $e) = @$factor_ref;

        # Calculate p^e
        Math::GMPz::Rmpz_set_str($p_z, $p, 10);
        Math::GMPz::Rmpz_pow_ui($pe_z, $p_z, $e);

        # Get the power of p dividing n!
        my $valuation = _legendre_valuation($n_scalar, $p);

        # If the power of p in n! is >= e, then n! is divisible by p^e.
        # This is where we save O(n) computations!
        if ($valuation >= $e) {
            push @residues, [0, Math::GMPz::Rmpz_get_str($pe_z, 10)];
            next;
        }

        # If we reach here, n! is NOT perfectly divisible by p^e.
        # This means n is quite small relative to p^e. We compute it directly.
        my $res = _facmod(Math::GMPz::Rmpz_get_ui($n), $pe_z);

        push @residues, [
            Math::GMPz::Rmpz_get_str($res, 10),
            Math::GMPz::Rmpz_get_str($pe_z, 10)
        ];
    }

    # Recombine using Chinese Remainder Theorem
    Math::GMPz->new(chinese(@residues));
}

# --- Example Usage ---

my $n = 1000000;
my $m = vecprod(503, 503, 863, 1000000007);
say factorialmod_crt($n, $m);           #=> 51017729998226472


================================================
FILE: Math/modular_fibonacci.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 21 August 2016
# Edit: 30 September 2017
# https://github.com/trizen

# An efficient algorithm for computing large Fibonacci numbers, modulo some n.

# Algorithm from:
#   https://codeforces.com/blog/entry/14516

use 5.020;
use strict;
use warnings;

use ntheory qw(mulmod addmod);
use experimental qw(signatures);

sub fibmod($n, $mod, $cache={}) {

    $n <= 1 && return $n;

    sub ($n) {

        $n <= 1 && return 1;

        if (exists($cache->{$n})) {
            return $cache->{$n};
        }

        my $k = $n >> 1;

#<<<
        $cache->{$n} = (
            ($n % 2 == 0)
                ? addmod(mulmod(__SUB__->($k), __SUB__->($k    ), $mod), mulmod(__SUB__->($k - 1), __SUB__->($k - 1), $mod), $mod)
                : addmod(mulmod(__SUB__->($k), __SUB__->($k + 1), $mod), mulmod(__SUB__->($k - 1), __SUB__->($k    ), $mod), $mod)
        );
#>>>

    }->($n - 1);
}

say fibmod(329468, 10**10, {});     # 352786941


================================================
FILE: Math/modular_fibonacci_anynum.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 June 2018
# https://github.com/trizen

# An efficient algorithm for computing the nth-Fibonacci number (mod m).

use 5.020;
use warnings;
use experimental qw(signatures);
use Math::AnyNum qw(:overload ilog2 getbit);

sub fibonacci_number($n, $m) {

    my ($f, $g) = (0, 1);
    my ($a, $b) = (0, 1);

    foreach my $k (0 .. ilog2($n)||0) {
        ($f, $g) = (($f*$a + $g*$b)%$m, ($f*$b + $g*($a+$b))%$m) if getbit($n, $k);
        ($a, $b) = (($a*$a + $b*$b)%$m, ($a*$b + $b*($a+$b))%$m);
    }

    return $f;
}

# Last 20 digits of the 10^100-th Fibonacci number
say fibonacci_number(10**100, 10**20);       #=> 59183788299560546875


================================================
FILE: Math/modular_fibonacci_cassini.pl
================================================
#!/usr/bin/perl

# An efficient algorithm for computing the nth-Fibonacci number (mod m).

# Algorithm from:
#   https://metacpan.org/source/KRYDE/Math-NumSeq-72/lib/Math/NumSeq/Fibonacci.pm

# See also:
#   https://en.wikipedia.org/wiki/Fibonacci_number

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;
use Math::Prime::Util::GMP qw(consecutive_integer_lcm gcd);

sub fibmod ($n, $m) {

    $n = Math::GMPz->new("$n");
    $m = Math::GMPz->new("$m");

    my ($f, $g, $a) = (0, 1, -2);

    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($n, 2), 1))) {

        ($g *= $g) %= $m;
        ($f *= $f) %= $m;

        my $t = ($g << 2) - $f + $a;

        $f += $g;

        if ($bit) {
            ($f, $g, $a) = ($t - $f, $t, -2);
        }
        else {
            ($g, $a) = ($t - $f, 2);
        }
    }

    return ($g % $m);
}

sub fibonacci_factorization ($n, $B = 10000) {

    my $k = consecutive_integer_lcm($B);    # lcm(1..B)
    my $F = fibmod($k, $n);                 # Fibonacci(k) (mod n)

    return gcd($F, $n);
}

say fibonacci_factorization("121095274043",             700);     #=> 470783           (p+1 is  700-smooth)
say fibonacci_factorization("544812320889004864776853", 3000);    #=> 333732865481     (p-1 is 3000-smooth)


================================================
FILE: Math/modular_fibonacci_cassini_fast.pl
================================================
#!/usr/bin/perl

# An efficient algorithm for computing the nth-Fibonacci number (mod m).

# Algorithm from:
#   https://metacpan.org/source/KRYDE/Math-NumSeq-72/lib/Math/NumSeq/Fibonacci.pm

# See also:
#   https://en.wikipedia.org/wiki/Fibonacci_number

use 5.020;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use Math::Prime::Util::GMP qw(gcd consecutive_integer_lcm);

sub fibmod ($n, $m) {

    $n = Math::GMPz->new("$n");
    $m = Math::GMPz->new("$m");

    my ($f, $g, $w) = (
        Math::GMPz::Rmpz_init_set_ui(0),
        Math::GMPz::Rmpz_init_set_ui(1),
    );

    my $t = Math::GMPz::Rmpz_init();

    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($n, 2), 1))) {

        Math::GMPz::Rmpz_powm_ui($g, $g, 2, $m);
        Math::GMPz::Rmpz_powm_ui($f, $f, 2, $m);

        Math::GMPz::Rmpz_mul_2exp($t, $g, 2);
        Math::GMPz::Rmpz_sub($t, $t, $f);

        $w
          ? Math::GMPz::Rmpz_add_ui($t, $t, 2)
          : Math::GMPz::Rmpz_sub_ui($t, $t, 2);

        Math::GMPz::Rmpz_add($f, $f, $g);

        if ($bit) {
            Math::GMPz::Rmpz_sub($f, $t, $f);
            Math::GMPz::Rmpz_set($g, $t);
            $w = 0;
        }
        else {
            Math::GMPz::Rmpz_sub($g, $t, $f);
            $w = 1;
        }
    }

    Math::GMPz::Rmpz_mod($g, $g, $m);

    return $g;
}

sub fibonacci_factorization ($n, $B = 10000) {

    my $k = consecutive_integer_lcm($B);    # lcm(1..B)
    my $F = fibmod($k, $n);                 # Fibonacci(k) (mod n)

    return gcd($F, $n);
}

say fibonacci_factorization("121095274043",             700);     #=> 470783           (p+1 is  700-smooth)
say fibonacci_factorization("544812320889004864776853", 3000);    #=> 333732865481     (p-1 is 3000-smooth)


================================================
FILE: Math/modular_fibonacci_fast_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 June 2018
# https://github.com/trizen

# An efficient algorithm for computing the nth-Fibonacci number (mod m).

# See also:
#   https://en.wikipedia.org/wiki/Fibonacci_number

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use experimental qw(signatures);

sub modular_fibonacci ($n, $m) {

    $n = Math::GMPz->new("$n");
    $m = Math::GMPz->new("$m");

    state $t = Math::GMPz::Rmpz_init_nobless();
    state $u = Math::GMPz::Rmpz_init_nobless();

    my $f = Math::GMPz::Rmpz_init_set_ui(0);    # set to 2 for Lucas numbers
    my $g = Math::GMPz::Rmpz_init_set_ui(1);

    my $A = Math::GMPz::Rmpz_init_set_ui(0);
    my $B = Math::GMPz::Rmpz_init_set_ui(1);

    my @bits = split(//, Math::GMPz::Rmpz_get_str($n, 2));

    while (@bits) {

        if (pop @bits) {

            # (f, g) = (f*a + g*b, f*b + g*(a+b))  mod m

            Math::GMPz::Rmpz_mul($u, $g, $B);
            Math::GMPz::Rmpz_mul($t, $f, $A);
            Math::GMPz::Rmpz_mul($g, $g, $A);

            Math::GMPz::Rmpz_add($t, $t, $u);
            Math::GMPz::Rmpz_add($g, $g, $u);

            Math::GMPz::Rmpz_addmul($g, $f, $B);

            Math::GMPz::Rmpz_mod($f, $t, $m);
            Math::GMPz::Rmpz_mod($g, $g, $m);
        }

        # (a, b) = (a*a + b*b, a*b + b*(a+b))  mod m

        Math::GMPz::Rmpz_mul($t, $A, $A);
        Math::GMPz::Rmpz_mul($u, $B, $B);

        Math::GMPz::Rmpz_mul($B, $B, $A);
        Math::GMPz::Rmpz_mul_2exp($B, $B, 1);

        Math::GMPz::Rmpz_add($B, $B, $u);
        Math::GMPz::Rmpz_add($t, $t, $u);

        Math::GMPz::Rmpz_mod($A, $t, $m);
        Math::GMPz::Rmpz_mod($B, $B, $m);
    }

    return $f;
}

say "=> Last 20 digits of the 10^100-th Fibonacci number:";
say modular_fibonacci(Math::GMPz->new(10)**100, Math::GMPz->new(10)**20);

say "\n=> First few Fibonacci numbers:";
say join(' ', map { modular_fibonacci($_, 10**9) } 0 .. 25);

say "\n=> Last digit of Fibonacci numbers: ";
say join(' ', map { modular_fibonacci($_, 10) } 0 .. 50);


================================================
FILE: Math/modular_fibonacci_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 June 2017
# https://github.com/trizen

# An efficient algorithm for computing large Fibonacci numbers, modulo some n.

# Algorithm from:
#   https://codeforces.com/blog/entry/14516

use 5.020;
use strict;
use warnings;

use Math::GMPz qw();
use experimental qw(signatures);

sub fibmod($n, $mod, $cache={}) {

    $n <= 1 && return $n;

    sub ($n) {

        $n <= 1 && return do {
            state $one = Math::GMPz::Rmpz_init_set_ui(1)
        };

        if (exists($cache->{$n})) {
            return $cache->{$n};
        }

        my $k = $n >> 1;

        $cache->{$n} = (
                        $n % 2 == 0
                        ? (__SUB__->($k) * __SUB__->($k)     + __SUB__->($k - 1) * __SUB__->($k - 1)) % $mod
                        : (__SUB__->($k) * __SUB__->($k + 1) + __SUB__->($k - 1) * __SUB__->($k)    ) % $mod
                       );
    }->($n - 1);
}

say fibmod(329468, 10**10, {});     # 352786941


================================================
FILE: Math/modular_fibonacci_polynomial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 October 2017
# https://github.com/trizen

# Algorithm for computing a Fibonacci polynomial modulo m.

#   (Sum_{k=1..n} (fibonacci(k) * x^k)) (mod m)

# See also:
#   https://projecteuler.net/problem=435

use 5.020;
use strict;
use warnings;

use experimental qw(signatures lexical_subs);
use ntheory qw(lcm addmod mulmod factor_exp powmod);

sub pisano_period($mod) {

    my sub find_period($mod) {
        my ($x, $y) = (0, 1);

        for (my $n = 1 ; ; ++$n) {
            ($x, $y) = ($y, addmod($x, $y, $mod));

            if ($x == 0 and $y == 1) {
                return $n;
            }
        }
    }

    my @prime_powers  = map { $_->[0]**$_->[1] } factor_exp($mod);
    my @power_periods = map { find_period($_) } @prime_powers;

    return lcm(@power_periods);
}

sub modular_fibonacci_polynomial ($n, $x, $mod) {

    $n %= pisano_period($mod);

    my $sum = 0;

    my ($f1, $f2) = (0, 1);
    foreach my $k (1 .. $n) {
        $sum = addmod($sum, mulmod($f2, powmod($x, $k, $mod), $mod), $mod);
        ($f1, $f2) = ($f2, addmod($f1, $f2, $mod));
    }

    return $sum;
}

say modular_fibonacci_polynomial(7,      11, 100000);        #=> 57683
say modular_fibonacci_polynomial(10**15, 13, 6227020800);    #=> 4631902275


================================================
FILE: Math/modular_fibonacci_polynomial_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 October 2017
# https://github.com/trizen

# Algorithm for computing a Fibonacci polynomial modulo m.

#   (Sum_{k=1..n} (fibonacci(k) * x^k)) (mod m)

# See also:
#   https://projecteuler.net/problem=435

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(addmod mulmod powmod factor_exp chinese);

sub modular_fibonacci_polynomial ($n, $x, $m) {

    my @chinese;
    foreach my $p (factor_exp($m)) {

        my $pp = $p->[0]**$p->[1];

        my $sum = 0;
        my ($f1, $f2) = (0, 1);

        my @array;
        foreach my $k (1 .. $n) {

            $sum = addmod($sum, mulmod($f2, powmod($x, $k, $pp), $pp), $pp);

            push @array, $sum;

            ($f1, $f2) = ($f2, addmod($f1, $f2, $pp));

            if ($f1 == 0 and $f2 == 1 and $k > 20 and
                    join(' ', @array[9              .. $#array/2])
                 eq join(' ', @array[$#array/2 + 10 .. $#array])
            ) {
                $sum = $array[($n % $k) - 1];
                last;
            }
        }

        push @chinese, [$sum, $pp];
    }

    return chinese(@chinese);
}

say modular_fibonacci_polynomial(7,      11, 100000);        #=> 57683
say modular_fibonacci_polynomial(10**15, 13, 6227020800);    #=> 4631902275


================================================
FILE: Math/modular_hyperoperation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 August 2016
# Edit: 20 April 2019
# https://github.com/trizen

# Generalized implementation of Knuth's up-arrow hyperoperation (modulo some m).

# See also:
#   https://en.wikipedia.org/wiki/Knuth%27s_up-arrow_notation

use utf8;
use 5.020;
use strict;
use warnings;

no warnings 'recursion';
use experimental qw(signatures);

binmode(STDOUT, ':utf8');

use Memoize qw(memoize);
use ntheory qw(powmod euler_phi forprimes);

memoize('knuth');
memoize('hyper1');
memoize('hyper2');
memoize('hyper3');
memoize('hyper4');

sub hyper1 ($n, $k, $m) {
    powmod($n, $k, $m);
}

sub hyper2 ($n, $k, $m) {

    return 0 if ($m == 1);
    return 1 if ($k == 0);

    hyper1($n, hyper2($n, $k-1, euler_phi($m)), $m);
}

sub hyper3 ($n, $k, $m) {

    return 0 if ($m == 1);
    return 1 if ($k == 0);

    hyper2($n, hyper3($n, $k-1, euler_phi($m)), $m);
}

sub hyper4 ($n, $k, $m) {

    return 0 if ($m == 1);
    return 1 if ($k == 0);

    hyper3($n, hyper4($n, $k-1, euler_phi($m)), $m);
}

sub knuth ($k, $n, $g, $m) {

    $n >= 1 and $g == 0 and return 1;

    $n == 0 and return (($k * $g) % $m);
    $n == 1 and return hyper1($k, $g, $m);
    $n == 2 and return hyper2($k, $g, $m);
    $n == 3 and return hyper3($k, $g, $m);
    $n == 4 and return hyper4($k, $g, $m);

    knuth($k, $n - 1, knuth($k, $n, $g - 1, $m), $m);
}

my $m = 10**3;

foreach my $i (0 .. 6) {

    my $x = 1 + int(rand(100));
    my $y = 1 + int(rand(100));

    my $n = knuth($x, $i, $y, $m);
    printf("%5s %10s %5s = %5s   (mod %s)\n", $x, '↑' x $i, $y, $n, $m);
}

say "\n=> Finding prime factors of 10↑↑10 + 23:";

forprimes {
    if (((knuth(10, 2, 10, $_) + 23) % $_) == 0) {
        printf("%6s | (10↑↑10 + 23)\n", $_);
    }
} 1e6;

__END__
   47               20 =   940   (mod 1000)
   84          ↑    59 =   664   (mod 1000)
   49         ↑↑    79 =   449   (mod 1000)
   95        ↑↑↑    71 =   375   (mod 1000)
    7       ↑↑↑↑    41 =   343   (mod 1000)
   40      ↑↑↑↑↑     7 =    40   (mod 1000)
   17     ↑↑↑↑↑↑    55 =   777   (mod 1000)

=> Finding prime factors of 10↑↑10 + 23:
     2 | (10↑↑10 + 23)
     3 | (10↑↑10 + 23)
    13 | (10↑↑10 + 23)
   673 | (10↑↑10 + 23)
 18301 | (10↑↑10 + 23)
400109 | (10↑↑10 + 23)


================================================
FILE: Math/modular_inverse.pl
================================================
#!/usr/bin/perl

# Algorithm for computing the modular inverse: 1/k mod n, with gcd(k, n) = 1.

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub divmod ($n, $k) {
    (int($n / $k), $n % $k);
}

sub modular_inverse ($k, $n) {

    my ($u, $w) = (1, 0);
    my ($q, $r) = (0, 0);

    my $c = $n;

    while ($c != 0) {
        ($q, $r) = divmod($k, $c);
        ($k, $c) = ($c, $r);
        ($u, $w) = ($w, $u - $q*$w);
    }

    $u += $n if ($u < 0);

    return $u;
}

say modular_inverse(42, 2017);      #=> 1969


================================================
FILE: Math/modular_k-th_root_all_solutions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 December 2025
# Edit: 10 December 2025
# https://github.com/trizen

# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)

use 5.036;
use Test::More tests => 60;
use Math::Prime::Util qw(:all);

# Solve x^k ≡ r (mod p) for prime p.
sub solve_mod_p($k, $r, $p) {
    die "p must be prime > 1" unless $p > 1 && is_prime($p);
    $r %= $p;

    return (0)                                           if $r == 0;    # trivial zero solution
    return grep { powmod($_, $k, $p) == $r } 0 .. $p - 1 if $p <= 31;

    my $phi = $p - 1;
    my $d   = gcd($k, $phi);
    return () if powmod($r, $phi / $d, $p) != 1;                        # necessary condition

    return ($r) if $k == 1;

    my $g = znprimroot($p) // return grep { powmod($_, $k, $p) == $r } 0 .. $p - 1;
    my $a = znlog($r, $g, $p);
    return () unless defined $a;

    my $k1   = divint($k,   $d);
    my $phi1 = divint($phi, $d);
    my $a1   = divint($a,   $d);
    my $t0   = ($a1 * invmod($k1, $phi1)) % $phi1;

    return map { powmod($g, $t0 + $_ * $phi1, $p) } 0 .. $d - 1;
}

# Solve x^k ≡ r (mod p^e) for prime powers by lifting.
sub solve_prime_power_lift($k, $r, $p, $e) {
    my $mod = powint($p, $e);

    $r %= $mod;

    return () if $mod == 0;

    if ($r % $mod == 0) {    # x^k ≡ 0
        my $vx_min = divint($e + $k - 1, $k);    # ceil(e / k)
        my $base   = powint($p, $vx_min);
        return map { $_ * $base } 0 .. (powint($p, $e - $vx_min) - 1);
    }

    my @sol_t = solve_mod_p($k, $r, $p);         # solutions mod p
    return () unless @sol_t;
    return @sol_t if $e == 1;

    my $t = 1;
    while ($t < $e) {                            # lift to p^{t+1}
        my $next_mod = powint($p, $t + 1);
        my @next;
        for my $a (@sol_t) {
            my $base = powint($p, $t);
            for my $s (0 .. $p - 1) {
                my $cand = ($a + $s * $base) % $next_mod;
                push @next, $cand if powmod($cand, $k, $next_mod) == ($r % $next_mod);
            }
        }
        @sol_t = @next;
        return () unless @sol_t;
        $t++;
    }

    return @sol_t;
}

# All solutions to x^k ≡ r (mod m).
sub kth_root_mod($k, $r, $m) {
    return () if $m == 0;

    if ($k == 0 and $r == 1) {
        return (0 .. $m - 1);
    }

    # Support negative k: solve y^{|k|} ≡ r and invert solutions y -> x = y^{-1}
    if ($k < 0) {

        # r must be a unit modulo m to be a power of a unit
        return () if gcd($r, $m) != 1;
        my @yinv = kth_root_mod(-$k, $r, $m);    # recursive call with positive exponent
        return () unless @yinv;
        my @xs;
        for my $y (@yinv) {
            my $y_mod = $y % $m;
            my $inv   = invmod($y_mod, $m);
            push @xs, $inv if defined $inv;      # should be defined because y is a unit
        }
        return sort { $a <=> $b } @xs;
    }

    my @factors = factor_exp($m);    # [p, e] pairs
    my @current = ([0, 1]);          # [residue, modulus]

    for my $fe (@factors) {
        my ($p, $e) = @$fe;
        my $mod_pe = powint($p, $e);
        my @sol_pe = solve_prime_power_lift($k, $r % $mod_pe, $p, $e);
        return () unless @sol_pe;

        my @next;
        for my $pe (@sol_pe) {
            for my $cur (@current) {
                my ($A, $mod_a) = @$cur;
                push @next, [chinese([$A, $mod_a], [$pe, $mod_pe]), $mod_a * $mod_pe];
            }
        }
        @current = @next;
    }

    return sort { $a <=> $b } map { $_->[0] % $m } @current;
}

is_deeply([kth_root_mod(3, 2, 101)], [26]);
is_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);
is_deeply([kth_root_mod(2, 1, 101)], [1, 100]);
is_deeply([kth_root_mod(5, 4320, 5040)],
          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);
is_deeply(
          [kth_root_mod(6, 4320, 5040)],
          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,
           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,
           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,
           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,
           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,
           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010
          ]
         );
is_deeply(
          [kth_root_mod(124, 2016, 5040)],
          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,
           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,
           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,
           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998
          ]
         );
is_deeply([kth_root_mod(5, 43,  5040)], [1723]);
is_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);
is_deeply(
          [kth_root_mod(383, 32247425005, 64552988163)],
          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,
           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,
           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,
           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,
           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,
           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,
           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,
           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,
           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,
           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,
           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,
           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,
           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,
           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,
           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,
           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,
           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,
           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,
           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,
           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,
           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,
           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,
           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,
           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,
           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,
           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,
           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,
           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,
           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,
           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,
           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,
           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,
           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,
           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,
           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,
           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,
           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,
           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,
           64047351229, 64215896890, 64384442551
          ]
         );

is_deeply(
          [kth_root_mod(3432, 33, 10428581733134514527),],
          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,
           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,
           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,
           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,
           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,
           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,
           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,
           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623
          ]
         );

# Check:
#   p {prime, prime power, square-free composite, non-SF composite}
#   k {prime, prime power, square-free composite, non-SF composite}
my @rootmods = (

    # prime moduli
    [14,    -3, 101,    [17]],
    [13,     6, 107,    [24, 83]],
    [13,    -6, 107,    [49, 58]],
    [64,     6, 101,    [2,  99]],
    [9,     -2, 101,    [34, 67]],
    [2,      3, 3,      [2]],
    [2,      3, 7,      undef],
    [17,    29, 19,     [6]],
    [5,      3, 13,     [7,     8,  11]],
    [53,     3, 151,    [15,    27, 109]],
    [3,      3, 73,     [25,    54, 67]],
    [7,      3, 73,     [13,    29, 31]],
    [49,     3, 73,     [12,    23, 38]],
    [44082,  4, 100003, [2003,  98000]],
    [90594,  6, 100019, [37071, 62948]],
    [6,      5, 31,     [11,    13, 21, 22, 26]],
    [0,      2, 2,      [0]],
    [2,      4, 5,      undef],
    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],

    #[15,3,"1000000000000000000117",[qw/72574612502199260377 361680004182786118804 565745383315014620936/]],
    [1,  0, 13, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],
    [2,  0, 13, undef],
    [0,  5, 0,  undef],
    [0, -1, 3,  undef],

    # composite moduli.
    # Pari will usually give a *wrong* answer for these if using Mod(a,p).
    # The right way with Pari is to use p-adic.
    [4,  2, 10,   [2, 8]],
    [4,  2, 18,   [2, 16]],
    [2,  3, 21,   undef],                                                # Pari says 2
    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26
    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408
    [58787, 3, 100035,
     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,
      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003
     ]
    ],
    [3748, 2, 4992,
     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,
      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838
     ]
    ],
    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],
    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],
    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],
    [2,            3,  4,    undef],
    [3,            2,  4,    undef],
    [3,            4,  19,   undef],
    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],
    [9,            2,  24,   [3, 9, 15, 21]],
    [6,            6,  35,   undef],
    [36,           2,  40,   [6, 14, 26, 34]],
    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],
    [13,           6,  112,  undef],
    [52,           6,  117,  undef],
    [48,           3,  128,  undef],
    [382,          3,  1000, undef],
    [10,           3,  81,   [13, 40,  67]],
    [26,           5,  625,  [81, 206, 331, 456, 581]],
    [51,           5,  625,  [61, 186, 311, 436, 561]],
    ["9833625071", 3,  "10000000071", [qw/3333332807 6666666164 9999999521/]],

    #[2131968,5,10000000000, [...]],   # Far too many
    [198, -1, 519, undef],
);

foreach my $t (@rootmods) {
    say "Testing: kth_root_mod($t->[1], $t->[0], $t->[2])";
    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));
}

# ----- CLI usage -----
if (@ARGV == 3) {
    my ($k, $v, $m) = @ARGV;
    my @sol = kth_root_mod($k, $v, $m);
    if (!@sol) {
        print "No solution: x^$k ≡ $v (mod $m) has no solution.\n";
    }
    else {
        print scalar(@sol),                        " solution(s) mod $m:\n";
        print join(", ", sort { $a <=> $b } @sol), "\n";
    }
    exit 0;
}


================================================
FILE: Math/modular_k-th_root_all_solutions_fast.pl
================================================
#!/usr/bin/perl

# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)

# Based on code from Math::Prime::Util::PP by Dana Jacobsen.

use 5.036;
use ntheory qw(:all);
use Test::More tests => 60;

#----------------------------------------------------------
# Tonelli-Shanks algorithm for k-th roots modulo a prime
#----------------------------------------------------------
sub _tonelli_shanks($a, $k, $p) {
    my ($exp, $q) = (0, $p - 1);
    ($exp++, $q = divint($q, $k)) while $q % $k == 0;

    my $k_exp = divint($p - 1, $q);
    my $root  = powmod($a, invmod($k % $q, $q), $p);
    my $b     = mulmod(powmod($root, $k, $p), invmod($a, $p), $p);

    # Find a generator of the k-th roots of unity
    my ($candidate, $zeta, $gen) = (2, 1, undef);
    until ($zeta != 1) {
        $gen  = powmod($candidate++, $q,                 $p);
        $zeta = powmod($gen,         divint($k_exp, $k), $p);
    }

    # Iteratively refine the root
    while ($k_exp != $k) {
        $k_exp = divint($k_exp, $k);
        ($candidate, $gen) = ($gen, powmod($gen, $k, $p));
        my $test = powmod($b, divint($k_exp, $k), $p);
        while ($test != 1) {
            $root = mulmod($root, $candidate, $p);
            $b    = mulmod($b,    $gen,       $p);
            $test = mulmod($test, $zeta,      $p);
        }
    }

    return ($root, $gen);
}

#----------------------------------------------------------
# Chinese Remainder Theorem:  combine roots from two moduli
#----------------------------------------------------------
sub _crt_combine($roots_a, $mod_a, $roots_b, $mod_b) {
    my $mod = mulint($mod_a, $mod_b);
    my $inv = invmod($mod_a, $mod_b) // die "CRT: undefined inverse";

    my @roots;
    foreach my $ra (@$roots_a) {
        foreach my $rb (@$roots_b) {
            my $diff = mulmod($inv, submod($rb, $ra, $mod_b), $mod_b);
            push @roots, addmod(mulmod($mod_a, $diff, $mod), $ra, $mod);
        }
    }

    return @roots;
}

#----------------------------------------------------------
# All k-th roots of a modulo prime p
#----------------------------------------------------------
sub _roots_mod_prime($a, $k, $p) {
    $a %= $p;
    return ($a) if $p == 2 || $a == 0;

    my $phi = $p - 1;
    my $g   = gcd($k, $phi);

    # Unique root when gcd(k, p-1) = 1
    return (powmod($a, invmod($k % $phi, $phi), $p)) if $g == 1;

    # No roots if a is not a k-th power residue
    return ()     if powmod($a, divint($phi, $g), $p) != 1;
    return (1, 2) if $p == 3;

    # Find one root and generate all others using roots of unity
    my ($root, $gen) = _tonelli_shanks($a, $k, $p);
    die "Failed to find root" if ($gen == 0 || powmod($root, $k, $p) != $a);

    my @roots = ($root);
    for (my $r = mulmod($root, $gen, $p) ; $r != $root && @roots < $k ; $r = mulmod($r, $gen, $p)) {
        push @roots, $r;
    }
    return @roots;
}

#----------------------------------------------------------
# Hensel lifting helpers
#----------------------------------------------------------
sub _hensel_lift_standard($roots, $A, $k, $mod) {
    map {
        my $deriv   = mulmod($k, powmod($_, $k - 1, $mod), $mod);
        my $residue = submod($A, powmod($_, $k, $mod), $mod);
        my $common  = gcd($residue, $deriv);
        addmod($_, divmod(divint($residue, $common), divint($deriv, $common), $mod), $mod);
    } @$roots;
}

sub _hensel_lift_singular($roots, $A, $k, $p, $mod) {
    my $ext_mod = mulint($mod, $p);
    my $submod  = divint($mod, $p);
    my %seen;

    for my $s (@$roots) {
        my $deriv   = mulmod($k, powmod($s, $k - 1, $ext_mod), $ext_mod);
        my $residue = submod($A, powmod($s, $k, $ext_mod), $ext_mod);
        my $common  = gcd($residue, $deriv);
        my $r       = addmod($s, divmod(divint($residue, $common), divint($deriv, $common), $mod), $mod);

        next if powmod($r, $k, $mod) != $A % $mod;
        $seen{mulmod($r, addmod(mulmod($_, $submod, $mod), 1, $mod), $mod)} = 1 for 0 .. $k - 1;
    }
    return keys %seen;
}

#----------------------------------------------------------
# All k-th roots of r modulo prime power p^e
#----------------------------------------------------------
sub _roots_mod_prime_power($r, $k, $p, $e) {
    return _roots_mod_prime($r, $k, $p) if $e == 1;

    my $mod = powint($p, $e);
    my $pk  = powint($p, $k);

    # Special case:  a ≡ 0 (mod p^e)
    if ($r % $mod == 0) {
        my $t   = divint($e - 1, $k) + 1;
        my $pt  = powint($p, $t);
        my $cnt = powint($p, $e - $t);
        return map { mulmod($_, $pt, $mod) } 0 .. $cnt - 1;
    }

    # Special case: a ≡ 0 (mod p^k) but a ≢ 0 (mod p^e)
    if ($r % $pk == 0) {
        my $factor = powint($p, $e - $k + 1);
        my $count  = powint($p, $k - 1);
        my @sub    = _roots_mod_prime_power(divint($r, $pk), $k, $p, $e - $k);
        return map {
            my $base = mulmod($_, $p, $mod);
            map { addmod(mulmod($_, $factor, $mod), $base, $mod) } 0 .. $count - 1;
        } @sub;
    }

    # No roots if p | a but p^k ∤ a
    return () if $r % $p == 0;

    # Hensel lifting from smaller exponent
    my $half = ($p > 2 || $e < 5) ? divint($e + 1, 2) : divint($e + 3, 2);
    my @sub  = _roots_mod_prime_power($r, $k, $p, $half);

    return $k != $p
      ? _hensel_lift_standard(\@sub, $r, $k, $mod)
      : _hensel_lift_singular(\@sub, $r, $k, $p, $mod);
}

#----------------------------------------------------------
# All k-th roots of r modulo n (with factorization)
#----------------------------------------------------------
sub _roots_mod_composite($r, $k, @factors) {
    my ($mod, @roots) = (1);

    for my $factor (@factors) {
        my ($p, $e) = @$factor;
        my @sub = _roots_mod_prime_power($r, $k, $p, $e);
        return () unless @sub;

        my $pe = powint($p, $e);
        @roots = @roots ? _crt_combine(\@roots, $mod, \@sub, $pe) : @sub;
        $mod   = mulint($mod, $pe);
    }
    return @roots;
}

#----------------------------------------------------------
# Main entry point:  all k-th roots of A modulo n
#----------------------------------------------------------
sub kth_root_mod($k, $A, $n) {
    $n = abs($n);
    return () if $n == 0;

    $A %= $n;
    return () if $k <= 0 && $A == 0;

    if ($k < 0) {
        $A = invmod($A, $n) // return ();
        return () if $A <= 0;
        $k = -$k;
    }

    return ($A)                         if $n <= 2 || $k == 1;
    return $A == 1 ? (0 .. $n - 1) : () if $k == 0;

    my @factors = factor_exp($n);
    my @roots   = ($A);

    for my $prime_factor (factor($k)) {
        @roots = map { _roots_mod_composite($_, $prime_factor, @factors) } @roots;
    }

    return sort { $a <=> $b } @roots;
}

is_deeply([kth_root_mod(3, 2, 101)], [26]);
is_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);
is_deeply([kth_root_mod(2, 1, 101)], [1, 100]);
is_deeply([kth_root_mod(5, 4320, 5040)],
          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);
is_deeply(
          [kth_root_mod(6, 4320, 5040)],
          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,
           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,
           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,
           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,
           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,
           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010
          ]
         );
is_deeply(
          [kth_root_mod(124, 2016, 5040)],
          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,
           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,
           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,
           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998
          ]
         );
is_deeply([kth_root_mod(5, 43,  5040)], [1723]);
is_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);
is_deeply(
          [kth_root_mod(383, 32247425005, 64552988163)],
          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,
           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,
           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,
           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,
           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,
           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,
           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,
           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,
           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,
           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,
           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,
           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,
           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,
           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,
           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,
           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,
           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,
           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,
           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,
           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,
           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,
           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,
           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,
           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,
           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,
           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,
           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,
           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,
           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,
           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,
           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,
           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,
           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,
           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,
           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,
           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,
           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,
           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,
           64047351229, 64215896890, 64384442551
          ]
         );

is_deeply(
          [kth_root_mod(3432, 33, 10428581733134514527),],
          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,
           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,
           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,
           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,
           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,
           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,
           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,
           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623
          ]
         );

# Check:
#   p {prime, prime power, square-free composite, non-SF composite}
#   k {prime, prime power, square-free composite, non-SF composite}
my @rootmods = (

    # prime moduli
    [14,    -3, 101,    [17]],
    [13,     6, 107,    [24, 83]],
    [13,    -6, 107,    [49, 58]],
    [64,     6, 101,    [2,  99]],
    [9,     -2, 101,    [34, 67]],
    [2,      3, 3,      [2]],
    [2,      3, 7,      undef],
    [17,    29, 19,     [6]],
    [5,      3, 13,     [7,     8,  11]],
    [53,     3, 151,    [15,    27, 109]],
    [3,      3, 73,     [25,    54, 67]],
    [7,      3, 73,     [13,    29, 31]],
    [49,     3, 73,     [12,    23, 38]],
    [44082,  4, 100003, [2003,  98000]],
    [90594,  6, 100019, [37071, 62948]],
    [6,      5, 31,     [11,    13, 21, 22, 26]],
    [0,      2, 2,      [0]],
    [2,      4, 5,      undef],
    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],

    #[15,3,1000000000000000000117,[qw/72574612502199260377 361680004182786118804 565745383315014620936/]],
    [1,  0, 13, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],
    [2,  0, 13, undef],
    [0,  5, 0,  undef],
    [0, -1, 3,  undef],

    # composite moduli.
    # Pari will usually give a *wrong* answer for these if using Mod(a,p).
    # The right way with Pari is to use p-adic.
    [4,  2, 10,   [2, 8]],
    [4,  2, 18,   [2, 16]],
    [2,  3, 21,   undef],                                                # Pari says 2
    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26
    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408
    [58787, 3, 100035,
     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,
      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003
     ]
    ],
    [3748, 2, 4992,
     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,
      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838
     ]
    ],
    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],
    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],
    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],
    [2,            3,  4,    undef],
    [3,            2,  4,    undef],
    [3,            4,  19,   undef],
    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],
    [9,            2,  24,   [3, 9, 15, 21]],
    [6,            6,  35,   undef],
    [36,           2,  40,   [6, 14, 26, 34]],
    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],
    [13,           6,  112,  undef],
    [52,           6,  117,  undef],
    [48,           3,  128,  undef],
    [382,          3,  1000, undef],
    [10,           3,  81,   [13, 40,  67]],
    [26,           5,  625,  [81, 206, 331, 456, 581]],
    [51,           5,  625,  [61, 186, 311, 436, 561]],
    ["9833625071", 3,  "10000000071", [qw/3333332807 6666666164 9999999521/]],

    #[2131968,5,10000000000, [...]],   # Far too many
    [198, -1, 519, undef],
);

foreach my $t (@rootmods) {
    say "Testing: kth_root_mod($t->[1], $t->[0], $t->[2])";
    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));
}

# ----- CLI usage -----
if (@ARGV == 3) {
    my ($k, $v, $m) = @ARGV;
    my @sol = kth_root_mod($k, $v, $m);
    if (!@sol) {
        print "No solution: x^$k ≡ $v (mod $m) has no solution.\n";
    }
    else {
        print scalar(@sol),                        " solution(s) mod $m:\n";
        print join(", ", sort { $a <=> $b } @sol), "\n";
    }
    exit 0;
}


================================================
FILE: Math/modular_k-th_root_all_solutions_fast_mpz.pl
================================================
#!/usr/bin/perl

# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)

# Based on code from Math::Prime::Util::PP by Dana Jacobsen.

use 5.036;
use ntheory qw(:all);
use Math::GMPz;
use Test::More tests => 61;

#----------------------------------------------------------
# Tonelli-Shanks algorithm for k-th roots modulo a prime
#----------------------------------------------------------
sub _tonelli_shanks {
    my ($a, $k, $p) = @_;

    my $exp = 0;
    my $q   = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_sub_ui($q, $p, 1);

    while (Math::GMPz::Rmpz_divisible_p($q, $k)) {
        $exp++;
        Math::GMPz::Rmpz_divexact($q, $q, $k);
    }

    my $k_exp = Math::GMPz::Rmpz_init();
    my $tmp   = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_sub_ui($tmp, $p, 1);
    Math::GMPz::Rmpz_divexact($k_exp, $tmp, $q);

    my $inv_k   = Math::GMPz::Rmpz_init();
    my $k_mod_q = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mod($k_mod_q, $k, $q);
    Math::GMPz::Rmpz_invert($inv_k, $k_mod_q, $q);

    my $root = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_powm($root, $a, $inv_k, $p);

    my $root_k = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_powm($root_k, $root, $k, $p);

    my $inv_a = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_invert($inv_a, $a, $p);

    my $b = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul($b, $root_k, $inv_a);
    Math::GMPz::Rmpz_mod($b, $b, $p);

    # Find a generator of the k-th roots of unity
    my $candidate   = Math::GMPz::Rmpz_init_set_ui(2);
    my $zeta        = Math::GMPz::Rmpz_init_set_ui(1);
    my $gen         = Math::GMPz::Rmpz_init();
    my $k_exp_div_k = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_divexact($k_exp_div_k, $k_exp, $k);

    while (Math::GMPz::Rmpz_cmp_ui($zeta, 1) == 0) {
        Math::GMPz::Rmpz_powm($gen,  $candidate, $q,           $p);
        Math::GMPz::Rmpz_powm($zeta, $gen,       $k_exp_div_k, $p);
        Math::GMPz::Rmpz_add_ui($candidate, $candidate, 1);
    }

    # Iteratively refine the root
    my $new_gen           = Math::GMPz::Rmpz_init();
    my $k_exp_div_k_inner = Math::GMPz::Rmpz_init();
    my $test              = Math::GMPz::Rmpz_init();

    while (Math::GMPz::Rmpz_cmp($k_exp, $k) != 0) {
        Math::GMPz::Rmpz_divexact($k_exp, $k_exp, $k);

        Math::GMPz::Rmpz_powm($new_gen, $gen, $k, $p);
        Math::GMPz::Rmpz_set($candidate, $gen);
        Math::GMPz::Rmpz_set($gen,       $new_gen);

        Math::GMPz::Rmpz_divexact($k_exp_div_k_inner, $k_exp, $k);
        Math::GMPz::Rmpz_powm($test, $b, $k_exp_div_k_inner, $p);

        while (Math::GMPz::Rmpz_cmp_ui($test, 1) != 0) {
            Math::GMPz::Rmpz_mul($root, $root, $candidate);
            Math::GMPz::Rmpz_mod($root, $root, $p);

            Math::GMPz::Rmpz_mul($b, $b, $gen);
            Math::GMPz::Rmpz_mod($b, $b, $p);

            Math::GMPz::Rmpz_mul($test, $test, $zeta);
            Math::GMPz::Rmpz_mod($test, $test, $p);
        }
    }

    return ($root, $gen);    # return both root and zeta (gen)
}

#----------------------------------------------------------
# Chinese Remainder Theorem:   combine roots from two moduli
#----------------------------------------------------------
sub _crt_combine {
    my ($roots_a, $mod_a, $roots_b, $mod_b) = @_;

    state $mod = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul($mod, $mod_a, $mod_b);

    state $inv = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_invert($inv, $mod_a, $mod_b)
      or die "CRT: undefined inverse";

    my @roots;
    state $diff   = Math::GMPz::Rmpz_init();
    state $result = Math::GMPz::Rmpz_init();

    for my $ra (@$roots_a) {
        for my $rb (@$roots_b) {
            Math::GMPz::Rmpz_sub($diff, $rb, $ra);
            Math::GMPz::Rmpz_mul($diff, $diff, $inv);
            Math::GMPz::Rmpz_mod($diff, $diff, $mod_b);

            Math::GMPz::Rmpz_mul($result, $mod_a, $diff);
            Math::GMPz::Rmpz_add($result, $result, $ra);
            Math::GMPz::Rmpz_mod($result, $result, $mod);

            push @roots, Math::GMPz::Rmpz_init_set($result);
        }
    }

    return \@roots;
}

#----------------------------------------------------------
# All k-th roots of a modulo prime p
#----------------------------------------------------------
sub _roots_mod_prime {
    my ($a, $k, $p) = @_;

    state $a_mod = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mod($a_mod, $a, $p);

    if (Math::GMPz::Rmpz_cmp_ui($p, 2) == 0 || Math::GMPz::Rmpz_cmp_ui($a_mod, 0) == 0) {
        return [Math::GMPz::Rmpz_init_set($a_mod)];
    }

    state $phi = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_sub_ui($phi, $p, 1);

    state $g = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_gcd($g, $k, $phi);

    # Unique root when gcd(k, p-1) = 1
    if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0) {
        my $k_mod_phi = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_mod($k_mod_phi, $k, $phi);
        my $inv = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_invert($inv, $k_mod_phi, $phi);
        my $root = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_powm($root, $a_mod, $inv, $p);
        return [$root];
    }

    # No roots if a is not a k-th power residue
    state $phi_div_g = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_divexact($phi_div_g, $phi, $g);
    state $test = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_powm($test, $a_mod, $phi_div_g, $p);
    return [] if (Math::GMPz::Rmpz_cmp_ui($test, 1) != 0);

    if (Math::GMPz::Rmpz_cmp_ui($p, 3) == 0) {
        return [Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(2)];
    }

    # Find one root and generate all others using roots of unity
    my ($root, $zeta) = _tonelli_shanks($a_mod, $k, $p);

    if (Math::GMPz::Rmpz_cmp_ui($zeta, 0) == 0) {
        die "Failed to find root";
    }
    state $root_k = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_powm($root_k, $root, $k, $p);
    if (Math::GMPz::Rmpz_cmp($root_k, $a_mod) != 0) {
        die "Failed to find root";
    }

    my @roots = (Math::GMPz::Rmpz_init_set($root));
    my $r     = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul($r, $root, $zeta);
    Math::GMPz::Rmpz_mod($r, $r, $p);

    my $k_ui = Math::GMPz::Rmpz_get_ui($k);

    while (Math::GMPz::Rmpz_cmp($r, $root) != 0 && scalar(@roots) < $k_ui) {
        push @roots, Math::GMPz::Rmpz_init_set($r);
        Math::GMPz::Rmpz_mul($r, $r, $zeta);
        Math::GMPz::Rmpz_mod($r, $r, $p);
    }

    return \@roots;
}

#----------------------------------------------------------
# Hensel lifting helpers
#----------------------------------------------------------
sub _hensel_lift_standard {
    my ($roots, $A, $k, $mod) = @_;

    my @result;

    state $k_minus_1 = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_sub_ui($k_minus_1, $k, 1);

    state $s_pow     = Math::GMPz::Rmpz_init();
    state $deriv     = Math::GMPz::Rmpz_init();
    state $s_k       = Math::GMPz::Rmpz_init();
    state $residue   = Math::GMPz::Rmpz_init();
    state $common    = Math::GMPz::Rmpz_init();
    state $res_div   = Math::GMPz::Rmpz_init();
    state $deriv_div = Math::GMPz::Rmpz_init();
    state $inv_deriv = Math::GMPz::Rmpz_init();
    state $quot      = Math::GMPz::Rmpz_init();
    state $new_s     = Math::GMPz::Rmpz_init();

    for my $s (@$roots) {
        Math::GMPz::Rmpz_powm($s_pow, $s, $k_minus_1, $mod);

        Math::GMPz::Rmpz_mul($deriv, $k, $s_pow);
        Math::GMPz::Rmpz_mod($deriv, $deriv, $mod);

        Math::GMPz::Rmpz_powm($s_k, $s, $k, $mod);

        Math::GMPz::Rmpz_sub($residue, $A, $s_k);
        Math::GMPz::Rmpz_mod($residue, $residue, $mod);
        Math::GMPz::Rmpz_gcd($common, $residue, $deriv);

        Math::GMPz::Rmpz_divexact($res_div,   $residue, $common);
        Math::GMPz::Rmpz_divexact($deriv_div, $deriv,   $common);

        Math::GMPz::Rmpz_invert($inv_deriv, $deriv_div, $mod);

        Math::GMPz::Rmpz_mul($quot, $res_div, $inv_deriv);
        Math::GMPz::Rmpz_mod($quot, $quot, $mod);

        Math::GMPz::Rmpz_add($new_s, $s, $quot);
        Math::GMPz::Rmpz_mod($new_s, $new_s, $mod);

        push @result, Math::GMPz::Rmpz_init_set($new_s);
    }
    return \@result;
}

sub _hensel_lift_singular {
    my ($roots, $A, $k, $p, $mod) = @_;

    state $ext_mod = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mul($ext_mod, $mod, $p);

    state $submod_val = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_divexact($submod_val, $mod, $p);

    my %seen;

    state $k_minus_1 = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_sub_ui($k_minus_1, $k, 1);

    state $s_pow     = Math::GMPz::Rmpz_init();
    state $deriv     = Math::GMPz::Rmpz_init();
    state $s_k       = Math::GMPz::Rmpz_init();
    state $residue   = Math::GMPz::Rmpz_init();
    state $common    = Math::GMPz::Rmpz_init();
    state $res_div   = Math::GMPz::Rmpz_init();
    state $deriv_div = Math::GMPz::Rmpz_init();
    state $inv_deriv = Math::GMPz::Rmpz_init();
    state $quot      = Math::GMPz::Rmpz_init();
    state $r         = Math::GMPz::Rmpz_init();
    state $r_k       = Math::GMPz::Rmpz_init();
    state $A_mod     = Math::GMPz::Rmpz_init();
    state $i_val     = Math::GMPz::Rmpz_init();
    state $new_r     = Math::GMPz::Rmpz_init();

    my $k_ui = Math::GMPz::Rmpz_get_ui($k);

    for my $s (@$roots) {
        Math::GMPz::Rmpz_powm($s_pow, $s, $k_minus_1, $ext_mod);

        Math::GMPz::Rmpz_mul($deriv, $k, $s_pow);
        Math::GMPz::Rmpz_mod($deriv, $deriv, $ext_mod);
        Math::GMPz::Rmpz_powm($s_k, $s, $k, $ext_mod);

        Math::GMPz::Rmpz_sub($residue, $A, $s_k);
        Math::GMPz::Rmpz_mod($residue, $residue, $ext_mod);
        Math::GMPz::Rmpz_gcd($common, $residue, $deriv);

        Math::GMPz::Rmpz_divexact($res_div,   $residue, $common);
        Math::GMPz::Rmpz_divexact($deriv_div, $deriv,   $common);

        Math::GMPz::Rmpz_invert($inv_deriv, $deriv_div, $mod);

        Math::GMPz::Rmpz_mul($quot, $res_div, $inv_deriv);
        Math::GMPz::Rmpz_mod($quot, $quot, $mod);

        Math::GMPz::Rmpz_add($r, $s, $quot);
        Math::GMPz::Rmpz_mod($r, $r, $mod);

        Math::GMPz::Rmpz_powm($r_k, $r, $k, $mod);

        Math::GMPz::Rmpz_mod($A_mod, $A, $mod);
        next if (Math::GMPz::Rmpz_cmp($r_k, $A_mod) != 0);

        for my $i (0 .. $k_ui - 1) {
            Math::GMPz::Rmpz_mul_ui($i_val, $submod_val, $i);
            Math::GMPz::Rmpz_mod($i_val, $i_val, $mod);
            Math::GMPz::Rmpz_add_ui($i_val, $i_val, 1);
            Math::GMPz::Rmpz_mod($i_val, $i_val, $mod);

            Math::GMPz::Rmpz_mul($new_r, $r, $i_val);
            Math::GMPz::Rmpz_mod($new_r, $new_r, $mod);

            $seen{Math::GMPz::Rmpz_get_str($new_r, 10)} = Math::GMPz::Rmpz_init_set($new_r);
        }
    }
    return [values %seen];
}

#----------------------------------------------------------
# All k-th roots of r modulo prime power p^e
#----------------------------------------------------------
sub _roots_mod_prime_power {
    my ($r, $k, $p, $e) = @_;

    return _roots_mod_prime($r, $k, $p) if ($e == 1);

    my $mod = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_pow_ui($mod, $p, $e);

    my $k_ui = Math::GMPz::Rmpz_get_ui($k);
    my $pk   = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_pow_ui($pk, $p, $k_ui);

    # Special case:   a ≡ 0 (mod p^e)
    my $r_mod = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mod($r_mod, $r, $mod);
    if (Math::GMPz::Rmpz_cmp_ui($r_mod, 0) == 0) {
        my $t  = int(($e - 1) / $k_ui) + 1;
        my $pt = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_pow_ui($pt, $p, $t);
        my $cnt = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_pow_ui($cnt, $p, $e - $t);
        my $cnt_ui = Math::GMPz::Rmpz_get_ui($cnt);

        my @result;
        my $val = Math::GMPz::Rmpz_init();
        for my $i (0 .. $cnt_ui - 1) {
            Math::GMPz::Rmpz_mul_ui($val, $pt, $i);
            Math::GMPz::Rmpz_mod($val, $val, $mod);
            push @result, Math::GMPz::Rmpz_init_set($val);
        }
        return \@result;
    }

    # Special case:  a ≡ 0 (mod p^k) but a ≢ 0 (mod p^e)
    my $r_mod_pk = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mod($r_mod_pk, $r, $pk);
    if (Math::GMPz::Rmpz_cmp_ui($r_mod_pk, 0) == 0) {

        my $factor = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_pow_ui($factor, $p, ($e - $k_ui) + 1);

        my $count = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_pow_ui($count, $p, $k_ui - 1);

        my $count_ui = Math::GMPz::Rmpz_get_ui($count);
        my $r_div_pk = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_divexact($r_div_pk, $r, $pk);

        my $sub = _roots_mod_prime_power($r_div_pk, $k, $p, $e - $k_ui);

        my @result;
        my $base = Math::GMPz::Rmpz_init();
        my $val  = Math::GMPz::Rmpz_init();

        for my $s (@$sub) {
            Math::GMPz::Rmpz_mul($base, $s, $p);
            Math::GMPz::Rmpz_mod($base, $base, $mod);

            for my $i (0 .. $count_ui - 1) {
                Math::GMPz::Rmpz_mul_ui($val, $factor, $i);
                Math::GMPz::Rmpz_add($val, $val, $base);
                Math::GMPz::Rmpz_mod($val, $val, $mod);
                push @result, Math::GMPz::Rmpz_init_set($val);
            }
        }
        return \@result;
    }

    # No roots if p | a but p^k ∤ a
    my $r_mod_p = Math::GMPz::Rmpz_init();
    Math::GMPz::Rmpz_mod($r_mod_p, $r, $p);
    return [] if (Math::GMPz::Rmpz_cmp_ui($r_mod_p, 0) == 0);

    # Hensel lifting from smaller exponent
    my $half =
      (Math::GMPz::Rmpz_cmp_ui($p, 2) > 0 || $e < 5)
      ? int(($e + 1) / 2)
      : int(($e + 3) / 2);

    my $sub = _roots_mod_prime_power($r, $k, $p, $half);

    if (Math::GMPz::Rmpz_cmp($k, $p) != 0) {
        return _hensel_lift_standard($sub, $r, $k, $mod);
    }
    else {
        return _hensel_lift_singular($sub, $r, $k, $p, $mod);
    }
}

#----------------------------------------------------------
# All k-th roots of r modulo n (with factorization)
#----------------------------------------------------------
sub _roots_mod_composite {
    my ($r, $k, $factors) = @_;

    my $mod   = Math::GMPz::Rmpz_init_set_ui(1);
    my $roots = [];
    my $pe    = Math::GMPz::Rmpz_init();

    for my $factor (@$factors) {
        my ($p, $e) = @$factor;

        my $sub = _roots_mod_prime_power($r, $k, $p, $e);
        return [] if (!@$sub);

        Math::GMPz::Rmpz_pow_ui($pe, $p, $e);

        if (@$roots) {
            $roots = _crt_combine($roots, $mod, $sub, $pe);
        }
        else {
            $roots = $sub;
        }
        Math::GMPz::Rmpz_mul($mod, $mod, $pe);
    }
    return $roots;
}

#----------------------------------------------------------
# Main entry point:   all k-th roots of A modulo n
#----------------------------------------------------------
sub kth_root_mod {
    my ($k, $A, $n) = @_;

    $k = Math::GMPz->new($k);
    $A = Math::GMPz->new($A);
    $n = Math::GMPz->new($n);

    Math::GMPz::Rmpz_abs($n, $n);
    return () if (Math::GMPz::Rmpz_cmp_ui($n, 0) == 0);

    Math::GMPz::Rmpz_mod($A, $A, $n);

    if (Math::GMPz::Rmpz_cmp_ui($k, 0) <= 0 && Math::GMPz::Rmpz_cmp_ui($A, 0) == 0) {
        return ();
    }

    if (Math::GMPz::Rmpz_sgn($k) < 0) {
        my $inv = Math::GMPz::Rmpz_init();
        if (!Math::GMPz::Rmpz_invert($inv, $A, $n)) {
            return ();
        }
        my $g = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_gcd($g, $inv, $n);
        return () if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0);
        Math::GMPz::Rmpz_set($A, $inv);
        Math::GMPz::Rmpz_neg($k, $k);
    }

    if (Math::GMPz::Rmpz_cmp_ui($n, 2) <= 0 || Math::GMPz::Rmpz_cmp_ui($k, 1) == 0) {
        return (Math::GMPz::Rmpz_init_set($A));
    }

    if (Math::GMPz::Rmpz_cmp_ui($k, 0) == 0) {
        if (Math::GMPz::Rmpz_cmp_ui($A, 1) == 0) {
            my $n_ui = Math::GMPz::Rmpz_get_ui($n);
            return (0 .. $n_ui - 1);
        }
        return ();
    }

    my @factors = map { [Math::GMPz->new($_->[0]), $_->[1]] } factor_exp(Math::GMPz::Rmpz_get_str($n, 10));

    my $roots     = [Math::GMPz::Rmpz_init_set($A)];
    my @k_factors = map { Math::GMPz->new($_) } factor(Math::GMPz::Rmpz_get_str($k, 10));

    for my $prime_factor (@k_factors) {
        my @new_roots;
        for my $r (@$roots) {
            my $sub = _roots_mod_composite($r, $prime_factor, \@factors);
            push @new_roots, @$sub;
        }
        $roots = \@new_roots;
    }

    return sort { Math::GMPz::Rmpz_cmp($a, $b) } @$roots;
}

is_deeply([kth_root_mod(3, 2, 101)], [26]);
is_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);
is_deeply([kth_root_mod(2, 1, 101)], [1, 100]);
is_deeply([kth_root_mod(5, 4320, 5040)],
          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);
is_deeply(
          [kth_root_mod(6, 4320, 5040)],
          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,
           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,
           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,
           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,
           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,
           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010
          ]
         );
is_deeply(
          [kth_root_mod(124, 2016, 5040)],
          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,
           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,
           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,
           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998
          ]
         );
is_deeply([kth_root_mod(5, 43,  5040)], [1723]);
is_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);
is_deeply(
          [kth_root_mod(383, 32247425005, 64552988163)],
          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,
           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,
           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,
           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,
           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,
           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,
           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,
           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,
           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,
           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,
           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,
           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,
           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,
           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,
           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,
           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,
           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,
           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,
           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,
           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,
           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,
           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,
           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,
           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,
           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,
           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,
           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,
           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,
           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,
           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,
           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,
           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,
           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,
           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,
           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,
           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,
           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,
           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,
           64047351229, 64215896890, 64384442551
          ]
         );

is_deeply(
          [kth_root_mod(3432, 33, 10428581733134514527),],
          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,
           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,
           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,
           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,
           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,
           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,
           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,
           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623
          ]
         );

# Check:
#   p {prime, prime power, square-free composite, non-SF composite}
#   k {prime, prime power, square-free composite, non-SF composite}
my @rootmods = (

    # prime moduli
    [14,    -3, 101,    [17]],
    [13,     6, 107,    [24, 83]],
    [13,    -6, 107,    [49, 58]],
    [64,     6, 101,    [2,  99]],
    [9,     -2, 101,    [34, 67]],
    [2,      3, 3,      [2]],
    [2,      3, 7,      undef],
    [17,    29, 19,     [6]],
    [5,      3, 13,     [7,     8,  11]],
    [53,     3, 151,    [15,    27, 109]],
    [3,      3, 73,     [25,    54, 67]],
    [7,      3, 73,     [13,    29, 31]],
    [49,     3, 73,     [12,    23, 38]],
    [44082,  4, 100003, [2003,  98000]],
    [90594,  6, 100019, [37071, 62948]],
    [6,      5, 31,     [11,    13, 21, 22, 26]],
    [0,      2, 2,      [0]],
    [2,      4, 5,      undef],
    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],

    [15,  3, Math::GMPz->new("1000000000000000000117"), [qw/72574612502199260377 361680004182786118804 565745383315014620936/]],
    [1,   0, 13,                                        [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],
    [2,   0, 13,                                        undef],
    [0,   5, 0,                                         undef],
    [0,  -1, 3,                                         undef],

    # composite moduli.
    # Pari will usually give a *wrong* answer for these if using Mod(a,p).
    # The right way with Pari is to use p-adic.
    [4,  2, 10,   [2, 8]],
    [4,  2, 18,   [2, 16]],
    [2,  3, 21,   undef],                                                # Pari says 2
    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26
    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408
    [58787, 3, 100035,
     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,
      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003
     ]
    ],
    [3748, 2, 4992,
     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,
      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838
     ]
    ],
    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],
    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],
    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],
    [2,            3,  4,    undef],
    [3,            2,  4,    undef],
    [3,            4,  19,   undef],
    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],
    [9,            2,  24,   [3, 9, 15, 21]],
    [6,            6,  35,   undef],
    [36,           2,  40,   [6, 14, 26, 34]],
    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],
    [13,           6,  112,  undef],
    [52,           6,  117,  undef],
    [48,           3,  128,  undef],
    [382,          3,  1000, undef],
    [10,           3,  81,   [13, 40,  67]],
    [26,           5,  625,  [81, 206, 331, 456, 581]],
    [51,           5,  625,  [61, 186, 311, 436, 561]],
    ["9833625071", 3,  "10000000071", [qw/3333332807 6666666164 9999999521/]],

    #[2131968,5,10000000000, [...]],   # Far too many
    [198, -1, 519, undef],
);

foreach my $t (@rootmods) {
    say "Testing: kth_root_mod($t->[1], $t->[0], $t->[2])";
    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));
}

# ----- CLI usage -----
if (@ARGV == 3) {
    my ($k, $v, $m) = @ARGV;
    my @sol = kth_root_mod($k, $v, $m);
    if (!@sol) {
        print "No solution: x^$k ≡ $v (mod $m) has no solution.\n";
    }
    else {
        print scalar(@sol),                        " solution(s) mod $m:\n";
        print join(", ", sort { $a <=> $b } @sol), "\n";
    }
    exit 0;
}


================================================
FILE: Math/modular_k-th_root_all_solutions_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 December 2025
# https://github.com/trizen

# kth_root_mod: find all x (0 <= x < m) with x^k ≡ a (mod m)

use 5.036;
use Test::More tests => 60;
use Math::GMPz qw(:mpz);
use ntheory    qw(:all);

# Small helper: brute-force search for solutions mod p (p is small)
sub _bruteforce_mod_p ($k, $r, $p) {
    my $k_mpz = Math::GMPz->new($k);
    my $r_mpz = Math::GMPz->new($r);
    my $p_mpz = Math::GMPz->new($p);
    my $pow   = Math::GMPz->new;
    return map { Math::GMPz->new($_) } grep {
        Rmpz_powm($pow, Math::GMPz->new($_), $k_mpz, $p_mpz);
        $pow == $r_mpz;
    } 0 .. ($p - 1);
}

# Solve x^k ≡ r (mod p) for prime p.
sub solve_mod_p ($k_in, $r_in, $p_in) {
    my $p    = Math::GMPz->new($p_in);
    my $p_ui = $p + 0;
    die "p must be prime > 1" unless $p_ui > 1 && is_prime($p_ui);

    my $k_mpz = Math::GMPz->new($k_in);
    my $r     = Math::GMPz->new($r_in);
    Rmpz_mod($r, $r, $p);

    return (Math::GMPz->new(0))                if $r == 0;       # trivial zero solution
    return _bruteforce_mod_p($k_in, $r, $p_ui) if $p_ui <= 31;

    my $phi = Math::GMPz->new($p);
    Rmpz_sub_ui($phi, $phi, 1);

    my $d = Math::GMPz->new;
    Rmpz_gcd($d, $k_mpz, $phi);

    my $phi_over_d = Math::GMPz->new;
    Rmpz_fdiv_q($phi_over_d, $phi, $d);

    my $r_check = Math::GMPz->new;
    Rmpz_powm($r_check, $r, $phi_over_d, $p);
    return () if $r_check != 1;    # necessary condition

    return ($r) if $k_in == 1;

    my $g = znprimroot($p_ui) // return _bruteforce_mod_p($k_in, $r, $p_ui);
    my $a = znlog($r, $g, $p_ui);
    return () unless defined $a;

    my $k1   = Math::GMPz->new;
    my $phi1 = Math::GMPz->new;
    my $a1   = Math::GMPz->new;
    Rmpz_fdiv_q($k1,   $k_mpz, $d);
    Rmpz_fdiv_q($phi1, $phi,   $d);
    Rmpz_fdiv_q_ui($a1, Math::GMPz->new($a), $d);

    my $inv_k1 = Math::GMPz->new;
    return () unless Rmpz_invert($inv_k1, $k1, $phi1);

    my $t0 = Math::GMPz->new;
    Rmpz_mul($t0, $a1, $inv_k1);
    Rmpz_mod($t0, $t0, $phi1);

    my $g_mpz   = Math::GMPz->new($g);
    my $res     = Math::GMPz->new;
    my $tmp_exp = Math::GMPz->new;
    my $mul     = Math::GMPz->new;

    my $d_ui = $d + 0;
    return map {
        Rmpz_set($tmp_exp, $t0);
        Rmpz_mul_ui($mul, $phi1, $_);
        Rmpz_add($tmp_exp, $tmp_exp, $mul);
        Rmpz_powm($res, $g_mpz, $tmp_exp, $p);
        Math::GMPz->new($res);
    } 0 .. $d_ui - 1;
}

# Solve x^k ≡ r (mod p^e) for prime powers by lifting.
sub solve_prime_power_lift ($k_in, $r_in, $p_in, $e) {
    my $p     = Math::GMPz->new($p_in);
    my $k_mpz = Math::GMPz->new($k_in);
    my $r     = Math::GMPz->new($r_in);

    my $mod = Math::GMPz->new;
    Rmpz_pow_ui($mod, $p, $e);
    Rmpz_mod($r, $r, $mod);
    return () if $mod == 0;

    if ($r % $mod == 0) {    # x^k ≡ 0
        my $vx_min = Math::GMPz->new;
        Rmpz_add_ui($vx_min, Math::GMPz->new($e), $k_in - 1);
        Rmpz_fdiv_q_ui($vx_min, $vx_min, $k_in);    # ceil(e/k)

        my $base  = Math::GMPz->new;
        my $limit = Math::GMPz->new;
        Rmpz_pow_ui($base,  $p, "$vx_min");
        Rmpz_pow_ui($limit, $p, $e - "$vx_min");
        my $lim_i = $limit + 0;

        return map {
            my $t = Math::GMPz->new($base);
            Rmpz_mul_ui($t, $t, $_);
            $t;
        } 0 .. $lim_i - 1;
    }

    my @sol = solve_mod_p($k_in, $r, $p);
    return () unless @sol;
    return @sol if $e == 1;

    my $p_ui     = $p + 0;
    my $t        = 1;
    my $next_mod = Math::GMPz->new;
    my $base     = Math::GMPz->new;
    my $cand     = Math::GMPz->new;
    my $check    = Math::GMPz->new;
    my $r_next   = Math::GMPz->new;

    while ($t < $e) {    # lift to p^{t+1}
        Rmpz_pow_ui($next_mod, $p, $t + 1);
        my @next;

        for my $a (@sol) {
            Rmpz_pow_ui($base, $p, $t);
            for my $s (0 .. $p_ui - 1) {
                Rmpz_set($cand, $base);
                Rmpz_mul_ui($cand, $cand, $s);
                Rmpz_add($cand, $cand, $a);
                Rmpz_mod($cand, $cand, $next_mod);

                Rmpz_powm($check, $cand, $k_mpz, $next_mod);
                Rmpz_set($r_next, $r);
                Rmpz_mod($r_next, $r_next, $next_mod);

                push @next, Math::GMPz->new($cand) if $check == $r_next;
            }
        }
        @sol = @next;
        return () unless @sol;
        ++$t;
    }
    return @sol;
}

# All solutions to x^k ≡ r (mod m).
sub kth_root_mod ($k_in, $r_in, $m_in) {
    my $m     = Math::GMPz->new($m_in);
    my $r     = Math::GMPz->new($r_in);
    my $k_mpz = Math::GMPz->new($k_in);
    return () if $m == 0;

    if ($k_in == 0 && $r == 1) {    # any x satisfies x^0 = 1
        my $m_i = $m + 0;
        return map { Math::GMPz->new($_) } 0 .. $m_i - 1;
    }

    # Negative k: solve y^{|k|} ≡ r, then invert y -> x = y^{-1} mod m
    if ($k_in < 0) {
        my $g = Math::GMPz->new;
        Rmpz_gcd($g, $r, $m);
        return () if $g != 1;    # r must be a unit modulo m

        my @y = kth_root_mod(-$k_in, $r, $m);
        return () unless @y;

        my $y_mod = Math::GMPz->new;
        my $inv   = Math::GMPz->new;
        my @xs;
        for my $yy (@y) {
            Rmpz_set($y_mod, $yy);
            Rmpz_mod($y_mod, $y_mod, $m);
            push @xs, Math::GMPz->new($inv) if Rmpz_invert($inv, $y_mod, $m);
        }
        return sort { $a <=> $b } @xs;
    }

    my @factors = factor_exp("$m");                              # [p, e] pairs
    my @current = ([Math::GMPz->new(0), Math::GMPz->new(1)]);    # [residue, modulus]

    my $mod_pe = Math::GMPz->new;
    my $r_pe   = Math::GMPz->new;

    for my $fe (@factors) {
        my ($p_scalar, $e) = @$fe;
        my $p = Math::GMPz->new($p_scalar);

        Rmpz_pow_ui($mod_pe, $p, $e);
        Rmpz_set($r_pe, $r);
        Rmpz_mod($r_pe, $r_pe, $mod_pe);

        my @sol_pe = solve_prime_power_lift($k_in, $r_pe, $p, $e);
        return () unless @sol_pe;

        my @next;
        for my $pe (@sol_pe) {
            for my $cur (@current) {
                my ($A, $mod_a) = @$cur;
                my $combined = chinese(["$A", "$mod_a"], ["$pe", "$mod_pe"]);
                push @next, [Math::GMPz->new($combined), Math::GMPz->new($mod_a) * $mod_pe];
            }
        }
        @current = @next;
    }

    return sort { $a <=> $b } map {
        my $tmp = Math::GMPz->new($_->[0]);
        Rmpz_mod($tmp, $tmp, $m);
        $tmp;
    } @current;
}

is_deeply([kth_root_mod(3, 2, 101)], [26]);
is_deeply([kth_root_mod(2, 0, 16)],  [0, 4, 8, 12]);
is_deeply([kth_root_mod(2, 1, 101)], [1, 100]);
is_deeply([kth_root_mod(5, 4320, 5040)],
          [120, 330, 540, 750, 960, 1170, 1380, 1590, 1800, 2010, 2220, 2430, 2640, 2850, 3060, 3270, 3480, 3690, 3900, 4110, 4320, 4530, 4740, 4950]);
is_deeply(
          [kth_root_mod(6, 4320, 5040)],
          [30,   60,   90,   120,  150,  180,  240,  270,  300,  330,  360,  390,  450,  480,  510,  540,  570,  600,  660,  690,  720,  750,  780,  810,
           870,  900,  930,  960,  990,  1020, 1080, 1110, 1140, 1170, 1200, 1230, 1290, 1320, 1350, 1380, 1410, 1440, 1500, 1530, 1560, 1590, 1620, 1650,
           1710, 1740, 1770, 1800, 1830, 1860, 1920, 1950, 1980, 2010, 2040, 2070, 2130, 2160, 2190, 2220, 2250, 2280, 2340, 2370, 2400, 2430, 2460, 2490,
           2550, 2580, 2610, 2640, 2670, 2700, 2760, 2790, 2820, 2850, 2880, 2910, 2970, 3000, 3030, 3060, 3090, 3120, 3180, 3210, 3240, 3270, 3300, 3330,
           3390, 3420, 3450, 3480, 3510, 3540, 3600, 3630, 3660, 3690, 3720, 3750, 3810, 3840, 3870, 3900, 3930, 3960, 4020, 4050, 4080, 4110, 4140, 4170,
           4230, 4260, 4290, 4320, 4350, 4380, 4440, 4470, 4500, 4530, 4560, 4590, 4650, 4680, 4710, 4740, 4770, 4800, 4860, 4890, 4920, 4950, 4980, 5010
          ]
         );
is_deeply(
          [kth_root_mod(124, 2016, 5040)],
          [42,   84,   126,  168,  252,  294,  336,  378,  462,  504,  546,  588,  672,  714,  756,  798,  882,  924,  966,  1008, 1092, 1134, 1176, 1218,
           1302, 1344, 1386, 1428, 1512, 1554, 1596, 1638, 1722, 1764, 1806, 1848, 1932, 1974, 2016, 2058, 2142, 2184, 2226, 2268, 2352, 2394, 2436, 2478,
           2562, 2604, 2646, 2688, 2772, 2814, 2856, 2898, 2982, 3024, 3066, 3108, 3192, 3234, 3276, 3318, 3402, 3444, 3486, 3528, 3612, 3654, 3696, 3738,
           3822, 3864, 3906, 3948, 4032, 4074, 4116, 4158, 4242, 4284, 4326, 4368, 4452, 4494, 4536, 4578, 4662, 4704, 4746, 4788, 4872, 4914, 4956, 4998
          ]
         );
is_deeply([kth_root_mod(5, 43,  5040)], [1723]);
is_deeply([kth_root_mod(5, 243, 1000)], [3, 203, 403, 603, 803]);
is_deeply(
          [kth_root_mod(383, 32247425005, 64552988163)],
          [49,          168545710,   337091371,   505637032,   674182693,   842728354,   1011274015,  1179819676,  1348365337,  1516910998,
           1685456659,  1854002320,  2022547981,  2191093642,  2359639303,  2528184964,  2696730625,  2865276286,  3033821947,  3202367608,
           3370913269,  3539458930,  3708004591,  3876550252,  4045095913,  4213641574,  4382187235,  4550732896,  4719278557,  4887824218,
           5056369879,  5224915540,  5393461201,  5562006862,  5730552523,  5899098184,  6067643845,  6236189506,  6404735167,  6573280828,
           6741826489,  6910372150,  7078917811,  7247463472,  7416009133,  7584554794,  7753100455,  7921646116,  8090191777,  8258737438,
           8427283099,  8595828760,  8764374421,  8932920082,  9101465743,  9270011404,  9438557065,  9607102726,  9775648387,  9944194048,
           10112739709, 10281285370, 10449831031, 10618376692, 10786922353, 10955468014, 11124013675, 11292559336, 11461104997, 11629650658,
           11798196319, 11966741980, 12135287641, 12303833302, 12472378963, 12640924624, 12809470285, 12978015946, 13146561607, 13315107268,
           13483652929, 13652198590, 13820744251, 13989289912, 14157835573, 14326381234, 14494926895, 14663472556, 14832018217, 15000563878,
           15169109539, 15337655200, 15506200861, 15674746522, 15843292183, 16011837844, 16180383505, 16348929166, 16517474827, 16686020488,
           16854566149, 17023111810, 17191657471, 17360203132, 17528748793, 17697294454, 17865840115, 18034385776, 18202931437, 18371477098,
           18540022759, 18708568420, 18877114081, 19045659742, 19214205403, 19382751064, 19551296725, 19719842386, 19888388047, 20056933708,
           20225479369, 20394025030, 20562570691, 20731116352, 20899662013, 21068207674, 21236753335, 21405298996, 21573844657, 21742390318,
           21910935979, 22079481640, 22248027301, 22416572962, 22585118623, 22753664284, 22922209945, 23090755606, 23259301267, 23427846928,
           23596392589, 23764938250, 23933483911, 24102029572, 24270575233, 24439120894, 24607666555, 24776212216, 24944757877, 25113303538,
           25281849199, 25450394860, 25618940521, 25787486182, 25956031843, 26124577504, 26293123165, 26461668826, 26630214487, 26798760148,
           26967305809, 27135851470, 27304397131, 27472942792, 27641488453, 27810034114, 27978579775, 28147125436, 28315671097, 28484216758,
           28652762419, 28821308080, 28989853741, 29158399402, 29326945063, 29495490724, 29664036385, 29832582046, 30001127707, 30169673368,
           30338219029, 30506764690, 30675310351, 30843856012, 31012401673, 31180947334, 31349492995, 31518038656, 31686584317, 31855129978,
           32023675639, 32192221300, 32360766961, 32529312622, 32697858283, 32866403944, 33034949605, 33203495266, 33372040927, 33540586588,
           33709132249, 33877677910, 34046223571, 34214769232, 34383314893, 34551860554, 34720406215, 34888951876, 35057497537, 35226043198,
           35394588859, 35563134520, 35731680181, 35900225842, 36068771503, 36237317164, 36405862825, 36574408486, 36742954147, 36911499808,
           37080045469, 37248591130, 37417136791, 37585682452, 37754228113, 37922773774, 38091319435, 38259865096, 38428410757, 38596956418,
           38765502079, 38934047740, 39102593401, 39271139062, 39439684723, 39608230384, 39776776045, 39945321706, 40113867367, 40282413028,
           40450958689, 40619504350, 40788050011, 40956595672, 41125141333, 41293686994, 41462232655, 41630778316, 41799323977, 41967869638,
           42136415299, 42304960960, 42473506621, 42642052282, 42810597943, 42979143604, 43147689265, 43316234926, 43484780587, 43653326248,
           43821871909, 43990417570, 44158963231, 44327508892, 44496054553, 44664600214, 44833145875, 45001691536, 45170237197, 45338782858,
           45507328519, 45675874180, 45844419841, 46012965502, 46181511163, 46350056824, 46518602485, 46687148146, 46855693807, 47024239468,
           47192785129, 47361330790, 47529876451, 47698422112, 47866967773, 48035513434, 48204059095, 48372604756, 48541150417, 48709696078,
           48878241739, 49046787400, 49215333061, 49383878722, 49552424383, 49720970044, 49889515705, 50058061366, 50226607027, 50395152688,
           50563698349, 50732244010, 50900789671, 51069335332, 51237880993, 51406426654, 51574972315, 51743517976, 51912063637, 52080609298,
           52249154959, 52417700620, 52586246281, 52754791942, 52923337603, 53091883264, 53260428925, 53428974586, 53597520247, 53766065908,
           53934611569, 54103157230, 54271702891, 54440248552, 54608794213, 54777339874, 54945885535, 55114431196, 55282976857, 55451522518,
           55620068179, 55788613840, 55957159501, 56125705162, 56294250823, 56462796484, 56631342145, 56799887806, 56968433467, 57136979128,
           57305524789, 57474070450, 57642616111, 57811161772, 57979707433, 58148253094, 58316798755, 58485344416, 58653890077, 58822435738,
           58990981399, 59159527060, 59328072721, 59496618382, 59665164043, 59833709704, 60002255365, 60170801026, 60339346687, 60507892348,
           60676438009, 60844983670, 61013529331, 61182074992, 61350620653, 61519166314, 61687711975, 61856257636, 62024803297, 62193348958,
           62361894619, 62530440280, 62698985941, 62867531602, 63036077263, 63204622924, 63373168585, 63541714246, 63710259907, 63878805568,
           64047351229, 64215896890, 64384442551
          ]
         );

is_deeply(
          [kth_root_mod(3432, 33, 10428581733134514527),],
          [234538669356049904,  265172539733867379,  338494374696194946,  468144956219368759,   587920784072174975,   866212217277838851,
           1191587698502237300, 1469879131707901176, 2012837926243083376, 2116793631583228418,  2246444213106402231,  2616504840673145701,
           2819477257158647081, 2850111127536464556, 2969886955389270772, 3248178388594934648,  3672570580964689435,  3950862014170353311,
           4095753547647065419, 4374044980852729295, 4597776514045680553, 4699420462077127744,  4977711895282791620,  5201443428475742878,
           5227138304658771649, 5450869837851722907, 5729161271057386783, 5830805219088833974,  6054536752281785232,  6332828185487449108,
           6477719718964161216, 6756011152169825092, 7180403344539579879, 7458694777745243755,  7578470605598049971,  7609104475975867446,
           7812076892461368826, 8182137520028112296, 8311788101551286109, 8415743806891431151,  8958702601426613351,  9236994034632277227,
           9562369515856675676, 9840660949062339552, 9960436776915145768, 10090087358438319581, 10163409193400647148, 10194043063778464623
          ]
         );

# Check:
#   p {prime, prime power, square-free composite, non-SF composite}
#   k {prime, prime power, square-free composite, non-SF composite}
my @rootmods = (

    # prime moduli
    [14,    -3, 101,    [17]],
    [13,     6, 107,    [24, 83]],
    [13,    -6, 107,    [49, 58]],
    [64,     6, 101,    [2,  99]],
    [9,     -2, 101,    [34, 67]],
    [2,      3, 3,      [2]],
    [2,      3, 7,      undef],
    [17,    29, 19,     [6]],
    [5,      3, 13,     [7,     8,  11]],
    [53,     3, 151,    [15,    27, 109]],
    [3,      3, 73,     [25,    54, 67]],
    [7,      3, 73,     [13,    29, 31]],
    [49,     3, 73,     [12,    23, 38]],
    [44082,  4, 100003, [2003,  98000]],
    [90594,  6, 100019, [37071, 62948]],
    [6,      5, 31,     [11,    13, 21, 22, 26]],
    [0,      2, 2,      [0]],
    [2,      4, 5,      undef],
    [51,    12, 10009,  [64, 1203, 3183, 3247, 3999, 4807, 5202, 6010, 6762, 6826, 8806, 9945]],

    #[15,3,"1000000000000000000117",[qw/72574612502199260377 361680004182786118804 565745383315014620936/]],
    [1,  0, 13, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]],
    [2,  0, 13, undef],
    [0,  5, 0,  undef],
    [0, -1, 3,  undef],

    # composite moduli.
    # Pari will usually give a *wrong* answer for these if using Mod(a,p).
    # The right way with Pari is to use p-adic.
    [4,  2, 10,   [2, 8]],
    [4,  2, 18,   [2, 16]],
    [2,  3, 21,   undef],                                                # Pari says 2
    [8,  3, 27,   [2,   11,  20]],                                       # Pari says 26
    [22, 3, 1505, [148, 578, 673, 793, 813, 1103, 1243, 1318, 1458]],    # Pari says 1408
    [58787, 3, 100035,
     [3773,  8633,  10793, 13763, 19163, 24293, 26183, 26588, 31313, 37118, 41978, 44138, 47108, 52508,
      57638, 59528, 59933, 64658, 70463, 75323, 77483, 80453, 85853, 90983, 92873, 93278, 98003
     ]
    ],
    [3748, 2, 4992,
     [154,  262,  314,  518,  730,  934,  986,  1094, 1402, 1510, 1562, 1766, 1978, 2182, 2234, 2342,
      2650, 2758, 2810, 3014, 3226, 3430, 3482, 3590, 3898, 4006, 4058, 4262, 4474, 4678, 4730, 4838
     ]
    ],
    [68,           2,  2048, [46,  466, 558, 978,  1070, 1490, 1582, 2002]],
    [96,           5,  128,  [6,   14,  22,  30,   38,   46,   54,   62,   70,   78,   86,   94,   102,  110,  118,  126]],
    [2912,         5,  4992, [182, 494, 806, 1118, 1430, 1742, 2054, 2366, 2678, 2990, 3302, 3614, 3926, 4238, 4550, 4862]],
    [2,            3,  4,    undef],
    [3,            2,  4,    undef],
    [3,            4,  19,   undef],
    [1,            4,  20,   [1, 3, 7,  9, 11, 13, 17, 19]],
    [9,            2,  24,   [3, 9, 15, 21]],
    [6,            6,  35,   undef],
    [36,           2,  40,   [6, 14, 26, 34]],
    [16,           12, 48,   [2, 4,  8,  10, 14, 16, 20, 22, 26, 28, 32, 34, 38, 40, 44, 46]],
    [13,           6,  112,  undef],
    [52,           6,  117,  undef],
    [48,           3,  128,  undef],
    [382,          3,  1000, undef],
    [10,           3,  81,   [13, 40,  67]],
    [26,           5,  625,  [81, 206, 331, 456, 581]],
    [51,           5,  625,  [61, 186, 311, 436, 561]],
    ["9833625071", 3,  "10000000071", [qw/3333332807 6666666164 9999999521/]],

    #[2131968,5,10000000000, [...]],   # Far too many
    [198, -1, 519, undef],
);

foreach my $t (@rootmods) {
    say "Testing: kth_root_mod($t->[1], $t->[0], $t->[2])";
    is_deeply([kth_root_mod($t->[1], $t->[0], $t->[2])], (defined($t->[3]) ? $t->[3] : []));
}

# ----- CLI usage -----
if (@ARGV == 3) {
    my ($k, $v, $m) = @ARGV;
    my @sol = kth_root_mod($k, $v, $m);
    if (!@sol) {
        print "No solution: x^$k ≡ $v (mod $m) has no solution.\n";
    }
    else {
        print scalar(@sol),                        " solution(s) mod $m:\n";
        print join(", ", sort { $a <=> $b } @sol), "\n";
    }
    exit 0;
}


================================================
FILE: Math/modular_lucas_numbers.pl
================================================
#!/usr/bin/perl

# Efficient algorithm for computing the nth-Lucas number (mod m).

# Algorithm from:
#   https://metacpan.org/source/KRYDE/Math-NumSeq-72/lib/Math/NumSeq/LucasNumbers.pm

# See also:
#   https://en.wikipedia.org/wiki/Lucas_number

use 5.020;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use Math::Prime::Util::GMP qw(gcd consecutive_integer_lcm);

sub lucasmod ($n, $m) {

    $n = Math::GMPz->new("$n");
    $m = Math::GMPz->new("$m");

    my ($f, $g, $w) = (
        Math::GMPz::Rmpz_init_set_ui(3),
        Math::GMPz::Rmpz_init_set_ui(1),
    );

    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($n, 2), 1))) {

        Math::GMPz::Rmpz_powm_ui($g, $g, 2, $m);
        Math::GMPz::Rmpz_powm_ui($f, $f, 2, $m);

        $w
          ? do {
            Math::GMPz::Rmpz_sub_ui($g, $g, 2);
            Math::GMPz::Rmpz_add_ui($f, $f, 2);
          }
          : do {
            Math::GMPz::Rmpz_add_ui($g, $g, 2);
            Math::GMPz::Rmpz_sub_ui($f, $f, 2);
          };

        if ($bit) {
            Math::GMPz::Rmpz_sub($g, $f, $g);
            $w = 0;
        }
        else {
            Math::GMPz::Rmpz_sub($f, $f, $g);
            $w = 1;
        }
    }

    Math::GMPz::Rmpz_mod($g, $g, $m);

    return $g;
}

sub lucas_factorization ($n, $B = 10000) {

    my $k = consecutive_integer_lcm($B);    # lcm(1..B)
    my $L = lucasmod($k, $n);               # Lucas(k) (mod n)

    return gcd($L - 2, $n);
}

say lucas_factorization("121095274043",             700);     #=> 470783           (p+1 is  700-smooth)
say lucas_factorization("544812320889004864776853", 3000);    #=> 333732865481     (p-1 is 3000-smooth)


================================================
FILE: Math/modular_lucas_sequence_V.pl
================================================
#!/usr/bin/perl

# Efficient algorithm due to Aleksey Koval for computing the Lucas V sequence (mod m).

# See also:
#   https://en.wikipedia.org/wiki/Lucas_sequence

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;

sub lucas_V_mod ($P, $Q, $n, $m) {

    $n = Math::GMPz->new("$n");
    $P = Math::GMPz->new("$P");
    $Q = Math::GMPz->new("$Q");
    $m = Math::GMPz->new("$m");

    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));
    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $bit (split(//, Math::GMPz::Rmpz_get_str($n, 2))) {

        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);

        if ($bit) {
            Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);
            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);
            Math::GMPz::Rmpz_submul($V1, $P, $Q1);
            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);
            Math::GMPz::Rmpz_mod($V1, $V1, $m);
        }
        else {
            Math::GMPz::Rmpz_set($Q2, $Q1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
            Math::GMPz::Rmpz_submul($V2, $P, $Q1);
            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);
            Math::GMPz::Rmpz_mod($V2, $V2, $m);
        }
    }

    Math::GMPz::Rmpz_mod($V1, $V1, $m);

    return $V1;
}

say lucas_V_mod( 1, -1, 123456, 12345);    #=> 4487
say lucas_V_mod(-3,  4, 987654, 12345);    #=> 3928
say lucas_V_mod(-5, -7, 314159, 12345);    #=> 4565


================================================
FILE: Math/modular_lucas_sequences_U_V.pl
================================================
#!/usr/bin/perl

# Algorithm due to M. Joye and J.-J. Quisquater for efficiently computing the Lucas U and V sequences (mod m).

# See also:
#   https://en.wikipedia.org/wiki/Lucas_sequence

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;

sub lucas_UV_mod ($P, $Q, $n, $m) {

    $n = Math::GMPz->new("$n");
    $P = Math::GMPz->new("$P");
    $Q = Math::GMPz->new("$Q");
    $m = Math::GMPz->new("$m");

    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);

    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));
    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));

    my $t = Math::GMPz::Rmpz_init_set_ui(2);
    my $s = Math::GMPz::Rmpz_remove($t, $n, $t);

    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($t, 2), 0, -1))) {

        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
        Math::GMPz::Rmpz_mod($Q1, $Q1, $m);

        if ($bit) {

            #~ Q2 = (Q1 * Q)%m
            #~ U1 = (U1 * V2)%m
            #~ V1 = (V2*V1 - P*Q1)%m
            #~ V2 = (V2*V2 - 2*Q2)%m

            Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);
            Math::GMPz::Rmpz_mul($U1, $U1, $V2);
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);

            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);
            Math::GMPz::Rmpz_submul($V1, $Q1, $P);
            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);

            Math::GMPz::Rmpz_mod($V1, $V1, $m);
            Math::GMPz::Rmpz_mod($U1, $U1, $m);
        }
        else {
            #~ Q2 = Q1
            #~ U1 = (U1*V1 - Q1)%m
            #~ V2 = (V2*V1 - P*Q1)%m
            #~ V1 = (V1*V1 - 2*Q2)%m

            Math::GMPz::Rmpz_set($Q2, $Q1);
            Math::GMPz::Rmpz_mul($U1, $U1, $V1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_sub($U1, $U1, $Q1);

            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
            Math::GMPz::Rmpz_submul($V2, $Q1, $P);
            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);

            Math::GMPz::Rmpz_mod($V2, $V2, $m);
            Math::GMPz::Rmpz_mod($U1, $U1, $m);
        }
    }

    #~ Q1 = (Q1 * Q2)%m
    #~ Q2 = (Q1 * Q)%m
    #~ U1 = (U1*V1 - Q1)%m
    #~ V1 = (V2*V1 - P*Q1)%m
    #~ Q1 = (Q1 * Q2)%m

    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
    Math::GMPz::Rmpz_mul($Q2, $Q1, $Q);
    Math::GMPz::Rmpz_mul($U1, $U1, $V1);
    Math::GMPz::Rmpz_mul($V1, $V1, $V2);
    Math::GMPz::Rmpz_sub($U1, $U1, $Q1);
    Math::GMPz::Rmpz_submul($V1, $Q1, $P);
    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);

    for (1 .. $s) {

        #~ U1 = (U1 * V1)%m
        #~ V1 = (V1*V1 - 2*Q1)%m
        #~ Q1 = (Q1 * Q1)%m

        Math::GMPz::Rmpz_mul($U1, $U1, $V1);
        Math::GMPz::Rmpz_mod($U1, $U1, $m);
        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
        Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);
        Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $m);
    }

    Math::GMPz::Rmpz_mod($U1, $U1, $m);
    Math::GMPz::Rmpz_mod($V1, $V1, $m);

    return ($U1, $V1);
}

say join(' ', lucas_UV_mod( 1, -1, 123456, 12345));    #=> 1122 4487
say join(' ', lucas_UV_mod(-3,  4, 987654, 12345));    #=> 3855 3928
say join(' ', lucas_UV_mod(-5, -7, 314159, 12345));    #=> 8038 4565


================================================
FILE: Math/modular_pseudo_square_root.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 13 October 2017
# https://github.com/trizen

# Find the greatest divisor (mod m) of `n` that does not exceed the square root of `n`.

# See also:
#   https://projecteuler.net/problem=266

use 5.020;
use warnings;

use ntheory qw(factor mulmod);
use experimental qw(signatures);

sub pseudo_square_root_mod ($n, $mod) {

    my $sqrt_log = log("$n") / 2;
    my @factors  = factor($n);
    my $end      = $#factors;

    my $maximum_log = 0;
    my $maximum_num = 0;

    sub ($i, $log, $prod) {

        if ($log > $maximum_log) {
            $maximum_log = $log;
            $maximum_num = $prod;
        }

        if ($i > $end) {
            return;
        }

        if ($log + log($factors[$i]) <= $sqrt_log) {
            __SUB__->($i + 1, $log, $prod) if ($i < $end);
            __SUB__->($i + 1, $log + log($factors[$i]), mulmod($prod, $factors[$i], $mod));
        }

    }->(0, 0, 1);

    return $maximum_num;
}

say pseudo_square_root_mod(479001600,   10**16);    #=> 21600
say pseudo_square_root_mod(6469693230,  10**16);    #=> 79534
say pseudo_square_root_mod(12398712476, 10**16);    #=> 68

say pseudo_square_root_mod('614889782588491410',              10**8);     #=> 83152070
say pseudo_square_root_mod('3217644767340672907899084554130', 10**16);    #=> 1793779293633437


================================================
FILE: Math/modular_pseudo_square_root_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 June 2019
# https://github.com/trizen

# Find the greatest divisor (mod m) of `n` that does not exceed the square root of `n`.

# See also:
#   https://projecteuler.net/problem=266

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub pseudo_square_root_mod ($n, $mod) {

    my $lim     = sqrtint($n);
    my @factors = map { [$_, log($_)] } grep { $_ <= $lim } factor($n);

    my @d        = ([1, 0]);
    my $sqrt_log = log("$n") / 2;

    my %seen;
    while (my $p = shift(@factors)) {
        my @t;
        foreach my $d (@d) {
            if ($p->[1] + $d->[1] <= $sqrt_log) {
                push @t, [mulmod($p->[0], $d->[0], $mod), $p->[1] + $d->[1]];
            }
        }
        push @d, @t;
    }

    my $max_log = 0;
    my $max_div = 0;

    foreach my $d (@d) {
        if ($d->[1] > $max_log) {
            $max_div = $d->[0];
            $max_log = $d->[1];
        }
    }

    return $max_div;
}

say pseudo_square_root_mod(479001600,   10**16);    #=> 21600
say pseudo_square_root_mod(6469693230,  10**16);    #=> 79534
say pseudo_square_root_mod(12398712476, 10**16);    #=> 68

say pseudo_square_root_mod('614889782588491410',              10**8);     #=> 83152070
say pseudo_square_root_mod('3217644767340672907899084554130', 10**16);    #=> 1793779293633437


================================================
FILE: Math/modular_sigma_of_unitary_divisors_of_factorial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 August 2017
# https://github.com/trizen

# An efficient algorithm for computing:
#
#      --                 --
#      |       ---         |
#      |       \           |
#      |       /    d^k    |  (mod m)
#      |       ---         |
#      |       d|n!        |
#      |  gcd(d, n!/d) = 1 |
#      --                 --
#

# See also:
#   https://projecteuler.net/problem=429

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(forprimes mulmod powmod vecsum todigits);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub sigma_of_unitary_divisors_of_factorial ($n, $k, $m) {

    my $sigma = 1;

    forprimes {
        $sigma = mulmod($sigma, 1 + powmod($_, $k * factorial_power($n, $_), $m), $m);
    } $n;

    return $sigma;
}

my $k = 2;
my $n = 100;
my $m = 123456;

say sigma_of_unitary_divisors_of_factorial($n, $k, $m);   #=> 104128


================================================
FILE: Math/modular_square_root.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 July 2018
# https://github.com/trizen

# Find (almost) all solutions to the quadratic congruence:
#   x^2 = a (mod n)

use 5.020;
use warnings;

use experimental qw(signatures);

use List::Util qw(uniq);
use ntheory qw(factor_exp is_prime chinese forsetproduct);
use Math::AnyNum qw(:overload kronecker powmod valuation ipow);

sub tonelli_shanks ($n, $p) {

    $n %= $p;

    return $p if ($n == 0);

    my $q = $p - 1;
    my $s = valuation($q, 2);

    powmod($n, $q >> 1, $p) == $p - 1 and return;

    $s == 1
      and return powmod($n, ($p + 1) >> 2, $p);

    $q >>= $s;

    my $z = 1;
    for (my $i = 2 ; $i < $p ; ++$i) {
        if (kronecker($i, $p) == -1) {
            $z = $i;
            last;
        }
    }

    my $c = powmod($z, $q, $p);
    my $r = powmod($n, ($q + 1) >> 1, $p);
    my $t = powmod($n, $q, $p);

    while (($t - 1) % $p != 0) {

        my $k = 1;
        my $v = $t * $t % $p;

        for (my $i = 1 ; $i < $s ; ++$i) {
            if (($v - 1) % $p == 0) {
                $k = powmod($c, 1 << ($s - $i - 1), $p);
                $s = $i;
                last;
            }
            $v = $v * $v % $p;
        }

        $r = $r * $k % $p;
        $c = $k * $k % $p;
        $t = $t * $c % $p;
    }

    return $r;
}

sub sqrt_mod_n ($z, $n) {

    if ($n <= 1) {    # no solutions for n<=1
        return;
    }

    $z %= $n;

    if ($z == 0) {
        return 0;
    }

    if (!($n & 1)) {    # n is even

        if (!($n & ($n - 1))) {    # n is a power of two

            if ($n == 2) {
                return (1) if ($z & 1);
                return;
            }

            if ($n == 4) {
                return (1, 3) if ($z % 4 == 1);
                return;
            }

            if ($n == 8) {
                return (1, 3, 5, 7) if ($z % 8 == 1);
                return;
            }

            if ($z == 1) {
                return (1, ($n >> 1) - 1, ($n >> 1) + 1, $n - 1);
            }
        }

        my @roots;
        my $k = valuation($n, 2);

        foreach my $s (sqrt_mod_n($z, $n >> 1)) {

            my $i = ((($s * $s - $z) >> ($k - 1)) % 2);
            my $r = ($s + ($i << ($k - 2)));

            if (($r * $r) % $n == $z) {
                push(@roots, $r, $n - $r);
            }
        }

        return sort { $a <=> $b } uniq(@roots);
    }

    if (is_prime($n)) {
        my $r = tonelli_shanks($z, $n) // return;
        return sort { $a <=> $b } ($r, $n - $r);
    }

    my @pe = factor_exp($n);    # factorize `n` into prime powers

    if (@pe == 1) {
        my $p = Math::AnyNum->new($pe[0][0]);
        my $x = tonelli_shanks($z, $p) // return;
        my $r = $n / $p;
        my $e = ($n - 2 * $r + 1) >> 1;
        my $t = (powmod($x, $r, $n) * powmod($z, $e, $n)) % $n;
        return if ($t == 0);
        return sort { $a <=> $b } ($t, $n - $t);
    }

    my @chinese;

    foreach my $p (@pe) {
        my $m = ipow($p->[0], $p->[1]);
        my @r = sqrt_mod_n($z, $m);
        push @chinese, [map { [$_, $m] } @r];
    }

    my @roots;

    forsetproduct {
        push @roots, chinese(@_);
    } @chinese;

    return sort { $a <=> $b } uniq(grep { ($_ * $_) % $n == $z } @roots);
}

my @tests = (
    [1104, 6630],
    [2641, 4465],
    [993,  2048],
    [472,   972],
    [441,   920],
    [841,   905],
    [289,   992],
);

sub bf_sqrtmod ($z, $n) {
    grep { ($_ * $_) % $n == $z } 1 .. $n;
}

foreach my $t (@tests) {
    my @r = sqrt_mod_n($t->[0], $t->[1]);
    say "x^2 = $t->[0] (mod $t->[1]) = {", join(', ', @r), "}";
    die "error1 for (@$t) -- @r" if (@r != grep { ($_ * $_) % $t->[1] == $t->[0] } @r);
    die "error2 for (@$t) -- @r" if (join(' ', @r) ne join(' ', bf_sqrtmod($t->[0], $t->[1])));
}

say '';

# The algorithm also works for arbitrary large integers
say join(' ', sqrt_mod_n(-1, 13**18 * 5**7));    #=> 633398078861605286438568 2308322911594648160422943 6477255756527023177780182 8152180589260066051764557

foreach my $n (1 .. 100) {
    my $m = int(rand(10000));
    my $z = int(rand($m));

    my @a1 = sqrt_mod_n($z, $m);
    my @a2 = bf_sqrtmod($z, $m);

    if ("@a1" ne "@a2") {
        warn "\nerror for ($z, $m):\n\t(@a1) != (@a2)\n";
    }
}

say '';

# Too few solutions for some inputs
say 'x^2 = 1701 (mod 6300) = {' . join(' ', sqrt_mod_n(1701, 6300)) . '}';
say 'x^2 = 1701 (mod 6300) = {' . join(', ', bf_sqrtmod(1701, 6300)) . '}';

# No solutions for some inputs (although solutions do exist)
say join(' ', sqrt_mod_n(306, 810));
say join(' ', sqrt_mod_n(2754, 6561));
say join(' ', sqrt_mod_n(17640, 48465));

__END__
x^2 = 1104 (mod 6630) = {642, 1152, 1968, 2478, 4152, 4662, 5478, 5988}
x^2 = 2641 (mod 4465) = {1501, 2071, 2394, 2964}
x^2 = 993 (mod 2048) = {369, 655, 1393, 1679}
x^2 = 472 (mod 972) = {38, 448, 524, 934}
x^2 = 441 (mod 920) = {21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899}
x^2 = 841 (mod 905) = {29, 391, 514, 876}
x^2 = 289 (mod 992) = {17, 79, 417, 479, 513, 575, 913, 975}


================================================
FILE: Math/modular_square_root_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 21 July 2018
# https://github.com/trizen

# Find (almost) all solutions to the quadratic congruence:
#   x^2 = a (mod n)

use 5.020;
use warnings;

use experimental qw(signatures);

use List::Util qw(uniq);
use ntheory qw(factor_exp chinese forsetproduct);
use Math::Prime::Util::GMP qw(sqrtmod);
use Math::AnyNum qw(:overload powmod ipow);

sub sqrt_mod_n ($z, $n) {

    my @roots = sub ($z, $n) {

        return 0  if ($n == 1);
        return () if ($n < 1);

        $z %= $n;

        return $n if ($z == 0);

        my %congruences;

        foreach my $factor (factor_exp($n)) {

            my ($p, $e) = @$factor;
            my $pp = ipow($p, $e);

            if ($p eq '2') {

                if ($e == 1) {
                    if ($z & 1) {
                        push @{$congruences{$pp}}, [1, $pp];
                    }
                    else {
                        push @{$congruences{$pp}}, [0, $pp];
                    }
                }
                elsif ($e == 2) {
                    if ($z % 4 == 1) {
                        push @{$congruences{$pp}}, [1, $pp], [3, $pp];
                    }
                    else {
                        push @{$congruences{$pp}}, [0, $pp], [2, $pp];
                    }
                }
                elsif ($e == 3) {
                    if ($z % 8 == 1) {
                        push @{$congruences{$pp}}, [1, $pp], [3, $pp], [5, $pp], [7, $pp];
                    }
                    else {
                        push @{$congruences{$pp}}, [0, $pp], [2, $pp], [4, $pp], [6, $pp];
                    }
                }
                elsif ($z == 1) {
                    push @{$congruences{$pp}}, [1, $pp], [($pp >> 1) - 1, $pp], [($pp >> 1) + 1, $pp], [$pp - 1, $pp];
                }

                foreach my $s (__SUB__->($z, $pp >> 1)) {

                    my $i = ((($s * $s - $z) >> ($e - 1)) % 2);
                    my $r = ($s + ($i << ($e - 2)));

                    push @{$congruences{$pp}}, [$r, $pp], [$pp - $r, $pp];
                }

                next;
            }

            $p = Math::AnyNum->new($p);
            my $x = sqrtmod($z, $p) // next;   # Tonelli-Shanks algorithm
            my $r = $pp / $p;
            my $u = ($pp - 2 * $r + 1) >> 1;
            my $t = (powmod($x, $r, $pp) * powmod($z, $u, $pp)) % $pp;
            push @{$congruences{$pp}}, [$t, $pp], [$pp - $t, $pp];
        }

        my @roots;

        forsetproduct {
            push @roots, chinese(@_);
        } values %congruences;

        return grep { powmod($_, 2, $n) == $z } uniq(@roots);
    }->($z, $n);

    sort { $a <=> $b } @roots;
}

my @tests = ([1104, 6630], [2641, 4465], [993, 2048], [472, 972], [441, 920], [841, 905], [289, 992],);

sub bf_sqrtmod ($z, $n) {
    grep { ($_ * $_) % $n == $z } 1 .. $n;
}

foreach my $t (@tests) {
    my @r = sqrt_mod_n($t->[0], $t->[1]);
    say "x^2 = $t->[0] (mod $t->[1]) = {", join(', ', @r), "}";
    die "error1 for (@$t) -- @r" if (@r != grep { ($_ * $_) % $t->[1] == $t->[0] } @r);
    die "error2 for (@$t) -- @r" if (join(' ', @r) ne join(' ', bf_sqrtmod($t->[0], $t->[1])));
}

say '';

# The algorithm also works for arbitrary large integers
say join(' ', sqrt_mod_n(13**18 * 5**7 - 1, 13**18 * 5**7));    #=> 633398078861605286438568 2308322911594648160422943 6477255756527023177780182 8152180589260066051764557

foreach my $n (1 .. 100) {
    my $m = int(rand(10000));
    my $z = int(rand($m));

    my @a1 = sqrt_mod_n($z, $m);
    my @a2 = bf_sqrtmod($z, $m);

    if ("@a1" ne "@a2") {
        warn "\nerror for ($z, $m):\n\t(@a1) != (@a2)\n";
    }
}

say '';

# Too few solutions for some inputs
say 'x^2 = 1701 (mod 6300) = {' . join(' ', sqrt_mod_n(1701, 6300)) . '}';
say 'x^2 = 1701 (mod 6300) = {' . join(', ', bf_sqrtmod(1701, 6300)) . '}';

# No solutions for some inputs (although solutions do exist)
say join(' ', sqrt_mod_n(306,   810));
say join(' ', sqrt_mod_n(2754,  6561));
say join(' ', sqrt_mod_n(17640, 48465));

__END__
x^2 = 1104 (mod 6630) = {642, 1152, 1968, 2478, 4152, 4662, 5478, 5988}
x^2 = 2641 (mod 4465) = {1501, 2071, 2394, 2964}
x^2 = 993 (mod 2048) = {369, 655, 1393, 1679}
x^2 = 472 (mod 972) = {38, 448, 524, 934}
x^2 = 441 (mod 920) = {21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899}
x^2 = 841 (mod 905) = {29, 391, 514, 876}
x^2 = 289 (mod 992) = {17, 79, 417, 479, 513, 575, 913, 975}


================================================
FILE: Math/modular_square_root_3.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 26 February 2019
# https://github.com/trizen

# Find several integer solutions for x to the congruence:
#   x^2 = a (mod n)

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use experimental qw(signatures);
use ntheory qw();
use Math::Prime::Util::GMP qw();

sub modular_square_root ($x, $y) {

    $x = Math::GMPz->new("$x");
    $y = Math::GMPz->new("$y");

    Math::GMPz::Rmpz_sgn($y) <= 0 and return;

    if (Math::Prime::Util::GMP::is_prob_prime($y)) {
        my $r = Math::GMPz->new(Math::Prime::Util::GMP::sqrtmod($x, $y) // return);
        return ($r, $y - $r);
    }

    my %factors;
    ++$factors{$_} for Math::Prime::Util::GMP::factor($y);

    my %congruences;

    my $t = Math::GMPz::Rmpz_init();
    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();
    my $w = Math::GMPz::Rmpz_init();
    my $m = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_mod($m, $x, $y);

    foreach my $p (keys %factors) {

        if ($p eq '2') {
            my $e = $factors{$p};

            if ($e == 1) {
                push @{$congruences{$p}}, [(Math::GMPz::Rmpz_odd_p($m) ? 1 : 0), 2];
                next;
            }

            if ($e == 2) {
                push @{$congruences{$p}}, [(Math::GMPz::Rmpz_congruent_ui_p($m, 1, 4) ? 1 : 0), 4];
                next;
            }

            Math::GMPz::Rmpz_congruent_ui_p($m, 1, 8) or return;
            Math::GMPz::Rmpz_ui_pow_ui($v, 2, $e - 1);

            foreach my $r (__SUB__->($m, $v)) {

                Math::GMPz::Rmpz_mul($t, $r, $r);
                Math::GMPz::Rmpz_sub($t, $t, $m);
                Math::GMPz::Rmpz_div_2exp($t, $t, $e - 1);
                Math::GMPz::Rmpz_mod_ui($t, $t, 2);

                Math::GMPz::Rmpz_mul_2exp($t, $t, $e - 2);
                Math::GMPz::Rmpz_add($t, $t, $r);

                push @{$congruences{$p}}, ["$t", "$v"];
            }
            next;
        }

        my $r = Math::GMPz->new(Math::Prime::Util::GMP::sqrtmod($x, $p) // return);

        foreach my $w (Math::GMPz->new("$r"), $p - $r) {

            Math::GMPz::Rmpz_set_str($t, "$p", 10);

            # v = p^k
            Math::GMPz::Rmpz_pow_ui($v, $t, $factors{"$p"});

            # t = p^(k-1)
            Math::GMPz::Rmpz_divexact($t, $v, $t);

            # u = (p^k - 2*(p^(k-1)) + 1) / 2
            Math::GMPz::Rmpz_mul_2exp($u, $t, 1);
            Math::GMPz::Rmpz_sub($u, $v, $u);
            Math::GMPz::Rmpz_add_ui($u, $u, 1);
            Math::GMPz::Rmpz_div_2exp($u, $u, 1);

            # sqrtmod(a, p^k) = (powmod(sqrtmod(a, p), p^(k-1), p^k) * powmod(a, u, p^k)) % p^k
            Math::GMPz::Rmpz_powm($w, $w, $t, $v);
            Math::GMPz::Rmpz_powm($u, $m, $u, $v);
            Math::GMPz::Rmpz_mul($w, $w, $u);
            Math::GMPz::Rmpz_mod($w, $w, $v);

            push @{$congruences{$p}}, ["$w", "$v"];
        }
    }

    my @roots;

#<<<
    ntheory::forsetproduct {
        push @roots, Math::Prime::Util::GMP::chinese(@_);
    } values %congruences;
#>>>

    @roots = map { Math::GMPz->new($_) } @roots;

    @roots = grep {
        Math::GMPz::Rmpz_powm_ui($u, $_, 2, $y);
        Math::GMPz::Rmpz_cmp($u, $m) == 0;
    } @roots;

    @roots = sort { $a <=> $b } @roots;

    return @roots;
}

say join ' ', modular_square_root(43,  97);         #=> 25 72
say join ' ', modular_square_root(472, 972);        #=> 448 524
say join ' ', modular_square_root(43,  41 * 97);    #=> 557 1042 2935 3420
say join ' ', modular_square_root(1104, 6630);      #=> 642 642 1152 1152 1968 1968 2478 2478 4152 4152 4662 4662 5478 5478 5988 5988

say '';

say join(' ', modular_square_root(993, 2048));    #=> 369 1679 655 1393
say join(' ', modular_square_root(441, 920));     #=> 761 481 209 849 531 251 899 619 301 21 669 389 71 711 439 159
say join(' ', modular_square_root(841, 905));     #=> 391 876 29 514
say join(' ', modular_square_root(289, 992));     #=> 417 513 975 79 913 17 479 575

# No solutions for some inputs (although solutions do exist)
say join(' ', modular_square_root(306,   810));
say join(' ', modular_square_root(2754,  6561));
say join(' ', modular_square_root(17640, 48465));


================================================
FILE: Math/modular_square_root_all_solutions.pl
================================================
#!/usr/bin/perl

# Find all solutions to the quadratic congruence:
#   x^2 = a (mod n)

# Based on algorithm by Hugo van der Sanden:
#   https://github.com/danaj/Math-Prime-Util/pull/55

use 5.020;
use strict;
use warnings;

use Test::More tests => 11;

use experimental qw(signatures);
use Math::AnyNum qw(:overload ipow);
use ntheory qw(factor_exp sqrtmod forsetproduct chinese);

sub sqrtmod_all ($A, $N) {

    $A = Math::AnyNum->new("$A");
    $N = Math::AnyNum->new("$N");

    $N = -$N if ($N < 0);
    $N == 0 and return ();
    $N == 1 and return (0);
    $A = ($A % $N);

    my $sqrtmod_pk = sub ($A, $p, $k) {
        my $pk = ipow($p, $k);

        if ($A % $p == 0) {

            if ($A % $pk == 0) {
                my $low  = ipow($p, $k >> 1);
                my $high = ($k & 1) ? ($low * $p) : $low;
                return map { $high * $_ } 0 .. $low - 1;
            }

            my $A2 = $A / $p;
            return () if ($A2 % $p != 0);
            my $pj = $pk / $p;

            return map {
                my $q = $_;
                map { $q * $p + $_ * $pj } 0 .. $p - 1
            } __SUB__->($A2 / $p, $p, $k - 2);
        }

        my $q = sqrtmod($A, $pk) // eval {
            require Math::Sidef;
            Math::Sidef::sqrtmod($A, $pk);
        } || return;

        return ($q, $pk - $q) if ($p != 2);
        return ($q)           if ($k == 1);
        return ($q, $pk - $q) if ($k == 2);

        my $pj = ipow($p, $k - 1);
        my $q2 = ($q * ($pj - 1)) % $pk;

        return ($q, $pk - $q, $q2, $pk - $q2);
    };

    my @congruences;

    foreach my $pe (factor_exp($N)) {
        my ($p, $k) = @$pe;
        my $pk = ipow($p, $k);
        push @congruences, [map { [$_, $pk] } $sqrtmod_pk->($A, $p, $k)];
    }

    my @roots;

    forsetproduct {
        push @roots, chinese(@_);
    } @congruences;

    @roots = map  { Math::AnyNum->new($_) } @roots;
    @roots = grep { ($_ * $_) % $N == $A } @roots;
    @roots = sort { $a <=> $b } @roots;

    return @roots;
}

#<<<
is_deeply([sqrtmod_all(43, 97)],       [25, 72]);
is_deeply([sqrtmod_all(472, 972)],     [38, 448, 524, 934]);
is_deeply([sqrtmod_all(43, 41 * 97)],  [557, 1042, 2935, 3420]);
is_deeply([sqrtmod_all(1104, 6630)],   [642, 1152, 1968, 2478, 4152, 4662, 5478, 5988]);
is_deeply([sqrtmod_all(993, 2048)],    [369, 655, 1393, 1679]);
is_deeply([sqrtmod_all(441, 920)],     [21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899]);
is_deeply([sqrtmod_all(841, 905)],     [29, 391, 514, 876]);
is_deeply([sqrtmod_all(289, 992)],     [17, 79, 417, 479, 513, 575, 913, 975]);
is_deeply([sqrtmod_all(306, 810)],     [66, 96, 174, 204, 336, 366, 444, 474, 606, 636, 714, 744]);
is_deeply([sqrtmod_all(2754, 6561)],   [126, 603, 855, 1332, 1584, 2061, 2313, 2790, 3042, 3519, 3771, 4248, 4500, 4977, 5229, 5706, 5958, 6435]);
is_deeply([sqrtmod_all(17640, 48465)], [2865, 7905, 8250, 13290, 19020, 24060, 24405, 29445, 35175, 40215, 40560, 45600]);
#>>>

say join', ', sqrtmod_all(-1, 13**18 * 5**7);    # 633398078861605286438568, 2308322911594648160422943, 6477255756527023177780182, 8152180589260066051764557


================================================
FILE: Math/modular_square_root_all_solutions_cipolla.pl
================================================
#!/usr/bin/perl

# Find all the solutions to the quadratic congruence:
#   x^2 = a (mod n)

# Based on algorithm by Hugo van der Sanden:
#   https://github.com/danaj/Math-Prime-Util/pull/55

# See also:
#   https://rosettacode.org/wiki/Cipolla's_algorithm

use 5.020;
use strict;
use warnings;

use Test::More tests => 12;

use experimental qw(signatures);
use ntheory qw(factor_exp chinese forsetproduct kronecker);
use Math::AnyNum qw(:overload powmod ipow);

sub cipolla ($n, $p) {

    $n %= $p;

    return undef if kronecker($n, $p) != 1;

    if ($p == 2) {
        return ($n & 1);
    }

    my $w2;
    my $a = 0;

    $a++ until kronecker(($w2 = ($a * $a - $n) % $p), $p) < 0;

    my %r = (x => 1, y => 0);
    my %s = (x => $a, y => 1);
    my $i = $p + 1;

    while (1 <= ($i >>= 1)) {
        %r = (
              x => (($r{x} * $s{x} + $r{y} * $s{y} * $w2) % $p),
              y => (($r{x} * $s{y} + $s{x} * $r{y}) % $p)
             )
          if ($i & 1);
        %s = (
              x => (($s{x} * $s{x} + $s{y} * $s{y} * $w2) % $p),
              y => (($s{x} * $s{y} + $s{x} * $s{y}) % $p)
             );
    }

    $r{y} ? undef : $r{x};
}

sub sqrtmod_prime_power ($n, $p, $e) {    # sqrt(n) modulo a prime power p^e

    if ($e == 1) {
        return cipolla($n, $p);
    }

    # t = p^(k-1)
    my $t = ipow($p, $e - 1);

    # pp = p^k
    my $pp = $t * $p;

    # n %= p^k
    $n %= $pp;

    if ($n == 0) {
        return 0;
    }

    if ($p == 2) {

        if ($e == 1) {
            return (($n & 1) ? 1 : 0);
        }

        if ($e == 2) {
            return (($n % 4 == 1) ? 1 : 0);
        }

        ($n % 8 == 1) || return;

        my $r = __SUB__->($n, $p, $e - 1) // return;

        # (((r^2 - n) / 2^(e-1))%2) * 2^(e-2) + r
        return ((((($r * $r - $n) >> ($e - 1)) % 2) << ($e - 2)) + $r);
    }

    my $s = cipolla($n, $p) // return;

    # u = (p^k - 2*(p^(k-1)) + 1) / 2
    my $u = ($pp - 2 * $t + 1) >> 1;

    # sqrtmod(a, p^k) = (powmod(sqrtmod(a, p), p^(k-1), p^k) * powmod(a, u, p^k)) % p^k
    (powmod($s, $t, $pp) * powmod($n, $u, $pp)) % $pp;
}

sub sqrtmod_all ($A, $N) {

    $A = Math::AnyNum->new("$A");
    $N = Math::AnyNum->new("$N");

    $N = -$N if ($N < 0);
    $N == 0 and return ();
    $N == 1 and return (0);
    $A = ($A % $N);

    my $sqrtmod_pk = sub ($A, $p, $k) {
        my $pk = ipow($p, $k);

        if ($A % $p == 0) {

            if ($A % $pk == 0) {
                my $low  = ipow($p, $k >> 1);
                my $high = ($k & 1) ? ($low * $p) : $low;
                return map { $high * $_ } 0 .. $low - 1;
            }

            my $A2 = $A / $p;
            return () if ($A2 % $p != 0);
            my $pj = $pk / $p;

            return map {
                my $q = $_;
                map { $q * $p + $_ * $pj } 0 .. $p - 1
            } __SUB__->($A2 / $p, $p, $k - 2);
        }

        my $q = sqrtmod_prime_power($A, $p, $k) // return;

        return ($q, $pk - $q) if ($p != 2);
        return ($q)           if ($k == 1);
        return ($q, $pk - $q) if ($k == 2);

        my $pj = ipow($p, $k - 1);
        my $q2 = ($q * ($pj - 1)) % $pk;

        return ($q, $pk - $q, $q2, $pk - $q2);
    };

    my @congruences;

    foreach my $pe (factor_exp($N)) {
        my ($p, $k) = @$pe;
        my $pk = ipow($p, $k);
        push @congruences, [map { [$_, $pk] } $sqrtmod_pk->($A, $p, $k)];
    }

    my @roots;

    forsetproduct {
        push @roots, chinese(@_);
    } @congruences;

    @roots = map  { Math::AnyNum->new($_) } @roots;
    @roots = grep { ($_ * $_) % $N == $A } @roots;
    @roots = sort { $a <=> $b } @roots;

    return @roots;
}

my @tests = ([1104, 6630], [2641, 4465], [993, 2048], [472, 972], [441, 920], [841, 905], [289, 992]);

sub bf_sqrtmod ($z, $n) {
    grep { ($_ * $_) % $n == $z } 0 .. $n - 1;
    #ntheory::allsqrtmod($z, $n);
}

foreach my $t (@tests) {
    my @r = sqrtmod_all($t->[0], $t->[1]);
    say "x^2 = $t->[0] (mod $t->[1]) = {", join(', ', @r), "}";
    die "error1 for (@$t) -- @r" if (@r != grep { ($_ * $_) % $t->[1] == $t->[0] } @r);
    die "error2 for (@$t) -- @r" if (join(' ', @r) ne join(' ', bf_sqrtmod($t->[0], $t->[1])));
}

say '';

# The algorithm also works for arbitrary large integers
say join(' ', sqrtmod_all(13**18 * 5**7 - 1, 13**18 * 5**7));

foreach my $n (1 .. 100) {
    my $m = int(rand(10000));
    my $z = int(rand($m));

    my @a1 = sqrtmod_all($z, $m);
    my @a2 = bf_sqrtmod($z, $m);

    if ("@a1" ne "@a2") {
        warn "\nerror for ($z, $m):\n\t(@a1) != (@a2)\n";
    }
}

say '';

# Too few solutions for some inputs
say 'x^2 = 1701 (mod 6300) = {' . join(' ',  sqrtmod_all(1701, 6300)) . '}';
say 'x^2 = 1701 (mod 6300) = {' . join(', ', bf_sqrtmod(1701, 6300)) . '}';

# No solutions for some inputs (although solutions do exist)
say join(' ', sqrtmod_all(306,   810));
say join(' ', sqrtmod_all(2754,  6561));
say join(' ', sqrtmod_all(17640, 48465));

#<<<
is_deeply([sqrtmod_all(43, 97)],       [25, 72]);
is_deeply([sqrtmod_all(472, 972)],     [38, 448, 524, 934]);
is_deeply([sqrtmod_all(43, 41 * 97)],  [557, 1042, 2935, 3420]);
is_deeply([sqrtmod_all(1104, 6630)],   [642, 1152, 1968, 2478, 4152, 4662, 5478, 5988]);
is_deeply([sqrtmod_all(993, 2048)],    [369, 655, 1393, 1679]);
is_deeply([sqrtmod_all(441, 920)],     [21, 71, 159, 209, 251, 301, 389, 439, 481, 531, 619, 669, 711, 761, 849, 899]);
is_deeply([sqrtmod_all(841, 905)],     [29, 391, 514, 876]);
is_deeply([sqrtmod_all(289, 992)],     [17, 79, 417, 479, 513, 575, 913, 975]);
is_deeply([sqrtmod_all(306, 810)],     [66, 96, 174, 204, 336, 366, 444, 474, 606, 636, 714, 744]);
is_deeply([sqrtmod_all(2754, 6561)],   [126, 603, 855, 1332, 1584, 2061, 2313, 2790, 3042, 3519, 3771, 4248, 4500, 4977, 5229, 5706, 5958, 6435]);
is_deeply([sqrtmod_all(17640, 48465)], [2865, 7905, 8250, 13290, 19020, 24060, 24405, 29445, 35175, 40215, 40560, 45600]);
#>>>

is_deeply([sqrtmod_all(-1, 13**18 * 5**7)],
          [633398078861605286438568, 2308322911594648160422943, 6477255756527023177780182, 8152180589260066051764557]);


================================================
FILE: Math/multi_sqrt_nums.pl
================================================
#!/usr/bin/perl

# Author: Trizen

use 5.010;

my $format = "%20s ** %-20s = %s\n";

for my $x (2 .. 10) {
    for my $y (2 .. 10) {
        my $num = $x**$y;

        printf($format, $x, $y, $num);

        my $sqrt = $num;
        for (1 .. $y - 1) {
            $sqrt = sqrt($sqrt);
        }
        my $pow = 2**int($y - 1) / $y;
        printf($format, $sqrt, $pow, $sqrt**$pow);
        say "-" x 80;
    }
}


================================================
FILE: Math/multinomial_coefficient.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 01 February 2018
# https://github.com/trizen

# Simple algorithm for computing the multinomial coefficient, using prime powers.

# See also:
#   https://mathworld.wolfram.com/MultinomialCoefficient.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(forprimes vecsum);
use Math::AnyNum qw(:overload sumdigits);

sub factorial_power ($n, $p) {
    ($n - sumdigits($n, $p)) / ($p - 1);
}

sub multinomial (@mset) {

    my $sum  = vecsum(@mset);
    my $prod = 1;
    my $end  = $#mset;

    forprimes {
        my $p = $_;
        my $e = factorial_power($sum, $p);

        for (my $i = $end ; $i >= 0 ; --$i) {

            my $n = $mset[$i];

            if ($p <= $n) {
                $e -= factorial_power($n, $p);
            }
            else {
                splice(@mset, $i, 1), --$end;
            }
        }

        $prod *= $p**$e;
    } $sum;

    return $prod;
}

say multinomial(7, 2, 5, 2, 12, 11);    # 440981754363423854380800


================================================
FILE: Math/multinomial_coefficient_from_binomial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 February 2018
# https://github.com/trizen

# Identity for computing the multinomial coefficient using binomial coefficients.

# See also:
#   https://mathworld.wolfram.com/MultinomialCoefficient.html
#   https://en.wikipedia.org/wiki/Multinomial_theorem

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload binomial);

sub multinomial (@mset) {

    my $prod = 1;
    my $n    = shift(@mset);

    foreach my $k (@mset) {
        $prod *= binomial($n += $k, $k);
    }

    return $prod;
}

say multinomial(7, 2, 5, 2, 12, 11);    # 440981754363423854380800


================================================
FILE: Math/multiplicative_partitions.pl
================================================
#!/usr/bin/perl

# Generate all sets of integers >= 2 whose product equals n.

# See also:
#   https://oeis.org/A001055 -- The multiplicative partition function
#   https://oeis.org/A162247 -- Irregular triangle in which row n lists all factorizations of n

use 5.036;
use ntheory 0.74 qw(:all);

sub multiplicative_partitions($n, $max_part = $n) {

    my @results;
    my @divs = divisors($n);

    shift(@divs);    # remove divisor '1'

    my $end = $#divs;
    my @path;

    sub ($target, $min_idx) {

        if ($target == 1) {
            push @results, [@path];
            return;
        }

        for my $i ($min_idx .. $end) {
            my $d = $divs[$i];

            # Prune branch if the divisor exceeds the remaining target
            last if $d > $target;
            last if $d > $max_part;

            if ($target % $d == 0) {
                push @path, $d;
                __SUB__->(divint($target, $d), $i);
                pop @path;
            }
        }
    }->($n, 0);

    @results = sort { @$a <=> @$b } @results;

    return @results;
}

# --- Execution and Output ---
my $n            = shift(@ARGV) // 48;
my $max_part     = shift(@ARGV) // $n;
my @combinations = multiplicative_partitions($n, $max_part);

# Format and print the output
my @formatted;
for my $combo (@combinations) {
    push @formatted, "[" . join(", ", @$combo) . "]";
}

print "For n = $n, we have:\n" . join("\n", @formatted) . "\n";

__END__
For n = 48, we have:
[48]
[2, 24]
[3, 16]
[4, 12]
[6, 8]
[2, 2, 12]
[2, 3, 8]
[2, 4, 6]
[3, 4, 4]
[2, 2, 2, 6]
[2, 2, 3, 4]
[2, 2, 2, 2, 3]


================================================
FILE: Math/multisets.pl
================================================
#!/usr/bin/perl

# Generate Combinations with Replacement (also known as multisets) of size `n`, with maximum value `k` and maximum sum `max_sum`.

use 5.036;

sub multisets ($n, $k, $max_sum) {
    my @result;
    my @path;

    sub ($pos, $max_val, $sum) {

        if ($pos == $n) {
            push @result, [@path];
            return;
        }

        for my $v (1 .. $max_val) {
            last if ($sum + $v > $max_sum);
            push @path, $v;
            __SUB__->($pos + 1, $v, $sum + $v);
            pop @path;
        }
    }->(0, $k, 0);

    return @result;
}

# Print results
my ($n, $k, $max_sum) = (3, 4, 8);
my @perms = multisets($n, $k, $max_sum);
for my $perm (@perms) {
    print "[" . join(", ", @$perm) . "]\n";
}

__END__
[1, 1, 1]
[2, 1, 1]
[2, 2, 1]
[2, 2, 2]
[3, 1, 1]
[3, 2, 1]
[3, 2, 2]
[3, 3, 1]
[3, 3, 2]
[4, 1, 1]
[4, 2, 1]
[4, 2, 2]
[4, 3, 1]


================================================
FILE: Math/multivariate_gamma_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 October 2017
# https://github.com/trizen

# A simple implementation of the multivariate gamma function.

# See also:
#   https://en.wikipedia.org/wiki/Multivariate_gamma_function

use 5.014;
use warnings;

use Math::AnyNum qw(pi gamma);

sub multivariate_gamma {
    my ($n, $p) = @_;

    my $prod = 1;
    foreach my $j (1 .. $p) {
        $prod *= gamma($n + (1 - $j) / 2);
    }

    $prod * pi**($p * ($p - 1) / 4);
}

say multivariate_gamma(10, 5);    # means: gamma_5(10)


================================================
FILE: Math/mysterious_sum-pentagonal_numbers.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 14 August 2016
# License: GPLv3
# Website: https://github.com/trizen

# Mysterious sum-pentagonal numbers.

# A strange fact: at this very moment, as far as
# I searched, nothing is known about this numbers...

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);

memoize('sum_pentagonal');

sub p {
    $_[0] * (3 * $_[0] - 1) / 2;
}

sub sum_pentagonal {
    my ($n) = @_;

    my $i   = 1;
    my $sum = 0;

    while (1) {
        my $p1 = p($i);

        if ($n - $p1 == 0) {
            return $sum + $n;
        }
        elsif ($n - $p1 < 0) {
            last;
        }

        $sum += (-1)**($i - 1) * sum_pentagonal($n - $p1);

        my $p2 = p(-$i);

        if ($n - $p2 == 0) {
            return $sum + $n;
        }
        elsif ($n - $p2 < 0) {
            last;
        }

        $sum += (-1)**($i - 1) * sum_pentagonal($n - $p2);

        ++$i;
    }

    $sum;
}

foreach my $n (1 .. 100) {
    say "s($n) = ", sum_pentagonal($n);
}

__END__
s(1) = 1
s(2) = 3
s(3) = 4
s(4) = 7
s(5) = 16
s(6) = 22
s(7) = 42
s(8) = 59
s(9) = 91
s(10) = 130
s(11) = 192
s(12) = 276
s(13) = 388
s(14) = 534
s(15) = 752
s(16) = 1011
s(17) = 1376
s(18) = 1833
s(19) = 2448
s(20) = 3216
s(21) = 4232
s(22) = 5514
s(23) = 7152
s(24) = 9206
s(25) = 11823
s(26) = 15094
s(27) = 19198
s(28) = 24282
s(29) = 30624
s(30) = 38450


================================================
FILE: Math/mysterious_sum-pentagonal_numbers_2.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 14 August 2016
# License: GPLv3
# Website: https://github.com/trizen

# Mysterious sum-pentagonal numbers of second order.
# A strange fact: at this very moment, nothing is known about this numbers...

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);

memoize('sum_pentagonal');

# Tip: square numbers also produce a nice sequence.

sub p {
    $_[0] * (3 * $_[0] - 1) / 2;
}

sub f1 {
    my ($n, $i) = @_;

    my $p = p($i);

    return $n if $n - $p == 0;
    return 0  if $n - $p < 0;

    (-1)**($i + 1) * f1($n - $p, $i - 1) + sum_pentagonal($n - 1);
}

sub f2 {
    my ($n, $i) = @_;

    my $p = p($i);

    return $n if $n - $p == 0;
    return 0  if $n - $p < 0;

    (-1)**($i + 1) * f2($n - $p, $i - 1) + sum_pentagonal($n - 1);
}

sub sum_pentagonal {
    my ($n) = @_;
    f1($n, 1) + f2($n, -1);
}

foreach my $n (1 .. 50) {
    say "s($n) = ", sum_pentagonal($n);
}

__END__
s(1) = 1
s(2) = 3
s(3) = 5
s(4) = 10
s(5) = 20
s(6) = 40
s(7) = 80
s(8) = 160
s(9) = 327
s(10) = 727
s(11) = 1534
s(12) = 3235
s(13) = 6870
s(14) = 14547
s(15) = 30795
s(16) = 65225
s(17) = 138127
s(18) = 292502
s(19) = 619434
s(20) = 1311770
s(21) = 2777915
s(22) = 5882762
s(23) = 12457860
s(24) = 26381850
s(25) = 55837767
s(26) = 118216202
s(27) = 250283492
s(28) = 529868526
s(29) = 1121788555
s(30) = 2374952064


================================================
FILE: Math/n_dimensional_circles.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 November 2015
# Website: https://github.com/trizen

# The area of a circle in n-dimensions:
#   pi * d^n / (2*n)
#   pi * r^n * 2^(n-1) / n

# The circumference of a circle in n-dimensions:
#   pi * d^(n-1)
#   pi * r^(n-1) * 2^(n-1)

use 5.010;
use strict;
use warnings;

use Text::ASCIITable;

my @d_areas;
my @r_areas;

my @d_circumferences;
my @r_circumferences;

for my $i (1 .. 9) {
    push @d_areas, sprintf("pi * d^%d / %s", $i, 2 * $i);
    push @r_areas, sprintf("pi * r^%d * %d/%d", $i, 2**($i - 1), $i);
    push @d_circumferences, sprintf("pi * d^%d", $i - 1);
    push @r_circumferences, sprintf("pi * r^%d * %d", $i - 1, 2**($i - 1));
}

my $table = Text::ASCIITable->new;
$table->setCols('Dimension', 'Volume (d)', 'Volume (r)', 'Perimeter (d)', 'Perimeter (r)');

foreach my $i (0 .. $#d_areas) {
    $table->addRow($i + 1, $d_areas[$i], $r_areas[$i], $d_circumferences[$i], $r_circumferences[$i]);
}

print $table;

__END__
.-------------------------------------------------------------------------------.
| Dimension | Volume (d)    | Volume (r)       | Perimeter (d) | Perimeter (r)  |
+-----------+---------------+------------------+---------------+----------------+
|         1 | pi * d^1 / 2  | pi * r^1 * 1/1   | pi * d^0      | pi * r^0 * 1   |
|         2 | pi * d^2 / 4  | pi * r^2 * 2/2   | pi * d^1      | pi * r^1 * 2   |
|         3 | pi * d^3 / 6  | pi * r^3 * 4/3   | pi * d^2      | pi * r^2 * 4   |
|         4 | pi * d^4 / 8  | pi * r^4 * 8/4   | pi * d^3      | pi * r^3 * 8   |
|         5 | pi * d^5 / 10 | pi * r^5 * 16/5  | pi * d^4      | pi * r^4 * 16  |
|         6 | pi * d^6 / 12 | pi * r^6 * 32/6  | pi * d^5      | pi * r^5 * 32  |
|         7 | pi * d^7 / 14 | pi * r^7 * 64/7  | pi * d^6      | pi * r^6 * 64  |
|         8 | pi * d^8 / 16 | pi * r^8 * 128/8 | pi * d^7      | pi * r^7 * 128 |
|         9 | pi * d^9 / 18 | pi * r^9 * 256/9 | pi * d^8      | pi * r^8 * 256 |
'-----------+---------------+------------------+---------------+----------------'


================================================
FILE: Math/near-power_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 June 2019
# https://github.com/trizen

# A simple factorization method for numbers close to a perfect power.

# Very effective for numbers of the form:
#
#   n^k - 1
#
# where k has many divisors.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use ntheory qw(divisors is_power gcd powint rootint vecprod);

sub near_power_factorization ($n, $bound = 10000) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $orig = $n;

    my $f = sub ($r, $e, $k) {

        my @factors;

        foreach my $d (divisors($e)) {
            foreach my $j (1, -1) {

                my $t = $r**$d - $k * $j;
                my $g = gcd($t, $n);

                if ($g > 1 and $g < $n) {
                    while ($n % $g == 0) {
                        $n /= $g;
                        push @factors, $g;
                    }
                }
            }
        }

        push @factors, $orig / vecprod(@factors);
        return sort { $a <=> $b } @factors;
    };

    foreach my $j (1 .. $bound) {
        foreach my $k (1, -1) {

            my $u = $k * $j * $j;

            if ($n + $u > 0) {
                if (my $e = is_power($n + $u)) {
                    my $r = Math::GMPz->new(rootint($n + $u, $e));
                    return $f->($r, $e, $j);
                }
            }
        }
    }

    return $n;
}

if (@ARGV) {
    say join ', ', near_power_factorization($ARGV[0], defined($ARGV[1]) ? $ARGV[1] : ());
    exit;
}

say join ' * ', near_power_factorization(powint(2,  256) - 1);
say join ' * ', near_power_factorization(powint(10, 120) + 1);
say join ' * ', near_power_factorization(powint(10, 120) - 1);
say join ' * ', near_power_factorization(powint(10, 120) - 25);
say join ' * ', near_power_factorization(powint(10, 105) - 1);
say join ' * ', near_power_factorization(powint(10, 105) + 1);
say join ' * ', near_power_factorization(powint(10, 120) - 2134 * 2134);

__END__
3 * 5 * 17 * 257 * 65537 * 4294967297 * 18446744073709551617 * 340282366920938463463374607431768211457
100000001 * 9999999900000001 * 99999999000000009999999900000001 * 10000000099999999999999989999999899999999000000000000000100000001
3 * 9 * 11 * 37 * 91 * 101 * 9091 * 9901 * 10001 * 11111 * 90090991 * 99009901 * 99990001 * 109889011 * 9999000099990001 * 10099989899000101 * 100009999999899989999000000010001
3 * 5 * 5 * 29 * 2298850574712643678160919540229885057471264367816091954023 * 199999999999999999999999999999999999999999999999999999999999
9 * 111 * 11111 * 1111111 * 90090991 * 900900990991 * 900009090090909909099991 * 1109988789001111109989898989900111110998878900111
11 * 91 * 9091 * 909091 * 769223077 * 156985855573 * 1099988890111109888900011 * 910009191000909089989898989899909091000919100091
3 * 7 * 7 * 36 * 61 * 167280026764804282368685178989628638340582134493141518903 * 18518518518518518518518518518518518518518518518518518518479


================================================
FILE: Math/newton_s_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 01 October 2016
# Website: https://github.com/trizen

# Approximate nth-roots using Newton's method.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload);

sub nth_root {
    my ($n, $x) = @_;

    my $eps = 10**-($Math::AnyNum::PREC >> 2);

    my $r = 0.0;
    my $m = 1.0;

    while (abs($m - $r) > $eps) {
        $r = $m;
        $m = (($n - 1) * $r + $x / $r**($n - 1)) / $n;
    }

    $r;
}

say nth_root(2,  2);
say nth_root(3,  125);
say nth_root(7,  42**7);
say nth_root(42, 987**42);


================================================
FILE: Math/newton_s_method_recursive.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 18 July 2016
# Website: https://github.com/trizen

# Newton's method -- recursive

# x^(1/n) = f(k)    ; with k -> infinity.

# where f(k) is defined as:
# | f(1) = 1
# | f(k) = (f(k-1) * (n-1) + x / f(k-1)^(n-1)) / n

# Alternatively, f(k) can be defined as:
#  | f(1) = 1
#  | f(k) = (1 - 1/n) * f(k-1) + x / (n * f(k-1)^(n-1))

use 5.016;

sub nth_root {
    my ($n, $x, $k) = @_;

    my $p = $n - 1;

    sub {
        my $f = (
                 $_[0] > 1
                 ? __SUB__->($_[0] - 1)
                 : return 1
                );

        ($f * $p + $x / $f**$p) / $n;
      }
      ->($k);
}

say nth_root(2, 2,    100);    # square root of 2
say nth_root(3, 27,   100);    # third root of 27
say nth_root(3, 125,  100);    # third root of 125
say nth_root(5, 3125, 100);    # fifth root of 3125


================================================
FILE: Math/next_palindrome.pl
================================================
#!/usr/bin/perl

# A nice algorithm, due to David A. Corneth (Jun 06 2014), for generating the next palindrome from a given palindrome.

# See also:
#   https://oeis.org/A002113
#   https://en.wikipedia.org/wiki/Palindromic_number

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub next_palindrome ($n) {

    my @d = split(//, $n);
    my $l = $#d;
    my $i = ((scalar(@d) + 1) >> 1) - 1;

    while ($i >= 0 and $d[$i] == 9) {
        $d[$i] = 0;
        $d[$l - $i] = 0;
        $i--;
    }

    if ($i >= 0) {
        $d[$i]++;
        $d[$l - $i] = $d[$i];
    }
    else {
        @d = (0) x (scalar(@d) + 1);
        $d[0]  = 1;
        $d[-1] = 1;
    }

    join('', @d);
}

my $n = 1;
for (1 .. 100) {    # first 100 palindromes
    print("$n, ");
    $n = next_palindrome($n);
}
say "\n";

say next_palindrome(99977999);      #=> 99988999
say next_palindrome(99988999);      #=> 99999999
say next_palindrome(99999999);      #=> 100000001

say '';

say next_palindrome("51818186768181815");    #=> 51818186868181815
say next_palindrome("51818186868181815");    #=> 51818186968181815
say next_palindrome("51818186968181815");    #=> 51818187078181815


================================================
FILE: Math/next_palindrome_from_non-palindrome.pl
================================================
#!/usr/bin/perl

# Generate the next palindrome in a given base, where the input number may not be a palindrome.
# Algorithm by David A. Corneth (Jun 06 2014), with extensions by Daniel Suteu (Jun 06 2020).

# See also:
#   https://oeis.org/A002113
#   https://en.wikipedia.org/wiki/Palindromic_number

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);
use Test::More tests => 41;

sub next_palindrome ($n, $base = 10) {

    my @d = todigits($n, $base);
    my $l = $#d;
    my $i = ((scalar(@d) + 1) >> 1) - 1;

    my $is_palindrome = 1;

    foreach my $j (0 .. $i) {
        if ($d[$j] != $d[$l - $j]) {
            $is_palindrome = 0;
            last;
        }
    }

    if (!$is_palindrome) {
        my @copy = @d;

        foreach my $i (0 .. $i) {
            $d[$l - $i] = $d[$i];
        }

        my $is_greater = 1;

        foreach my $j (0 .. $i) {
            my $cmp = $d[$i + $j + 1] <=> $copy[$i + $j + 1];

            if ($cmp > 0) {
                last;
            }
            if ($cmp < 0) {
                $is_greater = 0;
                last;
            }
        }

        if ($is_greater) {
            return fromdigits(\@d, $base);
        }
    }

    while ($i >= 0 and $d[$i] == $base - 1) {
        $d[$i] = 0;
        $d[$l - $i] = 0;
        $i--;
    }

    if ($i >= 0) {
        $d[$i]++;
        $d[$l - $i] = $d[$i];
    }
    else {
        @d     = (0) x (scalar(@d) + 1);
        $d[0]  = 1;
        $d[-1] = 1;
    }

    fromdigits(\@d, $base);
}

#
## Run some tests
#

my @palindromes = do {
    my $x = 0;
    my @list;
    for (1 .. 61) {
        push @list, $x;
        $x = next_palindrome($x);
    }
    @list;
};

is_deeply(
          \@palindromes,
          [0,   1,   2,   3,   4,   5,   6,   7,   8,   9,   11,  22,  33,  44,  55,  66,  77,  88,  99,  101, 111, 121,
           131, 141, 151, 161, 171, 181, 191, 202, 212, 222, 232, 242, 252, 262, 272, 282, 292, 303, 313, 323, 333, 343,
           353, 363, 373, 383, 393, 404, 414, 424, 434, 444, 454, 464, 474, 484, 494, 505, 515
          ]
         );

is(next_palindrome(10),    11);
is(next_palindrome(11),    22);
is(next_palindrome(12),    22);
is(next_palindrome(110),   111);
is(next_palindrome(111),   121);
is(next_palindrome(112),   121);
is(next_palindrome(120),   121);
is(next_palindrome(121),   131);
is(next_palindrome(1234),  1331);
is(next_palindrome(12345), 12421);

is(next_palindrome(8887),  8888);
is(next_palindrome(8888),  8998);
is(next_palindrome(8889),  8998);
is(next_palindrome(88887), 88888);
is(next_palindrome(88888), 88988);
is(next_palindrome(88889), 88988);
is(next_palindrome(9998),  9999);
is(next_palindrome(99998), 99999);
is(next_palindrome(9999),  10001);
is(next_palindrome(99999), 100001);

is(next_palindrome(12311), 12321);
is(next_palindrome(1321),  1331);
is(next_palindrome(1331),  1441);
is(next_palindrome(13530), 13531);
is(next_palindrome(13520), 13531);
is(next_palindrome(13521), 13531);
is(next_palindrome(13530), 13531);
is(next_palindrome(13531), 13631);
is(next_palindrome(13540), 13631);
is(next_palindrome(13532), 13631);

is(next_palindrome(1234, 2), 1241);
is(next_palindrome(1234, 3), 1249);
is(next_palindrome(1234, 4), 1265);
is(next_palindrome(1234, 5), 1246);
is(next_palindrome(1234, 6), 1253);

is(next_palindrome(12345, 2), 12483);
is(next_palindrome(12345, 3), 12382);
is(next_palindrome(12345, 4), 12355);
is(next_palindrome(12345, 5), 12348);
is(next_palindrome(12345, 6), 12439);


================================================
FILE: Math/next_palindrome_in_base.pl
================================================
#!/usr/bin/perl

# A nice algorithm, due to David A. Corneth (Jun 06 2014), for generating the next palindrome from a given palindrome.

# Generalized to other bases by Daniel Suteu (Sep 16 2019).

# See also:
#   https://oeis.org/A002113
#   https://en.wikipedia.org/wiki/Palindromic_number

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub next_palindrome ($n, $base = 10) {

    my @d = todigits($n, $base);
    my $l = $#d;
    my $i = ((scalar(@d) + 1) >> 1) - 1;

    while ($i >= 0 and $d[$i] == $base - 1) {
        $d[$i] = 0;
        $d[$l - $i] = 0;
        $i--;
    }

    if ($i >= 0) {
        $d[$i]++;
        $d[$l - $i] = $d[$i];
    }
    else {
        @d     = (0) x (scalar(@d) + 1);
        $d[0]  = 1;
        $d[-1] = 1;
    }

    fromdigits(\@d, $base);
}

foreach my $base (2 .. 12) {
    my @a = do {
        my $n = 1;
        map { $n = next_palindrome($n, $base) } 1 .. 20;
    };
    say "base = $base -> [@a]";
}

__END__
base = 2 -> [3 5 7 9 15 17 21 27 31 33 45 51 63 65 73 85 93 99 107 119]
base = 3 -> [2 4 8 10 13 16 20 23 26 28 40 52 56 68 80 82 91 100 112 121]
base = 4 -> [2 3 5 10 15 17 21 25 29 34 38 42 46 51 55 59 63 65 85 105]
base = 5 -> [2 3 4 6 12 18 24 26 31 36 41 46 52 57 62 67 72 78 83 88]
base = 6 -> [2 3 4 5 7 14 21 28 35 37 43 49 55 61 67 74 80 86 92 98]
base = 7 -> [2 3 4 5 6 8 16 24 32 40 48 50 57 64 71 78 85 92 100 107]
base = 8 -> [2 3 4 5 6 7 9 18 27 36 45 54 63 65 73 81 89 97 105 113]
base = 9 -> [2 3 4 5 6 7 8 10 20 30 40 50 60 70 80 82 91 100 109 118]
base = 10 -> [2 3 4 5 6 7 8 9 11 22 33 44 55 66 77 88 99 101 111 121]
base = 11 -> [2 3 4 5 6 7 8 9 10 12 24 36 48 60 72 84 96 108 120 122]
base = 12 -> [2 3 4 5 6 7 8 9 10 11 13 26 39 52 65 78 91 104 117 130]


================================================
FILE: Math/next_power_of_two.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 25 December 2012
# https://github.com/trizen

sub next_power_of_two {
    return 2 << log($_[0]) / log(2);
}

for my $i (1, 31, 55, 129, 446, 9924) {
    print next_power_of_two($i), "\n";
}


================================================
FILE: Math/nth_composite.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 December 2019
# https://github.com/trizen

# Compute the n-th composite number and the number of composite numbers <= n.

# See also:
#   https://oeis.org/A002808 -- The composite numbers: numbers n of the form x*y for x > 1 and y > 1.
#   https://oeis.org/A065857 -- The (10^n)-th composite number.

use 5.020;
use warnings;
use ntheory qw(:all);
use experimental qw(signatures);

sub composite_count($n) {
    $n - prime_count($n) - 1;
}

sub nth_composite($n) {

    return undef if ($n <= 0);
    return 4     if ($n == 1);

    # Lower and upper bounds from A002808 (for n >= 4).
    my $min = int($n + $n / log($n) + $n / (log($n)**2));
    my $max = int($n + $n / log($n) + (3 * $n) / (log($n)**2));

    if ($n < 4) {
        $min = 4;
        $max = 8;
    }

    my $k = 0;

    while (1) {
        $k = ($min + $max) >> 1;

        my $cmp = ($k - prime_count($k) - 1) <=> $n;

        if ($cmp > 0) {
            $max = $k - 1;
        }
        elsif ($cmp < 0) {
            $min = $k + 1;
        }
        else {
            last;
        }
    }

    --$k if is_prime($k);

    return $k;
}

say nth_composite(1000000000);      #=> 1053422339
say composite_count(1053422339);    #=> 1000000000


================================================
FILE: Math/nth_digit_of_fraction.pl
================================================
#!/usr/bin/perl

# An efficient formula for computing the n-th decimal digit of a given fraction expression x/y.

# Formula from:
#   https://stackoverflow.com/questions/804934/getting-a-specific-digit-from-a-ratio-expansion-in-any-base-nth-digit-of-x-y

# See also:
#   https://projecteuler.net/problem=820

use 5.036;
use ntheory qw(:all);

sub nth_digit_of_fraction($n, $x, $y, $base = 10) {
    divint($base * powmod($base, $n - 1, $y) * $x, $y) % $base;
}

say vecsum(map { nth_digit_of_fraction(7,   1, $_) } 1 .. 7);      #=> 10
say vecsum(map { nth_digit_of_fraction(100, 1, $_) } 1 .. 100);    #=> 418


================================================
FILE: Math/nth_prime_approx.pl
================================================
#!/usr/bin/perl

# A messy, but interesting approximation for the nth-prime.

# Formulas from:
#   https://stackoverflow.com/a/9487883/1063770

use 5.010;
use strict;
use warnings;

use ntheory qw(nth_prime);

my $sum1 = 0;
my $sum2 = 0;

for (my $n = 1e6 ; $n < 1e7 ; $n += 1e6) {
    my $p = nth_prime($n);

    # more than good approximation (experimental)
    my $p1 = int(
         1 / 2 * (
             3 - (8 + log(2.3)) * $n - $n**2 + 1 / 2 * (
                            -1 + abs(
                                -(1 / 2) + $n + sqrt(
                                    log(log($n) / log(2)) *
                                      (-log(log(2)) + log(log($n)) + (8 * log(3) * log(($n * log(8 * $n)) / log($n))) / log(2))
                                  ) / (2 * log(log(($n * log(8 * $n)) / log($n)) / log(2)))
                              ) + abs(log($n) / log(3) + log(log(($n * log(8 * $n)) / log($n)) / log(2)) / log(2))
               ) * (
                 2 * abs(log(($n * log(8 * $n)) / log($n)) / log(3) + log(log(($n * log(8 * $n)) / log($n)) / log(2)) / log(2))
                   + abs(
                         1 / log(log($n) / log(2)) * (
                                 log(log(3)) - log(log($n)) + 2 * $n * log(log($n) / log(2)) + sqrt(
                                     ((8 * log(3) * log($n)) / log(2) - log(log(2)) + log(log(($n * log(8 * $n)) / log($n)))) *
                                       log(log(($n * log(8 * $n)) / log($n)) / log(2))
                                 )
                         )
                        )
                   )
                 )
                );

    # good approximation
    my $p2 = int(
                 1 / 2 * (
                     8 - 8.7 * $n - $n**2 + 1 / 2 * (
                         2 * abs(log($n) / log(3) + log(log($n) / log(2)) / log(2)) + abs(
                             (
                              log(log(3)) -
                                log(log($n)) +
                                2 * $n * log(log($n) / log(2)) +
                                sqrt(((8 * log(3) * log($n)) / log(2) - log(log(2)) + log(log($n))) * log(log($n) / log(2)))
                             ) / log(log($n) / log(2))
                         )
                       ) * (
                           -1 + abs(log($n) / log(3) + log(log($n) / log(2)) / log(2)) + abs(
                               -(1 / 2) +
                                 $n +
                                 sqrt(((8 * log(3) * log($n)) / log(2) - log(log(2)) + log(log($n))) * log(log($n) / log(2))) /
                                 (2 * log(log($n) / log(2)))
                           )
                       )
                 )
                );

    $sum1 += $p / $p1;
    $sum2 += $p / $p2;

    say "P($n) -> ",join(" ", sprintf("%10s" x 3, $p, $p1, $p2), "\t", sprintf("%.5f", $p / $p1), sprintf("%.5f", $p / $p2));
}

say "P1 error: $sum1";
say "P2 error: $sum2";

__END__
        29        36        29   0.80556 1.00000
  15486041  15457742  15439431   1.00183 1.00302
  32453039  32433008  32405572   1.00062 1.00146
  49979893  49975183  49941439   1.00009 1.00077
  67868153  67884333  67846000   0.99976 1.00033
  86028343  86065798  86024104   0.99956 1.00005
 104395451 104463936 104419831   0.99934 0.99977
 122950039 123042040 122996293   0.99925 0.99962
 141651127 141774052 141727310   0.99913 0.99946
 160481437 160640508 160593326   0.99901 0.99930

P1 error: 9.80416402659991
P2 error: 10.0037856546587


================================================
FILE: Math/nth_root_good_rational_approximations.pl
================================================
#!/usr/bin/perl

# Formula for computing good rational approximations to the n-th root of a number.

# See also:
#   https://www.mathpages.com/home/kmath434.htm

use 5.014;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload iroot sum binomial);

sub f ($N, $r) {

    my $m = iroot($N, $r);
    my $R = $N - $m**$r;

    my @s = ((0) x ($r - 1), 1);

    return (
        $m, $R,
        sub ($n) {
            $s[$n] //= sum(map { my $j = $_; binomial($r, $j) * $m**($r - $j) * $R**($j - 1) * $s[$n - $j] } 1 .. $r);
        }
    );
}

my ($m, $R, $g) = f(10, 3);     # approximations for 10^(1/3)

foreach my $n (1 .. 20) {

    my $x = $g->($n);
    my $y = $g->($n + 1);

    my $t = ($m + $R * $x / $y);

    printf("%20s / %-20s =~ %s\n", $t->nude, $t->as_dec);
}

__END__
                   2 / 1                    =~ 2
                  13 / 6                    =~ 2.16666666666666666666666666666666666666666666667
                  28 / 13                   =~ 2.15384615384615384615384615384615384615384615385
                1088 / 505                  =~ 2.15445544554455445544554455445544554455445544554
                1409 / 654                  =~ 2.1544342507645259938837920489296636085626911315
                7603 / 3529                 =~ 2.15443468404647208841031453669594786058373476906
              590774 / 274213               =~ 2.15443469128013624445230532469284826029400502529
             3825397 / 1775592              =~ 2.15443468995129511734677786338302943468995129512
             2752258 / 1277485              =~ 2.15443469003549943834956966226609314395080959855
            64157404 / 29779229             =~ 2.15443469003176677273948227470899263375824807284
          2077169449 / 964136652            =~ 2.1544346900318856460193985032735795215883982388
          1120845673 / 520250476            =~ 2.15443469003188379591218288476875896217344354722
        174185580626 / 80849784601          =~ 2.1544346900318837127732819746711696004361257185
       1127891541661 / 523520878530         =~ 2.15443469003188372228223079040300983199070198122
        486890409328 / 225994508713         =~ 2.1544346900318837217374632236690845669751527933
      94581808509632 / 43900986624121       =~ 2.15443469003188372175993267421075826039322542243
     612438879438973 / 284268946407426      =~ 2.15443469003188372175928686483574181826893273791
       5954477565019 / 2763823657579        =~ 2.15443469003188372175929288136249910595910099978
   51357399784775318 / 23837993336440045    =~ 2.15443469003188372175929362914637034425598873999
   66510185987581361 / 30871293660146676    =~ 2.15443469003188372175929356318484885473783216603


================================================
FILE: Math/nth_root_recurrence_constant.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 May 2016
# Website: https://github.com/trizen

# Compute the nth root recurrence constant (n * (n * (n * (n * ...)^(1/4))^(1/3))^(1/2))
# See also: https://en.wikipedia.org/wiki/Somos%27_quadratic_recurrence_constant

use 5.010;
use strict;

sub root_const {
    my ($n, $limit) = @_;
    $limit > 0 ? ($n * root_const($n+1, $limit-1))**(1/$n) : 1;
}

say root_const(1, 30000);


================================================
FILE: Math/nth_smooth_number.pl
================================================
#!/usr/bin/perl

# Generate the n-th smooth number that is the product of a given subset of primes.

# See also:
#   https://en.wikipedia.org/wiki/Smooth_number

use 5.020;
use warnings;

use ntheory qw(vecmin);
use experimental qw(signatures);

sub smooth_generator ($primes) {

    my @s = map { [1] } @$primes;

    sub {
        my $n = vecmin(map { $_->[0] } @s);

        for my $i (0..$#$primes) {
            shift(@{$s[$i]}) if ($s[$i][0] == $n);
            push(@{$s[$i]}, $n*$primes->[$i]);
        }
        return $n;
    };
}

sub nth_smooth_number($n, $primes) {
    my $g = smooth_generator($primes);
    $g->() for (1..$n-1);
    $g->();
}

say nth_smooth_number( 12, [2,7,13,19]);
say nth_smooth_number( 25, [2,5,7,11,13,23,29,31,53,67,71,73,79,89,97,107,113,127,131,137]);
say 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]);


================================================
FILE: Math/number2expression.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 02 May 2022
# https://github.com/trizen

# Compress a number into a polynomial expression in a given base.

use 5.020;
use strict;
use warnings;

use Math::Sidef qw(Polynomial Number sum);
use Math::AnyNum qw(:overload digits);
use Getopt::Long qw(GetOptions);

use ntheory qw(vecsum todigits);
use experimental qw(signatures);

sub run_length ($arr, $max_len = 1e9) {

    @$arr || return;

    my @result     = ([$arr->[0], 1]);
    my $prev_value = $arr->[0];

    foreach my $i (1 .. $#{$arr}) {

        my $curr_value = $arr->[$i];

        if ($curr_value == $prev_value) {
            ++$result[-1][1];
        }
        else {
            push(@result, [$curr_value, 1]);

            # Stop early when there are too many entries
            if (scalar(@result) > $max_len) {
                return @result;
            }
        }

        $prev_value = $curr_value;
    }

    return @result;
}

sub number2runLength ($n, $base = 10, $max_len = 1e9) {
    my @D = ($base < 2147483647) ? todigits($n, $base) : reverse(digits($n, $base));
    my $t = scalar(@D);
    my @R = run_length(\@D, $max_len);
    return \@R;
}

sub number2expr ($R, $base = 10) {

    my $t = vecsum(map { $_->[1] } @$R);

    my @terms;

    foreach my $pair (@$R) {
        my ($d, $l) = @$pair;
        $t -= $l;
        push @terms,
          (
            ($l == 1)
            ? Polynomial($t => $d)
            : Polynomial($l)->sub(Number(1))->div(Number($base - 1))->mul(Polynomial($t => $d))
          );
    }

    my $str = sum(@terms)->to_s;
    ## $str =~ s/x/$base/g;
    return $str;
}

sub number2expr_alt ($R, $base = 10) {

    my $t = vecsum(map { $_->[1] } @$R);

    my @terms;

    foreach my $pair (@$R) {
        my ($d, $l) = @$pair;
        $t -= $l;
        push @terms, Polynomial($l)->sub(Number(1))->mul(Polynomial($t => $d));
    }

    my $sum = sum(@terms);

    my $str = $sum->to_s;
    if ($base != 2) {
        $str = "($str)/" . ($base - 1);
    }

    ## $str =~ s/x/$base/g;
    return $str;
}

sub compress_number ($n, $from = 2, $upto = 100, $integer_coeff = 0) {

    my $min_runLength = [];
    my $min_base      = 0;
    my $min_len       = 1e9;

    foreach my $base ($from .. $upto) {

        my $R = number2runLength($n, $base, $min_len);

        if (scalar(@$R) < $min_len) {
            $min_len       = scalar(@$R);
            $min_base      = $base;
            $min_runLength = $R;
            last if ($min_len == 1);
        }
    }

    my $min_expr     = '';
    my $min_expr_len = 1e9;

    foreach my $base ($min_base) {
        my @list;

        push(@list, number2expr($min_runLength, $base)) if !$integer_coeff;
        push(@list, number2expr_alt($min_runLength, $base));

        foreach my $expr (@list) {

            if (length($expr) < $min_expr_len) {
                $min_expr     = $expr;
                $min_expr_len = length($expr);
            }
        }
    }

    $min_expr =~ s/x/$min_base/gr;
}

sub help {
    print <<"EOT";
usage: $0 [options] [integer]

options:

    -f  --from=i     : first base to check
    -t  --to=i       : last base to check
    -i  --int!       : prefer integer coefficients
    -b  --base=i     : use only this specific base

example:

    perl number2expr.pl 123123123
    perl number2expr.pl -i -b=1000 123123123
    perl number2expr.pl -from=900 -to=1200 123123123
    perl number2expr.pl -i -from=900 -to=1200 123123123
EOT

    exit 0;
}

my $base          = undef;
my $from          = 2;
my $upto          = 1000;
my $integer_coeff = 0;

GetOptions(
           'b|base=i' => \$base,
           'from=i'   => \$from,
           'to=i'     => \$upto,
           'i|int!'   => \$integer_coeff,
           'h|help'   => \&help,
          )
  or die("Error in command line arguments\n");

foreach my $n (@ARGV) {

    if (defined($base)) {
        if ($integer_coeff) {
            say number2expr_alt(number2runLength($n, $base), $base);
        }
        else {
            say number2expr(number2runLength($n, $base), $base);
        }
        next;
    }

    say compress_number($n, $from, $upto, $integer_coeff);
}

if (!@ARGV) {

#<<<
    my @tests = (
        [0b100000100000111111101, 2],
        [(7**911 - 4 * (7**455) - 1), 7],
        [11113338888999999999, 10],
    );
#>>>

    foreach my $pair (@tests) {
        my ($n, $b) = @$pair;
        say("base $b: ", number2expr(number2runLength($n, $b), $b));
        say("base $b: ", number2expr_alt(number2runLength($n, $b), $b));
        say '';
    }
}

__END__
base 2: x^20 + x^14 + x^9 - x^2 + 1
base 2: x^21 - x^20 + x^15 - x^14 + x^9 - x^2 + x - 1

base 7: x^911 - x^456 + 3*x^455 - 1
base 7: (6*x^911 - 4*x^456 + 4*x^455 - 6)/6

base 10: 1/9*x^20 + 2/9*x^16 + 5/9*x^13 + 1/9*x^9 - 1
base 10: (x^20 + 2*x^16 + 5*x^13 + x^9 - 9)/9


================================================
FILE: Math/number_of_conditional_GCDs.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 July 2018
# https://github.com/trizen

# Find the number of k = 1..n for which GCD(n,k) satisfies a certain condition (e.g.:
# GCD(n,k) is a prime number), using the divisors of `n` and the Euler totient function.

# See also:
#   https://oeis.org/A117494 -- Number of k = 1..n for which GCD(n, k) is a prime
#   https://oeis.org/A116512 -- Number of k = 1..n for which GCD(n, k) is a power of a prime
#   https://oeis.org/A206369 -- Number of k = 1..n for which GCD(n, k) is a square
#   https://oeis.org/A078429 -- Number of k = 1..n for which GCD(n, k) is a cube
#   https://oeis.org/A063658 -- Number of k = 1..n for which GCD(n, k) is divisible by a square greater than 1

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(divisors euler_phi is_prime is_square is_prime_power factorial);

sub conditional_euler_totient ($n, $condition) {

    my $count = 0;

    foreach my $d (divisors($n)) {
        if ($condition->($d)) {
            $count += euler_phi($n / $d);
        }
    }

    return $count;
}

say "Number of values of k with 1 <= k <= n such that gcd(n, k) is a prime number";
say conditional_euler_totient(factorial(10), sub ($d) { is_prime($d) });    # 995328
say conditional_euler_totient(factorial(11), sub ($d) { is_prime($d) });    # 10782720
say conditional_euler_totient(factorial(12), sub ($d) { is_prime($d) });    # 129392640

say '';

say "Number of values of k with 1 <= k <= n such that gcd(n, k) is a square";
say conditional_euler_totient(factorial(10), sub ($d) { is_square($d) });    # 1314306
say conditional_euler_totient(factorial(11), sub ($d) { is_square($d) });    # 13143060
say conditional_euler_totient(factorial(12), sub ($d) { is_square($d) });    # 156625560

say '';

say "Number of values of k with 1 <= k <= n such that gcd(n, k) is a prime power";
say conditional_euler_totient(factorial(10), sub ($d) { is_prime_power($d) });    # 1589760
say conditional_euler_totient(factorial(11), sub ($d) { is_prime_power($d) });    # 16727040
say conditional_euler_totient(factorial(12), sub ($d) { is_prime_power($d) });    # 200724480


================================================
FILE: Math/number_of_connected_permutations.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 December 2017
# https://github.com/trizen

# A new algorithm for computing number of connected permutations of [1..n].

# See also:
#   https://oeis.org/A003319

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload factorial binomial);

sub number_of_connected_permutations {
    my ($n) = @_;

    my @P = (1);

    foreach my $i (1 .. $n) {
        foreach my $k (0 .. $i - 1) {
            $P[$i] += $P[$k] / binomial($i, $k+1);
        }
    }

    map { $P[$_] * factorial($_) } 0 .. $#P;
}

my @P = number_of_connected_permutations(20);

foreach my $i (0 .. $#P) {
    say "P($i) = $P[$i]";
}

__END__
P(0) = 1
P(1) = 1
P(2) = 3
P(3) = 13
P(4) = 71
P(5) = 461
P(6) = 3447
P(7) = 29093
P(8) = 273343
P(9) = 2829325
P(10) = 31998903
P(11) = 392743957
P(12) = 5201061455
P(13) = 73943424413
P(14) = 1123596277863
P(15) = 18176728317413
P(16) = 311951144828863
P(17) = 5661698774848621
P(18) = 108355864447215063
P(19) = 2181096921557783605
P(20) = 46066653228356851631


================================================
FILE: Math/number_of_partitions_into_2_distinct_positive_cubes.pl
================================================
#!/usr/bin/perl

# Count the number of partitions of n into 2 distinct positive cubes.

# See also:
#   https://oeis.org/A025468
#   https://cs.uwaterloo.ca/journals/JIS/VOL6/Broughan/broughan25.pdf

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

# Number of solutions to `n = a^3 + b^3, with 0 < a < b.
sub r2_cubes_positive_distinct ($n) {

    my $count = 0;

    foreach my $d (divisors($n)) {

        my $l = $d*$d - $n/$d;
        ($l % 3 == 0) || next;
        my $t = $d*$d - 4*($l/3);

        if ($d*$d*$d >= $n and $d*$d*$d <= 4 * $n and $l >= 3 and $t > 0 and is_square($t)) {
            ++$count;
        }
    }

    return $count;
}

foreach my $n (1 .. 100) {
    print(r2_cubes_positive_distinct($n), ", ");
}

__END__
0, 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


================================================
FILE: Math/number_of_partitions_into_2_distinct_positive_squares.pl
================================================
#!/usr/bin/perl

# Count the number of partitions of n into 2 distinct nonzero squares.

# See also:
#   https://oeis.org/A025441
#   https://mathworld.wolfram.com/SumofSquaresFunction.html
#   https://en.wikipedia.org/wiki/Fermat%27s_theorem_on_sums_of_two_squares

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(:all);

# Number of solutions to `n = a^2 + b^2, with 0 < a < b.
sub r2_positive_distinct ($n) {

    my $B = 1;

    foreach my $p (factor_exp($n)) {

        my $r = $p->[0] % 4;

        if ($r == 3) {
            $p->[1] % 2 == 0 or return 0;
        }

        if ($r == 1) {
            $B *= $p->[1] + 1;
        }
    }

    return ($B >> 1);
}

foreach my $n(1..100) {
    print(r2_positive_distinct($n), ", ");
}


================================================
FILE: Math/number_of_partitions_into_2_nonnegative_cubes.pl
================================================
#!/usr/bin/perl

# Count the number partitions of n into 2 nonnegative cubes.

# See also:
#   https://oeis.org/A025446
#   https://cs.uwaterloo.ca/journals/JIS/VOL6/Broughan/broughan25.pdf

use 5.020;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub r2_cubes_partitions($n) {

    my $L = rootint($n-1, 3) + 1;
    my $U = rootint(4*$n, 3);

    my $count = 0;

    foreach my $m (divisors($n)) {
        if ($L <= $m and $m <= $U) {
            my $l = $m*$m - $n/$m;
            $l % 3 == 0 or next;
            $l /= 3;
            is_square($m*$m - 4*$l) && ++$count;
        }
    }

    return $count;
}

foreach my $n (1 .. 100) {
    print(r2_cubes_partitions($n), ", ");
}

__END__
1, 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,


================================================
FILE: Math/number_of_partitions_into_2_positive_squares.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 September 2019
# https://github.com/trizen

# Count the number of representations of n as the sum of two non-zero squares, ignoring order and signs (not necesarily distinct).

# See also:
#   https://oeis.org/A025426 -- Number of partitions of n into 2 nonzero squares.
#   https://oeis.org/A000161 -- Number of partitions of n into 2 squares.
#   https://mathworld.wolfram.com/SumofSquaresFunction.html
#   https://en.wikipedia.org/wiki/Fermat%27s_theorem_on_sums_of_two_squares

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(divisors valuation factor_exp vecsum vecprod);

# Number of solutions to `n = a^2 + b^2, with 0 < a <= b.
sub r2_positive($n) {

    my $B  = 1;
    my $a0 = 0;

    if ($n % 2 == 0) {
        $a0 = valuation($n, 2);
        $n >>= $a0;
    }

    foreach my $p (factor_exp($n)) {

        my $r = $p->[0] % 4;

        if ($r == 3) {
            $p->[1] % 2 == 0 or return 0;
        }

        if ($r == 1) {
            $B *= $p->[1] + 1;
        }
    }

    ($B % 2 == 0) ? ($B >> 1) : (($B - (-1)**$a0) >> 1);
}

foreach my $n (1 .. 100) {
    print(r2_positive($n), ", ");
}

__END__
0, 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,


================================================
FILE: Math/number_of_representations_as_sum_of_3_triangles.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 02 March 2018
# https://github.com/trizen

# Compute the number of ordered ways of writing `n` as the sum of 3 triangular numbers.

# See also:
#   https://oeis.org/A008443
#   https://projecteuler.net/problem=621

use 5.020;
use strict;
use warnings;

use ntheory qw(factor_exp);
use experimental qw(signatures);

sub count_sums_of_two_squares ($n) {

    my $count = 4;

    foreach my $p (factor_exp($n)) {

        my $r = $p->[0] % 4;

        if ($r == 3) {
            $p->[1] % 2 == 0 or return 0;
        }

        if ($r == 1) {
            $count *= $p->[1] + 1;
        }
    }

    return $count;
}

sub count_triangular_sums ($n) {

    my $count = 0;
    my $limit = (sqrt(8 * $n + 1) - 1) / 2;

    for my $u (0 .. $limit) {
        my $z = ($n - $u * ($u + 1) / 2) * 8 + 1;
        $count += count_sums_of_two_squares($z + 1);
    }

    return $count / 4;
}

say count_triangular_sums(10**6);           #=> 2106
say count_triangular_sums(10**9);           #=> 62760
say count_triangular_sums(31415926535);     #=> 263556


================================================
FILE: Math/number_of_representations_as_sum_of_four_squares.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 October 2017
# https://github.com/trizen

# Counting the number of representations for a given number `n` expressed as the sum of four squares.

# Formula:
#   R(n) = 8 * Sum_{d | n, d != 0 (mod 4)} d

# See also:
#   https://oeis.org/A000118
#   https://en.wikipedia.org/wiki/Lagrange's_four-square_theorem

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(is_prime divisor_sum);

sub count_representations_as_four_squares($n) {

    my $count = 8 * divisor_sum($n);

    if ($n % 4 == 0) {
        $count -= 32 * divisor_sum($n >> 2);
    }

    return $count;
}

foreach my $n (1 .. 20) {
    say "R($n) = ", count_representations_as_four_squares($n);
}

__END__
R(1) = 8
R(2) = 24
R(3) = 32
R(4) = 24
R(5) = 48
R(6) = 96
R(7) = 64
R(8) = 24
R(9) = 104
R(10) = 144
R(11) = 96
R(12) = 96
R(13) = 112
R(14) = 192
R(15) = 192
R(16) = 24
R(17) = 144
R(18) = 312
R(19) = 160
R(20) = 144


================================================
FILE: Math/number_of_representations_as_sum_of_two_squares.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 October 2017
# https://github.com/trizen

# Counting the number of representations for a given number `n` expressed as the sum of two squares.

# Formula:
#   R(n) = 4 * Prod_{ p^k|n, p = 1 (mod 4) } (k + 1)

# See also:
#   https://oeis.org/A004018
#   https://en.wikipedia.org/wiki/Fermat%27s_theorem_on_sums_of_two_squares

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(divisors valuation factor_exp vecsum vecprod);

sub r2($n) {

    my $count = 4;
    foreach my $p (factor_exp($n)) {

        my $r = $p->[0] % 4;

        if ($r == 3) {
            $p->[1] % 2 == 0 or return 0;
        }

        if ($r == 1) {
            $count *= $p->[1] + 1;
        }
    }

    return $count;
}

foreach my $n (1 .. 30) {
    my $count = r2($n);

    if ($count != 0) {
        say "R($n) = $count";
    }
}

__END__
R(1) = 4
R(2) = 4
R(4) = 4
R(5) = 8
R(8) = 4
R(9) = 4
R(10) = 8
R(13) = 8
R(16) = 4
R(17) = 8
R(18) = 4
R(20) = 8
R(25) = 12
R(26) = 8
R(29) = 8


================================================
FILE: Math/number_to_digits_subquadratic_algorithm.pl
================================================
#!/usr/bin/perl

# Subquadratic algorithm for converting a given integer into a list of digits in a given base.

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub FastIntegerOutput ($A, $B) {

    if ($A < $B) {
        return $A;
    }

    # Find k such that B^(2k - 2) <= A < B^(2k)
    my $k = (logint($A, $B) >> 1) + 1;

    my ($Q, $R) = divrem($A, powint($B, $k));
    my @r = __SUB__->($R, $B);

    (__SUB__->($Q, $B), (0) x ($k - scalar(@r)), @r);
}

foreach my $B (2 .. 100) {    # run some tests
    my $N = factorial($B);    # int(rand(~0));

    my @a = todigits($N, $B);
    my @b = FastIntegerOutput($N, $B);

    if ("@a" ne "@b") {
        die "Error for FastIntegerOutput($N, $B): (@a) != (@b)";
    }
}

say join ', ', FastIntegerOutput(5040, 10);    #=> 5, 0, 4, 0
say join ', ', FastIntegerOutput(5040, 11);    #=> 3, 8, 7, 2
say join ', ', FastIntegerOutput(5040, 12);    #=> 2, 11, 0, 0
say join ', ', FastIntegerOutput(5040, 13);    #=> 2, 3, 10, 9


================================================
FILE: Math/number_to_digits_subquadratic_algorithm_mpz.pl
================================================
#!/usr/bin/perl

# Subquadratic algorithm for converting a given integer into a list of digits in a given base.

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub FastIntegerOutput ($A, $B) {

    $A = Math::GMPz->new("$A");

    # Find k such that B^(2k - 2) <= A < B^(2k)
    my $k = (logint($A, $B) >> 1) + 1;

    my $Q = Math::GMPz::Rmpz_init();
    my $R = Math::GMPz::Rmpz_init();

    sub ($A, $k) {

        if (Math::GMPz::Rmpz_cmp_ui($A, $B) < 0) {
            return Math::GMPz::Rmpz_get_ui($A);
        }

        my $t = Math::GMPz::Rmpz_init();
        Math::GMPz::Rmpz_ui_pow_ui($t, $B, 2 * ($k - 1));   # can this be optimized away?

        if (Math::GMPz::Rmpz_cmp($t, $A) > 0) {
            --$k;
        }

        Math::GMPz::Rmpz_ui_pow_ui($t, $B, $k);
        Math::GMPz::Rmpz_divmod($Q, $R, $A, $t);

        my $w = ($k + 1) >> 1;
        Math::GMPz::Rmpz_set($t, $Q);

        my @right = __SUB__->($R, $w);
        my @left  = __SUB__->($t, $w);

        (@left, (0) x ($k - scalar(@right)), @right);
    }->($A, $k);
}

foreach my $B (2 .. 100) {    # run some tests
    my $N = factorial($B);    # int(rand(~0));

    my @a = todigits($N, $B);
    my @b = FastIntegerOutput($N, $B);

    if ("@a" ne "@b") {
        die "Error for FastIntegerOutput($N, $B): (@a) != (@b)";
    }
}

say join ', ', FastIntegerOutput(5040, 10);    #=> 5, 0, 4, 0
say join ', ', FastIntegerOutput(5040, 11);    #=> 3, 8, 7, 2
say join ', ', FastIntegerOutput(5040, 12);    #=> 2, 11, 0, 0
say join ', ', FastIntegerOutput(5040, 13);    #=> 2, 3, 10, 9


================================================
FILE: Math/numbers_with_pow_2_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 21 September 2016
# Website: https://github.com/trizen

# First smallest numbers with 2^n divisors.

# See also:
#    https://oeis.org/A037992
#    https://projecteuler.net/problem=500

use 5.010;
use strict;
use warnings;

use ntheory qw(forprimes primes logint);

sub first_n {
    my ($num) = @_;

    my $limit = logint($num, 2) * $num;    # overshoots a little bit
    my @factors = @{primes($limit)};

    forprimes {
        my $t = $_;
        while (($t**= 2) <= $limit) {
            push @factors, $t;
        }
    } $num;

    @factors = sort { $a <=> $b } @factors;
    $#factors = $num - 2;

    my @nums = 1;
    my $prod = 1;

    foreach my $f (@factors) {
        $prod *= $f;
        push @nums, $prod;
    }

    @nums;
}

say for first_n(10)

__END__
1
2
6
24
120
840
7560
83160
1081080
17297280


================================================
FILE: Math/omega_prime_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 21 March 2021
# https://github.com/trizen

# Generate all the k-omega prime divisors of n.

# Definition:
#   k-omega primes are numbers n such that omega(n) == k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub omega_prime_divisors ($n, $k) {

    if ($k == 0) {
        return (1);
    }

    my @factor_exp  = factor_exp($n);
    my @factors     = map { $_->[0] } @factor_exp;
    my %valuations  = map { @$_ } @factor_exp;
    my $factors_end = $#factors;

    if ($k > scalar(@factor_exp)) {
        return;
    }

    my @list;

    sub ($m, $k, $i = 0) {

        my $L = rootint(divint($n, $m), $k);

        foreach my $j ($i .. $factors_end) {

            my $q = $factors[$j];

            if (($k > 1 and $j == $factors_end) or ($q > $L)) {
                last;
            }

            my $t = mulint($m, $q);

            foreach (1 .. $valuations{$q}) {

                if ($k == 1) {
                    push @list, $t;
                }
                else {
                    __SUB__->($t, $k - 1, $j + 1);
                }

                $t = mulint($t, $q);
            }
        }
    }->(1, $k);

    sort { $a <=> $b } @list;
}

my $n = factorial(10);

foreach my $k (0 .. prime_omega($n)) {
    my @divisors = omega_prime_divisors($n, $k);
    printf("%2d-omega prime divisors of %s: [%s]\n", $k, $n, join(', ', @divisors));
}

__END__
 0-omega prime divisors of 3628800: [1]
 1-omega prime divisors of 3628800: [2, 3, 4, 5, 7, 8, 9, 16, 25, 27, 32, 64, 81, 128, 256]
 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]
 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]
 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]


================================================
FILE: Math/omega_prime_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 March 2021
# https://github.com/trizen

# Generate k-omega primes in range [a,b]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function

# PARI/GP code:
#   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)));

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub omega_prime_numbers ($A, $B, $k, $callback) {

    $A = vecmax($A, pn_primorial($k));

    sub ($m, $p, $k) {

        my $s = rootint(divint($B, $m), $k);

        foreach my $q (@{primes($p, $s)}) {

            my $r = next_prime($q);

            for (my $v = mulint($m, $q); $v <= $B ; $v = mulint($v, $q)) {
                if ($k == 1) {
                    $callback->($v) if ($v >= $A);
                }
                elsif (mulint($v, $r) <= $B) {
                    __SUB__->($v, $r, $k - 1);
                }
            }
        }
    }->(1, 2, $k);
}

# Generate 5-omega primes in the range [3000, 10000]

my $k    = 5;
my $from = 3000;
my $upto = 10000;

my @arr;
omega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });

my @test = grep { prime_omega($_) == $k } $from .. $upto;    # just for testing
join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);

# Run some tests

foreach my $k (1 .. 6) {

    my $from = pn_primorial($k) + int(rand(1e4));
    my $upto = $from + int(rand(1e5));

    say "Testing: $k with $from .. $upto";

    my @arr;
    omega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });

    my @test = grep { prime_omega($_) == $k } $from .. $upto;
    join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die "Error: not equal!";
}


================================================
FILE: Math/omega_prime_numbers_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 March 2021
# Edit: 04 April 2024
# https://github.com/trizen

# Generate all the k-omega primes in range [A,B].

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function

use 5.036;
use Math::GMPz;
use ntheory qw(:all);

sub omega_prime_numbers ($A, $B, $k) {

    $A = vecmax($A, pn_primorial($k));
    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();

    my @values = sub ($m, $lo, $j) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $j);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        my @lst;
        my $v = Math::GMPz::Rmpz_init();

        foreach my $q (@{primes($lo, $hi)}) {

            Math::GMPz::Rmpz_mul_ui($v, $m, $q);

            while (Math::GMPz::Rmpz_cmp($v, $B) <= 0) {
                if ($j == 1) {
                    if (Math::GMPz::Rmpz_cmp($v, $A) >= 0) {
                        push @lst, Math::GMPz::Rmpz_init_set($v);
                    }
                }
                else {
                    push @lst, __SUB__->($v, $q + 1, $j - 1);
                }
                Math::GMPz::Rmpz_mul_ui($v, $v, $q);
            }
        }

        return @lst;
      }
      ->(Math::GMPz->new(1), 2, $k);

    sort { Math::GMPz::Rmpz_cmp($a, $b) } @values;
}

# Generate 5-omega primes in the range [3000, 10000]

my $k    = 5;
my $from = 3000;
my $upto = 10000;

my @arr  = omega_prime_numbers($from, $upto, $k);
my @test = grep { prime_omega($_) == $k } $from .. $upto;    # just for testing

join(' ', @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);

# Run some tests

foreach my $k (1 .. 6) {

    my $from = pn_primorial($k) + int(rand(1e4));
    my $upto = $from + int(rand(1e5));

    say "Testing: $k with $from .. $upto";

    my @arr  = omega_prime_numbers($from, $upto, $k);
    my @test = grep { prime_omega($_) == $k } $from .. $upto;
    join(' ', @arr) eq join(' ', @test) or die "Error: not equal!";
}


================================================
FILE: Math/omega_prime_numbers_in_range_simple.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 March 2021
# Edit: 25 March 2025
# https://github.com/trizen

# Generate k-omega primes in range [a,b]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function

use 5.020;
use integer;
use ntheory      qw(:all);
use experimental qw(signatures);

sub omega_prime_numbers ($A, $B, $k, $callback) {

    $A = vecmax($A, pn_primorial($k));

    sub ($m, $p, $k) {

        my $s = rootint($B / $m, $k);

        foreach my $q (@{primes($p, $s)}) {

            my $r = next_prime($q);

            for (my $v = $m * $q ; $v <= $B ; $v *= $q) {
                if ($k == 1) {
                    $callback->($v) if ($v >= $A);
                }
                elsif ($v * $r <= $B) {
                    __SUB__->($v, $r, $k - 1);
                }
            }
        }
    }->(1, 2, $k);
}

# Generate 5-omega primes in the range [3000, 10000]

my $k    = 5;
my $from = 3000;
my $upto = 10000;

my @arr;
omega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });

my @test = grep { prime_omega($_) == $k } $from .. $upto;    # just for testing
join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);

# Run some tests

foreach my $k (1 .. 6) {

    my $from = pn_primorial($k) + int(rand(1e4));
    my $upto = $from + int(rand(1e5));

    say "Testing: $k with $from .. $upto";

    my @arr;
    omega_prime_numbers($from, $upto, $k, sub ($n) { push @arr, $n });

    my @test = grep { prime_omega($_) == $k } $from .. $upto;
    join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die "Error: not equal!";
}


================================================
FILE: Math/order_factorization_method.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 02 August 2020
# Edit: 07 January 2021
# https://github.com/trizen

# A new factorization method for numbers that have all prime factors close to each other.

# Inpsired by Fermat's Little Theorem (FLT).

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;

sub FLT_find_factor ($n, $base = 2, $reps = 1e5) {

    $n = Math::GMPz->new("$n");

    state $z = Math::GMPz::Rmpz_init_nobless();
    state $t = Math::GMPz::Rmpz_init_nobless();

    my $g = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_set_ui($t, $base);
    Math::GMPz::Rmpz_set_ui($z, $base);

    Math::GMPz::Rmpz_powm($z, $z, $n, $n);

    # Cannot factor Fermat pseudoprimes
    if (Math::GMPz::Rmpz_cmp_ui($z, $base) == 0) {
        return undef;
    }

    my $multiplier = $base * $base;

    for (my $k = 1 ; $k <= $reps ; ++$k) {

        Math::GMPz::Rmpz_mul_ui($t, $t, $multiplier);
        Math::GMPz::Rmpz_mod($t, $t, $n) if ($k % 10 == 0);
        Math::GMPz::Rmpz_sub($g, $z, $t);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);
            return $g;
        }
    }

    return undef;
}

say FLT_find_factor("1759590140239532167230871849749630652332178307219845847129");    #=> 12072684186515582507
say FLT_find_factor("28168370236334094367936640078057043313881469151722840306493");   #=> 30426633744568826749

say FLT_find_factor("97967651586822913179896725042136997967830602144506842054615710025444417607092711829309187");     #=> 86762184769343281845479348731
say FLT_find_factor("1129151505892449502375764445221583755878554451745780900429977", 3);                              #=> 867621847693432818454793487397


================================================
FILE: Math/palindrome_iteration.pl
================================================
#!/usr/bin/perl

# A nice algorithm, due to David A. Corneth (Jun 06 2014), for interating over palindromic numbers in base 10.

# See also:
#   https://oeis.org/A002113
#   https://en.wikipedia.org/wiki/Palindromic_number

# This program illustrates how to compute terms of:
#   https://oeis.org/A076886

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

my $n = 1;
my @d = split(//, $n);

my %table;

while (1) {

    my $r = prime_bigomega($n);

    if (not exists $table{$r}) {
        say "a($r) = $n";
        $table{$r} = 1;
    }

    my $l = $#d;
    my $i = ((scalar(@d) + 1) >> 1) - 1;

    while ($i >= 0 and $d[$i] == 9) {
        $d[$i] = 0;
        $d[$l - $i] = 0;
        $i--;
    }

    if ($i >= 0) {
        $d[$i]++;
        $d[$l - $i] = $d[$i];
    }
    else {
        @d = (0) x (scalar(@d) + 1);
        $d[0]  = 1;
        $d[-1] = 1;
    }

    $n = join('', @d);
}


================================================
FILE: Math/partial_sums_of_dedekind_psi_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 22 November 2018
# https://github.com/trizen

# A new algorithm for computing the partial-sums of the Dedekind psi function `ψ_m(k)`, for `1 <= k <= n`:
#
#   Sum_{k=1..n} ψ_m(k)
#
# for any fixed integer m >= 1.

# Based on the formula:
#   Sum_{k=1..n} ψ_m(k) = Sum_{k=1..n} moebius(k)^2 * F(m, floor(n/k))
#
# where F(n,x) is Faulhaber's formula for `Sum_{k=1..x} k^n`, defined in terms of Bernoulli polynomials as:
#   F(n, x) = (Bernoulli(n+1, x+1) - Bernoulli(n+1, 1)) / (n+1)

# Example for a(n) = Sum_{k=1..n} ψ_2(k):
#   a(10^1)  = 462
#   a(10^2)  = 400576
#   a(10^3)  = 394504950
#   a(10^4)  = 393921912410
#   a(10^5)  = 393861539651230
#   a(10^6)  = 393855661025817568
#   a(10^7)  = 393855049001462029696
#   a(10^8)  = 393854989687473892017612
#   a(10^9)  = 393854983651633712634417940
#   a(10^10) = 393854983070527507612754907046

# For m=1..3, we have the following asymptotic formulas:
#   Sum_{k=1..n} ψ_1(k) ~ n^2 * zeta(2) / (2*zeta(4))
#   Sum_{k=1..n} ψ_2(k) ~ n^3 * zeta(3) / (3*zeta(6))
#   Sum_{k=1..n} ψ_3(k) ~ n^4 * zeta(4) / (4*zeta(8))

# In general, for m>=1, we have:
#   Sum_{k=1..n} ψ_m(k) ~ n^(m+1) * zeta(m+1) / ((m+1) * zeta(2*(m+1)))

# See also:
#   https://oeis.org/A173290
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function
#   https://en.wikipedia.org/wiki/Dedekind_psi_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(ipow faulhaber_sum);
use ntheory qw(jordan_totient moebius vecsum sqrtint forsquarefree is_square_free);

sub squarefree_count {
    my ($n) = @_;

    my $k     = 0;
    my $count = 0;

    foreach my $m (moebius(1, sqrtint($n))) {
        ++$k; $count += $m * int($n / $k / $k);
    }

    return $count;
}

sub dedekind_psi_partial_sum ($n, $m) {     # O(sqrt(n)) complexity

    my $total = 0;

    my $s = sqrtint($n);
    my $u = int($n / ($s + 1));

    my $prev = squarefree_count($n);

    for my $k (1 .. $s) {
        my $curr = squarefree_count(int($n / ($k + 1)));
        $total += ($prev - $curr) * faulhaber_sum($k, $m);
        $prev = $curr;
    }

    forsquarefree {
        $total += faulhaber_sum(int($n / $_), $m);
    } $u;

    return $total;
}

sub dedekind_psi_partial_sum_2 ($n, $m) {     # O(sqrt(n)) complexity

    my $total = 0;
    my $s = sqrtint($n);

    for my $k (1 .. $s) {
        $total += ipow($k, $m) * squarefree_count(int($n/$k));
        $total += faulhaber_sum(int($n/$k), $m) if is_square_free($k);
    }

    $total -= squarefree_count($s) * faulhaber_sum($s, $m);

    return $total;
}

sub dedekind_psi_partial_sum_test ($n, $m) {    # just for testing
    vecsum(map { jordan_totient(2*$m, $_) / jordan_totient($m, $_) } 1 .. $n);
}

for my $m (1 .. 10) {

    my $n = int rand 1000;

    my $t1 = dedekind_psi_partial_sum($n, $m);
    my $t2 = dedekind_psi_partial_sum_2($n, $m);
    my $t3 = dedekind_psi_partial_sum_test($n, $m);

    die "error: $t1 != $t2" if ($t1 != $t2);
    die "error: $t1 != $t3" if ($t1 != $t3);

    say "Sum_{k=1..$n} psi_$m(k) = $t1";
}

__END__
Sum_{k=1..626} psi_1(k) = 298020
Sum_{k=1..203} psi_2(k) = 3314412
Sum_{k=1..527} psi_3(k) = 20858324486
Sum_{k=1..912} psi_4(k) = 131086192304600
Sum_{k=1..221} psi_5(k) = 20014030184914
Sum_{k=1..980} psi_6(k) = 125495875567427222916
Sum_{k=1..892} psi_7(k) = 50529225624273249380976
Sum_{k=1..831} psi_8(k) = 21153451972416324344508126
Sum_{k=1..384} psi_9(k) = 7069511971715257063270976
Sum_{k=1..434} psi_10(k) = 9477667039001209551910807864


================================================
FILE: Math/partial_sums_of_euler_totient_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 20 November 2018
# https://github.com/trizen

# A new algorithm for computing the partial-sums of `ϕ(k)`, for `1 <= k <= n`:
#
#   Sum_{k=1..n} phi(k)
#
# where phi(k) is the Euler totient function.

# Based on the formula:
#   Sum_{k=1..n} phi(k) = (1/2)*Sum_{k=1..n} moebius(k) * floor(n/k) * floor(1+n/k)

# Example:
#   a(10^1) = 32
#   a(10^2) = 3044
#   a(10^3) = 304192
#   a(10^4) = 30397486
#   a(10^5) = 3039650754
#   a(10^6) = 303963552392
#   a(10^7) = 30396356427242
#   a(10^8) = 3039635516365908
#   a(10^9) = 303963551173008414

# This algorithm can be improved.

# See also:
#   https://oeis.org/A002088
#   https://oeis.org/A064018
#   https://en.wikipedia.org/wiki/Mertens_function
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function
#   https://en.wikipedia.org/wiki/Euler%27s_totient_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use Math::GMPz qw();
use experimental qw(signatures);
use ntheory qw(euler_phi moebius mertens vecsum sqrtint forsquarefree);

sub euler_totient_partial_sum ($n) {

    my $total = Math::GMPz->new(0);

    my $s = sqrtint($n);
    my $u = int($n / ($s + 1));

    my $prev = mertens($n);

    for my $k (1 .. $s) {
        my $curr = mertens(int($n / ($k + 1)));
        $total += ($prev - $curr) * $k * ($k + 1);
        $prev = $curr;
    }

    forsquarefree {
        my $t = int($n / $_);
        $total += moebius($_) * $t * ($t + 1);
    } $u;

    return $total / 2;
}

sub euler_totient_partial_sum_test ($n) {    # just for testing
    vecsum(map { euler_phi($_) } 1 .. $n);
}

for my $m (0 .. 10) {

    my $n = int rand 10000;

    my $t1 = euler_totient_partial_sum($n);
    my $t2 = euler_totient_partial_sum_test($n);

    die "error: $t1 != $t2" if ($t1 != $t2);

    say "Sum_{k=1..$n} phi(k) = $t1";
}

__END__
Sum_{k=1..9321} phi(k) = 26411174
Sum_{k=1..2266} phi(k) = 1560824
Sum_{k=1..1049} phi(k) = 335018
Sum_{k=1..2571} phi(k) = 2009942
Sum_{k=1..3858} phi(k) = 4524786
Sum_{k=1..7348} phi(k) = 16412608
Sum_{k=1..7177} phi(k) = 15659862
Sum_{k=1..1247} phi(k) = 473174
Sum_{k=1..9787} phi(k) = 29119732
Sum_{k=1..4790} phi(k) = 6975570
Sum_{k=1..2453} phi(k) = 1830240


================================================
FILE: Math/partial_sums_of_euler_totient_function_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 February 2019
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the Euler totient function.

# The partial sums of the Euler totient function is defined as:
#
#   a(n) = Sum_{k=1..n} phi(k)
#
# where phi(k) is the Euler totient function.

# Recursive formula:
#   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)))

# Example:
#   a(10^1) = 32
#   a(10^2) = 3044
#   a(10^3) = 304192
#   a(10^4) = 30397486
#   a(10^5) = 3039650754
#   a(10^6) = 303963552392
#   a(10^7) = 30396356427242
#   a(10^8) = 3039635516365908
#   a(10^9) = 303963551173008414

# OEIS sequences:
#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).
#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.

# See also:
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(euler_phi sqrtint rootint);

sub partial_sums_of_euler_totient($n) {
    my $s = sqrtint($n);

    my @euler_sum_lookup = (0);

    my $lookup_size = 2 * rootint($n, 3)**2;
    my @euler_phi   = euler_phi(0, $lookup_size);

    foreach my $i (1 .. $lookup_size) {
        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + $euler_phi[$i];
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $euler_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $T = ($n * ($n + 1)) >> 1;

        foreach my $k (2 .. int($n / ($s + 1))) {
            $T -= __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $T -= (int($n / $k) - int($n / ($k + 1))) * $euler_sum_lookup[$k];
        }

        $seen{$n} = $T;

    }->($n);
}

foreach my $n (1 .. 8) {    # takes less than 1 second
    say "a(10^$n) = ", partial_sums_of_euler_totient(10**$n);
}


================================================
FILE: Math/partial_sums_of_euler_totient_function_fast_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 April 2022
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the Euler totient function.

# The partial sums of the Euler totient function is defined as:
#
#   a(n,m) = Sum_{k=1..n} phi(k)
#
# where phi(k) is the Euler totient function.

# Example:
#   a(10^1)  = 32
#   a(10^2)  = 3044
#   a(10^3)  = 304192
#   a(10^4)  = 30397486
#   a(10^5)  = 3039650754
#   a(10^6)  = 303963552392
#   a(10^7)  = 30396356427242
#   a(10^8)  = 3039635516365908
#   a(10^9)  = 303963551173008414
#   a(10^10) = 30396355092886216366

# General asymptotic formula:
#
#   Sum_{k=1..n} k^m * phi(k)  ~  F_{m+1}(n) / zeta(2).
#
# where F_m(n) are the Faulhaber polynomials.

# OEIS sequences:
#   https://oeis.org/A011755 -- Sum_{k=1..n} k*phi(k).
#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).
#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.

# See also:
#   https://en.wikipedia.org/wiki/Faulhaber's_formula
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub triangular ($n) {
    divint(mulint($n, $n + 1), 2);
}

sub partial_sums_of_euler_totient ($n) {
    my $s = sqrtint($n);

    my @euler_sum_lookup = (0);

    my $lookup_size = int(2 * rootint($n, 3)**2);
    my @euler_phi   = euler_phi(0, $lookup_size);

    foreach my $i (1 .. $lookup_size) {
        $euler_sum_lookup[$i] = addint($euler_sum_lookup[$i - 1], $euler_phi[$i]);
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $euler_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $T = triangular($n);

        foreach my $k (2 .. divint($n, $s + 1)) {
            $T = subint($T, __SUB__->(divint($n, $k)));
        }

        my $prev = $n;

        foreach my $k (1 .. $s) {
            my $curr = divint($n, $k + 1);
            $T    = subint($T, mulint(subint($prev, $curr), $euler_sum_lookup[$k]));
            $prev = $curr;
        }

        $seen{$n} = $T;

    }->($n);
}

foreach my $n (1 .. 8) {    # takes less than 1 second
    say "a(10^$n) = ", partial_sums_of_euler_totient(powint(10, $n));
}


================================================
FILE: Math/partial_sums_of_euler_totient_function_times_k.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 April 2022
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the Euler totient function times k.

# The partial sums of the Euler totient function is defined as:
#
#   a(n,m) = Sum_{k=1..n} k * phi(k)
#
# where phi(k) is the Euler totient function.

# Example:
#    a(10^1)  = 217
#    a(10^2)  = 203085
#    a(10^3)  = 202870719
#    a(10^4)  = 202653667159
#    a(10^5)  = 202643891472849
#    a(10^6)  = 202642368741515819
#    a(10^7)  = 202642380629476099463
#    a(10^8)  = 202642367994273571457613
#    a(10^9)  = 202642367530671221417109931
#    a(10^10) = 202642367286524384080814204093

# General asymptotic formula:
#
#   Sum_{k=1..n} k^m * phi(k)  ~  F_(m+1)(n) / zeta(2).
#
# where F_m(n) are the Faulhaber polynomials.

# OEIS sequences:
#   https://oeis.org/A011755 -- Sum_{k=1..n} k*phi(k).
#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).
#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.

# See also:
#   https://en.wikipedia.org/wiki/Faulhaber's_formula
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(:all);

sub triangular ($n) {
    divint(mulint($n, $n + 1), 2);
}

sub square_pyramidal ($n) {
    divint(vecprod($n, $n + 1, mulint(2, $n) + 1), 6);
}

sub partial_sums_of_euler_totient ($n) {
    my $s = sqrtint($n);

    my @euler_sum_lookup = (0);

    my $lookup_size = int(2 * rootint($n, 3)**2);
    my @euler_phi   = euler_phi(0, $lookup_size);

    foreach my $i (1 .. $lookup_size) {
        $euler_sum_lookup[$i] = addint($euler_sum_lookup[$i - 1], mulint($i, $euler_phi[$i]));
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $euler_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $T = square_pyramidal($n);

        foreach my $k (2 .. divint($n, $s + 1)) {
            $T = subint($T, mulint($k, __SUB__->(divint($n, $k))));
        }

        my $prev = triangular($n);

        foreach my $k (1 .. $s) {
            my $curr = triangular(divint($n, $k + 1));
            $T    = subint($T, mulint(subint($prev, $curr), $euler_sum_lookup[$k]));
            $prev = $curr;
        }

        $seen{$n} = $T;

    }->($n);
}

foreach my $n (1 .. 8) {    # takes ~5 seconds
    say "a(10^$n) = ", partial_sums_of_euler_totient(powint(10, $n));
}


================================================
FILE: Math/partial_sums_of_euler_totient_function_times_k_to_the_m.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 07 February 2019
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the Euler totient function times k^m.

# The partial sums of the Euler totient function is defined as:
#
#   a(n,m) = Sum_{k=1..n} k^m * phi(k)
#
# where phi(k) is the Euler totient function.

# Example:
#    a(10^1, 1) = 217
#    a(10^2, 1) = 203085
#    a(10^3, 1) = 202870719
#    a(10^4, 1) = 202653667159
#    a(10^5, 1) = 202643891472849
#    a(10^6, 1) = 202642368741515819
#    a(10^7, 1) = 202642380629476099463
#    a(10^8, 1) = 202642367994273571457613
#    a(10^9, 1) = 202642367530671221417109931

# General asymptotic formula:
#
#   Sum_{k=1..n} k^m * phi(k)  ~  F_(m+1)(n) / zeta(2).
#
# where F_m(n) are the Faulhaber polynomials.

# OEIS sequences:
#   https://oeis.org/A011755 -- Sum_{k=1..n} k*phi(k).
#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).
#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.

# See also:
#   https://en.wikipedia.org/wiki/Faulhaber's_formula
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum ipow);
use ntheory qw(euler_phi sqrtint rootint);

sub partial_sums_of_euler_totient ($n, $m) {
    my $s = sqrtint($n);

    my @euler_sum_lookup = (0);

    my $lookup_size = 2 * rootint($n, 3)**2;
    my @euler_phi   = euler_phi(0, $lookup_size);

    foreach my $i (1 .. $lookup_size) {
        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + ipow($i, $m) * $euler_phi[$i];
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $euler_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $T = faulhaber_sum($n, $m + 1);

        foreach my $k (2 .. int($n / ($s + 1))) {
            $T -= ipow($k, $m) * __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $T -= (faulhaber_sum(int($n / $k), $m) - faulhaber_sum(int($n / ($k + 1)), $m)) * $euler_sum_lookup[$k];
        }

        $seen{$n} = $T;

    }->($n);
}

foreach my $n (1 .. 7) {    # takes ~2.8 seconds
    say "a(10^$n, 1) = ", partial_sums_of_euler_totient(10**$n, 1);
}


================================================
FILE: Math/partial_sums_of_exponential_prime_omega_functions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 March 2021
# https://github.com/trizen

# Compute partial sums of the following three functions in sublinear time:
#   S1(n) = Sum_{k=1..n} v^bigomega(k)
#   S2(n) = Sum_{k=1..n} v^omega(k)
#   S3(n) = Sum_{k=1..n} v^omega(k) * mu(k)^2

use 5.036;
use ntheory qw(:all);

sub squarefree_almost_prime_count ($k, $n) {

    if ($k == 0) {
        return (($n <= 0) ? 0 : 1);
    }

    if ($k == 1) {
        return prime_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $j = 1) {

        my $s = rootint(divint($n, $m), $k);

        if ($k == 2) {

            forprimes {
                $count += prime_count(divint($n, mulint($m, $_))) - $j++;
            } $p, $s;

            return;
        }

        for (; $p <= $s ; ++$j) {
            my $r = next_prime($p);
            __SUB__->(mulint($m, $p), $r, $k - 1, $j + 1);
            $p = $r;
        }
    }->(1, 2, $k);

    return $count;
}

sub S1 ($n, $v = 2) {    # Sum_{k=1..n} v^bigomega(k)
    vecsum(map { mulint(powint($v, $_), almost_prime_count($_, $n)) } 0 .. logint($n, 2));
}

sub S2 ($n, $v = 2) {    # Sum_{k=1..n} v^omega(k)
    vecsum(map { mulint(powint($v, $_), omega_prime_count($_, $n)) } 0 .. logint($n, 2));
}

sub S3 ($n, $v = 2) {    # Sum_{k=1..n} v^omega(k) * mu(k)^2
    vecsum(map { mulint(powint($v, $_), squarefree_almost_prime_count($_, $n)) } 0 .. logint($n, 2));
}

say 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]
say 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]
say 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]

say '';

say 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]
say 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]
say 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]

__END__

# A069205(n) = Sum_{k=1..n} 2^bigomega(k)

A069205(10^1)  = 33
A069205(10^2)  = 811
A069205(10^3)  = 15301
A069205(10^4)  = 260615
A069205(10^5)  = 3942969
A069205(10^6)  = 55282297
A069205(10^7)  = 746263855
A069205(10^8)  = 9613563919
A069205(10^9)  = 120954854741
A069205(10^10) = 1491898574939
A069205(10^11) = 17944730372827
A069205(10^12) = 212986333467973
A069205(10^13) = 2498962573520227
A069205(10^14) = 28874142998632109

# A002819(n) = Sum_{k=1..n} (-1)^bigomega(k)
# See also: A090410

A002819(10^1) = 0
A002819(10^2) = -2
A002819(10^3) = -14
A002819(10^4) = -94
A002819(10^5) = -288
A002819(10^6) = -530
A002819(10^7) = -842
A002819(10^8) = -3884
A002819(10^9) = -25216
A002819(10^10) = -116026
A002819(10^11) = -342224
A002819(10^12) = -522626
A002819(10^13) = -966578
A002819(10^14) = -7424752

# A064608(n) = Sum_{k=1..n} 2^omega(k)
# See also: A180361

A064608(10^1)  = 23
A064608(10^2)  = 359
A064608(10^3)  = 4987
A064608(10^4)  = 63869
A064608(10^5)  = 778581
A064608(10^6)  = 9185685
A064608(10^7)  = 105854997
A064608(10^8)  = 1198530315
A064608(10^9)  = 13385107495
A064608(10^10) = 147849112851
A064608(10^11) = 1618471517571
A064608(10^12) = 17584519050293

# A174863(n) = Sum_{k=1..n} (-1)^omega(k)

A174863(10^1)  = -4
A174863(10^2)  = 14
A174863(10^3)  = 64
A174863(10^4)  = -16
A174863(10^5)  = -720
A174863(10^6)  = -1908
A174863(10^7)  = -1650
A174863(10^8)  = 10734
A174863(10^9)  = 53740
A174863(10^10) = 108654
A174863(10^11) = 195702
A174863(10^12) = 27158

# A069201(n) = Sum_{k=1..n} mu(k)^2 * 2^omega(k)

A069201(10^1)  = 17
A069201(10^2)  = 211
A069201(10^3)  = 2825
A069201(10^4)  = 34891
A069201(10^5)  = 414813
A069201(10^6)  = 4808081
A069201(10^7)  = 54684335
A069201(10^8)  = 612868643
A069201(10^9)  = 6788951097
A069201(10^10) = 74492096539
A069201(10^11) = 810947010335
A069201(10^12) = 8769730440341

# A002321(n) = Sum_{k=1..n} (-1)^omega(k) * mu(k)^2 = Sum_{k=1..n} mu(k)
# See also: A084237

A002321(10^1) = -1
A002321(10^2) = 1
A002321(10^3) = 2
A002321(10^4) = -23
A002321(10^5) = -48
A002321(10^6) = 212
A002321(10^7) = 1037
A002321(10^8) = 1928
A002321(10^9) = -222
A002321(10^10) = -33722
A002321(10^11) = -87856
A002321(10^12) = 62366

# A013928(n) = Sum_{k=1..n} mu(k)^2
# See also: A071172

A013928(10^1)  = 7
A013928(10^2)  = 61
A013928(10^3)  = 608
A013928(10^4)  = 6083
A013928(10^5)  = 60794
A013928(10^6)  = 607926
A013928(10^7)  = 6079291
A013928(10^8)  = 60792694
A013928(10^9)  = 607927124
A013928(10^10) = 6079270942
A013928(10^11) = 60792710280
A013928(10^12) = 607927102274


================================================
FILE: Math/partial_sums_of_gcd-sum_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 20 November 2018
# https://github.com/trizen

# A new algorithm for computing the partial-sums of the gcd-sum function `Sum_{d|k} d*ϕ(k/d)`, for `1 <= k <= n`:
#
#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)
#
# where phi(k) is the Euler totient function.

# Also equivalent with:
#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)

# Based on the formula:
#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)

# Example:
#   a(10^1) = 122
#   a(10^2) = 18065
#   a(10^3) = 2475190
#   a(10^4) = 317257140
#   a(10^5) = 38717197452
#   a(10^6) = 4571629173912
#   a(10^7) = 527148712519016
#   a(10^8) = 59713873168012716
#   a(10^9) = 6671288261316915052

# This algorithm can be vastly improved.

# See also:
#   https://oeis.org/A018804
#   https://oeis.org/A272718
#   https://en.wikipedia.org/wiki/Mertens_function
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function
#   https://en.wikipedia.org/wiki/Euler%27s_totient_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use Math::GMPz   qw();
use experimental qw(signatures);
use ntheory      qw(euler_phi moebius mertens sqrtint forsquarefree);

sub euler_totient_partial_sum ($n) {

    my $total = Math::GMPz->new(0);

    my $s = sqrtint($n);
    my $u = int($n / ($s + 1));

    my $prev = mertens($n);

    for my $k (1 .. $s) {
        my $curr = mertens(int($n / ($k + 1)));
        $total += ($prev - $curr) * $k * ($k + 1);
        $prev = $curr;
    }

    forsquarefree {
        my $t = int($n / $_);
        $total += moebius($_) * $t * ($t + 1);
    } $u;

    return $total / 2;
}

sub gcd_sum_partial_sum($n) {

    my $total = Math::GMPz->new(0);

    my $s = sqrtint($n);
    my $u = int($n / ($s + 1));

    my $prev = euler_totient_partial_sum($n);

    for my $k (1 .. $s) {
        my $curr = euler_totient_partial_sum(int($n / ($k + 1)));
        $total += ($prev - $curr) * $k * ($k + 1);
        $prev = $curr;
    }

    for my $k (1 .. $u) {
        my $t = int($n / $k);
        $total += euler_phi($k) * $t * ($t + 1);
    }

    return $total / 2;
}

sub gcd_sum_partial_sum_dirichlet($n) {

    my $total = Math::GMPz->new(0);

    my $s = sqrtint($n);

    for my $k (1 .. $s) {
        my $t = int($n / $k);
        $total += $k * euler_totient_partial_sum($t);
        $total += euler_phi($k) * (($t * ($t + 1)) >> 1);
    }

    $total -= euler_totient_partial_sum($s) * (($s * ($s + 1)) >> 1);

    return $total;
}

sub gcd_sum_partial_sum_test ($n) {    # just for testing
    my $sum = Math::GMPz->new(0);

    foreach my $k (1 .. $n) {
        my $t = int($n / $k);
        $sum += euler_phi($k) * $t * ($t + 1);
    }

    return $sum / 2;
}

for my $m (0 .. 10) {

    my $n = int rand 10000;

    my $t1 = gcd_sum_partial_sum($n);
    my $t2 = gcd_sum_partial_sum_dirichlet($n);
    my $t3 = gcd_sum_partial_sum_test($n);

    die "error: $t1 != $t2" if ($t1 != $t2);
    die "error: $t1 != $t3" if ($t1 != $t3);

    say "Sum_{k=1..$n} G(k) = $t1";
}

__END__
Sum_{k=1..6249} G(k) = 118276019
Sum_{k=1..6470} G(k) = 127257585
Sum_{k=1..1271} G(k) = 4109678
Sum_{k=1..4849} G(k) = 69427261
Sum_{k=1..6771} G(k) = 140029473
Sum_{k=1..5078} G(k) = 76492429
Sum_{k=1..1262} G(k) = 4054055
Sum_{k=1..7751} G(k) = 185959182
Sum_{k=1..4188} G(k) = 51033167
Sum_{k=1..5283} G(k) = 83132565
Sum_{k=1..2574} G(k) = 18289119


================================================
FILE: Math/partial_sums_of_gcd-sum_function_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 February 2019
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the gcd-sum function, using Dirichlet's hyperbola method.

# The partial sums of the gcd-sum function is defined as:
#
#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)
#
# where phi(k) is the Euler totient function.

# Also equivalent with:
#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)

# Based on the formula:
#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)

# Example:
#   a(10^1) = 122
#   a(10^2) = 18065
#   a(10^3) = 2475190
#   a(10^4) = 317257140
#   a(10^5) = 38717197452
#   a(10^6) = 4571629173912
#   a(10^7) = 527148712519016
#   a(10^8) = 59713873168012716
#   a(10^9) = 6671288261316915052

# OEIS sequences:
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.
#   https://oeis.org/A018804 -- Pillai's arithmetical function: Sum_{k=1..n} gcd(k, n).

# See also:
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(euler_phi moebius sqrtint rootint);

sub partial_sums_of_gcd_sum_function($n) {
    my $s = sqrtint($n);

    my @mertens_lookup   = (0);
    my @euler_sum_lookup = (0);

    my $lookup_size = 2 + 2 * rootint($n, 3)**2;

    my @moebius   = moebius(0, $lookup_size);
    my @euler_phi = euler_phi(0, $lookup_size);

    foreach my $i (1 .. $lookup_size) {
        $mertens_lookup[$i]   = $mertens_lookup[$i - 1] + $moebius[$i];
        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + $euler_phi[$i];
    }

    my %mertens_cache;

    my sub moebius_partial_sum ($n) {

        if ($n <= $lookup_size) {
            return $mertens_lookup[$n];
        }

        if (exists $mertens_cache{$n}) {
            return $mertens_cache{$n};
        }

        my $s = sqrtint($n);
        my $M = 1;

        foreach my $k (2 .. int($n / ($s + 1))) {
            $M -= __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $M -= $mertens_lookup[$k] * (int($n / $k) - int($n / ($k + 1)));
        }

        $mertens_cache{$n} = $M;
    }

    my %euler_phi_sum_cache;

    my sub euler_phi_partial_sum($n) {

        if ($n <= $lookup_size) {
            return $euler_sum_lookup[$n];
        }

        if (exists $euler_phi_sum_cache{$n}) {
            return $euler_phi_sum_cache{$n};
        }

        my $s = sqrtint($n);
        my $A = 0;

        foreach my $k (1 .. $s) {
            my $t = int($n / $k);
            $A += $k * moebius_partial_sum($t) + $moebius[$k] * (($t * ($t + 1)) >> 1);
        }

        my $C = moebius_partial_sum($s) * (($s * ($s + 1)) >> 1);

        $euler_phi_sum_cache{$n} = ($A - $C);
    }

    my $A = 0;

    foreach my $k (1 .. $s) {
        my $t = int($n / $k);
        $A += $k * euler_phi_partial_sum($t) + $euler_phi[$k] * (($t * ($t + 1)) >> 1);
    }

    my $C = euler_phi_partial_sum($s) * (($s * ($s + 1)) >> 1);

    return ($A - $C);
}

foreach my $n (1 .. 8) {    # takes less than 1 second
    say "a(10^$n) = ", partial_sums_of_gcd_sum_function(10**$n);
}


================================================
FILE: Math/partial_sums_of_gcd-sum_function_faster.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 February 2019
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the gcd-sum function, using Dirichlet's hyperbola method.

# The partial sums of the gcd-sum function is defined as:
#
#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)
#
# where phi(k) is the Euler totient function.

# Also equivalent with:
#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)

# Based on the formula:
#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)

# Example:
#   a(10^1) = 122
#   a(10^2) = 18065
#   a(10^3) = 2475190
#   a(10^4) = 317257140
#   a(10^5) = 38717197452
#   a(10^6) = 4571629173912
#   a(10^7) = 527148712519016
#   a(10^8) = 59713873168012716
#   a(10^9) = 6671288261316915052

# OEIS sequences:
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.
#   https://oeis.org/A018804 -- Pillai's arithmetical function: Sum_{k=1..n} gcd(k, n).

# See also:
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(euler_phi sqrtint rootint);

sub partial_sums_of_gcd_sum_function($n) {
    my $s = sqrtint($n);

    my @euler_sum_lookup = (0);

    my $lookup_size = 2 + 2 * rootint($n, 3)**2;
    my @euler_phi   = euler_phi(0, $lookup_size);

    foreach my $i (1 .. $lookup_size) {
        $euler_sum_lookup[$i] = $euler_sum_lookup[$i - 1] + $euler_phi[$i];
    }

    my %seen;

    my sub euler_phi_partial_sum($n) {

        if ($n <= $lookup_size) {
            return $euler_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $T = ($n * ($n + 1)) >> 1;

        foreach my $k (2 .. int($n / ($s + 1))) {
            $T -= __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $T -= (int($n / $k) - int($n / ($k + 1))) * $euler_sum_lookup[$k];
        }

        $seen{$n} = $T;
    }

    my $A = 0;

    foreach my $k (1 .. $s) {
        my $t = int($n / $k);
        $A += $k * euler_phi_partial_sum($t) + $euler_phi[$k] * (($t * ($t + 1)) >> 1);
    }

    my $T = ($s * ($s + 1)) >> 1;
    my $C = euler_phi_partial_sum($s);

    return ($A - $T * $C);
}

foreach my $n (1 .. 8) {    # takes less than 1 second
    say "a(10^$n) = ", partial_sums_of_gcd_sum_function(10**$n);
}


================================================
FILE: Math/partial_sums_of_generalized_gcd-sum_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 May 2025
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the generalized gcd-sum function, using Dirichlet's hyperbola method.

# Generalized Pillai's function:
#   pillai(n,k) = Sum_{d|n} mu(n/d) * d^k * tau(d)

# Multiplicative formula for Sum_{1 <= x_1, x_2, ..., x_k <= n} gcd(x_1, x_2, ..., x_k, n)^k:
#   a(p^e) = (e - e/p^k + 1) * p^(k*e) = p^((e - 1) * k) * (p^k + e*(p^k - 1))

# The partial sums of the gcd-sum function is defined as:
#
#   a(n) = Sum_{k=1..n} Sum_{d|k} d*phi(k/d)
#
# where phi(k) is the Euler totient function.

# Also equivalent with:
#   a(n) = Sum_{j=1..n} Sum_{i=1..j} gcd(i, j)

# Based on the formula:
#   a(n) = (1/2)*Sum_{k=1..n} phi(k) * floor(n/k) * floor(1+n/k)

# Generalized formula:
#   a(n,k) = Sum_{x=1..n} J_k(x) * F_k(floor(n/x))
# where F_k(n) are the Faulhaber polynomials: F_k(n) = Sum_{x=1..n} x^k.

# Example:
#   a(10^1) = 122
#   a(10^2) = 18065
#   a(10^3) = 2475190
#   a(10^4) = 317257140
#   a(10^5) = 38717197452
#   a(10^6) = 4571629173912
#   a(10^7) = 527148712519016
#   a(10^8) = 59713873168012716
#   a(10^9) = 6671288261316915052

#   a(10^1, 2) = 1106
#   a(10^2, 2) = 1598361
#   a(10^3, 2) = 2193987154
#   a(10^4, 2) = 2828894776292
#   a(10^5, 2) = 3466053625977000
#   a(10^6, 2) = 4104546122851466704
#   a(10^7, 2) = 4742992578252739471520
#   a(10^8, 2) = 5381500783126483704718848
#   a(10^9, 2) = 6020011093886996189443484608

# OEIS sequences:
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.
#   https://oeis.org/A018804 -- Pillai's arithmetical function: Sum_{k=1..n} gcd(k, n).

# See also:
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum ipow);
use ntheory      qw(jordan_totient sqrtint rootint);

sub partial_sums_of_gcd_sum_function($n, $m) {

    my $s                  = sqrtint($n);
    my @totient_sum_lookup = (0);

    my $lookup_size    = 2 + 2 * rootint($n, 3)**2;
    my @jordan_totient = (0);

    foreach my $x (1 .. $lookup_size) {
        push @jordan_totient, jordan_totient($m, $x);
    }

    foreach my $i (1 .. $lookup_size) {
        $totient_sum_lookup[$i] = $totient_sum_lookup[$i - 1] + $jordan_totient[$i];
    }

    my %seen;

    my sub totient_partial_sum($n) {

        if ($n <= $lookup_size) {
            return $totient_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $T = ${faulhaber_sum($n, $m)};

        foreach my $k (2 .. int($n / ($s + 1))) {
            $T -= __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $T -= (int($n / $k) - int($n / ($k + 1))) * $totient_sum_lookup[$k];
        }

        $seen{$n} = $T;
    }

    my $A = 0;

    foreach my $k (1 .. $s) {
        my $t = int($n / $k);
        $A += ${ipow($k, $m)} * totient_partial_sum($t) + $jordan_totient[$k] * ${faulhaber_sum($t, $m)};
    }

    my $T = ${faulhaber_sum($s, $m)};
    my $C = totient_partial_sum($s);

    return ($A - $T * $C);
}

foreach my $n (1 .. 8) {    # takes less than 1 second
    say "a(10^$n, 1) = ", partial_sums_of_gcd_sum_function(10**$n, 1);
}

say '';

foreach my $n (1 .. 8) {    # takes less than 1 second
    say "a(10^$n, 2) = ", partial_sums_of_gcd_sum_function(10**$n, 2);
}


================================================
FILE: Math/partial_sums_of_gpf.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 July 2020
# https://github.com/trizen

# Algorithm with sublinear time for computing:
#
#   Sum_{k=2..n} gpf(k)
#
# where:
#   gpf(k) = the greatest prime factor of k

# See also:
#   https://projecteuler.net/problem=642

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub partial_sums_of_gpf($n) {

    my $t = 0;
    my $s = sqrtint($n);

    forprimes {
        $t = addint($t, mulint($_, smooth_count(divint($n, $_), $_)));
    } $s;

    for(my $p = next_prime($s); $p <= $n; $p = next_prime($p)) {

        my $u = divint($n,$p);
        my $r = divint($n,$u);

        $t = addint($t, mulint($u, sum_primes($p,$r)));
        $p = $r;
    }

    return $t;
}

foreach my $k (1..10) {
    printf("S(10^%d) = %s\n", $k, partial_sums_of_gpf(powint(10, $k)));
}

__END__
S(10^1)  = 32
S(10^2)  = 1915
S(10^3)  = 135946
S(10^4)  = 10118280
S(10^5)  = 793111753
S(10^6)  = 64937323262
S(10^7)  = 5494366736156
S(10^8)  = 476001412898167
S(10^9)  = 41985754895017934
S(10^10) = 3755757137823525252
S(10^11) = 339760245382396733607
S(10^12) = 31019315736720796982142


================================================
FILE: Math/partial_sums_of_inverse_moebius_transform_of_dedekind_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2019
# https://github.com/trizen

# Partial sums of the inverse Möbius transform of the Dedekind psi function.

# Definition, for m >= 0:
#
#   a(n) = Sum_{k=1..n} Sum_{d|k} ψ_m(d)
#        = Sum_{k=1..n} Sum_{d|k} 2^omega(k/d) * d^m
#        = Sum_{k=1..n} 2^omega(k) * F_m(floor(n/k))
#
# where `F_n(x)` are the Faulhaber polynomials.

# Asymptotic formula:
#   Sum_{k=1..n} Sum_{d|k} ψ_m(d) ~ F_m(n) * (zeta(m+1)^2 / zeta(2*(m+1)))
#                                 ~ (n^(m+1) * zeta(m+1)^2) / ((m+1) * zeta(2*(m+1)))

# For m=1, we have:
#   a(n) ~ (5/4) * n^2.
#   a(n) = Sum_{k=1..n} A060648(k).
#   a(n) = Sum_{k=1..n} Sum_{d|k} 2^omega(k/d) * d.
#   a(n) = Sum_{k=1..n} Sum_{d|k} A001615(d).
#   a(n) = (1/2)*Sum_{k=1..n} 2^omega(k) * floor(n/k) * floor(1 + n/k).

# Related OEIS sequences:
#   https://oeis.org/A064608 -- Partial sums of A034444: sum of number of unitary divisors from 1 to n.
#   https://oeis.org/A061503 -- Sum_{k<=n} (tau(k^2)), where tau is the number of divisors function.

# See also:
#   https://en.wikipedia.org/wiki/Dedekind_psi_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum);
use ntheory qw(sqrtint rootint factor_exp moebius);

sub inverse_moebius_of_dedekind_partial_sum ($n, $m) {

    my $lookup_size = 2 + 2 * rootint($n, 3)**2;

    my @omega_lookup     = (0);
    my @omega_sum_lookup = (0);

    for my $k (1 .. $lookup_size) {
        $omega_lookup[$k]     = 2**factor_exp($k);
        $omega_sum_lookup[$k] = $omega_sum_lookup[$k - 1] + $omega_lookup[$k];
    }

    my $s  = sqrtint($n);
    my @mu = moebius(0, $s);

    my sub R($n) {    # A064608(n) = Sum_{k=1..n} 2^omega(k)

        if ($n <= $lookup_size) {
            return $omega_sum_lookup[$n];
        }

        my $total = 0;

        foreach my $k (1 .. sqrtint($n)) {

            $mu[$k] || next;

            my $tmp = 0;
            foreach my $j (1 .. sqrtint(int($n / $k / $k))) {
                $tmp += int($n / $j / $k / $k);
            }

            $total += $mu[$k] * (2 * $tmp - sqrtint(int($n / $k / $k))**2);
        }

        return $total;
    }

    my $total = 0;

    for my $k (1 .. $s) {
        $total += $omega_lookup[$k] * faulhaber_sum(int($n / $k), $m);
        $total += $k**$m * R(int($n / $k));
    }

    $total -= R($s) * faulhaber_sum($s, $m);

    return $total;
}

sub inverse_moebius_of_dedekind_partial_sum_test ($n, $m) {    # just for testing
    my $total = 0;

    foreach my $k (1 .. $n) {
        $total += 2**factor_exp($k) * faulhaber_sum(int($n / $k), $m);
    }

    return $total;
}

for my $m (0 .. 10) {

    my $n = int(rand(1000));

    my $t1 = inverse_moebius_of_dedekind_partial_sum($n, $m);
    my $t2 = inverse_moebius_of_dedekind_partial_sum_test($n, $m);

    die "error: $t1 != $t2" if $t1 != $t2;

    say "Sum_{k=1..$n} Sum_{d|k} ψ_$m(d) = $t1";
}

__END__
Sum_{k=1..399} Sum_{d|k} ψ_0(d) = 7125
Sum_{k=1..898} Sum_{d|k} ψ_1(d) = 1005565
Sum_{k=1..284} Sum_{d|k} ψ_2(d) = 10904384
Sum_{k=1..363} Sum_{d|k} ψ_3(d) = 5089543732
Sum_{k=1..676} Sum_{d|k} ψ_4(d) = 30446345621064
Sum_{k=1..719} Sum_{d|k} ψ_5(d) = 23921678049099402
Sum_{k=1..273} Sum_{d|k} ψ_6(d) = 16623157368659789
Sum_{k=1..291} Sum_{d|k} ψ_7(d) = 6568878240105603914
Sum_{k=1..668} Sum_{d|k} ψ_8(d) = 2974535697414122138503228
Sum_{k=1..772} Sum_{d|k} ψ_9(d) = 7583168029177266313981257004
Sum_{k=1..967} Sum_{d|k} ψ_10(d) = 63269226338847691226388054366024


================================================
FILE: Math/partial_sums_of_jordan_totient_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 21 November 2018
# https://github.com/trizen

# A new algorithm for computing the partial-sums of the Jordan totient function `J_m(k)`, for `1 <= k <= n`:
#
#   Sum_{k=1..n} J_m(k)
#
# for any fixed integer m >= 1.

# Based on the formula:
#   Sum_{k=1..n} J_m(k) = Sum_{k=1..n} moebius(k) * F(m, floor(n/k))
#
# where F(n,x) is Faulhaber's formula for `Sum_{k=1..x} k^n`, defined in terms of Bernoulli polynomials as:
#   F(n, x) = (Bernoulli(n+1, x+1) - Bernoulli(n+1, 1)) / (n+1)

# Example for a(n) = Sum_{k=1..n} J_2(k):
#  a(10^1) = 312
#  a(10^2) = 280608
#  a(10^3) = 277652904
#  a(10^4) = 277335915120
#  a(10^5) = 277305865353048
#  a(10^6) = 277302780859485648
#  a(10^7) = 277302491422450102032
#  a(10^8) = 277302460845902192282712
#  a(10^9) = 277302457878113251222146576

# Asymptotic formula:
#   Sum_{k=1..n} J_2(k) ~ n^3 / (3*zeta(3))

# In general, for m>=1:
#   Sum_{k=1..n} J_m(k) ~ n^(m+1) / ((m+1) * zeta(m+1))

# See also:
#   https://oeis.org/A321879
#   https://en.wikipedia.org/wiki/Mertens_function
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function
#   https://en.wikipedia.org/wiki/Jordan%27s_totient_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum ipow);
use ntheory qw(jordan_totient moebius mertens vecsum sqrtint forsquarefree is_square_free);

sub jordan_totient_partial_sum ($n, $m) {

    my $total = 0;

    my $s = sqrtint($n);
    my $u = int($n / ($s + 1));

    my $prev = mertens($n);

    for my $k (1 .. $s) {
        my $curr = mertens(int($n / ($k + 1)));
        $total += ($prev - $curr) * faulhaber_sum($k, $m);
        $prev = $curr;
    }

    forsquarefree {
        $total += moebius($_) * faulhaber_sum(int($n / $_), $m);
    } $u;

    return $total;
}

sub jordan_totient_partial_sum_2 ($n, $m) {

    my $total = 0;
    my $s = sqrtint($n);

    for my $k (1 .. $s) {
        $total += ipow($k, $m) * mertens(int($n/$k));
        $total += moebius($k) * faulhaber_sum(int($n/$k), $m) if is_square_free($k);
    }

    $total -= faulhaber_sum($s, $m) * mertens($s);

    return $total;
}

sub jordan_totient_partial_sum_test ($n, $m) {    # just for testing
    vecsum(map { jordan_totient($m, $_) } 1 .. $n);
}

for my $m (0 .. 10) {

    my $n = int rand 10000;

    my $t1 = jordan_totient_partial_sum($n, $m);
    my $t2 = jordan_totient_partial_sum_2($n, $m);
    my $t3 = jordan_totient_partial_sum_test($n, $m);

    die "error: $t1 != $t2" if ($t1 != $t2);
    die "error: $t1 != $t3" if ($t1 != $t3);

    say "Sum_{k=1..$n} J_$m(k) = $t1";
}

__END__
Sum_{k=1..3244} J_0(k) = 1
Sum_{k=1..5688} J_1(k) = 9834896
Sum_{k=1..9961} J_2(k) = 274117576704
Sum_{k=1..2548} J_3(k) = 9743111756724
Sum_{k=1..1147} J_4(k) = 383774380194000
Sum_{k=1..9985} J_5(k) = 162406071542610636006836
Sum_{k=1..8677} J_6(k) = 524873561219508820442845176
Sum_{k=1..3594} J_7(k) = 3469354096873688451827581144
Sum_{k=1..6424} J_8(k) = 2067471378951107437291216947429120
Sum_{k=1..5169} J_9(k) = 1361614000750853225756775763744598788
Sum_{k=1..7785} J_10(k) = 578821237542299170578127992588067328813064


================================================
FILE: Math/partial_sums_of_jordan_totient_function_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 February 2019
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the Jordan totient function.

# The partial sums of the Jordan totient function is defined as:
#
#   a_m(n) = Sum_{k=1..n} J_m(k)
#
# where J_m(k) is the Jordan totient function.

# Recursive formula:
#
#   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)))
#
# where F_m(x) are Faulhaber's polynomials.

# Example for a_2(n) = Sum_{k=1..n} J_2(k):
#    a_2(10^1) = 312
#    a_2(10^2) = 280608
#    a_2(10^3) = 277652904
#    a_2(10^4) = 277335915120
#    a_2(10^5) = 277305865353048
#    a_2(10^6) = 277302780859485648
#    a_2(10^7) = 277302491422450102032
#    a_2(10^8) = 277302460845902192282712
#    a_2(10^9) = 277302457878113251222146576

# Asymptotic formula:
#   Sum_{k=1..n} J_2(k) ~ n^3 / (3*zeta(3))

# In general, for m>=1:
#   Sum_{k=1..n} J_m(k) ~ n^(m+1) / ((m+1) * zeta(m+1))

# OEIS sequences:
#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).
#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.

# See also:
#   https://en.wikipedia.org/wiki/Faulhaber's_formula
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz qw();
use Math::AnyNum qw(faulhaber_sum);
use ntheory qw(sqrtint rootint jordan_totient);

sub partial_sums_of_jordan_totient ($n, $m) {
    my $s = sqrtint($n);

    my $lookup_size       = 2 * rootint($n, 3)**2;
    my @jordan_sum_lookup = (Math::GMPz->new(0));

    foreach my $i (1 .. $lookup_size) {
        $jordan_sum_lookup[$i] = $jordan_sum_lookup[$i - 1] + jordan_totient($m, $i);
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $jordan_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $A = ${faulhaber_sum($n, $m)};

        foreach my $k (2 .. int($n / ($s + 1))) {
            $A -= __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $A -= (int($n / $k) - int($n / ($k + 1))) * $jordan_sum_lookup[$k];
        }

        $seen{$n} = $A;

    }->($n);
}

foreach my $n (1 .. 8) {    # takes ~1.5 seconds
    say "a_2(10^$n) = ", partial_sums_of_jordan_totient(10**$n, 2);
}


================================================
FILE: Math/partial_sums_of_jordan_totient_function_times_k_to_the_m.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 07 February 2019
# https://github.com/trizen

# A sublinear algorithm for computing the partial sums of the Jordan totient function times k^m.

# The partial sums of the Jordan totient function is defined as:
#
#   a(n,j,m) = Sum_{k=1..n} k^m * J_j(k)
#
# where J_j(k) is the Jordan totient function.

# Example:
#   a(10^1, 2, 1) = 2431
#   a(10^2, 2, 1) = 21128719
#   a(10^3, 2, 1) = 208327305823
#   a(10^4, 2, 1) = 2080103011048135
#   a(10^5, 2, 1) = 20798025097513144783
#   a(10^6, 2, 1) = 207977166477794042245831
#   a(10^7, 2, 1) = 2079768770407248541815183631
#   a(10^8, 2, 1) = 20797684646417657386198683679183
#   a(10^9, 2, 1) = 207976843496387628847025371255443991

# General asymptotic formula:
#
#   Sum_{k=1..n} k^m * J_j(k)  ~  F_(m+j)(n) / zeta(j+1).
#
# where F_m(n) are the Faulhaber polynomials.

# OEIS sequences:
#   https://oeis.org/A321879 -- Partial sums of the Jordan function J_2(k), for 1 <= k <= n.
#   https://oeis.org/A002088 -- Sum of totient function: a(n) = Sum_{k=1..n} phi(k).
#   https://oeis.org/A064018 -- Sum of the Euler totients phi for 10^n.
#   https://oeis.org/A272718 -- Partial sums of gcd-sum sequence A018804.

# See also:
#   https://en.wikipedia.org/wiki/Faulhaber's_formula
#   https://en.wikipedia.org/wiki/Dirichlet_hyperbola_method
#   https://en.wikipedia.org/wiki/Jordan%27s_totient_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum ipow);
use ntheory qw(jordan_totient sqrtint rootint);

sub partial_sums_of_jordan_totient ($n, $j, $m) {
    my $s = sqrtint($n);

    my @jordan_sum_lookup = (0);
    my $lookup_size = 2 * rootint($n, 3)**2;

    foreach my $i (1 .. $lookup_size) {
        $jordan_sum_lookup[$i] = $jordan_sum_lookup[$i - 1] + ipow($i, $m) * jordan_totient($j, $i);
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $jordan_sum_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $T = faulhaber_sum($n, $m + $j);

        foreach my $k (2 .. int($n / ($s + 1))) {
            $T -= ipow($k, $m) * __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $T -= (faulhaber_sum(int($n / $k), $m) - faulhaber_sum(int($n / ($k + 1)), $m)) * $jordan_sum_lookup[$k];
        }

        $seen{$n} = $T;

    }->($n);
}

my $j = 2;
my $k = 1;

foreach my $n (1 .. 7) {    # takes ~2.9 seconds
    say "a(10^$n, $j, $k) = ", partial_sums_of_jordan_totient(10**$n, $j, $k);
}


================================================
FILE: Math/partial_sums_of_lcm_count_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 January 2021
# https://github.com/trizen

# 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.

# Let a(n) = A007875(n), with a(1) = 1, for n > 1 (due to Vladeta Jovovic, Jan 25 2002):
#   a(n) = (1/2)*Sum_{d|n} abs(mu(d))
#        = 2^(omega(n)-1)
#        = usigma_0(n)/2

# This gives us f(n) as:
#   f(n) = Sum_{d|n} a(d)

# This script implements a sub-linear formula for computing partial sums of f(n):
#   S(n) = Sum_{k=1..n} f(k)
#        = Sum_{k=1..n} Sum_{d|k} a(d)
#        = Sum_{k=1..n} a(k) * floor(n/k)

# See also:
#   https://oeis.org/A007875
#   https://oeis.org/A064608
#   https://oeis.org/A182082

# Problem from:
#   https://projecteuler.net/problem=379

# Several values for S(10^n):
#   S(10^1)  = 29
#   S(10^2)  = 647
#   S(10^3)  = 11751
#   S(10^4)  = 186991
#   S(10^5)  = 2725630
#   S(10^6)  = 37429395
#   S(10^7)  = 492143953
#   S(10^8)  = 6261116500
#   S(10^9)  = 77619512018
#   S(10^10) = 942394656385
#   S(10^11) = 11247100884096

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub S ($n) {

    my $lookup_size = 2 + 2 * rootint($n, 3)**2;

    $lookup_size = 50000000    if ($lookup_size > 50000000);
    $lookup_size = sqrtint($n) if ($lookup_size < sqrtint($n));

    my @omega_lookup     = (0);
    my @omega_sum_lookup = (0);

    for my $k (1 .. $lookup_size) {
        $omega_lookup[$k]     = ($k == 1) ? 0 : (1 << (factor_exp($k) - 1));
        $omega_sum_lookup[$k] = $omega_sum_lookup[$k - 1] + $omega_lookup[$k];
    }

    my $s  = sqrtint($n);
    my @mu = moebius(0, $s);

    my sub R ($n) {

        if ($n <= $lookup_size) {
            return $omega_sum_lookup[$n];
        }

        my $total = 0;

        foreach my $k (1 .. sqrtint($n)) {

            $mu[$k] || next;

            my $t = 0;
            my $r = sqrtint(divint($n, $k * $k));

            foreach my $j (1 .. $r) {
                $t += divint($n, $j * $k * $k);
            }

            $total += $mu[$k] * (2 * $t - $r * $r);
        }

        return (($total - 1) >> 1);
    }

    my $total = 0;

    for my $k (1 .. $s) {
        $total += $omega_lookup[$k] * divint($n, $k);
        $total += R(divint($n, $k));
    }

    $total -= R($s) * $s;

    return $total + $n;
}

foreach my $n (1 .. 9) {
    say "S(10^$n) = ", S(10**$n);
}


================================================
FILE: Math/partial_sums_of_liouville_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 April 2019
# https://github.com/trizen

# A sublinear algorithm for computing the summatory function of the Liouville function (partial sums of the Liouville function).

# Defined as:
#
#   L(n) = Sum_{k=1..n} λ(k)
#
# where λ(k) is the Liouville function.

# Example:
#   L(10^1) = 0
#   L(10^2) = -2
#   L(10^3) = -14
#   L(10^4) = -94
#   L(10^5) = -288
#   L(10^6) = -530
#   L(10^7) = -842
#   L(10^8) = -3884
#   L(10^9) = -25216
#   L(10^10) = -116026

# OEIS sequences:
#   https://oeis.org/A008836 -- Liouville's function lambda(n) = (-1)^k, where k is number of primes dividing n (counted with multiplicity).
#   https://oeis.org/A090410 -- L(10^n), where L(n) is the summatory function of the Liouville function.

# See also:
#   https://en.wikipedia.org/wiki/Liouville_function

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(liouville sqrtint rootint);

sub liouville_function_sum($n) {

    my $lookup_size = 2 * rootint($n, 3)**2;

    my @liouville_lookup = (0);

    foreach my $i (1 .. $lookup_size) {
        $liouville_lookup[$i] = $liouville_lookup[$i - 1] + liouville($i);
    }

    my %seen;

    sub ($n) {

        if ($n <= $lookup_size) {
            return $liouville_lookup[$n];
        }

        if (exists $seen{$n}) {
            return $seen{$n};
        }

        my $s = sqrtint($n);
        my $L = $s;

        foreach my $k (2 .. int($n / ($s + 1))) {
            $L -= __SUB__->(int($n / $k));
        }

        foreach my $k (1 .. $s) {
            $L -= $liouville_lookup[$k] * (int($n / $k) - int($n / ($k + 1)));
        }

        $seen{$n} = $L;

    }->($n);
}

foreach my $n (1 .. 9) {    # takes ~2.6 seconds
    say "L(10^$n) = ", liouville_function_sum(10**$n);
}


================================================
FILE: Math/partial_sums_of_lpf.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 July 2020
# https://github.com/trizen

# Algorithm with sublinear time for computing:
#
#   Sum_{k=2..n} lpf(k)
#
# where:
#   lpf(k) = the least prime factor of k

# See also:
#   https://projecteuler.net/problem=521

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub partial_sums_of_lpf($n) {

    my $t = 0;
    my $s = sqrtint($n);

    forprimes {
        $t = addint($t, mulint($_, rough_count(divint($n,$_), $_)));
    } $s;

    addint($t, sum_primes(next_prime($s), $n));
}

foreach my $k (1..10) {
    printf("S(10^%d) = %s\n", $k, partial_sums_of_lpf(powint(10, $k)));
}

__END__
S(10^1)  = 28
S(10^2)  = 1257
S(10^3)  = 79189
S(10^4)  = 5786451
S(10^5)  = 455298741
S(10^6)  = 37568404989
S(10^7)  = 3203714961609
S(10^8)  = 279218813374515
S(10^9)  = 24739731010688477
S(10^10) = 2220827932427240957
S(10^11) = 201467219561892846337
S(10^12) = 18435592284459044389811


================================================
FILE: Math/partial_sums_of_n_over_k-almost_prime_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 July 2020
# https://github.com/trizen

# Sublinear algorithm for computing the following partial sum:
#   S(n) = Sum_{k=1..n} Sum_{d|k, d is r-almost prime} (k/d)^m

# Equivalently:
#   S(n) = Sum_{t is r-almost prime <= n} F_m(floor(n/t))
# where F_m(x) are the Faulhaber polynomials.

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum ipow);

sub f($n, $r = 1, $m = 0) {

    my $total = 0;
    my $s = sqrtint($n);

    for my $k (1 .. $s) {
        $total += ipow($k, $m) * almost_prime_count($r, int($n/$k));
        $total += faulhaber_sum(int($n/$k), $m) if is_almost_prime($r, $k);
    }

    $total -= faulhaber_sum($s, $m) * almost_prime_count($r, $s);
    $total;
}

my $n = 100;

say f($n, 1, 0);      #=> Sum_{p     <= n} floor(n/p)       = Sum_{k=1..n} omega(k)
say f($n, 2, 0);      #=> Sum_{p*q   <= n} floor(n/(p*q))   = Sum_{k=1..n} (number of semiprime divisors of k)
say 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)

say '';

say f($n, 1, 1);      #=> Sum_{k=1..n} Sum_{d|k, d is prime} k/d
say f($n, 2, 1);      #=> Sum_{k=1..n} Sum_{d|k, d is semiprime} k/d
say f($n, 3, 1);      #=> Sum_{k=1..n} Sum_{d|k, d is 3-almost prime} k/d

say '';

say f($n, 1, 2);      #=> Sum_{k=1..n} Sum_{d|k, d is prime} (k/d)^2
say f($n, 2, 2);      #=> Sum_{k=1..n} Sum_{d|k, d is semiprime} (k/d)^2
say f($n, 3, 2);      #=> Sum_{k=1..n} Sum_{d|k, d is 3-almost prime} (k/d)^2

say "=> Sum_{k=1..10^n} (number of r-almost prime divisors of k)";

foreach my $r(1..10) {
    say "r = $r: {", join(', ', map{ f(powint(10, $_), $r, 0) } 1..10), "}";
}

say "\n=> Sum_{k=1..10^n} Sum_{d|k, d is r-almost prime} k/d";

foreach my $r(1..10) {
    say "r = $r: {", join(', ', map{ f(powint(10, $_), $r, 1) } 1..10), "}";
}

__END__
=> Sum_{k=1..10^n} (number of r-almost prime divisors of k)
r = 1: {11, 171, 2126, 24300, 266400, 2853708, 30130317, 315037281, 3271067968, 33787242719}
r = 2: {5, 122, 1913, 25368, 309107, 3587501, 40365331, 444658798, 4824183366, 51743978073}
r = 3: {1, 58, 1133, 17179, 230719, 2887977, 34547708, 400531419, 4538949470, 50558632114}
r = 4: {0, 22, 540, 9233, 134679, 1797417, 22659565, 274626874, 3233939674, 37258074465}
r = 5: {0, 7, 227, 4370, 68530, 965003, 12701142, 159627891, 1939960994, 22982979719}
r = 6: {0, 2, 87, 1916, 32224, 475757, 6492864, 84065469, 1048002136, 12697321609}
r = 7: {0, 0, 31, 798, 14434, 222925, 3142601, 41737061, 531430463, 6557159407}
r = 8: {0, 0, 10, 320, 6254, 101133, 1470682, 19990495, 259291249, 3249251063}
r = 9: {0, 0, 2, 123, 2636, 44843, 673192, 9358736, 123499047, 1569291893}
r = 10: {0, 0, 0, 43, 1082, 19518, 303259, 4314150, 57902495, 745552461}

=> Sum_{k=1..10^n} Sum_{d|k, d is r-almost prime} k/d
r = 1: {25, 2298, 226342, 22616110, 2261266482, 226124236118, 22612374197143, 2261237139656553, 226123710243814636, 22612371006991736766}
r = 2: {6, 708, 70451, 7039258, 703809052, 70380387011, 7038023049102, 703802183270761, 70380217285372212, 7038021718888470558}
r = 3: {1, 185, 19261, 1926267, 192581190, 19258134188, 1925810130677, 192580966614994, 19258096515198495, 1925809649512680144}
r = 4: {0, 45, 4923, 500170, 50040884, 5004660706, 500471363203, 50047175747701, 5004718038062777, 500471809568738447}
r = 5: {0, 11, 1223, 126815, 12721482, 1272501930, 127253328013, 12725377777502, 1272538042723713, 127253807917463043}
r = 6: {0, 2, 294, 31833, 3202085, 320487410, 32051378868, 3205166314991, 320516898071185, 32051692261591786}
r = 7: {0, 0, 71, 7961, 802623, 80380033, 8039296889, 803941592045, 80394302031247, 8039431476576389}
r = 8: {0, 0, 14, 1987, 200573, 20122035, 2012708079, 201279547587, 20128037882005, 2012804711838236}
r = 9: {0, 0, 2, 478, 50020, 5033105, 503486440, 50352373220, 5035281352929, 503528648179002}
r = 10: {0, 0, 0, 106, 12431, 1257575, 125898801, 12591617913, 1259181979675, 125918535892823}


================================================
FILE: Math/partial_sums_of_powerfree_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 August 2021
# https://github.com/trizen

# Sub-linear formula for computing the sum of the k-powerfree numbers <= n.

# See also:
#   https://oeis.org/A066779

use 5.036;
use ntheory qw(addint mulint divint powint rootint
               vecprod vecsum forsquarefree vecall factor_exp);

sub T ($n) {    # n-th triangular number
    divint(mulint($n, addint($n, 1)), 2);
}

sub is_powerfree ($n, $k = 2) {
    (vecall { $_->[1] < $k } factor_exp($n)) ? 1 : 0;
}

sub powerfree_sum ($n, $k = 2) {
    my $sum = 0;
    forsquarefree {
        $sum = addint($sum, vecprod(((scalar(@_) & 1) ? -1 : 1), powint($_, $k), T(divint($n, powint($_, $k)))));
    } rootint($n, $k);
    return $sum;
}

foreach my $k (2 .. 10) {
    printf("Sum of %2d-powerfree numbers <= 10^j: {%s}\n", $k,
           join(', ', map { powerfree_sum(powint(10, $_), $k) } 0 .. 10));
}

use Test::More tests => 10;

foreach my $k (1..10) {
    my $n = 100;

    is_deeply(
        [map { powerfree_sum($_, $k) } 1..$n],
        [map { vecsum(grep { is_powerfree($_, $k) } 1..$_) } 1..$n],
    );
}

__END__
Sum of  2-powerfree numbers <= 10^j: {1, 34, 2967, 303076, 30420034, 3039711199, 303961062910, 30396557311887, 3039633904822886, 303963567619632057, 30396354343039613622}
Sum of  3-powerfree numbers <= 10^j: {1, 47, 4264, 416150, 41586160, 4159363010, 415954865054, 41595434367696, 4159535757149773, 415953684178098104, 41595368549000401165}
Sum of  4-powerfree numbers <= 10^j: {1, 55, 4633, 462309, 46194572, 4619706557, 461968894786, 46196921076177, 4619691742903970, 461969203230753906, 46196920137396170242}
Sum of  5-powerfree numbers <= 10^j: {1, 55, 4858, 482198, 48222307, 4821980585, 482193364705, 48219363893896, 4821936891554962, 482193669861570387, 48219367054214757071}
Sum of  6-powerfree numbers <= 10^j: {1, 55, 4986, 492091, 49154917, 4914845614, 491476913298, 49147631895757, 4914762949966044, 491476293899695450, 49147629625656526116}
Sum of  7-powerfree numbers <= 10^j: {1, 55, 5050, 496916, 49588762, 4958620842, 495860136228, 49585989492140, 4958599241977593, 495859927007565418, 49585992797893696932}
Sum of  8-powerfree numbers <= 10^j: {1, 55, 5050, 498964, 49798759, 4979743960, 497969661841, 49796960766296, 4979696019857946, 497969600482512058, 49796960053175724454}
Sum of  9-powerfree numbers <= 10^j: {1, 55, 5050, 499988, 49907720, 4989970435, 498998466703, 49899772216835, 4989978143911393, 498997816910227655, 49899781642188970208}
Sum of 10-powerfree numbers <= 10^j: {1, 55, 5050, 500500, 49958920, 4995123879, 499504250712, 49950320120610, 4995032061303318, 499503206523627025, 49950320659515298125}


================================================
FILE: Math/partial_sums_of_powerfree_part.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 August 2021
# https://github.com/trizen

# Sub-linear formula for computing the partial sum of the k-powerfree part of numbers <= n.

# See also:
#   https://oeis.org/A007913 -- Squarefree part of n: a(n) is the smallest positive number m such that n/m is a square.
#   https://oeis.org/A050985 -- Cubefree part of n.
#   https://oeis.org/A069891 -- a(n) = Sum_{k=1..n} A007913(k), the squarefree part of k.

use 5.036;
use ntheory qw(divint addint mulint powint rootint factor_exp vecprod vecsum);

sub T ($n) {    # n-th triangular number
    divint(mulint($n, addint($n, 1)), 2);
}

sub powerfree_part ($n, $k = 2) {
    return 0 if ($n == 0);
    vecprod(map { powint($_->[0], $_->[1] % $k) } factor_exp($n));
}

sub f ($n, $r) {
    vecprod(map { 1 - powint($_->[0], $r) } factor_exp($n));
}

sub powerfree_part_sum ($n, $k = 2) {
    my $sum = 0;
    for (1 .. rootint($n, $k)) {
        $sum = addint($sum, mulint(f($_, $k), T(divint($n, powint($_, $k)))));
    }
    return $sum;
}

foreach my $k (2 .. 10) {
    printf("Sum of %2d-powerfree part of numbers <= 10^j: {%s}\n", $k,
           join(', ', map { powerfree_part_sum(powint(10, $_), $k) } 0 .. 7));
}

use Test::More tests => 10;

foreach my $k (1..10) {
    my $n = 100;

    is_deeply(
        [map { powerfree_part_sum($_, $k) } 1..$n],
        [map { vecsum(map { powerfree_part($_, $k) } 1..$_) } 1..$n],
    );
}

__END__
Sum of  2-powerfree part of numbers <= 10^j: {1, 38, 3233, 328322, 32926441, 3289873890, 328984021545, 32898872196712}
Sum of  3-powerfree part of numbers <= 10^j: {1, 48, 4341, 423422, 42307792, 4231510721, 423168867323, 42316819978538}
Sum of  4-powerfree part of numbers <= 10^j: {1, 55, 4655, 464251, 46382816, 4638539465, 463852501943, 46385283123175}
Sum of  5-powerfree part of numbers <= 10^j: {1, 55, 4864, 482704, 48270333, 4826777870, 482672975112, 48267321925901}
Sum of  6-powerfree part of numbers <= 10^j: {1, 55, 4987, 492212, 49167065, 4916054515, 491597851229, 49159726433201}
Sum of  7-powerfree part of numbers <= 10^j: {1, 55, 5050, 496944, 49591853, 4958924582, 495890504497, 49589026540242}
Sum of  8-powerfree part of numbers <= 10^j: {1, 55, 5050, 498970, 49799540, 4979820070, 497977273243, 49797721800745}
Sum of  9-powerfree part of numbers <= 10^j: {1, 55, 5050, 499989, 49907910, 4989989560, 499000372993, 49899962707231}
Sum of 10-powerfree part of numbers <= 10^j: {1, 55, 5050, 500500, 49958965, 4995128633, 499504727624, 49950367771436}


================================================
FILE: Math/partial_sums_of_prime_bigomega_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 November 2018
# https://github.com/trizen

# A nice algorithm in terms of the prime-counting function for computing partial sums of the generalized bigomega(n) function:
#   B_m(n) = Sum_{k=1..n} Ω_m(k)

# For `m=0`, we have:
#   B_0(n) = bigomega(n!)

# OEIS related sequences:
#   https://oeis.org/A025528
#   https://oeis.org/A022559
#   https://oeis.org/A071811
#   https://oeis.org/A154945  (0.55169329765699918...)
#   https://oeis.org/A286229  (0.19411816983263379...)

# Example for `B_0(n)`:
#    B_0(10^1) = 15
#    B_0(10^2) = 239
#    B_0(10^3) = 2877
#    B_0(10^4) = 31985
#    B_0(10^5) = 343614
#    B_0(10^6) = 3626619
#    B_0(10^7) = 37861249
#    B_0(10^8) = 392351272
#    B_0(10^9) = 4044220058
#    B_0(10^10) = 41518796555
#    B_0(10^11) = 424904645958

# Example for `B_1(n)`:
#   B_1(10^1) = 30
#   B_1(10^2) = 2815
#   B_1(10^3) = 276337
#   B_1(10^4) = 27591490
#   B_1(10^5) = 2758525172
#   B_1(10^6) = 275847515154
#   B_1(10^7) = 27584671195911
#   B_1(10^8) = 2758466558498626
#   B_1(10^9) = 275846649393437566
#   B_1(10^10) = 27584664891073330599
#   B_1(10^11) = 2758466488352698209587

# Example for `B_2(n)`:
#   B_2(10^1) = 82
#   B_2(10^2) = 66799
#   B_2(10^3) = 64901405
#   B_2(10^4) = 64727468210
#   B_2(10^5) = 64708096890744
#   B_2(10^6) = 64706281936598588
#   B_2(10^7) = 64706077322294843451
#   B_2(10^8) = 64706058761567362618628
#   B_2(10^9) = 64706056807390376400359474
#   B_2(10^10) = 64706056632561375736945155965
#   B_2(10^11) = 64706056612919470606889256184409

# Asymptotic formulas:
#   B_1(n) ~ 0.55169329765699918... * n*(n+1)/2
#   B_2(n) ~ 0.19411816983263379... * n*(n+1)*(2*n+1)/6

# In general, for `m>=1`, we have the following asymptotic formula:
#   B_m(n) ~ (Sum_{k>=1} primezeta((m+1)*k)) * F_m(n)
#
# where F_n(x) is Faulhaber's formula and primezeta(s) is the prime zeta function.

# The prime zeta function is defined as:
#   primezeta(s) = Sum_{p prime >= 2} 1/p^s

# OEIS sequences:
#   https://oeis.org/A022559    -- Sum of exponents in prime-power factorization of n!.
#   https://oeis.org/A071811    -- Sum_{k <= 10^n} number of primes (counted with multiplicity) dividing k.

# See also:
#   https://en.wikipedia.org/wiki/Prime_zeta_function
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://en.wikipedia.org/wiki/Prime-counting_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum ipow);
use ntheory qw(logint sqrtint rootint prime_count is_prime_power forprimes prime_power_count divint);

sub prime_bigomega_partial_sum ($n, $m) {

    my $s = sqrtint($n);
    my $u = divint($n, $s+1);

    my $total = 0;
    my $prev = prime_power_count($n);

    for my $k (1 .. $s) {
        my $curr = prime_power_count(divint($n, $k+1));
        $total += faulhaber_sum($k, $m) * ($prev - $curr);
        $prev = $curr;
    }

    forprimes {
        for (my $q = $_; $q <= $u; $q *= $_) {
            $total += faulhaber_sum(divint($n, $q), $m);
        }
    } $u;

    return $total;
}

sub prime_bigomega_partial_sum_2 ($n, $m) {

    my $s = sqrtint($n);
    my $total = 0;

    for my $k (1 .. $s) {
        $total += ipow($k, $m) * prime_power_count(divint($n,$k));
        $total += faulhaber_sum(divint($n,$k), $m) if is_prime_power($k);
    }

    $total -= prime_power_count($s) * faulhaber_sum($s, $m);

    return $total;
}

sub prime_bigomega_partial_sum_test ($n, $m) {    # just for testing
    my $total = 0;

    foreach my $k (1 .. $n) {
        if (is_prime_power($k)) {
            $total += faulhaber_sum(divint($n,$k), $m);
        }
    }

    return $total;
}

for my $m (0 .. 10) {

    my $n = int rand 100000;

    my $t1 = prime_bigomega_partial_sum($n, $m);
    my $t2 = prime_bigomega_partial_sum_2($n, $m);
    my $t3 = prime_bigomega_partial_sum_test($n, $m);

    die "error: $t1 != $t2" if ($t1 != $t2);
    die "error: $t1 != $t3" if ($t1 != $t3);

    say "Sum_{k=1..$n} bigomega_$m(k) = $t1";
}

__END__
Sum_{k=1..64129} bigomega_0(k) = 217697
Sum_{k=1..80658} bigomega_1(k) = 1794616247
Sum_{k=1..14117} bigomega_2(k) = 182041102184
Sum_{k=1..42256} bigomega_3(k) = 64820877399946967
Sum_{k=1..94333} bigomega_4(k) = 54949545016977768030431
Sum_{k=1..67787} bigomega_5(k) = 280074038628976042168758675
Sum_{k=1..35346} bigomega_6(k) = 82191526450425222986408201316
Sum_{k=1..26871} bigomega_7(k) = 138516432841564488200009700415893
Sum_{k=1..37827} bigomega_8(k) = 35383863032817120893574255077390725080
Sum_{k=1..75109} bigomega_9(k) = 568264668321999976994584691196910905310669837
Sum_{k=1..86486} bigomega_10(k) = 90982066598399530764623907560522017063257428908802


================================================
FILE: Math/partial_sums_of_prime_omega_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 24 November 2018
# https://github.com/trizen

# A new algorithm for computing the partial-sums of the generalized prime omega function `ω_m(k)`, for `1 <= k <= n`:
#   A_m(n) = Sum_{k=1..n} ω_m(k)
#
# where:
#     ω_m(n) = n^m * Sum_{p|n} 1/p^m

# Based on the formula:
#   Sum_{k=1..n} ω_m(k) = Sum_{p prime <= n} F_m(floor(n/p))
#
# where F_n(x) is Faulhaber's formula.

# Example for `m=0`:
#   A_0(10^1) = 11
#   A_0(10^2) = 171
#   A_0(10^3) = 2126
#   A_0(10^4) = 24300
#   A_0(10^5) = 266400
#   A_0(10^6) = 2853708
#   A_0(10^7) = 30130317
#   A_0(10^8) = 315037281
#   A_0(10^9) = 3271067968
#   A_0(10^10) = 33787242719
#   A_0(10^11) = 347589015681
#   A_0(10^12) = 3564432632541

# Example for `m=1`:
#   A_1(10^1) = 25
#   A_1(10^2) = 2298
#   A_1(10^3) = 226342
#   A_1(10^4) = 22616110
#   A_1(10^5) = 2261266482
#   A_1(10^6) = 226124236118
#   A_1(10^7) = 22612374197143
#   A_1(10^8) = 2261237139656553
#   A_1(10^9) = 226123710243814636
#   A_1(10^10) = 22612371006991736766
#   A_1(10^11) = 2261237100241987653515
#   A_1(10^12) = 226123710021083492369813

# Example for `m=2`:
#   A_2(10^1) = 75
#   A_2(10^2) = 59962
#   A_2(10^3) = 58403906
#   A_2(10^4) = 58270913442
#   A_2(10^5) = 58255785988898
#   A_2(10^6) = 58254390385024132
#   A_2(10^7) = 58254229074894448703
#   A_2(10^8) = 58254214780225801032503
#   A_2(10^9) = 58254213248247357411667320
#   A_2(10^10) = 58254213116747777047390609694
#   A_2(10^11) = 58254213101385832019517484266265
#   A_2(10^12) = 58254213099991292350208499967189227

# Asymptotic formulas:
#   A_1(n) ~ 0.4522474200410654985065... * n*(n+1)/2               (see: https://oeis.org/A085548)
#   A_2(n) ~ 0.1747626392994435364231... * n*(n+1)*(2*n+1)/6       (see: https://oeis.org/A085541)

# For `m >= 1`, `A_m(n)` can be described asymptotically in terms of the prime zeta function:
#   A_m(n) ~ F_m(n) * P(m+1)
#
# where P(s) is defined as:
#   P(s) = Sum_{p prime >= 2} 1/p^s

# OEIS sequences:
#   https://oeis.org/A013939     -- Partial sums of sequence A001221 (number of distinct primes dividing n).
#   https://oeis.org/A064182     -- Sum_{k <= 10^n} number of distinct primes dividing k.

# See also:
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://en.wikipedia.org/wiki/Prime-counting_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum ipow);
use ntheory qw(forprimes prime_count sqrtint is_prime);

sub prime_omega_partial_sum ($n, $m) {     # O(sqrt(n)) complexity

    my $total = 0;

    my $s = sqrtint($n);
    my $u = int($n / ($s + 1));

    for my $k (1 .. $s) {
        $total += faulhaber_sum($k, $m) * prime_count(int($n/($k+1))+1, int($n/$k));
    }

    forprimes {
        $total += faulhaber_sum(int($n/$_), $m);
    } $u;

    return $total;
}

sub prime_omega_partial_sum_2 ($n, $m) {     # O(sqrt(n)) complexity

    my $total = 0;
    my $s = sqrtint($n);

    for my $k (1 .. $s) {
        $total += ipow($k, $m) * prime_count(int($n/$k));
        $total += faulhaber_sum(int($n/$k), $m) if is_prime($k);
    }

    $total -= faulhaber_sum($s, $m) * prime_count($s);

    return $total;
}

sub prime_omega_partial_sum_test ($n, $m) {      # just for testing
    my $total = 0;

    forprimes {
        $total += faulhaber_sum(int($n/$_), $m);
    } $n;

    return $total;
}

for my $m (0 .. 10) {

    my $n = int rand 100000;

    my $t1 = prime_omega_partial_sum($n, $m);
    my $t2 = prime_omega_partial_sum_2($n, $m);
    my $t3 = prime_omega_partial_sum_test($n, $m);

    die "error: $t1 != $t2" if ($t1 != $t2);
    die "error: $t1 != $t3" if ($t1 != $t3);

    say "Sum_{k=1..$n} omega_$m(k) = $t1";
}

__END__
Sum_{k=1..93178} omega_0(k) = 247630
Sum_{k=1..60545} omega_1(k) = 828906439
Sum_{k=1..61222} omega_2(k) = 13368082621946
Sum_{k=1..58175} omega_3(k) = 220463446471253532
Sum_{k=1..26576} omega_4(k) = 94816277435320229002
Sum_{k=1..17978} omega_5(k) = 96085844643312478233603
Sum_{k=1..99336} omega_6(k) = 112956550182103434253591001302255
Sum_{k=1..15217} omega_7(k) = 1459563487599016502195229269710
Sum_{k=1..62565} omega_8(k) = 3271462737352430519765722633491562894793
Sum_{k=1..91318} omega_9(k) = 4007044838270388920307792726568428120477189405
Sum_{k=1..28834} omega_10(k) = 514524955177931497535073881648700561462698676


================================================
FILE: Math/partial_sums_of_sigma0_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 09 November 2018
# Edit: 30 March 2025
# https://github.com/trizen

# Algorithm with O(sqrt(n)) complexity for computing the partial-sums of the `sigma_0(k)` function:
#   Sum_{k=1..n} sigma_0(k)

# See also:
#   https://oeis.org/A006218
#   https://en.wikipedia.org/wiki/Divisor_function
#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula
#   https://en.wikipedia.org/wiki/Bernoulli_polynomials
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.036;

sub sigma0_partial_sum_faulhaber ($n) {

    my $s   = int(sqrt($n));
    my $sum = 0;

    foreach my $k (1 .. $s) {
        $sum += 2 * int($n / $k);
    }

    return ($sum - $s * $s);
}

sub sigma0_partial_sum_test ($n) {    # just for testing
    my $sum = 0;
    foreach my $k (1 .. $n) {
        $sum += int($n / $k);
    }
    return $sum;
}

foreach my $m (0 .. 10) {

    my $n = int(rand(1 << (2 * $m)));

    my $t1 = sigma0_partial_sum_test($n);
    my $t2 = sigma0_partial_sum_faulhaber($n);

    say "Sum_{k=1..$n} sigma_0(k) = $t2";

    die "error: $t1 != $t2" if ($t1 != $t2);
}

__END__
Sum_{k=1..0} sigma_0(k) = 0
Sum_{k=1..3} sigma_0(k) = 5
Sum_{k=1..13} sigma_0(k) = 37
Sum_{k=1..30} sigma_0(k) = 111
Sum_{k=1..193} sigma_0(k) = 1049
Sum_{k=1..51} sigma_0(k) = 211
Sum_{k=1..2288} sigma_0(k) = 18059
Sum_{k=1..15985} sigma_0(k) = 157208
Sum_{k=1..10112} sigma_0(k) = 94818
Sum_{k=1..152099} sigma_0(k) = 1838389
Sum_{k=1..446108} sigma_0(k) = 5872025


================================================
FILE: Math/partial_sums_of_sigma_function.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 09 November 2018
# Edit: 30 March 2025
# https://github.com/trizen

# A new generalized algorithm with O(sqrt(n)) complexity for computing the partial-sums of the `sigma_j(k)` function:
#
#   Sum_{k=1..n} sigma_j(k)
#
# for any integer j >= 0.

# See also:
#   https://en.wikipedia.org/wiki/Divisor_function
#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula
#   https://en.wikipedia.org/wiki/Bernoulli_polynomials
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.036;
use ntheory      qw(divisors);
use Math::AnyNum qw(faulhaber_sum bernoulli sum isqrt ipow);

sub sigma_partial_sum_faulhaber ($n, $m = 1) {    # using Faulhaber's formula

    my $s = isqrt($n);
    my $u = int($n / ($s + 1));

    my $sum = 0;

    foreach my $k (1 .. $s) {
        $sum += $k * (faulhaber_sum(int($n / $k), $m) - faulhaber_sum(int($n / ($k + 1)), $m));
    }

    foreach my $k (1 .. $u) {
        $sum += ipow($k, $m) * int($n / $k);
    }

    return $sum;
}

sub sigma_partial_sum_dirichlet ($n, $m = 1) {    # using the Dirichlet hyperbola method

    my $total = 0;
    my $s     = isqrt($n);

    for my $k (1 .. $s) {
        $total += faulhaber_sum(int($n / $k), $m);
        $total += ipow($k, $m) * int($n / $k);
    }

    $total -= $s * faulhaber_sum($s, $m);

    return $total;
}

sub sigma_partial_sum_bernoulli ($n, $m = 1) {    # using Bernoulli polynomials

    my $s = isqrt($n);
    my $u = int($n / ($s + 1));

    my $sum = 0;

    foreach my $k (1 .. $s) {
        $sum += $k * (bernoulli($m + 1, 1 + int($n / $k)) - bernoulli($m + 1, 1 + int($n / ($k + 1)))) / ($m + 1);
    }

    foreach my $k (1 .. $u) {
        $sum += ipow($k, $m) * int($n / $k);
    }

    return $sum;
}

sub sigma_partial_sum_test ($n, $m = 1) {    # just for testing
    sum(
        map {
            sum(map { ipow($_, $m) } divisors($_))
          } 1 .. $n
       );
}

foreach my $m (0 .. 10) {

    my $n = int(rand(1000));

    my $t1 = sigma_partial_sum_test($n, $m);
    my $t2 = sigma_partial_sum_faulhaber($n, $m);
    my $t3 = sigma_partial_sum_bernoulli($n, $m);
    my $t4 = sigma_partial_sum_dirichlet($n, $m);

    say "Sum_{k=1..$n} sigma_$m(k) = $t2";

    die "error: $t1 != $t2" if ($t1 != $t2);
    die "error: $t1 != $t3" if ($t1 != $t3);
    die "error: $t1 != $t4" if ($t1 != $t4);
}

__END__
Sum_{k=1..198} sigma_0(k) = 1084
Sum_{k=1..657} sigma_1(k) = 355131
Sum_{k=1..933} sigma_2(k) = 325914283
Sum_{k=1..905} sigma_3(k) = 181878297343
Sum_{k=1..402} sigma_4(k) = 2191328841200
Sum_{k=1..967} sigma_5(k) = 139059243381760868
Sum_{k=1..320} sigma_6(k) = 50042081613053611
Sum_{k=1..168} sigma_7(k) = 81561359789498529
Sum_{k=1..977} sigma_8(k) = 90713993807165413835362083
Sum_{k=1..219} sigma_9(k) = 25985664184393953943010
Sum_{k=1..552} sigma_10(k) = 133190310787744370768676943091


================================================
FILE: Math/partial_sums_of_sigma_function_times_k.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 10 November 2018
# https://github.com/trizen

# A new generalized algorithm with O(sqrt(n)) complexity for computing the partial-sums of `k * sigma_j(k)`, for `1 <= k <= n`:
#
#   Sum_{k=1..n} k * sigma_j(k)
#
# for any integer j >= 0.

# Example: `a(n) = Sum_{k=1..n} k * sigma(k)`
#   a(10^1)  = 622
#   a(10^2)  = 558275
#   a(10^3)  = 549175530
#   a(10^4)  = 548429473046
#   a(10^5)  = 548320905633448
#   a(10^6)  = 548312690631798482
#   a(10^7)  = 548311465139943768941
#   a(10^8)  = 548311366911386862908968
#   a(10^9)  = 548311356554322895313137239
#   a(10^10) = 548311355740964925044531454428

# For m>=0 and j>=1, we have the following asymptotic formula:
#   Sum_{k=1..n} k^m * sigma_j(k) ~ zeta(j+1)/(j+m+1) * n^(j+m+1)

# See also:
#   https://en.wikipedia.org/wiki/Divisor_function
#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula
#   https://en.wikipedia.org/wiki/Bernoulli_polynomials
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use ntheory qw(divisors);
use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum sum isqrt ipow);

sub sigma_partial_sum($n, $m) {       # O(sqrt(n)) complexity

    my $total = 0;

    my $s = isqrt($n);
    my $u = int($n / ($s + 1));

    for my $k (1 .. $s) {
        $total += $k*($k+1) * (faulhaber_sum(int($n/$k), $m+1) - faulhaber_sum(int($n/($k+1)), $m+1));
    }

    for my $k (1 .. $u) {
        $total += ipow($k, $m+1) * int($n/$k) * (1 + int($n/$k));
    }

    return $total/2;
}

sub sigma_partial_sum_test($n, $m) {      # just for testing
    sum(map { $_ * sum(map { ipow($_, $m) } divisors($_)) } 1..$n);
}

for my $m (0..10) {

    my $n = int(rand(1000));

    my $t1 = sigma_partial_sum($n, $m);
    my $t2 = sigma_partial_sum_test($n, $m);

    die "error: $t1 != $t2" if ($t1 != $t2);

    say "Sum_{k=1..$n} k * σ_$m(k) = $t2"
}

__END__
Sum_{k=1..649} k * σ_0(k) = 1505437
Sum_{k=1..184} k * σ_1(k) = 3442689
Sum_{k=1..156} k * σ_2(k) = 180861250
Sum_{k=1..781} k * σ_3(k) = 63090289257686
Sum_{k=1..822} k * σ_4(k) = 53514505511600484
Sum_{k=1..982} k * σ_5(k) = 128445772086331164364
Sum_{k=1..742} k * σ_6(k) = 11644176895188820029668
Sum_{k=1..837} k * σ_7(k) = 22614022054863154308526282
Sum_{k=1..355} k * σ_8(k) = 3230297764819153302018985
Sum_{k=1..837} k * σ_9(k) = 12937980446016909148074821860258
Sum_{k=1..699} k * σ_10(k) = 1144140317656849776081892799180303


================================================
FILE: Math/partial_sums_of_sigma_function_times_k_to_the_m.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 10 November 2018
# https://github.com/trizen

# A new generalized algorithm with O(sqrt(n)) complexity for computing the partial-sums of `k^m * sigma_j(k)`, for `1 <= k <= n`:
#
#   Sum_{k=1..n} k^m * sigma_j(k)
#
# for any fixed m >= 0 and j >= 0.

# Formula:
#   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))))
#                                   + Sum_{k=1..floor(n/(floor(sqrt(n))+1))} k^(m+j) * F(m, floor(n/k))
#
# where F(n,x) is Faulhaber's formula for `Sum_{k=1..x} k^n`, defined in terms of Bernoulli polynomials as:
#
#   F(n,x) = (Bernoulli(n+1, x+1) - Bernoulli(n+1, 1)) / (n+1)
#
# and Bernoulli(n,x) are the Bernoulli polynomials.

# Example for `a(n) = Sum_{k=1..n} k^2 * sigma(k)`
#   a(10^1)  = 4948
#   a(10^2)  = 42206495
#   a(10^3)  = 412181273976
#   a(10^4)  = 4113599787351824
#   a(10^5)  = 41124390000844973548
#   a(10^6)  = 411234935063990235195050
#   a(10^7)  = 4112336345692801578349555781
#   a(10^8)  = 41123352884070223300364205949432
#   a(10^9)  = 411233517733637365707365200123054947
#   a(10^10) = 4112335168452793891288471658633554668746

# For m>=0 and j>=1, we have the following asymptotic formula:
#   Sum_{k=1..n} k^m * sigma_j(k) ~ n^(j+m+1) * zeta(j+1) / (j+m+1)

# See also:
#   https://en.wikipedia.org/wiki/Divisor_function
#   https://en.wikipedia.org/wiki/Faulhaber%27s_formula
#   https://en.wikipedia.org/wiki/Bernoulli_polynomials
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use ntheory qw(divisor_sum);
use experimental qw(signatures);
use Math::AnyNum qw(faulhaber_sum isqrt ipow sum);

sub sigma_partial_sum ($n, $m, $j) {    # O(sqrt(n)) complexity

    my $total = 0;

    my $s = isqrt($n);
    my $u = int($n / ($s + 1));

    for my $k (1 .. $s) {
        $total += faulhaber_sum($k, $m) * (faulhaber_sum(int($n / $k), $m + $j) - faulhaber_sum(int($n / ($k + 1)), $m + $j));
    }

    for my $k (1 .. $u) {
        $total += ipow($k, $m + $j) * faulhaber_sum(int($n / $k), $m);
    }

    return $total;
}

sub sigma_partial_sum_2 ($n, $m, $j) {    # O(sqrt(n)) complexity

    my $total = 0;
    my $s = isqrt($n);

    for my $k (1 .. $s) {
        $total += ipow($k, $m) * faulhaber_sum(int($n / $k), $m + $j);
        $total += ipow($k, $m + $j) * faulhaber_sum(int($n / $k), $m);
    }

    $total -= faulhaber_sum($s, $m) * faulhaber_sum($s, $j + $m);

    return $total;
}

sub sigma_partial_sum_test ($n, $m, $j) {    # just for testing
    sum(map { ipow($_, $m) * divisor_sum($_, $j) } 1 .. $n);
}

for my $m (0 .. 10) {

    my $j = int rand 10;
    my $n = int rand 1000;

    my $t1 = sigma_partial_sum($n, $m, $j);
    my $t2 = sigma_partial_sum_2($n, $m, $j);
    my $t3 = sigma_partial_sum_test($n, $m, $j);

    die "error: $t1 != $t2" if ($t1 != $t2);
    die "error: $t1 != $t3" if ($t1 != $t3);

    say "Sum_{k=1..$n} k^$m * σ_$j(k) = $t1";
}

__END__
Sum_{k=1..955} k^0 * σ_7(k) = 87199595877187457268469
Sum_{k=1..765} k^1 * σ_5(k) = 22385163976024509818
Sum_{k=1..805} k^2 * σ_6(k) = 15993292528868648475167542
Sum_{k=1..477} k^3 * σ_2(k) = 2374273670858643
Sum_{k=1..522} k^4 * σ_8(k) = 16674413261032779166355164886215351
Sum_{k=1..983} k^5 * σ_0(k) = 1180528862233337314
Sum_{k=1..293} k^6 * σ_1(k) = 11217015502565855041
Sum_{k=1..906} k^7 * σ_7(k) = 15353361004402823613827018815424339863159897
Sum_{k=1..467} k^8 * σ_2(k) = 25400023350505369496677066803
Sum_{k=1..801} k^9 * σ_4(k) = 3343390385697199861864437708422750691782
Sum_{k=1..142} k^10 * σ_8(k) = 4409116061384423423777822848241899183830


================================================
FILE: Math/partitions_count.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 August 2016
# Website: https://github.com/trizen

# A very fast algorithm for counting the number of partitions of a given number.

# OEIS:
#   https://oeis.org/A000041

# See also:
#   https://www.youtube.com/watch?v=iJ8pnCO0nTY

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

use Memoize qw(memoize);
use Math::AnyNum qw(:overload floor ceil);

memoize('partitions_count');

#
## 3b^2 - b - 2n <= 0
#
sub b1 {
    my ($n) = @_;

    my $x = 3;
    my $y = -1;
    my $z = -2 * $n;

    floor((-$y + sqrt($y**2 - 4 * $x * $z)) / (2 * $x));
}

#
## 3b^2 + 7b - 2n+4 >= 0
#
sub b2 {
    my ($n) = @_;

    my $x = 3;
    my $y = 7;
    my $z = -2 * $n + 4;

    ceil((-$y + sqrt($y**2 - 4 * $x * $z)) / (2 * $x));
}

sub p {
    (3 * $_[0]**2 - $_[0]) / 2;
}

# Based on the recursive function described by Christian Schridde:
# https://numberworld.blogspot.com/2013/09/sum-of-divisors-function-eulers.html

sub partitions_count {
    my ($n) = @_;

    return $n if ($n <= 1);

    my $sum_1 = 0;
    foreach my $i (1 .. b1($n)) {
        $sum_1 += (-1)**($i - 1) * partitions_count($n - p($i));
    }

    my $sum_2 = 0;
    foreach my $i (1 .. b2($n)) {
        $sum_2 += (-1)**($i - 1) * partitions_count($n - p(-$i));
    }

    $sum_1 + $sum_2;
}

foreach my $n (1 .. 100) {
    say "p($n) = ", partitions_count($n+1);
}

__END__
p(1) = 1
p(2) = 2
p(3) = 3
p(4) = 5
p(5) = 7
p(6) = 11
p(7) = 15
p(8) = 22
p(9) = 30
p(10) = 42
p(11) = 56
p(12) = 77
p(13) = 101
p(14) = 135
p(15) = 176
p(16) = 231
p(17) = 297
p(18) = 385
p(19) = 490
p(20) = 627


================================================
FILE: Math/partitions_count_abs.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 April 2017
# Website: https://github.com/trizen

# Simple counting of the number of partitions of n that
# absolutely sum to n, in the range [-n, n], excluding 0.

# See also:
#   https://oeis.org/A000041

use 5.016;
use strict;
use warnings;
use Memoize qw(memoize);

no warnings 'recursion';

my $atoms;
sub partitions_count_abs {
    my ($n, $i, $sum) = @_;

        (abs($sum) == $n)                   ? 1
      : (abs($sum) > $n || $i > $#{$atoms}) ? 0
      : ( partitions_count_abs($n, $i, $sum + $atoms->[$i])
        + partitions_count_abs($n, $i + 1, $sum));
}

memoize('partitions_count_abs');

foreach my $n (1 .. 20) {
    $atoms = [grep { $_ != 0 } (-$n .. $n)];
    say "P($n) = ", partitions_count_abs($n, 0, 0);
}

__END__
P(1) = 2
P(2) = 6
P(3) = 20
P(4) = 67
P(5) = 219
P(6) = 637
P(7) = 1823
P(8) = 4748
P(9) = 12045
P(10) = 28875
P(11) = 67320
P(12) = 150137
P(13) = 328849
P(14) = 694865
P(15) = 1441493
P(16) = 2915967
P(17) = 5800757
P(18) = 11292100
P(19) = 21683942
P(20) = 40885671


================================================
FILE: Math/partitions_count_simple.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 August 2016
# Website: https://github.com/trizen

# A very fast algorithm for counting the number of partitions of a given number.

# OEIS:
#   https://oeis.org/A000041

# See also:
#   https://www.youtube.com/watch?v=iJ8pnCO0nTY
#   https://rosettacode.org/wiki/Partition_function_P
#   https://en.wikipedia.org/wiki/Partition_(number_theory)#Partition_function

use 5.010;
use strict;
use warnings;

no warnings 'recursion';
use Math::AnyNum qw(floor ceil);

# Based on the recursive function described by Christian Schridde:
# https://numberworld.blogspot.com/2013/09/sum-of-divisors-function-eulers.html

sub partitions_count {
    my ($n, $cache) = @_;

    $n <= 1 && return $n;

    if (exists $cache->{$n}) {
        return $cache->{$n};
    }

    my @terms;

    foreach my $i (1 .. floor((sqrt(24*$n + 1) + 1) / 6)) {
        push @terms, (-1)**($i - 1) * partitions_count($n - (($i * (3*$i - 1)) >> 1), $cache);
    }

    foreach my $i (1 .. ceil((sqrt(24*$n + 1) - 7) / 6)) {
        push @terms, (-1)**($i - 1) * partitions_count($n - (($i * (3*$i + 1)) >> 1), $cache);
    }

    $cache->{$n} = Math::AnyNum::sum(@terms);
}

my %cache;

foreach my $n (1 .. 100) {
    say "p($n) = ", partitions_count($n + 1, \%cache);
}

__END__
p(1) = 1
p(2) = 2
p(3) = 3
p(4) = 5
p(5) = 7
p(6) = 11
p(7) = 15
p(8) = 22
p(9) = 30
p(10) = 42
p(11) = 56
p(12) = 77
p(13) = 101
p(14) = 135
p(15) = 176
p(16) = 231
p(17) = 297
p(18) = 385
p(19) = 490
p(20) = 627


================================================
FILE: Math/pascal-fibonacci_triangle.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 March 2019
# https://github.com/trizen

# Generate the Pascal-Fibonacci triangle.

# Definition by Elliott Line, Mar 22 2019:
#   Consider a version of Pascal's Triangle: a triangular array with a single 1 on row 0,
#   with numbers below equal to the sum of the two numbers above it if and only if that sum
#   appears in the Fibonacci sequence. If the sum is not a Fibonacci number, `1` is put in its place.

# OEIS sequence:
#   https://oeis.org/A307069

use 5.010;
use strict;
use warnings;

use ntheory qw(is_square);
use experimental qw(signatures);

sub is_fibonacci($n) {
    my $m = 5 * $n * $n;
    is_square($m - 4) or is_square($m + 4);
}

my @row  = (1);
my $rows = 40;

foreach my $n (1 .. $rows) {

    my @t = (
        map {
            my $t = $row[$_] + $row[$_ + 1];
            is_fibonacci($t) ? $t : 1;
          } 0 .. ($n - ($n % 2)) / 2 - 1
    );

    say "@row";

    # The triangle is symmetric
    # See also: https://photos.app.goo.gl/q3981kei8LJyvzgZ9
    my @u = reverse(@t);

    if ($n % 2 == 0) {
        shift @u;
    }
    @row = (1, @t, @u, 1);
}

__END__
1
1 1
1 2 1
1 3 3 1
1 1 1 1 1
1 2 2 2 2 1
1 3 1 1 1 3 1
1 1 1 2 2 1 1 1
1 2 2 3 1 3 2 2 1
1 3 1 5 1 1 5 1 3 1
1 1 1 1 1 2 1 1 1 1 1
1 2 2 2 2 3 3 2 2 2 2 1
1 3 1 1 1 5 1 5 1 1 1 3 1
1 1 1 2 2 1 1 1 1 2 2 1 1 1
1 2 2 3 1 3 2 2 2 3 1 3 2 2 1
1 3 1 5 1 1 5 1 1 5 1 1 5 1 3 1
1 1 1 1 1 2 1 1 2 1 1 2 1 1 1 1 1
1 2 2 2 2 3 3 2 3 3 2 3 3 2 2 2 2 1
1 3 1 1 1 5 1 5 5 1 5 5 1 5 1 1 1 3 1
1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 2 2 1 1 1
1 2 2 3 1 3 2 2 2 2 2 2 2 2 2 3 1 3 2 2 1
1 3 1 5 1 1 5 1 1 1 1 1 1 1 1 5 1 1 5 1 3 1
1 1 1 1 1 2 1 1 2 2 2 2 2 2 2 1 1 2 1 1 1 1 1
1 2 2 2 2 3 3 2 3 1 1 1 1 1 1 3 2 3 3 2 2 2 2 1
1 3 1 1 1 5 1 5 5 1 2 2 2 2 2 1 5 5 1 5 1 1 1 3 1
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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
1 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


================================================
FILE: Math/pascal_s_triangle_multiples.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 November 2015
# Website: https://github.com/trizen

# Pascal's triangle with the multiples of a given integer highlighted.

use 5.010;
use strict;
use warnings;

use ntheory qw(binomial);
use Term::ANSIColor qw(colored);

my $div  = 3;     # highlight multiples of this integer
my $size = 80;    # the size of the triangle

sub pascal {
    my ($rows) = @_;

    for my $n (1 .. $rows - 1) {
        say ' ' x ($rows - $n), join "",
          map { $_ % $div == 0 ? colored('.', 'red') : '*' }
          map { binomial(2*$n, $_) } 0 .. 2*$n;
    }
}

pascal(int($size / 2));


================================================
FILE: Math/pattern_mixing.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 03 July 2015
# Website: https://github.com/trizen

#
# The problem:
#
# Mix the stars with the letters in the following pattern,
# in a random, but uniform way, preserving the original order
# of letters and preserving the original shape of the pattern.
#

my $pattern = <<'EOT';
 ******C*******w*******X*******y*******X*******o*******f******
 igpvAoBLhCffXgIIlyI8gFC8L88vILCg98Io81gaICXpIIg8CIvwFB8I8wXgC
 vIAgLA,L>8CgCCyywcIiF>L=8LX='CgCLfgvC8wXgXKef9B8CIggvIALKXLCv
y>IgXIXg8w1}CA=y8ylAyw=8Cgyffy8loKK88A8f=,II'gfFFwfvgvCAC8yyLIg
KXf'''IAX=yiovg>C,8gIAgvAIXFjgCy8Xv89v'XIILy=AC1A8yvov9KvXywffX
8CFyCC9LvfCvF8gg$yv8vALIIILKsKXyvgCI8yfIKF8L,I9C8BiFwfg,A8h8gF'
BvgL8C8FfXCC8gB,Iv88AgC8X1CCIFuCX8L>Xi=CCv8ICI8I>KC8IFB8oIFKAvA
LvgCIg'wBAFLg'1''f=yLLI'ff'fo9gIA>yFv8FIoy'CLfI8f8vk'y8F=vw>gKf
vy8X        >KLXgKw'og'vF1By'gBvLIXX8KB'XvA'8vofilg        CgC'
fyBA           8iLIy8IoIvoC,yg,gI=yC8i'I8gL>8'9{           8gB>
AF18              I8A=vyA'1pfwv,I8lvIABACffIy              AyFC
1Avpg               Cv'KIyK8C'g9IyFKIL8A=vo               yCABX
Ffv8A                C,9wyIKI,Kn=iXf8wL1w9                8,ygf
X88oKC                 ICII8'F8ILCLy>>If                 CC8LCy
 XCAIg                  CFAwBvCfyAIgIyA                  BI9'g
 gyIwL8                  lgXIXXXAX8gI8                  8IBiyX
  FXAygA                  vgoFFFXAggC                  i,LI>I
   KIXgt                   vXCA8prCI                   gAK=y
   ******                  *********                  ******
    *******                 *******                 *******
     *******                *******                *******
      ********               *****               ********
       *********             *****             *********
        **********           *****           **********
         ************       *******       ************
          *******************************************
           *****************************************
            ***************************************
             *************************************
               *********************************
                *******************************
                 *****************************
                   *************************
                     *********************
                       *****************
                         *************
                           *********
EOT

#
## Solution
#

my @chars = split(//, $pattern);

my @letters = grep { $_ ne '*' and /^\S/ } @chars;
my @stars = grep { $_ eq '*' } @chars;

my $ratio = @stars / (@letters + @stars);

foreach my $char (@chars) {
    if ($char =~ /^\s/) {
        print $char;
        next;
    }

    if (@stars) {
        if (rand(1) <= $ratio) {
            print shift @stars;
            next;
        }
    }

    print @letters ? shift(@letters) : shift(@stars);
}


================================================
FILE: Math/pell_cfrac_factorization.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 April 2018
# https://github.com/trizen

# A simple factorization algorithm, based on ideas from the continued fraction factorization method.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use ntheory qw(is_prime factor_exp vecprod);
use Math::AnyNum qw(is_square isqrt irand idiv gcd valuation);

sub pell_cfrac ($n) {

    # Check for primes and negative numbers
    return ()   if $n <= 1;
    return ($n) if is_prime($n);

    # Check for perfect squares
    if (is_square($n)) {
        my @factors = __SUB__->(isqrt($n));
        return sort { $a <=> $b } ((@factors) x 2);
    }

    # Check for divisibility by 2
    if (!($n & 1)) {

        my $v = valuation($n, 2);
        my $t = $n >> $v;

        my @factors = (2) x $v;

        if ($t > 1) {
            push @factors, __SUB__->($t);
        }

        return @factors;
    }

    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;
    my $w = 2 * $x;
    my $k = isqrt($w);

    my $r = $x + $x;

    my ($e1, $e2) = (1, 0);
    my ($f1, $f2) = (0, 1);

    my %table;

    for (; ;) {

        $y = $r * $z - $y;
        $z = idiv($n - $y * $y, $z);
        $r = idiv($x + $y, $z);

        my $u = ($x * $f2 + $e2) % $n;
        my $v = ($u * $u) % $n;

        my $c = ($v > $w ? $n - $v : $v);

        # Congruence of squares
        if (is_square($c)) {
            my $g = gcd($u - isqrt($c), $n);

            if ($g > 1 and $g < $n) {
                return sort { $a <=> $b } (
                    __SUB__->($g),
                    __SUB__->($n / $g)
                );
            }
        }

        my @factors = factor_exp($c);
        my @odd_powers = grep { $factors[$_][1] % 2 == 1 } 0 .. $#factors;

        if (@odd_powers <= 3) {
            my $key = join(' ', map { $_->[0] } @factors[@odd_powers]);

            # Congruence of squares by creating a square from previous terms
            if (exists $table{$key}) {
                foreach my $d (@{$table{$key}}) {

                    my $g = gcd($d->{u} * $u - isqrt($d->{c} * $c), $n);

                    if ($g > 1 and $g < $n) {
                        return sort { $a <=> $b } (
                            __SUB__->($g),
                            __SUB__->($n / $g)
                        );
                    }
                }
            }

            push @{$table{$key}}, {c => $c, u => $u};

            # Create easier building blocks for building squares
            if (@odd_powers >= 2) {
                foreach my $i (0 .. $#odd_powers) {
                    my $key = join(' ', map { $_->[0] } @factors[@odd_powers[0 .. $i - 1, $i + 1 .. $#odd_powers]]);

                    if (exists($table{$key}) and @{$table{$key}} < 5) {

                        my $missing_factor = $factors[$odd_powers[$i]][0];

                        next if ($missing_factor > $k);

                        foreach my $d (@{$table{$key}}) {
                            push @{$table{$missing_factor}},
                              {
                                c => $c * $d->{c},
                                u => $u * $d->{u},
                              };
                        }
                    }
                }
            }
        }

        my $the_end = ($z == 1);

        {
            ($f1, $f2) = ($f2, ($r * $f2 + $f1) % $n);
            ($e1, $e2) = ($e2, ($r * $e2 + $e1) % $n);

            # Pell factorization
            foreach my $t (
                $e2 + $e2 + $f2 + $x,
                $e2 + $f2 + $f2,
                $e2 + $f2 * $x,
                $e2 + $f2,
                $e2,
            ) {
                my $g = gcd($t, $n);

                if ($g > 1 and $g < $n) {
                    return sort { $a <=> $b } (
                        __SUB__->($g),
                        __SUB__->($n / $g)
                    );
                }
            }

            redo if $the_end;
        }
    }
}

foreach my $k (2 .. 60) {

    my $n = irand(2, 1 << $k);
    my @f = pell_cfrac($n);

    say "$n = ", join(' * ', @f);

    die 'error' if grep { !is_prime($_) } @f;
    die 'error' if vecprod(@f) != $n;
}


================================================
FILE: Math/pell_factorization.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 February 2019
# https://github.com/trizen

# A simple integer factorization method, using square root convergents.

# See also:
#   https://en.wikipedia.org/wiki/Pell%27s_equation

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub pell_factorization ($n) {

    my $x = sqrtint($n);
    my $y = $x;
    my $z = 1;
    my $r = 2 * $x;
    my $w = $r;

    return $n if is_prime($n);
    return $x if is_square($n);

    my ($f1, $f2) = (1, $x);

    for (; ;) {

        $y = $r*$z - $y;
        $z = divint($n - $y*$y, $z);
        $r = divint($x + $y, $z);

        ($f1, $f2) = ($f2, addmod(mulmod($r, $f2, $n), $f1, $n));

        if (is_square($z)) {
            my $g = gcd($f1 - sqrtint($z), $n);
            if ($g > 1 and $g < $n) {
                return $g;
            }
        }

        return $n if ($z == 1);
    }
}

for (1 .. 10) {
    my $n = random_nbit_prime(31) * random_nbit_prime(31);
    say "PellFactor($n) = ", pell_factorization($n);
}

__END__
PellFactor(2101772756469048319) = 1228264087
PellFactor(2334333625703344609) = 1709282917
PellFactor(2358058220132276317) = 1210584887
PellFactor(1482285997261862561) = 1197377617
PellFactor(2759217719449375403) = 1559110667
PellFactor(2828146117168463857) = 1493774729
PellFactor(1732707024229573211) = 1165003451
PellFactor(2510049724431882299) = 1820676019
PellFactor(1585505630716792319) = 1311005599
PellFactor(1612976091192715981) = 1453708381


================================================
FILE: Math/pell_factorization_anynum.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 February 2019
# https://github.com/trizen

# A simple integer factorization method, using square root convergents.

# See also:
#   https://en.wikipedia.org/wiki/Pell%27s_equation

use 5.020;
use strict;
use warnings;

use ntheory qw(random_nbit_prime);
use Math::AnyNum qw(:all);
use experimental qw(signatures);

sub pell_factorization ($n) {

    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;
    my $r = 2 * $x;
    my $w = $r;

    return $x if is_square($n);

    my ($f1, $f2) = (1, $x);

    for (; ;) {

        $y = $r*$z - $y;
        $z = idiv($n - $y*$y, $z);
        $r = idiv($x + $y, $z);

        ($f1, $f2) = ($f2, ($r*$f2 + $f1) % $n);

        if (is_square($z)) {
            my $g = gcd($f1 - isqrt($z), $n);
            if ($g > 1 and $g < $n) {
                return $g;
            }
        }

        return $n if ($z == 1);
    }
}

for (1 .. 10) {
    my $n = random_nbit_prime(25) * random_nbit_prime(25);
    say "PellFactor($n) = ", pell_factorization($n);
}

__END__
PellFactor(607859142082991) = 20432749
PellFactor(926859728053057) = 33170069
PellFactor(523709106944971) = 19544953
PellFactor(379392152082407) = 18361823
PellFactor(397926699623521) = 22529261
PellFactor(596176048102421) = 27540133
PellFactor(556290216898421) = 21828529
PellFactor(799063586749279) = 27381929
PellFactor(513015423767879) = 25622173
PellFactor(964450431874939) = 30653317


================================================
FILE: Math/perfect_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 May 2016
# https://github.com/trizen

# Generator of perfect numbers, using the fact that
# the Mth triangular number, where M is a Mersenne
# prime in the form 2^p-1, gives us a perfect number.

# See also:
#   https://en.wikipedia.org/wiki/Perfect_number

use 5.010;
use strict;
use warnings;

use Math::AnyNum;
use ntheory qw(forprimes is_mersenne_prime);

my $one = Math::AnyNum->one;

forprimes {
    if (is_mersenne_prime($_)) {
        my $n = $one << $_;
        say "2^($_-1) * (2^$_-1) = ", $n * ($n - 1) / 2;
    }
} 1, 100;

__END__
2^(2-1) * (2^2-1) = 6
2^(3-1) * (2^3-1) = 28
2^(5-1) * (2^5-1) = 496
2^(7-1) * (2^7-1) = 8128
2^(13-1) * (2^13-1) = 33550336
2^(17-1) * (2^17-1) = 8589869056
2^(19-1) * (2^19-1) = 137438691328
2^(31-1) * (2^31-1) = 2305843008139952128
2^(61-1) * (2^61-1) = 2658455991569831744654692615953842176
2^(89-1) * (2^89-1) = 191561942608236107294793378084303638130997321548169216


================================================
FILE: Math/period_of_continued_fraction_for_square_roots.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 31 August 2016
# License: GPLv3
# https://github.com/trizen

# Algorithm from:
#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf

# See also:
#   https://oeis.org/A003285
#   https://oeis.org/A067280
#   https://projecteuler.net/problem=64
#   https://en.wikipedia.org/wiki/Continued_fraction
#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html

use 5.010;
use strict;
use warnings;

use ntheory qw(is_square sqrtint);

sub period_length {
    my ($n) = @_;

    my $x = sqrtint($n);
    my $y = $x;
    my $z = 1;

    return 0 if is_square($n);

    my $period = 0;

    do {
        $y = int(($x + $y) / $z) * $z - $y;
        $z = int(($n - $y * $y) / $z);
        ++$period;
    } until ($z == 1);

    return $period;
}

for my $i (1 .. 20) {
    say "P($i) = ", period_length($i);
}

__END__
P(1) = 0
P(2) = 1
P(3) = 2
P(4) = 0
P(5) = 1
P(6) = 2
P(7) = 4
P(8) = 2
P(9) = 0
P(10) = 1
P(11) = 2
P(12) = 2
P(13) = 5
P(14) = 4
P(15) = 2
P(16) = 0
P(17) = 1
P(18) = 2
P(19) = 6
P(20) = 2


================================================
FILE: Math/period_of_continued_fraction_for_square_roots_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 January 2019
# License: GPLv3
# https://github.com/trizen

# Compute the period length of the continued fraction for square root of a given number.

# Algorithm from:
#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf

# OEIS sequences:
#   https://oeis.org/A003285 -- Period of continued fraction for square root of n (or 0 if n is a square).
#   https://oeis.org/A059927 -- Period length of the continued fraction for sqrt(2^(2n+1)).
#   https://oeis.org/A064932 -- Period length of the continued fraction for sqrt(3^(2n+1)).
#   https://oeis.org/A067280 -- Terms in continued fraction for sqrt(n), excl. 2nd and higher periods.
#   https://oeis.org/A064025 -- Length of period of continued fraction for square root of n!.
#   https://oeis.org/A064486 -- Quotient cycle lengths of square roots of primorials.

# See also:
#   https://en.wikipedia.org/wiki/Continued_fraction
#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html

# A064486 = {1, 2, 2, 2, 2, 4, 2, 36, 38, 244, 244, 1830, 3422, 10626, 3828, 20970, 580384, 4197850, 18395762, 76749396, 166966158, ...}
# 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, ...}

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(factorial);

sub period_length_mpz {
    my ($n) = @_;

    $n = Math::GMPz->new("$n");

    return 0 if Math::GMPz::Rmpz_perfect_square_p($n);

    my $t = Math::GMPz::Rmpz_init();
    my $x = Math::GMPz::Rmpz_init();
    my $z = Math::GMPz::Rmpz_init_set_ui(1);

    Math::GMPz::Rmpz_sqrt($x, $n);

    my $y = Math::GMPz::Rmpz_init_set($x);

    my $period = 0;

    do {
        Math::GMPz::Rmpz_add($t, $x, $y);
        Math::GMPz::Rmpz_div($t, $t, $z);
        Math::GMPz::Rmpz_mul($t, $t, $z);
        Math::GMPz::Rmpz_sub($y, $t, $y);

        Math::GMPz::Rmpz_mul($t, $y, $y);
        Math::GMPz::Rmpz_sub($t, $n, $t);
        Math::GMPz::Rmpz_divexact($z, $t, $z);

        ++$period;

    } until (Math::GMPz::Rmpz_cmp_ui($z, 1) == 0);

    return $period;
}

foreach my $n (1..20) {
    say "A064025($n) = ", period_length_mpz(factorial($n));
}


================================================
FILE: Math/period_of_continued_fraction_for_square_roots_ntheory.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 January 2019
# License: GPLv3
# https://github.com/trizen

# Compute the period length of the continued fraction for square root of a given number.

# Algorithm from:
#   https://web.math.princeton.edu/mathlab/jr02fall/Periodicity/mariusjp.pdf

# OEIS sequences:
#   https://oeis.org/A003285 -- Period of continued fraction for square root of n (or 0 if n is a square).
#   https://oeis.org/A059927 -- Period length of the continued fraction for sqrt(2^(2n+1)).
#   https://oeis.org/A064932 -- Period length of the continued fraction for sqrt(3^(2n+1)).
#   https://oeis.org/A067280 -- Terms in continued fraction for sqrt(n), excl. 2nd and higher periods.

# See also:
#   https://en.wikipedia.org/wiki/Continued_fraction
#   https://mathworld.wolfram.com/PeriodicContinuedFraction.html

# This program was used in computing the a(15)-a(19) terms of the OEIS sequence A064932.
#   A064932(15) = 15924930
#   A064932(16) = 47779238
#   A064932(17) = 143322850
#   A064932(18) = 429998586
#   A064932(19) = 1289970842

use 5.010;
use strict;
use warnings;

use ntheory qw(is_square sqrtint powint divint);

sub period_length {
    my ($n) = @_;

    my $x = sqrtint($n);
    my $y = $x;
    my $z = 1;

    return 0 if is_square($n);

    my $period = 0;

    do {
        $y = divint(($x + $y),      $z) * $z - $y;
        $z = divint(($n - $y * $y), $z);
        ++$period;
    } until ($z == 1);

    return $period;
}

for my $n (1 .. 14) {
    print "A064932($n) = ", period_length(powint(3, 2 * $n + 1)), "\n";
}

__END__
A064932(1) = 2
A064932(2) = 10
A064932(3) = 30
A064932(4) = 98
A064932(5) = 270
A064932(6) = 818
A064932(7) = 2382
A064932(8) = 7282
A064932(9) = 21818
A064932(10) = 65650
A064932(11) = 196406
A064932(12) = 589982
A064932(13) = 1768938
A064932(14) = 5309294


================================================
FILE: Math/phi-finder_factorization_method.pl
================================================
#!/usr/bin/perl

# A new factorization algorithm for semiprimes, by estimating phi(n).

# The algorithm is called "Phi-Finder" and is due to Kyle Kloster (2010), described in his thesis:
#   Factoring a semiprime n by estimating φ(n)

# See also:
#   http://gregorybard.com/papers/phi_version_may_7.pdf

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use ntheory qw(is_prime is_square sqrtint logint powmod random_nbit_prime);

sub phi_factor($n) {

    return ()   if $n <= 1;
    return ($n) if is_prime($n);

    if (is_square($n)) {
        return sqrtint($n);
    }

    $n = Math::GMPz->new($n);

    my $E  = $n - 2 * sqrtint($n) + 1;
    my $E0 = Math::GMPz->new(powmod(2, -$E, $n));

    my $L = logint($n, 2);
    my $i = 0;

    while ($E0 & ($E0 - 1)) {
        $E0 <<= $L;
        $E0 %= $n;
        ++$i;
    }

    my $t = 0;

    foreach my $k (0 .. $L) {
        if (powmod(2, $k, $n) == $E0) {
            $t = $k;
            last;
        }
    }

    my $phi = abs($i * $L - $E - $t);

    my $q = ($n - $phi + 1);
    my $p = ($q + sqrtint($q * $q - 4 * $n)) >> 1;

    return $p;
}

foreach my $k (10 .. 30) {

    my $n = Math::GMPz->new(random_nbit_prime($k)) * random_nbit_prime($k);
    my $p = phi_factor($n);

    say "$n = ", $p, ' * ', $n / $p;
}


================================================
FILE: Math/pi_from_infinity.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 15 May 2016
# Website: https://github.com/trizen

# Generic implementations for infinite sums, infinite
# products, continued fractions and nested radicals.

use 5.020;
use warnings;

no warnings 'recursion';
use experimental qw(signatures);

#
## Infinite sum
#

sub sum ($from, $to, $expr) {
    my $sum = 0;
    for my $i ($from .. $to) {
        $sum += $expr->($i);
    }
    $sum;
}

say "=> PI from an infinite sum:";
say 4 * sum(0, 100000, sub($n) { (-1)**$n / (2 * $n + 1) });

#
## Infinite product
#

sub prod ($from, $to, $expr) {
    my $prod = 1;
    for my $i ($from .. $to) {
        $prod *= $expr->($i);
    }
    $prod;
}

say "=> PI from an infinite product:";
say 2 / prod(1, 100000, sub($n) { 1 - 1 / (4 * $n**2) });

#
## Continued fractions
#

sub cfrac ($from, $to, $num, $den) {
    return 0 if ($from > $to);
    $num->($from) / ($den->($from) + cfrac($from + 1, $to, $num, $den));
}

say "=> PI from a continued fraction:";
say 4 / (1 + cfrac(1, 100000, sub($n) { $n**2 }, sub($n) { 2 * $n + 1 }));

#
## Nested radicals
#

sub nestrad ($from, $to, $coeff, $expr) {
    return 0 if ($from > $to);
    $expr->($coeff->($from) + nestrad($from + 1, $to, $coeff, $expr));
}

say "=> PI from nested square roots:";
say 2 / prod(
    1, 100,
    sub ($n) {
        nestrad(1, $n, sub($) { 2 }, sub($x) { sqrt($x) }) / 2;
    }
);

# A formula by N. J. Wildberger
# https://www.youtube.com/watch?v=lcIbCZR0HbU

say sqrt(4**(12+1) *
    (2 - nestrad(1, 12, sub($) { 2 }, sub($x) { sqrt($x) }))
);


================================================
FILE: Math/pisano_periods.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 October 2017
# https://github.com/trizen

# Algorithm for computing the Pisano numbers (period of Fibonacci numbers mod n), using the prime factorization of `n`.

# See also:
#   https://oeis.org/A001175
#   https://en.wikipedia.org/wiki/Pisano_period

use 5.020;
use strict;
use warnings;

use experimental qw(signatures lexical_subs);
use ntheory qw(addmod factor_exp lcm);

sub pisano_period($mod) {

    my sub find_period($mod) {
        my ($x, $y) = (0, 1);

        for (my $n = 1 ; ; ++$n) {
            ($x, $y) = ($y, addmod($x, $y, $mod));

            if ($x == 0 and $y == 1) {
                return $n;
            }
        }
    }

    my @prime_powers  = map { $_->[0]**$_->[1] } factor_exp($mod);
    my @power_periods = map { find_period($_) } @prime_powers;

    return lcm(@power_periods);
}

my $n      = 5040;
my $period = pisano_period($n);
say "Pisano period for modulus $n is $period.";    #=> 240


================================================
FILE: Math/pisano_periods_efficient_algorithm.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 September 2018
# https://github.com/trizen

# Efficient algorithm for computing the Pisano period: period of Fibonacci
# numbers mod `n`, assuming that the factorization of `n` can be computed.

# See also:
#   https://oeis.org/A001175
#   https://oeis.org/A053031
#   https://en.wikipedia.org/wiki/Pisano_period
#   https://en.wikipedia.org/wiki/Wall%E2%80%93Sun%E2%80%93Sun_prime

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use List::Util qw(first);
use ntheory qw(divisors factor_exp);
use Math::AnyNum qw(:overload kronecker fibmod lcm factorial);

sub pisano_period_pp ($p, $k = 1) {
    $p**($k - 1) * first { fibmod($_, $p) == 0 } divisors($p - kronecker($p, 5));
}

sub pisano_period($n) {

    return 0 if ($n <= 0);
    return 1 if ($n == 1);

    my $d = lcm(map { pisano_period_pp($_->[0], $_->[1]) } factor_exp($n));

    foreach my $k (0 .. 2) {
        my $t = $d << $k;

        if ((fibmod($t, $n) == 0) and (fibmod($t + 1, $n) == 1)) {
            return $t;
        }
    }

    die "Conjecture disproved for n=$n";
}

say pisano_period(factorial(10));    #=> 86400
say pisano_period(factorial(30));    #=> 204996473853050880000000
say pisano_period(2**128 + 1);       #=> 28356863910078205764000346543980814080

say 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


================================================
FILE: Math/pocklington-pratt_primality_proving.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 January 2020
# https://github.com/trizen

# Prove the primality of a number, using the Pocklington primality test recursively.

# See also:
#   https://en.wikipedia.org/wiki/Pocklington_primality_test
#   https://en.wikipedia.org/wiki/Primality_certificate
#   https://mathworld.wolfram.com/PrattCertificate.html

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

use List::Util qw(uniq);
use ntheory qw(is_prime is_prob_prime primes);
use Math::AnyNum qw(:overload isqrt prod is_coprime irand powmod primorial gcd);
use Math::Prime::Util::GMP qw(ecm_factor is_strong_pseudoprime);

my $primorial = primorial(10**6);

sub trial_factor ($n) {

    my @f;
    my $g = gcd($primorial, $n);

    if ($g > 1) {
        my @primes = ntheory::factor($g);
        foreach my $p (@primes) {
            while ($n % $p == 0) {
                push @f, $p;
                $n /= $p;
            }
        }
    }

    return ($n, @f);
}

sub pocklington_pratt_primality_proving ($n, $lim = 2**64) {

    if ($n <= $lim or $n <= 2) {
        return is_prime($n);    # fast deterministic test for small n
    }

    is_prob_prime($n) || return 0;

    if (ref($n) ne 'Math::AnyNum') {
        $n = Math::AnyNum->new("$n");
    }

    my $d = $n - 1;
    my ($B, @f) = trial_factor($d);

    if ($B > 1 and __SUB__->($B, $lim)) {
        push @f, $B;
        $B = 1;
    }

    for (; ;) {
        my $A = prod(@f);

        if ($A > $B and is_coprime($A, $B)) {

            say "\n:: Proving primality of: $n";

            foreach my $p (uniq(@f)) {
                for (; ;) {
                    my $a = irand(2, $d);
                    is_strong_pseudoprime($n, $a) || return 0;
                    if (is_coprime(powmod($a, $d / $p, $n) - 1, $n)) {
                        say "a = $a ; p = $p";
                        last;
                    }
                }
            }

            return 1;
        }

        my @ecm_factors = map { Math::AnyNum->new($_) } ecm_factor($B);

        foreach my $p (@ecm_factors) {
            if (__SUB__->($p, $lim)) {
                while ($B % $p == 0) {
                    $B /= $p;
                    $A *= $p;
                    push @f, $p;
                }
            }
            if ($A > $B) {
                say ":: Stopping early with A = $A and B = $B" if ($B > 1);
                last;
            }
        }
    }
}

say "Is prime: ",
  pocklington_pratt_primality_proving(115792089237316195423570985008687907853269984665640564039457584007913129603823);

__END__
:: Proving primality of: 1202684276868524221513588244947
a = 346396580104425418965575454682 ; p = 2
a = 395385292850838170128328828116 ; p = 3
a = 560648981353249253078437405876 ; p = 192697
a = 494703015287234994679974119746 ; p = 5829139
a = 306457770974323789423503072510 ; p = 59483944987587859

:: Proving primality of: 3201964079152361724098258636758155557
a = 1356115518279653627564352210970159943 ; p = 2
a = 2457916028227754146876991447098503864 ; p = 13
a = 11728301593361244989156925656983410 ; p = 51199
a = 2108054294077847671434547666614921115 ; p = 1202684276868524221513588244947

:: Proving primality of: 2848630210554880446022254608450222949126931851754251657020267
a = 1209988187472090611751147313669268320351528758910368461329491 ; p = 2
a = 2300573356420091000839516595493416230415669494600279441813823 ; p = 7
a = 2255070062675661569997567047423251088740948129004746039001652 ; p = 71
a = 1700776819424249129400987278064417150296142232503378309546959 ; p = 397
a = 1557663127914051170819266186415060024746272157947950396848254 ; p = 22483
a = 1529304355972906129963007304614010762285079880618804024992958 ; p = 100274029791527
a = 1359380483007119191612142919174796446436066905484471515166032 ; p = 3201964079152361724098258636758155557

:: Proving primality of: 57896044618658097711785492504343953926634992332820282019728792003956564801911
a = 57400691074692315475639863020768426880305244856451980889960538168345429022524 ; p = 2
a = 25820275722126461008372188295587408543429765560766435733697174460356575227321 ; p = 5
a = 27298126184613458024322898773516636407461062104891054863568660611145831927443 ; p = 19
a = 7100354002561105328600593201175960102344714262592146066784856909856617007329 ; p = 106969315701167
a = 18941027101040193108179225001169566407134428948824247293492332749705988365235 ; p = 2848630210554880446022254608450222949126931851754251657020267

:: Proving primality of: 115792089237316195423570985008687907853269984665640564039457584007913129603823
a = 113522921208063424748606312287587727138037143611024280238876731030118912160215 ; p = 2
a = 2309014289093855479517407977261240733911340029895025970257499692025785552300 ; p = 57896044618658097711785492504343953926634992332820282019728792003956564801911
Is prime: 1


================================================
FILE: Math/pollard-strassen_factorization_method.pl
================================================
#!/usr/bin/perl

# Pollard-Strassen O(n^(1/4)) factorization algorithm.

# Illustrated by David Harvey in the following video:
#   https://yewtu.be/watch?v=_53s-0ZLxbQ

use 5.020;
use warnings;

use bigint try => 'GMP';
use experimental qw(signatures);
use ntheory      qw(random_prime rootint gcd);

use Math::Polynomial;
use Math::ModInt qw(mod);
use Math::Polynomial::ModInt;

sub pollard_strassen_factorization ($n, $d = 1 + rootint($n, 4), $tries = $d) {

    my $a = random_prime($n);

    my @baby_steps;

    my $bs = mod(1, $n);
    foreach my $k (1 .. $d) {
        push @baby_steps, $bs;
        $bs *= $a;
    }

    my $x = Math::Polynomial::ModInt->new(mod(0, $n), mod(1, $n));
    my @f = map { $x - $_ } @baby_steps;

    # --- Divide-and-Conquer Polynomial Multiplication ---
    while (@f > 1) {
        my @next_level;

        # Multiply adjacent pairs in the current level
        while (@f >= 2) {
            my $p1 = shift @f;
            my $p2 = shift @f;
            push @next_level, $p1->mul($p2);
        }

        # If there's an odd polynomial left over, promote it to the next level
        push @next_level, shift @f if @f;

        @f = @next_level;
    }

    # Extract the final product, or return a constant polynomial of 1 if empty
    my $f = @f ? $f[0] : Math::Polynomial::ModInt->new(mod(1, $n));

    my $r = mod($a, $n);

    foreach my $k (1 .. $tries) {

        my $b = $r**($k * $d);
        my $v = $f->evaluate($b)->residue;
        my $g = gcd($v, $n);

        if ($g > 1 and $g < $n) {
            return $g;
        }
    }

    return 1;
}

say pollard_strassen_factorization(1207);
say pollard_strassen_factorization(503 * 863);
say pollard_strassen_factorization(2**64 + 1, 300, 5 * 300);


================================================
FILE: Math/pollard_p-1_factorization.pl
================================================
#!/usr/bin/perl

# Simple implementation of Pollard's p-1 integer factorization algorithm, with the B2 stage.

# See also:
#   https://en.wikipedia.org/wiki/Pollard%27s_p_%E2%88%92_1_algorithm
#   https://trizenx.blogspot.com/2019/08/special-purpose-factorization-algorithms.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory      qw(is_prime logint primes prime_iterator sqrtint next_prime);
use Math::AnyNum qw(:overload powmod gcd is_coprime mulmod);

sub pollard_pm1_factor ($n, $B1 = logint($n, 6)**3, $B2 = $B1 * logint($B1, 2)) {

    return () if $n <= 1;
    return $n if is_prime($n);
    return 2  if $n % 2 == 0;

    my $G = log($B1 * $B1);
    my $t = 2;

    foreach my $p (@{primes(2, sqrtint($B1))}) {
        for (1 .. int($G / log($p))) {
            $t = powmod($t, $p, $n);
        }
    }

    my $it = prime_iterator(sqrtint($B1) + 1);
    for (my $p = $it->() ; $p <= $B1 ; $p = $it->()) {
        $t = powmod($t, $p, $n);
        is_coprime($t - 1, $n) || return gcd($t - 1, $n);
    }

    my @table;
    my $Q  = next_prime($B1);
    my $TQ = powmod($t, $Q, $n);

    my $it2 = prime_iterator($Q + 1);
    for (my $p = $it2->() ; $p <= $B2 ; $p = $it2->()) {
        $TQ = mulmod($TQ, ($table[$p - $Q] //= powmod($t, $p - $Q, $n)), $n);
        is_coprime($TQ - 1, $n) || return gcd($TQ - 1, $n);
        $Q = $p;
    }

    return gcd($t - 1, $n);
}

say pollard_pm1_factor(1204123279);                                #=> 25889
say pollard_pm1_factor(83910721266759813859);                      #=> 4545646757
say pollard_pm1_factor(406816927495811038353579431);               #=> 9074269
say pollard_pm1_factor(38568900844635025971879799293495379321);    #=> 17495058332072672321


================================================
FILE: Math/pollard_rho_exp_factorization.pl
================================================
#!/usr/bin/perl

# Pollard's rho integer factorization algorithm.

# This version uses the polynomial:
#   f(x) = x^e + 2*e - 1

# where e = lcm(1..B), for a small bound B.

# See also:
#   https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use Math::Prime::Util::GMP qw(consecutive_integer_lcm logint);

sub rho_exp_factor ($n, $max_iter = 5000) {

    my $B = logint($n, 5)**2;
    my $e = Math::GMPz::Rmpz_init_set_str(consecutive_integer_lcm($B), 10);
    my $c = 2*$e - 1;

    if (length("$n") <= 12) {
        $e = Math::GMPz->new(2);
    }

    my $x = Math::GMPz::Rmpz_init_set_ui(1);
    my $y = Math::GMPz::Rmpz_init();
    my $g = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_powm($x, $x, $e, $n);
    Math::GMPz::Rmpz_add($x, $x, $c);
    Math::GMPz::Rmpz_mod($x, $x, $n);

    Math::GMPz::Rmpz_powm($y, $x, $e, $n);
    Math::GMPz::Rmpz_add($y, $y, $c);
    Math::GMPz::Rmpz_mod($y, $y, $n);

    for (1 .. $max_iter) {

        Math::GMPz::Rmpz_powm($x, $x, $e, $n);
        Math::GMPz::Rmpz_add($x, $x, $c);
        Math::GMPz::Rmpz_mod($x, $x, $n);

        Math::GMPz::Rmpz_powm($y, $y, $e, $n);
        Math::GMPz::Rmpz_add($y, $y, $c);
        Math::GMPz::Rmpz_mod($y, $y, $n);

        Math::GMPz::Rmpz_powm($y, $y, $e, $n);
        Math::GMPz::Rmpz_add($y, $y, $c);
        Math::GMPz::Rmpz_mod($y, $y, $n);

        Math::GMPz::Rmpz_sub($g, $x, $y);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0) {
            return undef if ($g == $n);
            return $g;
        }
    }

    return $n;
}

my @nums = qw(
    314159265358979323 350011490889402191 2954624367769580651
    7167393334524676153 10033529742475370477 20135752530477192241
    21316902507352787201 2559469924891866771047 63469917720180180377579
  );

@nums = map { Math::GMPz->new($_) } @nums;

foreach my $n (@nums) {
    say "rho_exp_factor($n) = ", rho_exp_factor($n);
}

__END__
rho_exp_factor(314159265358979323) = 990371647
rho_exp_factor(350011490889402191) = 692953181
rho_exp_factor(2954624367769580651) = 490066931
rho_exp_factor(7167393334524676153) = 4721424559
rho_exp_factor(10033529742475370477) = 1412164441
rho_exp_factor(20135752530477192241) = 5907768749
rho_exp_factor(21316902507352787201) = 3055371353
rho_exp_factor(2559469924891866771047) = 266349879973
rho_exp_factor(63469917720180180377579) = 126115748167


================================================
FILE: Math/pollard_rho_factorization.pl
================================================
#!/usr/bin/perl

# Simple implementation of Pollard's rho integer factorization algorithm.

# See also:
#   https://facthacks.cr.yp.to/rho.html
#   https://en.wikipedia.org/wiki/Pollard%27s_rho_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload powmod gcd);

sub rho_factor ($n, $tries = 50000) {

    my sub f($x) {
        powmod($x, 2, $n) + 1;
    }

    my $x = f(2);
    my $y = f($x);

    for (1 .. $tries) {

        $x = f($x);
        $y = f(f($y));

        my $g = gcd($x - $y, $n);

        $g <= 1  and next;
        $g >= $n and last;

        return $g;
    }

    return 1;
}

say rho_factor(503 * 863);                   #=> 863
say rho_factor(33670570905491953);           #=> 36169843
say rho_factor(314159265358979323);          #=> 317213509
say rho_factor(242363923520394591022973);    #=> 786757556719


================================================
FILE: Math/polygonal_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 September 2017
# License: GPLv3
# https://github.com/trizen

# Util functions for working with polygonal numbers.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload);

sub polygonal_number ($n, $k) {
    $n * ($k * ($n - 1) - 2 * ($n - 2)) / 2;
}

sub polygonal_root ($n, $k) {
    (sqrt(8 * ($k - 2) * $n + ($k - 4)**2) + $k - 4) / (2 * ($k - 2));
}

sub is_polygonal ($n, $k) {
    polygonal_root($n, $k)->is_int;
}

#<<<
say "Triangular numbers: ", join(', ', grep { is_polygonal($_, 3) } 1 .. 100);
say "Square numbers:     ", join(', ', grep { is_polygonal($_, 4) } 1 .. 100);
say "Pentagonal numbers: ", join(', ', grep { is_polygonal($_, 5) } 1 .. 100);
say "Hexagonal numbers:  ", join(', ', grep { is_polygonal($_, 6) } 1 .. 100);
say "Heptagonal numbers: ", join(', ', grep { is_polygonal($_, 7) } 1 .. 100);
say "Octagonal numbers:  ", join(', ', grep { is_polygonal($_, 8) } 1 .. 100);
#>>>

say '';

#<<<
say "Decagonal numbers: ", join(', ', map { polygonal_number($_, 10) } 1..10);
say "25-gonal numbers:  ", join(', ', map { polygonal_number($_, 25) } 1..10);
say "50-gonal numbers:  ", join(', ', map { polygonal_number($_, 50) } 1..10);
#>>>

__END__
Triangular numbers: 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, 66, 78, 91
Square numbers:     1, 4, 9, 16, 25, 36, 49, 64, 81, 100
Pentagonal numbers: 1, 5, 12, 22, 35, 51, 70, 92
Hexagonal numbers:  1, 6, 15, 28, 45, 66, 91
Heptagonal numbers: 1, 7, 18, 34, 55, 81
Octagonal numbers:  1, 8, 21, 40, 65, 96

Decagonal numbers: 1, 10, 27, 52, 85, 126, 175, 232, 297, 370
25-gonal numbers:  1, 25, 72, 142, 235, 351, 490, 652, 837, 1045
50-gonal numbers:  1, 50, 147, 292, 485, 726, 1015, 1352, 1737, 2170


================================================
FILE: Math/polygonal_representations.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2018
# https://github.com/trizen

# Find all the possible polygonal representations P(a,b) for a given number `n`.

# Example:
#  235 = P(5, 25) = P(235, 2) = P(10, 7)

# See also:
#   https://oeis.org/A176774

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use ntheory qw(divisors);
use Math::AnyNum qw(:overload polygonal);

sub polygonal_representations ($n) {

    my @divisors = divisors(2 * $n);

    shift @divisors;    # skip d=1

    my @representations;

    foreach my $d (@divisors) {

        my $t = $d - 1;
        my $k = (2*$n / $d + 2*$d - 4);

        if ($k % $t == 0) {
            push @representations, [$d, $k / $t];
        }
    }

    return @representations;
}

foreach my $i (1 .. 30) {

    my $n = 2**$i + 1;
    my @P = polygonal_representations($n);

    # Display the solutions
    say "2^$i + 1 = ", join(' = ', map { "P($_->[0], $_->[1])" } @P);

    # Verify the solutions
    die 'error' if grep { $_ != $n } map { polygonal($_->[0], $_->[1]) } @P;
}

__END__
2^1 + 1 = P(2, 3) = P(3, 2)
2^2 + 1 = P(2, 5) = P(5, 2)
2^3 + 1 = P(2, 9) = P(3, 4) = P(9, 2)
2^4 + 1 = P(2, 17) = P(17, 2)
2^5 + 1 = P(2, 33) = P(3, 12) = P(33, 2)
2^6 + 1 = P(2, 65) = P(5, 8) = P(65, 2)
2^7 + 1 = P(2, 129) = P(3, 44) = P(129, 2)
2^8 + 1 = P(2, 257) = P(257, 2)
2^9 + 1 = P(2, 513) = P(3, 172) = P(9, 16) = P(513, 2)
2^10 + 1 = P(2, 1025) = P(5, 104) = P(1025, 2)
2^11 + 1 = P(2, 2049) = P(3, 684) = P(2049, 2)
2^12 + 1 = P(2, 4097) = P(17, 32) = P(4097, 2)
2^13 + 1 = P(2, 8193) = P(3, 2732) = P(8193, 2)
2^14 + 1 = P(2, 16385) = P(5, 1640) = P(16385, 2)
2^15 + 1 = P(2, 32769) = P(3, 10924) = P(9, 912) = P(33, 64) = P(32769, 2)
2^16 + 1 = P(2, 65537) = P(65537, 2)
2^17 + 1 = P(2, 131073) = P(3, 43692) = P(131073, 2)
2^18 + 1 = P(2, 262145) = P(5, 26216) = P(65, 128) = P(262145, 2)
2^19 + 1 = P(2, 524289) = P(3, 174764) = P(524289, 2)
2^20 + 1 = P(2, 1048577) = P(17, 7712) = P(1048577, 2)
2^21 + 1 = P(2, 2097153) = P(3, 699052) = P(9, 58256) = P(129, 256) = P(2097153, 2)
2^22 + 1 = P(2, 4194305) = P(5, 419432) = P(4194305, 2)
2^23 + 1 = P(2, 8388609) = P(3, 2796204) = P(8388609, 2)
2^24 + 1 = P(2, 16777217) = P(257, 512) = P(16777217, 2)
2^25 + 1 = P(2, 33554433) = P(3, 11184812) = P(33, 63552) = P(33554433, 2)
2^26 + 1 = P(2, 67108865) = P(5, 6710888) = P(67108865, 2)
2^27 + 1 = P(2, 134217729) = P(3, 44739244) = P(9, 3728272) = P(513, 1024) = P(134217729, 2)
2^28 + 1 = P(2, 268435457) = P(17, 1973792) = P(268435457, 2)
2^29 + 1 = P(2, 536870913) = P(3, 178956972) = P(536870913, 2)
2^30 + 1 = P(2, 1073741825) = P(5, 107374184) = P(65, 516224) = P(1025, 2048) = P(1073741825, 2)


================================================
FILE: Math/polynomial_interpolation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 December 2018
# https://github.com/trizen

# Polynomial interpolation:
#   find the polynomial of lowest possible degree that passes through all the points of a given dataset.

# See also:
#   https://en.wikipedia.org/wiki/Vandermonde_matrix
#   https://en.wikipedia.org/wiki/Polynomial_interpolation

use 5.010;
use strict;
use warnings;

use Math::MatrixLUP;
use Math::AnyNum qw(ipow sum);

# A sequence of n numbers
my @v = (35, 85, 102, 137, 120);

# Create a new nXn Vandermonde matrix
my @A = map {
    my $n = $_;
    [map { ipow($n, $_) } 0..$#v];
} 0..$#v;

my $A = Math::MatrixLUP->new(\@A);
my $S = $A->solve(\@v);

say "Coefficients: [", join(', ', @$S), "]";
say "Polynomial  : ", join(' + ', map { "($S->[$_] * x^$_)" } 0..$#{$S});
say "Terms       : ", join(', ', map { my $x = $_; sum(map { $x**$_ * $S->[$_] } 0..$#{$S}) } 0..$#v);

__END__
Coefficients: [35, 455/4, -2339/24, 155/4, -121/24]
Polynomial  : (35 * x^0) + (455/4 * x^1) + (-2339/24 * x^2) + (155/4 * x^3) + (-121/24 * x^4)
Terms       : 35, 85, 102, 137, 120


================================================
FILE: Math/power_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 August 2021
# https://github.com/trizen

# Generate all the k-th power divisors of a given number.

use 5.036;
use ntheory qw(:all);

sub power_divisors ($n, $k=1) {

    my @d = (1);
    my @pp = grep { $_->[1] >= $k } factor_exp($n);

    foreach my $pp (@pp) {
        my ($p, $e) = @$pp;

        my @t;
        for (my $i = $k ; $i <= $e ; $i += $k) {
            my $u = powint($p, $i);
            push @t, map { mulint($_, $u) } @d;
        }

        push @d, @t;
    }

    sort { $a <=> $b } @d;
}

say join(', ', power_divisors(3628800, 2));     # square divisors
say join(', ', power_divisors(3628800, 3));     # cube divisors
say join(', ', power_divisors(3628800, 4));     # 4th power divisors


================================================
FILE: Math/power_of_factorial_ramanujan.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 November 2017
# https://github.com/trizen

# Given a prime `p` and number `n`, the highest power of `p` dividing `n!` equals:
#   N = Sum_{k>=1} floor(n/p^k)

# In his third notebook, Ramanujan wrote the following inequalities:
#   n/(p-1) - log(n+1)/log(p) <= N <= (n-1)/(p-1)

# By writing `n` in base `p` (n = Sum_{j=0..m} (b_j * p^j), we can see that:
#   N = (n - Sum_{j=0..m} b_j) / (p-1)

use 5.020;
use strict;
use warnings;

use ntheory qw(todigits vecsum);
use experimental qw(signatures);

sub power_of_factorial_ramanujan ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

say power_of_factorial_ramanujan(100, 2);    #=> 97
say power_of_factorial_ramanujan(100, 3);    #=> 48

say power_of_factorial_ramanujan(123456, 7);      #=> 20573
say power_of_factorial_ramanujan(123456, 127);    #=> 979


================================================
FILE: Math/power_unitary_divisors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 September 2023
# https://github.com/trizen

# Generate the k-th power unitary divisors of n.

# See also:
#   https://oeis.org/A056624

use 5.036;
use ntheory qw(:all);

sub power_udivisors ($n, $k = 1) {

    my @d = (1);

    foreach my $pp (factor_exp($n)) {
        my ($p, $e) = @$pp;

        if ($e % $k == 0) {
            my $u = powint($p, $e);
            push @d, map { mulint($_, $u) } @d;
        }
    }

    sort { $a <=> $b } @d;
}

say join(', ', power_udivisors(3628800, 1));    # unitary divisors
say join(', ', power_udivisors(3628800, 2));    # square unitary divisors
say join(', ', power_udivisors(3628800, 3));    # cube unitary divisors
say join(', ', power_udivisors(3628800, 4));    # 4th power unitary divisors

__END__
1, 7, 25, 81, 175, 256, 567, 1792, 2025, 6400, 14175, 20736, 44800, 145152, 518400, 3628800
1, 25, 81, 256, 2025, 6400, 20736, 518400
1
1, 81, 256, 20736


================================================
FILE: Math/powerfree_divisors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 13 September 2023
# https://github.com/trizen

# Generate the k-powerfree divisors of a given number.

# See also:
#   https://oeis.org/A048250

use 5.036;
use ntheory qw(:all);

sub powerfree_divisors ($n, $k = 2) {

    my @d = (1);

    foreach my $pp (factor_exp($n)) {
        my ($p, $e) = @$pp;

        $e = vecmin($e, $k - 1);

        my @t;
        my $r = 1;
        for (1 .. $e) {
            $r = mulint($r, $p);
            push @t, map { mulint($r, $_) } @d;
        }
        push @d, @t;
    }

    return sort { $a <=> $b } @d;
}

say join(', ', powerfree_divisors(5040, 2));    # squarefree divisors
say join(', ', powerfree_divisors(5040, 3));    # cubefree divisors

__END__
1, 2, 3, 5, 6, 7, 10, 14, 15, 21, 30, 35, 42, 70, 105, 210
1, 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


================================================
FILE: Math/powers_of_primes_in_factorial.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 25 August 2016
# Website: https://github.com/trizen

# A simple function that returns the power of a given prime in the factorial of a number.

# For example:
#
#   factorial_power(100, 3) = 48
#
# because 100! contains 48 factors of 3.

use 5.010;
use strict;
use warnings;

sub factorial_power {
    my ($n, $p) = @_;

    my $count = 0;
    my $ppow  = $p;

    while ($ppow <= $n) {
        $count += int($n / $ppow);
        $ppow *= $p;
    }

    return $count;
}

say factorial_power(100, 3);    #=> 48


================================================
FILE: Math/powers_of_primes_modulus_in_factorial.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 15 September 2016
# Website: https://github.com/trizen

# Count the number of factors of p modulo p^k in (p^n)! with k <= n.

# Example:
#           p   n  k
#   fpower(43, 10, 7) = 6471871693
#
# because (43^10)! contains 514559102697244 factors of 43
# and 514559102697244 mod 43^7 = 6471871693

# See also:
#   https://projecteuler.net/problem=288

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload powmod);

#
## Iterative version
#
sub fpower {
    my ($p, $n, $k) = @_;

    return 0 if $n <= 0;
    $k = $n if $k > $n;

    my $sum = 0;
    my $mod = $p**$k;

    while ($n > 0) {
        $sum += powmod($p, --$n, $mod);
    }

    $sum;
}

#
## Recursive version
#
sub _fpower_rec {
    my ($p, $n, $mod) = @_;
    $n == 0 ? 0 : powmod($p, $n - 1, $mod) + _fpower_rec($p, $n - 1, $mod);
}

sub fpower_rec {
    my ($p, $n, $k) = @_;

    return 0 if $n <= 0;
    $k = $n if $k > $n;

    _fpower_rec($p, $n, $p**$k);
}

say fpower(43, 10, 7);
say fpower_rec(43, 10, 7);


================================================
FILE: Math/prime_41.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 April 2015
# https://github.com/trizen

# The prime41() function.
# Inspired from: https://www.youtube.com/watch?v=3K-12i0jclM

# See more about this on: https://en.wikipedia.org/wiki/Formula_for_primes

use 5.010;
use strict;
use warnings;

use ntheory qw(is_prime divisors);

#
## A general form of: n^2 - n + 41
#
sub p41 {
    my ($x, $y) = @_;

    # $x: Nth number in the sequence
    # $y: position in the sequence relative to 41

    ## Simple:
    # $x**2 - $x + 41;

    ## General:
    $x**2 + (2 * $x * $y) - $x + $y**2 - $y + 41;
}

foreach my $i (0 .. 100) {
    my $n = p41($i, 1);

    if (is_prime($n)) {
        say "$i. $n - prime";
    }
    else {
        say "$i. $n - not prime (factors: ", join(', ', grep { $_ != 1 and $_ != $n } divisors($n)), ")";
    }
}

__END__
=> Deduced from:
43^2-2 = 1847 - prime
44^2-3 = 1933 - prime
45^2-4 = 2021 - not prime (factors: 43, 47)
46^2-5 = 2111 - prime
47^2-6 = 2203 - prime
48^2-7 = 2297 - prime
49^2-8 = 2393 - prime
50^2-9 = 2491 - not prime (factors: 47, 53)
51^2-10 = 2591 - prime
52^2-11 = 2693 - prime
53^2-12 = 2797 - prime
54^2-13 = 2903 - prime
55^2-14 = 3011 - prime
56^2-15 = 3121 - prime
57^2-16 = 3233 - not prime (factors: 53, 61)
58^2-17 = 3347 - prime
59^2-18 = 3463 - prime
60^2-19 = 3581 - prime
61^2-20 = 3701 - prime
62^2-21 = 3823 - prime
63^2-22 = 3947 - prime
64^2-23 = 4073 - prime
65^2-24 = 4201 - prime


================================================
FILE: Math/prime_abundant_sequences.pl
================================================
#!/usr/bin/perl

# For a fixed integer base b > 1,
#   a(n) is the smallest k > a(n-1) such that b^(k-1) == 1 (mod a(n-1)*k), with a(0) = 1.

# Thomas Ordowski's conjecture:
#   For any integer base b > 1, a(n) is prime for almost all n.

# See also:
#   https://oeis.org/A306826

use 5.014;
use ntheory qw(:all);
use Memoize qw(memoize);
use experimental qw(signatures);

memoize('a');

sub a ($n, $base) {

    return 1 if ($n == 0);

    my $t = a($n - 1, $base);
    for (my $k = $t + 1 ; ; ++$k) {
        if (powmod($base, $k - 1, $t * $k) == 1) {
            return $k;
        }
    }
}

foreach my $base (2 .. 30) {

    my @list;
    my $k = a(0, $base);

    for (my $n = 0 ; $k < 1e5 ; ++$n) {
        $k = a($n, $base);
        push @list, $k;
    }

    my $prime_count = scalar grep { is_prime($_) } @list;
    my $total_count = scalar @list;

    printf("[%.2f%% primes] b = %2d, a(n) = {%s, ...}\n",
           $prime_count / $total_count * 100,
           $base, join(', ', @list),
           ", ...}");
}

__END__
[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, ...}
[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, ...}
[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, ...}
[93.75% primes] b =  5, a(n) = {1, 2, 3, 7, 13, 17, 97, 193, 577, 1153, 3457, 10369, 28513, 228097, 456193, 5930497, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}
[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, ...}


================================================
FILE: Math/prime_count_smooth_sum.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 25 October 2016
# Website: https://github.com/trizen

# sum(PI(n) - PI(n - sqrt(n)), {n=1, k})

# Interestingly,
#
#   PI(n) - PI(n - sqrt(n)) = 0
#
# only for n={1, 125, 126}, tested with n <= 10^6.

use 5.010;
use strict;
use warnings;

use ntheory qw(prime_count);

my $limit = shift(@ARGV) || 20;

my $sum = 0;
foreach my $n (1 .. $limit) {
    my $count = prime_count($n) - prime_count(int($n - sqrt($n)));
    $sum += $count;
    say $sum;
}

__END__
0
1
3
4
6
7
9
10
11
12
13
14
16
18
19
20
22
23
25
27


================================================
FILE: Math/prime_counting_from_almost_primes.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 27 August 2025
# https://github.com/trizen

# A sublinear algorithm for computing the Prime Counting function `pi(n)`,
# based on the number of k-almost primes <= n, for `k >= 2`, which can be computed in sublinear time.

# See also:
#   https://mathworld.wolfram.com/AlmostPrime.html

use 5.036;
use ntheory qw(:all);

sub k_prime_count ($k, $n) {

    if ($k == 1) {
        return my_prime_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $j = 0) {

        my $s = rootint(divint($n, $m), $k);

        if ($k == 2) {

            forprimes {
                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;
            } $p, $s;

            return;
        }

        foreach my $q (@{primes($p, $s)}) {
            __SUB__->($m * $q, $q, $k - 1, $j++);
        }
    }->(1, 2, $k);

    return $count;
}

sub my_prime_count ($n) {

    state $pi_table = [0, 0, 1, 2, 2];      # a larger lookup table helps a lot!

    if ($n < 0) {
        return 0;
    }

    if (defined($pi_table->[$n])) {
        return $pi_table->[$n];
    }

    my $M = $n - 1;

    foreach my $k (2 .. logint($n, 2)) {
        $M -= k_prime_count($k, $n);
    }

    return ($pi_table->[$n] //= $M);
}

foreach my $n (1..7) {    # takes ~3 seconds
    say "pi(10^$n) = ", my_prime_count(10**$n);
}

__END__
pi(10^1) = 4
pi(10^2) = 25
pi(10^3) = 168
pi(10^4) = 1229
pi(10^5) = 9592
pi(10^6) = 78498
pi(10^7) = 664579


================================================
FILE: Math/prime_counting_from_squarefree_almost_primes.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 27 August 2025
# https://github.com/trizen

# A sublinear algorithm for computing the Prime Counting function `pi(n)`,
# based on the number of squarefree k-almost primes <= n, for `k >= 2`, which can be computed in sublinear time.

# See also:
#   https://mathworld.wolfram.com/AlmostPrime.html

use 5.036;
use ntheory qw(:all);

sub squarefree_almost_prime_count ($k, $n) {

    if ($k == 0) {
        return (($n <= 0) ? 0 : 1);
    }

    if ($k == 1) {
        return my_prime_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $j = 1) {

        my $s = rootint(divint($n, $m), $k);

        if ($k == 2) {

            forprimes {
                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;
            }
            $p, $s;

            return;
        }

        foreach my $q (@{primes($p, $s)}) {
            __SUB__->(mulint($m, $q), $q + 1, $k - 1, ++$j);
        }
      }
      ->(1, 2, $k);

    return $count;
}

sub my_prime_count ($n) {

    state %cache = (    # a larger lookup table helps a lot!
                     0 => 0,
                     1 => 0,
                     2 => 1,
                     3 => 2,
                     4 => 2,
                   );

    if ($n < 0) {
        return 0;
    }

    if (exists $cache{$n}) {
        return $cache{$n};
    }

    my $M = powerfree_count($n, 2) - 1;

    foreach my $k (2 .. exp(LambertW(log($n))) + 1) {
        $M -= squarefree_almost_prime_count($k, $n);
    }

    $cache{$n} //= $M;
}

foreach my $n (1 .. 7) {    # takes ~1 second
    say "pi(10^$n) = ", my_prime_count(10**$n);
}

__END__
pi(10^1) = 4
pi(10^2) = 25
pi(10^3) = 168
pi(10^4) = 1229
pi(10^5) = 9592
pi(10^6) = 78498
pi(10^7) = 664579


================================================
FILE: Math/prime_counting_liouville_formula.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 17 July 2025
# https://github.com/trizen

# A sublinear algorithm for computing the Prime Counting function `pi(n)`,
# based on the Liouville function and the number of k-almost primes <= n, for `k >= 2`.

# See also:
#   https://mathworld.wolfram.com/AlmostPrime.html

use 5.036;
use ntheory qw(:all);

sub k_prime_count ($k, $n) {

    if ($k == 1) {
        return my_prime_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $j = 0) {

        my $s = rootint(divint($n, $m), $k);

        if ($k == 2) {

            forprimes {
                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;
            } $p, $s;

            return;
        }

        foreach my $q (@{primes($p, $s)}) {
            __SUB__->($m * $q, $q, $k - 1, $j++);
        }
    }->(1, 2, $k);

    return $count;
}

sub my_prime_count ($n) {

    state $pi_table = [0, 0, 1, 2, 2];      # a larger lookup table helps a lot!

    if ($n < 0) {
        return 0;
    }

    if (defined($pi_table->[$n])) {
        return $pi_table->[$n];
    }

    my $M = sumliouville($n);

    foreach my $k (2 .. logint($n, 2)) {
        $M -= (-1)**$k * k_prime_count($k, $n);
    }

    return ($pi_table->[$n] //= 1 - $M);
}

foreach my $n (1..7) {    # takes ~3 seconds
    say "pi(10^$n) = ", my_prime_count(10**$n);
}

__END__
pi(10^1) = 4
pi(10^2) = 25
pi(10^3) = 168
pi(10^4) = 1229
pi(10^5) = 9592
pi(10^6) = 78498
pi(10^7) = 664579


================================================
FILE: Math/prime_counting_mertens_formula.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 17 July 2025
# https://github.com/trizen

# A sublinear algorithm for computing the Prime Counting function `pi(n)`, based on the
# Mertens function and the number of squarefree k-almost primes <= n, for `k >= 2`.

# See also:
#   https://en.wikipedia.org/wiki/Mertens_function
#   https://en.wikipedia.org/wiki/M%C3%B6bius_function

use 5.036;
use ntheory qw(:all);

sub squarefree_almost_prime_count ($k, $n) {

    if ($k == 0) {
        return (($n <= 0) ? 0 : 1);
    }

    if ($k == 1) {
        return my_prime_count($n);
    }

    my $count = 0;

    sub ($m, $p, $k, $j = 1) {

        my $s = rootint(divint($n, $m), $k);

        if ($k == 2) {

            forprimes {
                $count += my_prime_count(divint($n, mulint($m, $_))) - $j++;
            } $p, $s;

            return;
        }

        foreach my $q (@{primes($p, $s)}) {
            __SUB__->(mulint($m, $q), $q + 1, $k - 1, ++$j);
        }
      }
      ->(1, 2, $k);

    return $count;
}

sub my_prime_count ($n) {

    state $pi_table = [0, 0, 1, 2, 2];      # a larger lookup table helps a lot!

    if ($n < 0) {
        return 0;
    }

    if (defined($pi_table->[$n])) {
        return $pi_table->[$n];
    }

    my $M = mertens($n);

    foreach my $k (2 .. exp(LambertW(log($n))) + 1) {
        $M -= (-1)**$k * squarefree_almost_prime_count($k, $n);
    }

    return ($pi_table->[$n] //= 1 - $M);
}

foreach my $n (1 .. 7) {    # takes ~1 second
    say "pi(10^$n) = ", my_prime_count(10**$n);
}

__END__
pi(10^1) = 4
pi(10^2) = 25
pi(10^3) = 168
pi(10^4) = 1229
pi(10^5) = 9592
pi(10^6) = 78498
pi(10^7) = 664579


================================================
FILE: Math/prime_factorization_concept.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 06 July 2015
# Website: https://github.com/trizen

# Prime factorization in polynomial time (concept only)

use 5.010;
use strict;
use warnings;

#
## The backwards process of:
#

#   23 *
#   17
#  ----
#  161
#  23
# -----
#  391

# 23
my $x2 = 2;
my $x1 = 3;

# 17
my $y2 = 1;
my $y1 = 7;

# {
#    1=10*(a*c/10-floor(a*c/10)),
#    9=10*(b*c/10-floor(b*c/10))+floor(a*c/10)+10*(a*d/10-floor(a*d/10)),
#    3=floor((b*c+floor(a*c/10))/10)+10*(b*d/10-floor(b*d/10))
# }

# Last digit
say(($x1 * $y1) % 10);

# Middle digit
say((($x2 * $y1) % 10) + int($x1 * $y1 / 10) + (($x1 * $y2) % 10));

# First digit
say(int((($x2 * $y1) + int($x1 * $y1 / 10)) / 10) + (($x2 * $y2) % 10));


#
## Alternate forms:
#

say "-" x 80;

# Last digit
say(($x1 * $y1 / 10 - int($x1 * $y1 / 10)) * 10);

# Middle digit
say(int($x1 * $y1 / 10) - 10 * int($x1 * $y2 / 10) + $x1 * $y2 - 10 * int($x2 * $y1 / 10) + $x2 * $y1);

# First digit
say(int($x2 * $y1 / 10 + int($x1 * $y1 / 10) / 10) + 10 * ($x2 * $y2 / 10 - int($x2 * $y2 / 10)));


================================================
FILE: Math/prime_factors_of_binomial_coefficients.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 25 August 2016
# Website: https://github.com/trizen

# An efficient algorithm for prime factorization of binomial coefficients.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(forprimes todigits vecsum);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

#
# Example for:
#     binomial(100, 50)
#
# which is equivalent with:
#    100! / (100-50)! / 50!
#

my $n = 100;
my $k = 50;
my $j = $n - $k;

my @factors;

forprimes {
    my $p = factorial_power($n, $_);

    if ($_ <= $k) {
        $p -= factorial_power($k, $_);
    }

    if ($_ <= $j) {
        $p -= factorial_power($j, $_);
    }

    if ($p > 0) {
        push @factors, ($_) x $p;
    }
} $n;

say "Prime factors of binomial($n, $k) = (@factors)";


================================================
FILE: Math/prime_factors_of_binomial_product.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 January 2019
# https://github.com/trizen

# Efficient formula due to Jeffrey C. Lagarias and Harsh Meht for computing the prime-power factorization of the product of binomials.

# Using the identities:
#   G(n) = Product_{k=0..n} binomial(n, k) = Product_{k=1..n} k^(2*k - n - 1)
#                                          = hyperfactorial(n)/superfactorial(n)

# See also:
#   https://oeis.org/A001142
#   https://oeis.org/A323444

# Paper:
#   Jeffrey C. Lagarias, Harsh Mehta
#   Products of binomial coefficients and unreduced Farey fractions
#   https://arxiv.org/abs/1409.4145

use 5.020;
use strict;
use warnings;

no warnings 'recursion';

use experimental qw(signatures);
use ntheory qw(forprimes todigits vecsum);

my @cache;

sub sum_of_digits ($n, $p) {
    return 0 if ($n <= 0);
    $cache[$n][$p] //= vecsum(todigits($n - 1, $p)) + sum_of_digits($n - 1, $p);
}

sub power_of_product_of_binomials ($n, $p) {
    (2 * sum_of_digits($n, $p) - ($n - 1) * vecsum(todigits($n, $p))) / ($p - 1);
}

sub prime_factorization_of_binomial_product ($n) {
    my @pp;

    forprimes {

        my $p = $_;
        my $k = power_of_product_of_binomials($n, $p);

        push @pp, [$p, $k];
    } $n;

    return @pp;
}

foreach my $n (2 .. 20) {
    my @pp = prime_factorization_of_binomial_product($n);
    printf("G(%2d) = %s\n", $n, join(' * ', map { sprintf("%2d^%-2d", $_->[0], $_->[1]) } @pp));
}

__END__
G( 2) =  2^1
G( 3) =  2^0  *  3^2
G( 4) =  2^5  *  3^1
G( 5) =  2^2  *  3^0  *  5^4
G( 6) =  2^4  *  3^4  *  5^3
G( 7) =  2^0  *  3^2  *  5^2  *  7^6
G( 8) =  2^17 *  3^0  *  5^1  *  7^5
G( 9) =  2^10 *  3^14 *  5^0  *  7^4
G(10) =  2^12 *  3^10 *  5^8  *  7^3
G(11) =  2^4  *  3^6  *  5^6  *  7^2  * 11^10
G(12) =  2^18 *  3^13 *  5^4  *  7^1  * 11^9
G(13) =  2^8  *  3^8  *  5^2  *  7^0  * 11^8  * 13^12
G(14) =  2^11 *  3^3  *  5^0  *  7^12 * 11^7  * 13^11
G(15) =  2^0  *  3^12 *  5^12 *  7^10 * 11^6  * 13^10
G(16) =  2^49 *  3^6  *  5^9  *  7^8  * 11^5  * 13^9
G(17) =  2^34 *  3^0  *  5^6  *  7^6  * 11^4  * 13^8  * 17^16
G(18) =  2^36 *  3^28 *  5^3  *  7^4  * 11^3  * 13^7  * 17^15
G(19) =  2^20 *  3^20 *  5^0  *  7^2  * 11^2  * 13^6  * 17^14 * 19^18
G(20) =  2^42 *  3^12 *  5^16 *  7^0  * 11^1  * 13^5  * 17^13 * 19^17


================================================
FILE: Math/prime_factors_of_factorial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 July 2016
# https://github.com/trizen

# A shortcut algorithm for finding the factors of n!
# without computing the factorial in the first place.

# Example:
#    6! =  2^4  *  3^2  *  5^1

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(forprimes vecsum todigits);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub factorial_prime_powers ($n) {
    my @pp;

    forprimes {
        push @pp, [$_, factorial_power($n, $_)];
    } $n;

    return @pp;
}

for my $n (2 .. 20) {
    my @pp = factorial_prime_powers($n);
    printf("%2s! = %s\n", $n, join(' * ', map { sprintf("%2d^%-2d", $_->[0], $_->[1]) } @pp));
}

__END__
 2! =  2^1
 3! =  2^1  *  3^1
 4! =  2^3  *  3^1
 5! =  2^3  *  3^1  *  5^1
 6! =  2^4  *  3^2  *  5^1
 7! =  2^4  *  3^2  *  5^1  *  7^1
 8! =  2^7  *  3^2  *  5^1  *  7^1
 9! =  2^7  *  3^4  *  5^1  *  7^1
10! =  2^8  *  3^4  *  5^2  *  7^1
11! =  2^8  *  3^4  *  5^2  *  7^1  * 11^1
12! =  2^10 *  3^5  *  5^2  *  7^1  * 11^1
13! =  2^10 *  3^5  *  5^2  *  7^1  * 11^1  * 13^1
14! =  2^11 *  3^5  *  5^2  *  7^2  * 11^1  * 13^1
15! =  2^11 *  3^6  *  5^3  *  7^2  * 11^1  * 13^1
16! =  2^15 *  3^6  *  5^3  *  7^2  * 11^1  * 13^1
17! =  2^15 *  3^6  *  5^3  *  7^2  * 11^1  * 13^1  * 17^1
18! =  2^16 *  3^8  *  5^3  *  7^2  * 11^1  * 13^1  * 17^1
19! =  2^16 *  3^8  *  5^3  *  7^2  * 11^1  * 13^1  * 17^1  * 19^1
20! =  2^18 *  3^8  *  5^4  *  7^2  * 11^1  * 13^1  * 17^1  * 19^1


================================================
FILE: Math/prime_factors_of_superfactorial_and_hyperfactorial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 January 2019
# https://github.com/trizen

# Efficient formula due to Jeffrey C. Lagarias and Harsh Meht for computing the prime-power factorization of the superfactorial(n) and hyperfactorial(n).

# See also:
#   https://oeis.org/A001142
#   https://oeis.org/A323444

# Paper:
#   Jeffrey C. Lagarias, Harsh Mehta
#   Products of binomial coefficients and unreduced Farey fractions
#   https://arxiv.org/abs/1409.4145

use 5.020;
use strict;
use warnings;

no warnings 'recursion';

use experimental qw(signatures);
use ntheory qw(todigits vecsum forprimes);
use Math::AnyNum qw(superfactorial hyperfactorial prod ipow);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

my @cache;

sub superfactorial_power ($n, $p) {
    return 0 if ($n <= 0);
    $cache[$n][$p] //= superfactorial_power($n - 1, $p) + factorial_power($n, $p);
}

sub hyperfactorial_power ($n, $p) {
    $n * factorial_power($n, $p) - superfactorial_power($n - 1, $p);
}

sub prime_factorization_of_superfactorial ($n) {
    my @pp;

    forprimes {

        my $p = $_;
        my $k = superfactorial_power($n, $p);

        push @pp, [$p, $k];
    }
    $n;

    return @pp;
}

sub prime_factorization_of_hyperfactorial ($n) {
    my @pp;

    forprimes {

        my $p = $_;
        my $k = hyperfactorial_power($n, $p);

        push @pp, [$p, $k];
    }
    $n;

    return @pp;
}

foreach my $n (2 .. 15) {

    my @S_pp = prime_factorization_of_superfactorial($n);
    my @H_pp = prime_factorization_of_hyperfactorial($n);

    printf("S(%2d) = %s\n", $n, join(' * ', map { sprintf("%2d^%-2d", $_->[0], $_->[1]) } @S_pp));
    printf("H(%2d) = %s\n", $n, join(' * ', map { sprintf("%2d^%-2d", $_->[0], $_->[1]) } @H_pp));

    prod(map { ipow($_->[0], $_->[1]) } @S_pp) == superfactorial($n) or die "S($n) error";
    prod(map { ipow($_->[0], $_->[1]) } @H_pp) == hyperfactorial($n) or die "H($n) error";
}

__END__
S( 2) =  2^1
H( 2) =  2^2
S( 3) =  2^2  *  3^1
H( 3) =  2^2  *  3^3
S( 4) =  2^5  *  3^2
H( 4) =  2^10 *  3^3
S( 5) =  2^8  *  3^3  *  5^1
H( 5) =  2^10 *  3^3  *  5^5
S( 6) =  2^12 *  3^5  *  5^2
H( 6) =  2^16 *  3^9  *  5^5
S( 7) =  2^16 *  3^7  *  5^3  *  7^1
H( 7) =  2^16 *  3^9  *  5^5  *  7^7
S( 8) =  2^23 *  3^9  *  5^4  *  7^2
H( 8) =  2^40 *  3^9  *  5^5  *  7^7
S( 9) =  2^30 *  3^13 *  5^5  *  7^3
H( 9) =  2^40 *  3^27 *  5^5  *  7^7
S(10) =  2^38 *  3^17 *  5^7  *  7^4
H(10) =  2^50 *  3^27 *  5^15 *  7^7
S(11) =  2^46 *  3^21 *  5^9  *  7^5  * 11^1
H(11) =  2^50 *  3^27 *  5^15 *  7^7  * 11^11
S(12) =  2^56 *  3^26 *  5^11 *  7^6  * 11^2
H(12) =  2^74 *  3^39 *  5^15 *  7^7  * 11^11
S(13) =  2^66 *  3^31 *  5^13 *  7^7  * 11^3  * 13^1
H(13) =  2^74 *  3^39 *  5^15 *  7^7  * 11^11 * 13^13
S(14) =  2^77 *  3^36 *  5^15 *  7^9  * 11^4  * 13^2
H(14) =  2^88 *  3^39 *  5^15 *  7^21 * 11^11 * 13^13
S(15) =  2^88 *  3^42 *  5^18 *  7^11 * 11^5  * 13^3
H(15) =  2^88 *  3^54 *  5^30 *  7^21 * 11^11 * 13^13


================================================
FILE: Math/prime_formulas.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 03 July 2015
# Website: https://github.com/trizen

# Generate a top list of prime formulas (in the form of: n^2 - n ± m)

use 5.010;
use strict;
use warnings;

use ntheory qw(is_prime);

my %top;
my $n_limit = 1e4;
my $m_limit = 1e2;

for (my $m = 1 ; $m <= $m_limit ; $m += 2) {
    foreach my $n (0 .. $n_limit) {
        is_prime($n**2 - $n + $m)      && ++$top{$m};
        is_prime(abs($n**2 - $n - $m)) && ++$top{-$m};
    }
}

foreach my $key (sort { $top{$b} <=> $top{$a} } keys %top) {
    printf("[%5d] n^2 - n %s %s\n", $top{$key}, $key > 0 ? ('+', $key) : ('-', abs($key)));
}


================================================
FILE: Math/prime_functions_in_terms_of_zeros_of_zeta.pl
================================================
#!/usr/bin/perl

# Approximate the Chebyshev function and the weighted prime counting function, using zeros of the Riemann zeta function.

# See also:
#   https://oeis.org/A267712
#   https://en.wikipedia.org/wiki/Chebyshev_function
#   https://en.wikipedia.org/wiki/Logarithmic_integral_function
#   https://en.wikipedia.org/wiki/Riemann_zeta_function

use utf8;
use 5.020;
use strict;
use warnings;

binmode(STDOUT, ':utf8');

use ntheory qw(forprimes prime_count);
use experimental qw(signatures);
use Math::AnyNum qw(:overload gamma complex tau ilog iroot log Li harmreal);

my @zeta_ρ = map { chomp; complex(1 / 2, $_) } ;

sub Li_approx ($x) {

    my $sum = 0;
    foreach my $k (0 .. 0) {
        $sum += gamma($k + 1) / log($x)**$k;
    }

    return ($sum * ($x / log($x)));
}

sub chebyshev_ψ ($x) {

    my $sum = 0;
    forprimes {
        $sum += ilog($x, $_) * log($_)
    } $x;

    return $sum;
}

sub weighted_prime_count ($x) {
    my $sum = 0;

    foreach my $k (1 .. ilog($x, 2)) {
        $sum += Math::AnyNum->new(prime_count(iroot($x, $k))) / $k;
    }

    return $sum;
}

sub weighted_prime_count_from_zeta_zeros ($x) {
    my $sum = Li($x);

    foreach my $ρ (@zeta_ρ) {
        $sum -= Li_approx($x**$ρ);
    }

    return abs($sum - log(2));
}

sub chebyshev_ψ_from_zeta_zeros($x) {
    my $sum = $x - log(tau) - log(1 - $x**(-2)) / 2;

    foreach my $ρ (@zeta_ρ) {
        $sum -= $x**$ρ / $ρ;
    }

    return abs($sum);
}

my $x = 10**3;

say "ψ($x) = ", chebyshev_ψ($x);                    # 996.680912247175240263021765666421541665778436902
say "ψ($x) ≅ ", chebyshev_ψ_from_zeta_zeros($x);    # 996.068434632130345546023799228964726756917555651

say "\n=> Weighted prime count approximation: ";
foreach my $k (10 .. 14) {
    my $exact  = weighted_prime_count(10**$k);
    my $approx = weighted_prime_count_from_zeta_zeros(10**$k);
    say "Π(10^$k) = ", $exact->as_dec, " ≅ ", $approx, ' -> ', abs($exact - $approx);
}

__DATA__
14.1347251417346937904572519835624702707842571157
21.0220396387715549926284795938969027773343405249
25.0108575801456887632137909925628218186595496726
30.4248761258595132103118975305840913201815600237
32.9350615877391896906623689640749034888127156035
37.5861781588256712572177634807053328214055973508
40.9187190121474951873981269146332543957261659628
43.3270732809149995194961221654068057826456683718
48.0051508811671597279424727494275160416868440011
49.7738324776723021819167846785637240577231782997
52.9703214777144606441472966088809900638250178888
56.4462476970633948043677594767061275527822644717
59.3470440026023530796536486749922190310987728065
60.8317785246098098442599018245240038029100904512
65.1125440480816066608750542531837050293481492952
67.0798105294941737144788288965222167701071449517
69.5464017111739792529268575265547384430124742096
72.0671576744819075825221079698261683904809066215
75.7046906990839331683269167620303459228119035307
77.1448400688748053726826648563046370157960324492
79.3373750202493679227635928771162281906132467431
82.9103808540860301831648374947706094975088805938
84.7354929805170501057353112068277414171066279342
87.4252746131252294065316678509192132521718864013
88.8091112076344654236823480795093783954448934098
92.4918992705584842962597252418106848787217940277
94.6513440405198869665979258152081539377280270157
95.870634228245309758741029219246781695256461225
98.8311942181936922333244201386223278206580390634
101.317851005731391228785447940292308906332866384
103.725538040478339416398408108695280834481173069
105.446623052326094493670832414111808997282753929
107.168611184276407515123351963086191213476707881
111.02953554316967452465645030994435041534596839
111.874659176992637085612078716770594960311749873
114.320220915452712765890937276191079809917657724
116.226680320857554382160804312064755127329851232
118.790782865976217322979139702699824347306210593
121.370125002420645918945532970499922723001310632
122.946829293552588200817460330770016496214389874
124.256818554345767184732007966129924441573538775
127.516683879596495124279323766906076268088309882
129.578704199956050985768033906179973608640953265
131.087688530932656723566372461501349059203547503
133.497737202997586450130492042640607664974174944
134.756509753373871331326064157169736178396068614
138.116042054533443200191555190282447859835274624
139.736208952121388950450046523382460846790052565
141.12370740402112376194035381847535509030066088
143.11184580762063273940512386891392996623310243
146.000982486765518547402507596424682428975741233
147.42276534255960204952118501043150616877277525
150.05352042078488035143246723695937062303732156
150.925257612241466761852524678305627602426770473
153.024693811198896198256544255185446508590434904
156.112909294237867569750189310169194746535308501
157.597591817594059887530503158498765730723899519
158.849988171420498724174994775540271414335083049
161.188964137596027519437344129369554364915790327
163.030709687181987243311039000687994896964461416
165.537069187900418830038919354874797328367251745
167.184439978174513440957756246210378736460769243
169.09451541556882148950587118143183479666764858
169.911976479411698966699843595821792288394437125
173.411536519591552959846118649345595254156066063
174.754191523365725813378762455866917938755717621
176.441434297710418888892641057860933528118497109
178.377407776099977285830935414184426183132361461
179.916484020256996139340036612051237453687607553
182.207078484366461915407037226987798690797457778
184.874467848387508800960646617234258413351022912
185.59878367770747146652770426839264661293471765
187.228922583501851991641540586131243016810734604
189.416158656016937084852289099845324491357103023
192.026656360713786547283631425583430105839920298
193.079726603845704047402205794376054604020615811
195.265396679529235321463187814862250926905052452
196.876481840958316948622263914696207735746028692
198.015309676251912424919918702208867155062695439
201.264751943703788733016133427548173222402863639
202.493594514140534277686660637864315821020244899
204.189671803104554330716438386313685136534529229
205.394697202163286025212379390693090923722914772
207.906258887806209861501967907753644268659403769
209.576509716856259852835644289886752175390783181
211.690862595365307563907486730719294253394030983
213.347919359712666190639122021072608821897183277
214.547044783491423222944201072590691045599888053
216.169538508263700265869563354498128575453714274
219.067596349021378985677256590437241245149182927
220.714918839314003369115592633906339656761145078
221.430705554693338732097475119276077950222331077
224.00700025460433521172887552850489535608598995
224.983324669582287503782523680528656772090054486
227.421444279679291310461436160659639963969148322
229.337413305525348107760083306055740082752341388
231.250188700499164773806186770010372606708495843
231.987235253180248603771668539197862205419833995
233.693404178908300640704494732569788179537227755
236.524229665816205802475507955662978689529495212


================================================
FILE: Math/prime_numbers_generator.pl
================================================
#!/usr/bin/perl

use 5.014;

OUTER: for (my $i = 3 ; ; $i += 2) {
    foreach my $j (2 .. sqrt($i)) {
        $i % $j || next OUTER;
    }
    say $i;
}


================================================
FILE: Math/prime_omega_function_generalized.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 25 November 2018
# https://github.com/trizen

# Generalization of the prime omega functions `ω_m(n)` and `Ω_m(n)`, for `m>=0`:
#
#     ω_m(n) = n^m * Sum_{p|n} 1/p^m
#
# and:
#
#     Ω_m(n) = Sum_{p^k|n} Sum_{j=1..k} n^m / p^(j*m)
#            = Sum_{p^k|n} n^m * (p^(m*k) - 1) / (p^m - 1) / p^(m*k)
#

# Where we have the following identities:
#   ω(n) = ω_0(n)
#   Ω(n) = Ω_0(n)

# See also:
#   https://oeis.org/A069359
#   https://oeis.org/A322068
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://trizenx.blogspot.com/2018/11/partial-sums-of-arithmetical-functions.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(factor_exp vecsum);

sub omega ($n, $m) {
    vecsum(map { $n**$m / $_->[0]**$m } factor_exp($n));
}

sub bigomega ($n, $m) {
    vecsum(
        map {
            my $p = $_;
            vecsum(map { $n**$m / $p->[0]**($_ * $m) } 1 .. $p->[1])
        } factor_exp($n)
    );
}

foreach my $k (0 .. 5) {
    say "ω_$k(n) = [", join(', ', map { omega($_, $k) } 1 .. 25), "]";
    say "Ω_$k(n) = [", join(', ', map { bigomega($_, $k) } 1 .. 25), "]\n";
}

__END__
ω_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]
Ω_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]

ω_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]
Ω_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]

ω_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]
Ω_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]

ω_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]
Ω_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]

ω_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]
Ω_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]

ω_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]
Ω_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]


================================================
FILE: Math/prime_quadratic_polynomial_analyzer.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 12 April 2015
# https://github.com/trizen

# Analyze the number of primes generated by each quadratic polynomial formula

use 5.010;
use strict;
use warnings;

use ntheory qw(is_prime);

my @formulas = (
                sub { $_[0]**2 - $_[0] + 41 },
                sub { $_[0]**2 - $_[0] + 111 },
                sub { $_[0]**2 - $_[0] + 285 },
                sub { $_[0]**2 - $_[0] + 171 },
                sub { $_[0]**2 - $_[0] + 107 },
                sub { $_[0]**2 - $_[0] + 101 },
                sub { $_[0]**2 - $_[0] + 75 },
                sub { $_[0]**2 - $_[0] + 315 },
                sub { $_[0]**2 - $_[0] + 227 },
                sub { $_[0]**2 - $_[0] + 621 },
               );

my %top;
my $n = shift(@ARGV) // 100000;

foreach my $i (0 .. $#formulas) {
    foreach my $j (1 .. $n) {
        ++$top{$i} if is_prime($formulas[$i]->($j));
    }
}

foreach my $key (sort { $top{$b} <=> $top{$a} } keys %top) {
    my $y = $formulas[$key]->(0);
    my $f = sprintf("n^2 - n + %3d", $y);
    printf "%13s: %56d (%5.2f%%)\n", $f, $top{$key}, $top{$key} / $n * 100;
}

__END__
# For n={1,100000}:
n^2 - n +  41:                                                    31985 (31.99%)
n^2 - n + 107:                                                    25162 (25.16%)
n^2 - n + 227:                                                    24658 (24.66%)
n^2 - n + 101:                                                    24549 (24.55%)
n^2 - n + 171:                                                     8647 ( 8.65%)
n^2 - n + 111:                                                     6838 ( 6.84%)
n^2 - n + 621:                                                     3738 ( 3.74%)
n^2 - n + 315:                                                     3305 ( 3.31%)
n^2 - n + 285:                                                     2992 ( 2.99%)
n^2 - n +  75:                                                     2933 ( 2.93%)


================================================
FILE: Math/prime_quadratic_polynomials.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 12 April 2015
# https://github.com/trizen

# A program that finds quadratic polynomials which will generate primes (with some gaps)
# -- algorithm complexity: O(n) --

# See also: https://en.wikipedia.org/wiki/Formula_for_primes

use 5.010;
use strict;
use warnings;

use ntheory qw(is_prime);

my $i = 1;
my $j = 1;

my $n = shift(@ARGV) // 8000000;    # duration: about 7 seconds
my $limit = int(sqrt($n)) - 1;

my %top;                          # store some info about primes
my $top = 10;                     # how many formulas to display at the end

for my $m (reverse(0 .. $limit)) {
    my $pos = $m;
    for my $n ($j .. $i**2) {
        $top{$pos}{height} //= $i;
        $top{$pos}{count}  //= 0;
        if (is_prime($j)) {
            $top{$pos}{count}++;
            $top{$pos}{first} //= $j;
        }
        ++$pos;
        ++$j;
    }
    ++$i;
}

my $counter = 0;
foreach my $i (sort { $top{$b}{count} <=> $top{$a}{count} } keys %top) {
    say(
        "height: "            => $top{$i}{height},
        "; count: "           => $top{$i}{count},
        "; first: "           => $top{$i}{first},
        "\nf(n) = n^2 + n + " => $top{$i}{height},
        "\ng(n) = n^2 + "     => ($top{$i}{height} * 2 + 1) . 'n + ' . (($top{$i}{height} + 1)**2 - 1),
        "\n"
       );
    last if ++$counter == $top;
}


================================================
FILE: Math/prime_signature_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 April 2026
# https://github.com/trizen

# Generate all the k-omega numbers in range [A,B] that have a given prime signature.

use 5.036;
use ntheory 0.74 qw(:all);

sub rootint_ceil($n, $k) {
    return rootint($n, $k) + (is_power($n, $k) ? 0 : 1);
}

sub prime_signature_numbers_in_range($A, $B, $prime_signature) {

    my @list;
    my $k = scalar(@$prime_signature);

    if ($k == 0) {
        push(@list, 1) if ($A <= 1 and 1 <= $B);
        return @list;
    }

    # The smallest possible number with k distinct prime factors
    $A = vecmax(pn_primorial($k), $A);

    my $generate = sub ($m, $lo, $k, $P, $sum_e) {

        my $e = $P->[$k - 1];
        my $hi = rootint(divint($B, $m), $sum_e);

        if ($lo > $hi) {
            return;
        }

        # Base case
        if ($k == 1) {

            # Tighten the lower bound based on A
            my $lo_tight = vecmax($lo, rootint_ceil(cdivint($A, $m), $e));

            foreach my $p (@{primes($lo_tight, $hi)}) {
                push @list, mulint($m, powint($p, $e));
            }

            return;
        }

        for (my $p = $lo; $p <= $hi; ) {
            my $t = mulint($m, powint($p, $e));
            my $r = next_prime($p);
            __SUB__->($t, $r, $k - 1, $P, $sum_e - $e);
            $p = $r;
        }
    };

    my %seen;
    my $sum_e = vecsum(@$prime_signature);

    if ($sum_e > logint($B, 2)) {
        return;
    }

    forperm {
        my @perm = @{$prime_signature}[@_];
        if (!$seen{join(' ', @perm)}++) {
            $generate->(1, 2, scalar(@perm), \@perm, $sum_e);
        }
    } $k;

    return sort { $a <=> $b } @list;
}

# Example
my $prime_signature = [3, 2, 2];
my $A               = 2000;
my $B               = 10000;

my @arr = prime_signature_numbers_in_range($A, $B, $prime_signature);
say "Generated: @arr";

my @bf = grep {
    join(' ', prime_signature($_)) eq join(' ', sort { $b <=> $a } @$prime_signature)
} vecmax(pn_primorial(scalar(@$prime_signature)), $A) .. $B;

"@arr" eq "@bf" or die "Mismatch detected!";


================================================
FILE: Math/prime_summation.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 28 October 2015
# Website: https://github.com/trizen

# Count how many times an even number can be written as the sum of two or more sub-primes

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

use ntheory qw(primes);
use Memoize qw(memoize);

my $limit = 1000;
my $primes = primes(0, $limit);

my %primes;
@primes{@{$primes}} = ();

sub sum_prime {
    my ($n) = @_;

    my $sum = 0;
    foreach my $prime (@{$primes}) {
        last if ($prime > ($n / 2));
        my $diff = $n - $prime;
        if (exists $primes{$diff}) {
            $sum += 1 + sum_prime($diff);
        }
    }

    $sum;
}

memoize('sum_prime');     # cache the function to improve performance

for (my $i = 2 ; $i <= $limit ; $i += 2) {
    say "$i\t", sum_prime($i);
}


================================================
FILE: Math/prime_zeta.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 16 November 2015
# Website: https://github.com/trizen

# zeta(s) = sum(1 / k^s)                        from k=1 to Infinity
# zeta(s) = product(1 / (1 - prime(k)^(-s)))    from k=1 to Infinity

use 5.010;
use strict;
use warnings;

use ntheory qw(nth_prime);

sub prime_zeta {
    my ($s) = @_;

    my $p = 1;
    for my $i (1 .. 10000) {
        $p *= 1 / (1 - 1 / nth_prime($i)**$s);
    }
    return $p;
}

say sqrt(prime_zeta(2) * 6);


================================================
FILE: Math/primes_diff.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# License: GPLv3
# Date: 20th November 2013
# https://trizenx.blogspot.com

# Prime numbers with difference of two
# are grouped together if have a given difference
# related to other numbers.

# Example: 17, 19 and 59, 61 (diff == 42)

use 5.010;
use strict;
use warnings;

use Data::Dump qw(pp);
use ntheory qw(is_prime);

my @primes = grep { is_prime($_) } 0 .. 1000;

my @twin_primes;
foreach my $i (0 .. $#primes) {
    foreach my $j ($i + 1 .. $#primes) {
        my $diff = $primes[$j] - $primes[$i];
        if ($diff == 2) {
            push @twin_primes, [$primes[$i], $primes[$j]];
        }
        elsif ($diff > 2) {
            last;
        }
    }
}

my %table;
foreach my $i (0 .. $#twin_primes) {
    foreach my $j ($i + 1 .. $#twin_primes) {
        my $diff = $twin_primes[$j][0] - $twin_primes[$i][0];
        push @{$table{$diff}}, [[@{$twin_primes[$i]}], [@{$twin_primes[$j]}]];
    }
}

my @max = (sort { $#{$table{$b}} <=> $#{$table{$a}} } keys %table);

# Top 10
foreach my $i (0 .. 9) {
    say "$max[$i]: ", pp($table{$max[$i]});
}


================================================
FILE: Math/primes_sum_of_pair_product.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 07 April 2016
# Website: https://github.com/trizen

# Sum of product of pair of primes that differ by a given constant.
#   ∞
#  ---
#  \     1     1
#  /    --- * ---
#  ---   p    p+c
#  p
#  p+c

use 5.010;
use strict;

use ntheory qw(is_prime forprimes);

my $C = 2;      # 2 is for twin primes
my $j = 0;
my $S = 0.0;

forprimes {
    is_prime($j = $_ + $C) && (
        $S += 1 / ($_ * $j)
    );
} 1, 1000000000;

say $S;


================================================
FILE: Math/primitive_sum_of_two_squares.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 October 2017
# https://github.com/trizen

# Find a solution to x^2 + y^2 = n, for numbers `n` whose prime divisors are
# all congruent to 1 mod 4, with the exception of at most a single factor of 2.

# Blog post:
#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html

# See also:
#   https://oeis.org/A008784

use 5.020;
use strict;
use warnings;

use ntheory qw(sqrtmod);
use experimental qw(signatures);

sub primitive_sum_of_two_squares ($p) {

    if ($p == 2) {
        return (1, 1);
    }

    my $s = sqrtmod($p - 1, $p) || return;
    my $q = $p;

    while ($s * $s > $p) {
        ($s, $q) = ($q % $s, $s);
    }

    return ($s, $q % $s);
}

foreach my $n (1 .. 100) {
    my ($x, $y) = primitive_sum_of_two_squares($n);

    if (defined($x) and defined($y)) {
        say "f($n) = $x^2 + $y^2";

        if ($n != $x**2 + $y**2) {
            die "error for $n";
        }
    }
}

__END__
f(2) = 1^2 + 1^2
f(5) = 2^2 + 1^2
f(10) = 3^2 + 1^2
f(13) = 3^2 + 2^2
f(17) = 4^2 + 1^2
f(25) = 4^2 + 3^2
f(26) = 5^2 + 1^2
f(29) = 5^2 + 2^2
f(34) = 5^2 + 3^2
f(37) = 6^2 + 1^2
f(41) = 5^2 + 4^2
f(50) = 7^2 + 1^2
f(53) = 7^2 + 2^2
f(58) = 7^2 + 3^2
f(61) = 6^2 + 5^2
f(65) = 8^2 + 1^2
f(73) = 8^2 + 3^2
f(74) = 7^2 + 5^2
f(82) = 9^2 + 1^2
f(85) = 7^2 + 6^2
f(89) = 8^2 + 5^2
f(97) = 9^2 + 4^2


================================================
FILE: Math/primorial_deflation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 April 2019
# https://github.com/trizen

# Represent a given number as a product of primorials (if possible).

# The sequence of numbers that can be represented as a product of primorials, is given by:
#   https://oeis.org/A025487

# Among other terms, the sequence includes the factorials and the highly composite numbers.

# See also:
#   https://oeis.org/A181815 -- "primorial deflation" of A025487(n)
#   https://oeis.org/A108951 -- "primorial inflation" of n

use 5.020;
use strict;
use warnings;

use experimental qw(signatures declared_refs);

use ntheory qw(factor factor_exp prev_prime);
use Math::AnyNum qw(factorial primorial prod ipow);

sub primorial_deflation ($n) {

    my @terms;

    while ($n > 1) {

        my $g = (factor($n))[-1];
        my $p = primorial($g);

        $n /= $p;
        $n->is_int || return undef;

        push @terms, $g;
    }

    return prod(@terms);
}

sub primorial_deflation_fast ($n) {

    my @p;

    foreach my \@pp (factor_exp($n)) {
        my ($p, $e) = @pp;
        push @p, ($p == 2) ? 1 : ipow(prev_prime($p), $e);
    }

    $n / prod(@p);
}

my @arr = map { primorial_deflation(factorial($_)) } 0 .. 15;    # https://oeis.org/A307035

say join ', ', @arr;                                                   #=> 1, 1, 2, 3, 12, 20, 60, 84, 672, 1512, 5040, 7920, 47520, 56160, 157248
say join ', ', map { prod(map { primorial($_) } factor($_)) } @arr;    #=> 1, 1, 2, 6, 24, 120, 720, 5040, 40320, 362880, 3628800, 39916800, 479001600, 6227020800, 87178291200

my @test = map { primorial_deflation_fast(factorial($_)) } 0 .. 15;

if ("@arr" ne "@test") {
    die "error: (@arr) != (@test)";
}

say join ', ', map { primorial_deflation_fast($_) } 1..20;      # A319626 / A319627

my $n = Math::AnyNum->new("14742217487368791965347653720647452690286549052234444179664342042930370966727413549068727214664401976854238590421417268673037399536054005777393104248210539172848500736334237168727231561710827753972114334247396552090671649834020135652920430241738510495400044737265204738821393451152066370913670083496651044937158497896720493198891148968218874744806522767468280764179516341996273430700779982929787918221844760577694188288275419541410142336911631623319041967633591283303769044016192030492715535641753600000");

say primorial_deflation($n);        #=> 52900585920
say primorial_deflation_fast($n);   #=> 52900585920


================================================
FILE: Math/pseudo_square_root.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 August 2017
# https://github.com/trizen

# Find the greatest divisor of `n` that does not exceed the square root of `n`.

# See also:
#   https://projecteuler.net/problem=266

use 5.010;
use strict;
use warnings;

use ntheory qw(factor_exp sqrtint vecmax);

sub pseudo_square_root {
    my ($n) = @_;

    my $limit = sqrtint($n);

    my @d  = (1);
    my @pp = grep { $_->[0] <= $limit } factor_exp($n);

    foreach my $pp (@pp) {

        my $p = $pp->[0];
        my $e = $pp->[1];

        my @t;
        my $r = 1;

        for my $i (1 .. $e) {
            $r *= $p;
            foreach my $u (@d) {
                push(@t, $u * $r) if ($u * $r <= $limit);
            }
        }

        push @d, @t;
    }

    return vecmax(@d);
}

say pseudo_square_root(479001600);     #=> 21600
say pseudo_square_root(6469693230);    #=> 79534
say pseudo_square_root(12398712476);   #=> 68


================================================
FILE: Math/pythagorean_triples.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 18 August 2016
# Website: https://github.com/trizen

# Generate Pythagorean triples whose sum goes up to a certain limit.

# See also: https://projecteuler.net/problem=75
#           https://en.wikipedia.org/wiki/Pythagorean_triple

use 5.010;
use strict;
use warnings;

use ntheory qw(gcd);

sub pythagorean_triples {
    my ($limit) = @_;

    my @triples;
    my $end = int(sqrt($limit));

    foreach my $n (1 .. $end - 1) {
        for (my $m = $n + 1 ; $m <= $end ; $m += 2) {

            my $x = ($m**2 - $n**2);
            my $y = (2 * $m * $n);
            my $z = ($m**2 + $n**2);

            last if $x + $y + $z > $limit;

            if (gcd($n, $m) == 1) {    # n and m coprime

                my $k = 1;

                while (1) {
                    my $x = $k * $x;
                    my $y = $k * $y;
                    my $z = $k * $z;

                    last if $x + $y + $z > $limit;

                    push @triples, [$x, $y, $z];
                    ++$k;
                }
            }
        }
    }

    map { $_->[1] } sort { $a->[0] <=> $b->[0] } map {
        [$_->[0] + $_->[1] + $_->[2], [sort { $a <=> $b } @{$_}]]
    } @triples;
}

my @triples = pythagorean_triples(50);

foreach my $triple (@triples) {
    say "P(@$triple) = ", $triple->[0] + $triple->[1] + $triple->[2];
}

__END__
P(3 4 5) = 12
P(6 8 10) = 24
P(5 12 13) = 30
P(9 12 15) = 36
P(8 15 17) = 40
P(12 16 20) = 48


================================================
FILE: Math/quadratic-integer_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 28 June 2020
# https://github.com/trizen

# A simple factorization method, using quadratic integers.
# Similar in flavor to Pollard's p-1 and Williams's p+1 methods.

# See also:
#   https://en.wikipedia.org/wiki/Quadratic_integer

use 5.020;
use warnings;

use ntheory qw(primes);
use experimental qw(signatures);
use Math::AnyNum qw(:overload gcd ilog isqrt);

sub quadratic_powmod ($a, $b, $w, $n, $m) {

    my ($x, $y) = (1, 0);

    do {
        ($x, $y) = (($a * $x + $b * $y * $w) % $m, ($a * $y + $b * $x) % $m) if ($n & 1);
        ($a, $b) = (($a * $a + $b * $b * $w) % $m, (2 * $a * $b) % $m);
    } while ($n >>= 1);

    ($x, $y);
}

sub quadratic_factorization ($n, $B, $a = 3, $b = 4, $w = 2) {

    foreach my $p (@{primes(isqrt($B))}) {
        ($a, $b) = quadratic_powmod($a, $b, $w, $p**ilog($B, $p), $n);
    }

    foreach my $p (@{primes(isqrt($B) + 1, $B)}) {

        ($a, $b) = quadratic_powmod($a, $b, $w, $p, $n);

        my $g = gcd($b, $n);

        if ($g > 1) {
            return 1 if ($g == $n);
            return $g;
        }
    }

    return 1;
}

say quadratic_factorization(2**64 + 1, 20, 9, 2, 4);                 #=> 274177           (p-1 is   20-smooth)
say quadratic_factorization(257221 * 470783,               1000);    #=> 470783           (p-1 is 1000-smooth)
say quadratic_factorization(1124075136413 * 3556516507813, 4000);    #=> 1124075136413    (p+1 is 4000-smooth)
say quadratic_factorization(7553377229 * 588103349,        800);     #=> 7553377229       (p+1 is  800-smooth)

say '';

say quadratic_factorization(333732865481 * 1632480277613, 3000);     #=> 333732865481     (p-1 is 3000-smooth)
say quadratic_factorization(15597344393 * 12388291753,    3000);     #=> 15597344393      (p-1 is 3000-smooth)
say quadratic_factorization(43759958467 * 59037829639,    3200);     #=> 43759958467      (p+1 is 3200-smooth)
say quadratic_factorization(112601635303 * 83979783007,   700);      #=> 112601635303     (p-1 is  700-smooth)
say quadratic_factorization(228640480273 * 224774973299,  2000);     #=> 228640480273     (p-1 is 2000-smooth)

say '';

say quadratic_factorization(5140059121 * 8382882743,     2500);            #=> 5140059121       (p-1 is 2500-smooth)
say quadratic_factorization(18114813019 * 17402508649,   6000);            #=> 18114813019      (p+1 is 6000-smooth)
say quadratic_factorization(533091092393 * 440050095029, 300, 1, 2, 3);    #=> 533091092393     (p+1 is  300-smooth)


================================================
FILE: Math/quadratic-integer_factorization_method_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 28 June 2020
# https://github.com/trizen

# A simple factorization method, using quadratic integers.
# Similar in flavor to Pollard's p-1 and Williams's p+1 methods.

# See also:
#   https://en.wikipedia.org/wiki/Quadratic_integer

use 5.020;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub quadratic_powmod ($a, $b, $w, $n, $m) {

    state $t = Math::GMPz::Rmpz_init_nobless();

    my $x = Math::GMPz::Rmpz_init_set_ui(1);
    my $y = Math::GMPz::Rmpz_init_set_ui(0);

    do {

        if ($n & 1) {
            # (x, y) = ((a*x + b*y*w) % m, (a*y + b*x) % m)
            Math::GMPz::Rmpz_mul_ui($t, $b, $w);
            Math::GMPz::Rmpz_mul($t, $t, $y);
            Math::GMPz::Rmpz_addmul($t, $a, $x);
            Math::GMPz::Rmpz_mul($y, $y, $a);
            Math::GMPz::Rmpz_addmul($y, $x, $b);
            Math::GMPz::Rmpz_mod($x, $t, $m);
            Math::GMPz::Rmpz_mod($y, $y, $m);
        }

        # (a, b) = ((a*a + b*b*w) % m, (2*a*b) % m)
        Math::GMPz::Rmpz_mul($t, $a, $b);
        Math::GMPz::Rmpz_mul_2exp($t, $t, 1);
        Math::GMPz::Rmpz_powm_ui($a, $a, 2, $m);
        Math::GMPz::Rmpz_powm_ui($b, $b, 2, $m);
        Math::GMPz::Rmpz_addmul_ui($a, $b, $w);
        Math::GMPz::Rmpz_mod($b, $t, $m);

    } while ($n >>= 1);

    Math::GMPz::Rmpz_set($a, $x);
    Math::GMPz::Rmpz_set($b, $y);
}

sub quadratic_factorization ($n, $B, $a = 3, $b = 4, $w = 2) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    $a = Math::GMPz::Rmpz_init_set_ui($a);
    $b = Math::GMPz::Rmpz_init_set_ui($b);

    my $g = Math::GMPz::Rmpz_init();

    my $lnB = log($B);

    foreach my $p (@{primes(sqrtint($B))}) {
        quadratic_powmod($a, $b, $w, $p**int($lnB / log($p)), $n);
    }

    foreach my $p (@{primes(sqrtint($B) + 1, $B)}) {

        quadratic_powmod($a, $b, $w, $p, $n);
        Math::GMPz::Rmpz_gcd($g, $b, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return 1 if (Math::GMPz::Rmpz_cmp($g, $n) == 0);
            return $g;
        }
    }

    return 1;
}

foreach my $n (
#<<<
    Math::GMPz->new("4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271"),
    Math::GMPz->new("2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151"),
    Math::GMPz->new("850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733"),
#>>>
  ) {

    say "\n:: Factoring: $n";

    until (is_prime($n)) {

        my ($a, $b, $w) = (int(rand(1e6)), int(rand(1e6)), int(rand(1e6)));

        #say "\n# Trying with parameters = ($a, $b, $w)";
        my $p = quadratic_factorization($n, 500_000, $a, $b, $w);

        if ($p > 1) {
            say "-> Found factor: $p";
            $n /= $p;
        }
    }
}

__END__
:: Factoring: 4687127904923490705199145598250386612169614860009202665502614423768156352727760127429892667212102542891417456048601608730032271
-> Found factor: 12993757635350024510533
-> Found factor: 31935028572177122017
-> Found factor: 441214532298715667413
-> Found factor: 515113549791151291993
-> Found factor: 896466791041143516471427

:: Factoring: 2593364104508085171532503084981517253915662037671433715309875378319680421662639847819831785007087909697206133969480076353307875655764139224094652151
-> Found factor: 2490501032020173490009
-> Found factor: 1927199759971282921
-> Found factor: 58637507352579687279739
-> Found factor: 765996534730183701229
-> Found factor: 4393290631695328772611
-> Found factor: 85625333993726265061

:: Factoring: 850794313761232105411847937800407457007819033797145693534409492587965757152430334305470463047097051354064302867874781454865376206137258603646386442018830837206634789761772899105582760694829533973614585552733
-> Found factor: 556010720288850785597
-> Found factor: 341190041753756943379
-> Found factor: 33311699120128903709
-> Found factor: 7672247345452118779313
-> Found factor: 182229202433843943841
-> Found factor: 5658991130760772523
-> Found factor: 386663601339343857313
-> Found factor: 55554864549706093104640631
-> Found factor: 775828538119834346827


================================================
FILE: Math/quadratic_frobenius_primality_test.pl
================================================
#!/usr/bin/perl

# A simple implemenetation of the Frobenius Quadratic pseudoprimality test.

# Conditions:
#   1. Make sure n is odd and is not a perfect power.
#   2. Find the smallest odd prime p such that kronecker(p, n) = -1.
#   3. Check if (1 + sqrt(p))^n == (1 - sqrt(p)) mod n.

# Generalized test:
#   1. Make sure n is odd and is not a perfect power.
#   2. Find the smallest squarefree number c such that kronecker(c, n) = -1.
#   3. Check if (a + b*sqrt(c))^n == (a - b*sqrt(c)) mod n, where a,b,c are all coprime with n.

# No counter-examples are known to this test.

# See also:
#   https://en.wikipedia.org/wiki/Quadratic_integer

use 5.020;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub quadratic_powmod ($x, $y, $a, $b, $w, $n, $m) {

    state $t = Math::GMPz::Rmpz_init_nobless();

    foreach my $bit (split(//, scalar reverse Math::GMPz::Rmpz_get_str($n, 2))) {

        if ($bit) {

            # (x, y) = ((a*x + b*y*w) % m, (a*y + b*x) % m)
            Math::GMPz::Rmpz_mul_ui($t, $b, $w);
            Math::GMPz::Rmpz_mul($t, $t, $y);
            Math::GMPz::Rmpz_addmul($t, $a, $x);
            Math::GMPz::Rmpz_mul($y, $y, $a);
            Math::GMPz::Rmpz_addmul($y, $x, $b);
            Math::GMPz::Rmpz_mod($x, $t, $m);
            Math::GMPz::Rmpz_mod($y, $y, $m);
        }

        # (a, b) = ((a*a + b*b*w) % m, (2*a*b) % m)
        Math::GMPz::Rmpz_mul($t, $a, $b);
        Math::GMPz::Rmpz_mul_2exp($t, $t, 1);
        Math::GMPz::Rmpz_powm_ui($a, $a, 2, $m);
        Math::GMPz::Rmpz_powm_ui($b, $b, 2, $m);
        Math::GMPz::Rmpz_addmul_ui($a, $b, $w);
        Math::GMPz::Rmpz_mod($b, $t, $m);
    }
}

sub find_discriminant ($n) {
    for (my $p = 3 ; ; $p = next_prime($p)) {

        my $k = Math::GMPz::Rmpz_ui_kronecker($p, $n);

        if ($k == 0 and $p != $n) {
            return undef;
        }
        elsif ($k == -1) {
            return $p;
        }
    }
}

sub is_quadratic_frobenius_pseudoprime ($n) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    return 0 if ($n <= 1);
    return 1 if ($n == 2);

    return 0 if Math::GMPz::Rmpz_even_p($n);
    return 0 if Math::GMPz::Rmpz_perfect_power_p($n);

    my $c = find_discriminant($n) // return 0;

    state $a = Math::GMPz::Rmpz_init();
    state $b = Math::GMPz::Rmpz_init();
    state $w = Math::GMPz::Rmpz_init();

    state $x = Math::GMPz::Rmpz_init();
    state $y = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_set_ui($a, 1);
    Math::GMPz::Rmpz_set_ui($b, 1);
    Math::GMPz::Rmpz_set_ui($w, $c);

    Math::GMPz::Rmpz_set_ui($x, 1);
    Math::GMPz::Rmpz_set_ui($y, 0);

    quadratic_powmod($x, $y, $a, $b, $w, $n, $n);

    Math::GMPz::Rmpz_congruent_p($x, $n - $n + 1, $n)
      && Math::GMPz::Rmpz_congruent_p($y, $n - 1, $n);
}

my $count = 0;
foreach my $n (1 .. 1e5) {
    if (is_quadratic_frobenius_pseudoprime($n)) {
        ++$count;
        if (!is_prime($n)) {
            die "Counter-example: $n";
        }
    }
    elsif (is_prime($n)) {
        die "Missed prime: $n";
    }
}

say "Count: $count";    #=> Count: 9592


================================================
FILE: Math/quadratic_frobenius_pseudoprimes_generation.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 19 November 2023
# https://github.com/trizen

# A new algorithm for generating (almost) Quadratic-Frobenius pseudoprimes.

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::AnyNum qw(prod);
use ntheory      qw(forcomb forprimes kronecker divisors);

sub quadratic_powmod ($a, $b, $w, $n, $m) {

    my ($x, $y) = (1, 0);

    do {
        ($x, $y) = (($a * $x + $b * $y * $w) % $m, ($a * $y + $b * $x) % $m) if ($n & 1);
        ($a, $b) = (($a * $a + $b * $b * $w) % $m, (2 * $a * $b) % $m);
    } while ($n >>= 1);

    ($x, $y);
}

sub quadratic_frobenius_pseudoprimes ($limit, $callback) {

    my %common_divisors;

    my $c = 5;

    forprimes {
        my $p = $_;
        foreach my $d (divisors($p - kronecker($c, $p))) {
            if ($d > 1 and (quadratic_powmod(1, 1, $c, $d, $p))[0] == 1) {
                push @{$common_divisors{$d}}, $p;
            }
        }
    } 3, $limit;

    my %seen;

    foreach my $arr (values %common_divisors) {

        my $l = $#{$arr} + 1;

        foreach my $k (2 .. $l) {
            forcomb {
                my $n = prod(@{$arr}[@_]);
                $callback->($n, @{$arr}[@_]) if !$seen{$n}++;
            } $l, $k;
        }
    }
}

my @pseudoprimes;

quadratic_frobenius_pseudoprimes(
    1e4,
    sub ($n, @f) {
        push @pseudoprimes, $n;
    }
);

@pseudoprimes = sort { $a <=> $b } @pseudoprimes;

say join(', ', @pseudoprimes);

__END__
1891, 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


================================================
FILE: Math/quadratic_polynomial_in_terms_of_its_zeros.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 August 2017
# https://github.com/trizen

# Representation of quadratic polynomials in terms of their zeros.

# Let:
#    P(x) = a*x^2 + b*x + c

# Let (m, n) be the solutions to P(x) = 0

# Then:
#   P(x) = c * (1 - x/m) * (1 - x/n)

use 5.010;
use strict;
use warnings;

use Math::Bacovia qw(:all);
use Math::AnyNum qw(isqrt);

sub integer_quadratic_formula {
    my ($x, $y, $z) = @_;
    (
        Fraction((-$y + isqrt($y**2 - 4 * $x * $z)), (2 * $x)),
        Fraction((-$y - isqrt($y**2 - 4 * $x * $z)), (2 * $x)),
    );
}

my @poly = (
    [  3, -15,   -42],
    [ 20, -97, -2119],
    [-43,  29, 14972],
);

my $x = Symbol('x');

foreach my $t (@poly) {
    my ($x1, $x2) = integer_quadratic_formula(@$t);

    my $expr = $t->[0] * $x**2 + $t->[1] * $x + $t->[2];

    my $f1 = (1 - $x / $x1);
    my $f2 = (1 - $x / $x2);

    printf("%s = %s * %s * %s\n",
        $expr->pretty,
        $f1->simple->pretty,
        $f2->simple->pretty,
        $t->[2],
    );
}

__END__

((3 * x^2) + (-15 * x) + -42) = (1 - (x/7)) * (1 - (x/-2)) * -42
((20 * x^2) + (-97 * x) + -2119) = (1 - (x/13)) * (1 - (x/(-326/40))) * -2119
((-43 * x^2) + (29 * x) + 14972) = (1 - (x/(-788/43))) * (1 - (x/19)) * 14972


================================================
FILE: Math/ramanujan_sum.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 26 July 2017
# https://github.com/trizen

# Ramanujan's sum:
#   c_k(n) = Sum_{m mod k; gcd(m, k) = 1} exp(2*pi*i*m*n/k)

# For n = 1, c_k(1) is equivalent to moebius(k).

# For integer real values of `n` and `k`, Ramanujan's sum is equivalent to:
#   c_k(n) = Sum_{m mod k; gcd(m, k) = 1} cos(2*pi*m*n/k)

# Alternatively, when n = k, `c_n(n)` is equivalent with `euler_phi(n)`.

# The record values, `c_n(n) + 1`, are the prime numbers.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload tau gcd round);

sub ramanujan_sum {
    my ($n, $k) = @_;

    my $sum = 0;
    foreach my $m (1 .. $k) {
        if (gcd($m, $k) == 1) {
            $sum += exp(tau * i * $m * $n / $k);
        }
    }

    round($sum, -20);
}

my $sum = 0;
my @partial_sums;
foreach my $n (1 .. 30) {
    my $r = ramanujan_sum($n, $n**2);
    say "R($n, $n^2) = $r";
    push @partial_sums, $sum += $r;
}

say "\n=> Partial sums:";
say join(' ', @partial_sums);

__END__
R(1, 1^2) = 1
R(2, 2^2) = -2
R(3, 3^2) = -3
R(4, 4^2) = 0
R(5, 5^2) = -5
R(6, 6^2) = 6
R(7, 7^2) = -7
R(8, 8^2) = 0
R(9, 9^2) = 0
R(10, 10^2) = 10
R(11, 11^2) = -11
R(12, 12^2) = 0
R(13, 13^2) = -13
R(14, 14^2) = 14
R(15, 15^2) = 15
R(16, 16^2) = 0
R(17, 17^2) = -17
R(18, 18^2) = 0
R(19, 19^2) = -19
R(20, 20^2) = 0
R(21, 21^2) = 21
R(22, 22^2) = 22
R(23, 23^2) = -23
R(24, 24^2) = 0
R(25, 25^2) = 0
R(26, 26^2) = 26
R(27, 27^2) = 0
R(28, 28^2) = 0
R(29, 29^2) = -29
R(30, 30^2) = -30

=> Partial sums:
1 -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


================================================
FILE: Math/ramanujan_sum_fast.pl
================================================
#!/usr/bin/perl

# Efficient implementation of Ramanujan's sum.

use 5.010;
use strict;
use warnings;

use ntheory qw(gcd euler_phi moebius);

sub ramanujan_sum {
    my ($n, $k) = @_;

    my $g = $k / gcd($n, $k);
    my $m = moebius($g);

    $m * euler_phi($k) / euler_phi($g);
}

foreach my $n (1 .. 30) {
    say ramanujan_sum($n, $n**2);
}


================================================
FILE: Math/random_carmichael_fibonacci_pseudoprimes.pl
================================================
#!/usr/bin/perl

# Generate random Carmichael numbers of the form:
#   `n = p * (2*p - 1) * (3*p - 2) * (6*p - 5)`.

# About half of this numbers are also Fibonacci pseudoprimes, satisfying:
#   `Fibonacci(n - kronecker(n, 5)) = 0 (mod n)`.

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(is_prob_prime random_nbit_prime);

my $bits = 50;    # bits of p

foreach my $n (1 .. 1e6) {
    my $p = Math::GMPz->new(random_nbit_prime($bits));

    if (is_prob_prime(2 * $p - 1) && is_prob_prime(3 * $p - 2) && is_prob_prime(6 * $p - 5)) {
        say $p * ($p * 2 - 1) * ($p * 3 - 2) * ($p * 6 - 5);
    }
}


================================================
FILE: Math/random_integer_factorization.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 19 May 2017
# https://github.com/trizen

# A very simple random integer factorization algorithm.

use 5.010;
use strict;
use warnings;

use ntheory qw(random_prime);

my $n = 1355533 * 3672541;
my $r = int(sqrt($n));

my $x = $r;
my $y = $r;

while (1) {
    my $p = $x * $y;

    last if $p == $n;

    $x = random_prime(2, $r);
    $y = int($n / $x);
}

say "$n = $x * $y";


================================================
FILE: Math/random_miller-rabin_pseudoprimes.pl
================================================
#!/usr/bin/perl

# Generate random probable Miller-Rabin pseudoprimes of the form:
#
#   `n = p * (2*p - 1)`
#
# where `2*p - 1` is also prime.

use 5.010;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);

my @bases = (2, 3, 5);    # Miller-Rabin pseudoprimes to these bases
my $bits  = 50;           # bits of p

foreach my $n (1 .. 1e6) {
    my $p = Math::GMPz->new(random_nbit_prime($bits));

    if (is_prob_prime(2 * $p - 1)) {
        my $n = $p * ($p * 2 - 1);

        if (is_strong_pseudoprime($n, @bases)) {
            say $n;
        }
    }
}


================================================
FILE: Math/range_map.pl
================================================
#!/usr/bin/perl

# Map a given value from a given range into another range.

use 5.010;
use strict;
use warnings;

sub range_map {
    my ($value, $in_min, $in_max, $out_min, $out_max) = @_;
    ($value - $in_min) * ($out_max - $out_min) / ($in_max - $in_min) + $out_min;
}

say range_map(5, 1, 10, 0, 4);    #=> 1.777... (maps the value 5 from range [1, 10] to range [0, 4])
say range_map(9, 1, 10, 1, 5);    #=> 4.555... (maps the value 9 from range [1, 10] to range [1, 5])


================================================
FILE: Math/rational_approximations.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 16 January 2019
# https://github.com/trizen

# Simple and efficient algorithm for finding the first continued-fraction convergents to a given real constant.

# Continued-fraction convergents for PI:
#   https://oeis.org/A002485
#   https://oeis.org/A002486

# See also:
#   https://en.wikipedia.org/wiki/Continued_fraction

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload float);

sub rational_approximations ($x, $callback, $first = 10) {

    $x = float($x) || return;

    my ($n1, $n2) = (0, 1);
    my ($d1, $d2) = (1, 0);

    my $f = $x;

    for (1 .. $first) {
        my $z = int($f);

        $n1 += $n2 * $z;
        $d1 += $d2 * $z;

        ($n1, $n2) = ($n2, $n1);
        ($d1, $d2) = ($d2, $d1);

        $callback->($n2 / $d2);

        $f -= $z;
        $f || last;
        $f = 1 / $f;
    }
}

my $x = atan2(0, -1);
my $f = sub ($q) { say "PI =~ $q" };

rational_approximations($x, $f, 20);

__END__
PI =~ 3
PI =~ 22/7
PI =~ 333/106
PI =~ 355/113
PI =~ 103993/33102
PI =~ 104348/33215
PI =~ 208341/66317
PI =~ 312689/99532
PI =~ 833719/265381
PI =~ 1146408/364913
PI =~ 4272943/1360120
PI =~ 5419351/1725033
PI =~ 80143857/25510582
PI =~ 165707065/52746197
PI =~ 245850922/78256779
PI =~ 411557987/131002976
PI =~ 1068966896/340262731
PI =~ 2549491779/811528438
PI =~ 6167950454/1963319607
PI =~ 14885392687/4738167652


================================================
FILE: Math/rational_continued_fractions.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 31 July 2016
# Website: https://github.com/trizen

# Recursive evaluation of continued fractions rationally,
# by computing the numerator and the denominator individually.

# For every continued fraction, we have the following relation:
#
#    n
#   | / a(k)    kn(n)
#   |/ ----- = -------
#   | \ b(k)    kd(n)
#   k=0

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);

no warnings qw(recursion);
use experimental qw(signatures);

memoize('kn');
memoize('kd');

sub a($n) {
    $n**2;
}

sub b($n) {
    2 * $n + 1;
}

sub kn($n) {
    $n < 2
      ? ($n == 0 ? 1 : 0)
      : b($n - 1) * kn($n - 1) + a($n - 1) * kn($n - 2);
}

sub kd($n) {
    $n < 2
      ? $n
      : b($n - 1) * kd($n - 1) + a($n - 1) * kd($n - 2);
}

for my $i (0 .. 10) {
    printf("%2d. %20d %20d\n", $i, kn($i), kd($i));
}


================================================
FILE: Math/rational_prime_product.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 June 2017
# https://github.com/trizen

# Prime product, related to the zeta function.

# ___
# | | (p^(2n) - 1) / (p^(2n) + 1) = {2/5, 6/7, 691/715, 7234/7293, 523833/524875, ...}
#  p

# Example:
#   Product_{n >= 1} (prime(n)^2 - 1)/(prime(n)^2 + 1) = 2/5

use 5.010;
use strict;
use warnings;

use ntheory qw(forprimes);

my $n = 2;

{
    my $prod = 1;
    forprimes {
        $prod *= ($_**$n + 1) / ($_**$n - 1);
    } 1e7;

    say $prod;
}

{
    my $prod = 1;
    forprimes {
        $prod *= ($_**$n + 1) / ($_**$n - 1);
    } 1e8;

    say $prod;
    say 1 / $prod;
}

__END__
2.49999997066443
2.49999999690776
0.400000000494758


================================================
FILE: Math/rational_summation_of_fractions.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 23 June 2016
# Website: https://github.com/trizen

# Rationalized summation of fractions, based on the identity:
#
#  a     c     ad + bc
# --- + --- = ----------
#  b     d       bd

# Combining this method with memoization, results in a practical
# generalized algorithm for summation of arbitrary fractions.

# In addition, with this method, any infinite sum can be converted into a limit.

# Example:                ∞
#            f(n)        ---  1
#  lim    ----------  =  \   ----  = e
#  n->∞      _n_         /    n!
#            | | k!      ---
#            k=0         n=0
#
# where:                     _n_
#   f(n+1) = (n+1)! * f(n) + | | k!
#                            k=0
#   f(0)   = 1
#
#====================================================
#
# Generally:
#
#   x
#  ---
#  \    a(n)       f(x)
#   -  ------  =  ------
#  /    b(n)       g(x)
#  ---
#  n=0
#
# where:
# | f(0) = a(0)
# | f(n) = b(n) * f(n-1) + a(n) * g(n-1)
#
# and:
# | g(0) = b(0)
# | g(n) = b(n) * g(n-1)

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);
use Math::AnyNum qw(:overload factorial);

memoize('b');
memoize('f');
memoize('g');

my $start = 0;     # start iteration from this value
my $iter  = 90;    # number of iterations

sub a {
    2**$_[0];
}

sub b {
    factorial($_[0]);
}

sub f {
    my ($n) = @_;
    $n <= $start
      ? a($n)
      : b($n) * f($n - 1) + a($n) * g($n - 1);
}

sub g {
    my ($n) = @_;
    $n <= $start
      ? b($n)
      : b($n) * g($n - 1);
}

my $x = f($iter) / g($iter);
say $x;
say "e^2 =~ ", $x->as_dec(64);


================================================
FILE: Math/reciprocal_cycle_length.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 May 2020
# https://github.com/trizen

# Algorithm for finding the length of the recurring cycle of 1/n in base b.

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub reciprocal_cycle_length ($n, $base = 10) {

    for (my $g = gcd($n, $base) ; $g > 1 ; $g = gcd($n, $base)) {
        $n /= $g;
    }

    ($n == 1) ? 0 : znorder($base, $n);
}

foreach my $n (1 .. 20) {
    my $r = reciprocal_cycle_length($n);
    say "1/$n has cycle length of $r";
}

__END__
1/1 has cycle length of 0
1/2 has cycle length of 0
1/3 has cycle length of 1
1/4 has cycle length of 0
1/5 has cycle length of 0
1/6 has cycle length of 1
1/7 has cycle length of 6
1/8 has cycle length of 0
1/9 has cycle length of 1
1/10 has cycle length of 0
1/11 has cycle length of 2
1/12 has cycle length of 1
1/13 has cycle length of 6
1/14 has cycle length of 6
1/15 has cycle length of 1
1/16 has cycle length of 0
1/17 has cycle length of 16
1/18 has cycle length of 1
1/19 has cycle length of 18
1/20 has cycle length of 0


================================================
FILE: Math/rectangle_sides_from_area_and_diagonal.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 January 2018
# https://github.com/trizen

# Formula for finding the length of the sides of a rectangle
# when only its area and the length of its diagonal are known.

# See also:
#   https://en.wikipedia.org/wiki/Fermat%27s_factorization_method

use 5.010;
use strict;
use warnings;

sub extract_rectangle_sides {
    my ($n, $h) = @_;

    my $s = (2 * $n + $h);

    my $x = sqrt($s - 4 * $n) / 2;
    my $y = sqrt($s) / 2;

    return ($y - $x, $x + $y);
}

my $p = 43;
my $q = 97;

my $n = $p * $q;          # rectangle area
my $h = $p**2 + $q**2;    # diagonal length, squared

say join(' ', extract_rectangle_sides($n, $h));


================================================
FILE: Math/rectangle_sides_from_diagonal_angles.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 January 2018
# https://github.com/trizen

# Formula for finding the smallest integer sides of a rectangle, given the internal angles of its diagonal.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:trig :overload);

sub diagonal_angles ($x, $y, $z) {
    (
        acos(($x**2 + $z**2 - $y**2) / (2 * $x * $z)),
        acos(($y**2 + $z**2 - $x**2) / (2 * $y * $z)),
    );
}

sub rectangle_side_from_angle ($theta) {
    sqrt((cos($theta)**2)->rat_approx->numerator);
}

my $x = 43;                         # side 1
my $y = 97;                         # side 2
my $z = sqrt($x**2 + $y**2);        # diagonal

my ($a1, $a2) = diagonal_angles($x, $y, $z);

say "The internal diagonal angles:";
say '  ', rad2deg($a1);     #=> 66.0923395058274991877532084833790002675999587054
say '  ', rad2deg($a2);     #=> 23.9076604941725008122467915166209997324000412946

say "\nThe smallest side lengths matching the internal angles:";
say rectangle_side_from_angle($a1);         #=> 43
say rectangle_side_from_angle($a2);         #=> 97


================================================
FILE: Math/rectangle_sides_from_one_diagonal_angle.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 January 2018
# https://github.com/trizen

# Formula for finding the smallest integer sides of a rectangle, given one internal angle of its diagonal.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:trig :overload);

sub rectangle_sides_from_angle ($theta) {
    tan($theta)->rat_approx->nude;
}

my $x = 43;    # side 1
my $y = 97;    # side 2

my $theta = atan2($x, $y);

say "A rectangle internal diagonal angle:";
say '  ', rad2deg($theta);    #=> 23.9076604941725008122467915166209997324000412946

say "\nThe smallest integer sides matching the internal angle:";
say join(' ', rectangle_sides_from_angle($theta));    #=> 43 97


================================================
FILE: Math/recursive_matrix_multiplication.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 April 2016
# Website: https://github.com/trizen

# Recursive matrix multiplication, using a divide and conquer algorithm.
# See also: https://en.wikipedia.org/wiki/Matrix_multiplication

# NOTE: works only with n*n matrices, where n must be a power of 2.

use 5.010;
use strict;
use warnings;

sub add {
    my ($A, $B) = @_;

    my $C = [[]];

    foreach my $i (0 .. $#{$A}) {
        foreach my $j (0 .. $#{$A->[$i]}) {
            $C->[$i][$j] += $A->[$i][$j] + $B->[$i][$j];
        }
    }

    $C;
}

sub msplit {
    my ($A, $B, $C, $D) = @_;

    my $end = $#{$A};
    my $mid = int($end / 2);

    my @A = @{$A}[0 .. $mid];
    my @B = @{$B}[0 .. $mid];

    my @C = @{$A}[$mid + 1 .. $end];
    my @D = @{$B}[$mid + 1 .. $end];

    my @E = @{$C}[0 .. $mid];
    my @F = @{$D}[0 .. $mid];

    my @G = @{$C}[$mid + 1 .. $end];
    my @H = @{$D}[$mid + 1 .. $end];

#<<<
    if ($end > 3) {
        return
            msplit(\@A, \@C, \@B, \@D),
            msplit(\@E, \@G, \@F, \@H);
    }
#>>>

#<<<
    [
        [@A, @B],
        [@C, @D],
        [@E, @F],
        [@G, @H],
    ]
#>>>
}

#
## Known issue: broken
#
sub merge_rows {
    my (@blocks) = @_;

    if (@{$blocks[0]} > 4) {

        my @merged;
        while (@{$blocks[0]}) {
            my @rows;
            foreach my $block (@blocks) {
                push @rows, [splice(@{$block}, 0, 4)];
            }
            push @merged, @{merge_rows(@rows)};
        }

        return \@merged;
    }

    my @A;

    foreach my $i (0 .. 3) {
        push @{$A[$i]}, @{$blocks[0][$i]}, @{$blocks[1][$i]};
        push @{$A[$i + 4]}, @{$blocks[2][$i]}, @{$blocks[3][$i]};
    }

    return \@A;
}

#
## Known issue: broken
#
sub merge {
    my (@blocks) = @_;

    while (@blocks > 4) {
        push @blocks, merge_rows(splice(@blocks, 0, 4));
    }

    return merge_rows(@blocks);
}

sub mul {
    my ($A, $B) = @_;

    ## Base case:
#<<<
    if ($#{$A} == 1 and $#{$A->[0]} == 1 and $#{$B} == 1 and $#{$B->[0]} == 1) {
        return [
            [
                $A->[0][0] * $B->[0][0] + $A->[0][1] * $B->[1][0],
                $A->[0][0] * $B->[0][1] + $A->[0][1] * $B->[1][1],
            ],
            [
                $A->[1][0] * $B->[0][0] + $A->[1][1] * $B->[1][0],
                $A->[1][0] * $B->[0][1] + $A->[1][1] * $B->[1][1],
            ],
        ];
    }
#>>>

    my $end = $#{$A};
    my $mid = int($end / 2);

    my @A = map { [@{$_}[0 .. $mid]] } @{$A}[0 .. $mid];
    my @B = map { [@{$_}[$mid + 1 .. $end]] } @{$A}[0 .. $mid];

    my @C = map { [@{$_}[0 .. $mid]] } @{$A}[$mid + 1 .. $end];
    my @D = map { [@{$_}[$mid + 1 .. $end]] } @{$A}[$mid + 1 .. $end];

    my @E = map { [@{$_}[0 .. $mid]] } @{$B}[0 .. $mid];
    my @F = map { [@{$_}[$mid + 1 .. $end]] } @{$B}[0 .. $mid];

    my @G = map { [@{$_}[0 .. $mid]] } @{$B}[$mid + 1 .. $end];
    my @H = map { [@{$_}[$mid + 1 .. $end]] } @{$B}[$mid + 1 .. $end];

#<<<
    [
        (
            [map{@{$_}} @{add(mul(\@A, \@E), mul(\@B, \@G))}],
            [map{@{$_}} @{add(mul(\@A, \@F), mul(\@B, \@H))}],
            [map{@{$_}} @{add(mul(\@C, \@E), mul(\@D, \@G))}],
            [map{@{$_}} @{add(mul(\@C, \@F), mul(\@D, \@H))}]
        ),
    ];
#>>>
}

sub mmult {
    our @a;
    local *a = shift;
    our @b;
    local *b = shift;
    my @p    = [];
    my $rows = @a;
    my $cols = @{$b[0]};
    my $n    = @b - 1;
    for (my $r = 0 ; $r < $rows ; ++$r) {

        for (my $c = 0 ; $c < $cols ; ++$c) {
            foreach (0 .. $n) {
                $p[$r][$c] += $a[$r][$_] * $b[$_][$c];
            }
        }
    }
    return [@p];
}

sub new_matrix {
    my ($n) = @_;
    [map { [$n * $_ - $n + 1 .. $_ * $n] } 1 .. $n];
}

sub display_matrix {
    my ($A, $w) = @_;
    say join(
        "\n",
        map {
            join(' ', map { sprintf("%${w}d", $_) } @{$_})
          } @{$A}
    );
}

#
## Demo:
#

my $A = [[3, 4], [5, 6]];

use Data::Dump qw(pp);
pp mul($A, $A);
pp mmult($A, $A);

my $B = new_matrix(4);

pp mmult($B, $B);
pp mul($B, $B);

my $C = new_matrix(8);
my $D = mmult($C, $C);

display_matrix($D, 6);

my $x = mul($C, $C);
pp msplit(@{$x});


================================================
FILE: Math/rest_calc.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 January 2013
# https://github.com/trizen

# Calculates how to give back some amount of money.

use 5.010;
use strict;
use warnings;

my @steps = (500, 200, 100, 50, 10, 5, 1, 0.5, 0.1, 0.05, 0.01);

my $rest = shift // 9999.99;

foreach my $i (@steps) {
    my $x = 0;
    while ($rest >= $i) {
        ++$x;
        $rest -= $i;
    }
    if ($x) {
        say "$x x $i";
        last if $rest == 0;
    }
}


================================================
FILE: Math/reversed_number_triangle.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 July 2015
# Website: https://github.com/trizen

# Generate a "reversed" number triangle.

my $rows = 6;
my @arr  = ([1]);

my $n = 1;
foreach my $i (1 .. $rows) {

    foreach my $j (reverse 0 .. $#arr) {
        push @{$arr[$j]}, ++$n;
        unshift @{$arr[$j]}, ++$n;
    }

    unshift @arr, [++$n];
}

foreach my $row (@arr) {
    print " " x (3 * $rows--);
    print map { sprintf "%3d", $_ } @{$row};
    print "\n";
}


================================================
FILE: Math/reversed_number_triangles.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 26 July 2015
# Website: https://github.com/trizen

# Generate a set of interesting numeric triangles.

use 5.010;
use strict;
use warnings;

sub triangle {
    my ($rows, $type) = @_;

    my @triangle = ([1]);

    my $n = 1;
    foreach my $i (1 .. $rows) {

        if ($type == 1) {
            foreach my $j (0 .. $#triangle) {
                push @{$triangle[$j]}, ++$n;
                unshift @{$triangle[$j]}, ++$n;
            }
        }
        elsif ($type == 2) {
            foreach my $j (reverse 0 .. $#triangle) {
                push @{$triangle[$j]}, ++$n;
                unshift @{$triangle[$j]}, ++$n;
            }
        }
        elsif ($type == 3) {
            foreach my $j (0 .. $#triangle) {
                unshift @{$triangle[$j]}, ++$n;
            }
            foreach my $j (reverse 0 .. $#triangle) {
                push @{$triangle[$j]}, ++$n;
            }
        }
        elsif ($type == 4) {
            foreach my $j (reverse 0 .. $#triangle) {
                unshift @{$triangle[$j]}, ++$n;
            }
            foreach my $j (0 .. $#triangle) {
                push @{$triangle[$j]}, ++$n;
            }
        }
        else {
            die "Invalid type: $type";
        }

        unshift @triangle, [++$n];
    }

    return \@triangle;
}

my $width = 4;
my $rows  = 8;

foreach my $i (1 .. 4) {
    my $triangle = triangle($rows, $i);

    foreach my $i (0 .. $#{$triangle}) {
        my $row = $triangle->[$i];
        print " " x ($width * ($rows - $i));
        print map { sprintf "%*d", $width, $_ } @{$row};
        print "\n";
    }
    print "-" x ($width * ($rows + 1) * 2 - $width), "\n";
}


================================================
FILE: Math/riemann_prime-counting_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 February 2019
# https://github.com/trizen

# Compute the Riemann prime-power counting function for 10^n.

# OEIS sequences:
#   https://oeis.org/A322713 -- numerator of the Riemann prime counting function for 10^n.
#   https://oeis.org/A322714 -- denominator of the Riemann prime counting function for 10^n.

# See also:
#   https://mathworld.wolfram.com/RiemannPrimeCountingFunction.html
#   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

# PARI program:
#   a(n) = sum(k=1, logint(n, 2), primepi(sqrtnint(n, k))/k);

use 5.020;
use strict;
use warnings;

use ntheory qw(prime_count);
use experimental qw(signatures);
use Math::AnyNum qw(:overload iroot ipow10 ilog2);

my %primepi_lookup = (    # https://oeis.org/A006880
                       ipow10(0)  => 0,
                       ipow10(1)  => 4,
                       ipow10(2)  => 25,
                       ipow10(3)  => 168,
                       ipow10(4)  => 1229,
                       ipow10(5)  => 9592,
                       ipow10(6)  => 78498,
                       ipow10(7)  => 664579,
                       ipow10(8)  => 5761455,
                       ipow10(9)  => 50847534,
                       ipow10(10) => 455052511,
                       ipow10(11) => 4118054813,
                       ipow10(12) => 37607912018,
                       ipow10(13) => 346065536839,
                       ipow10(14) => 3204941750802,
                       ipow10(15) => 29844570422669,
                       ipow10(16) => 279238341033925,
                       ipow10(17) => 2623557157654233,
                       ipow10(18) => 24739954287740860,
                       ipow10(19) => 234057667276344607,
                       ipow10(20) => 2220819602560918840,
                       ipow10(21) => 21127269486018731928,
                       ipow10(22) => 201467286689315906290,
                       ipow10(23) => 1925320391606803968923,
                       ipow10(24) => 18435599767349200867866,
                       ipow10(25) => 176846309399143769411680,
                       ipow10(26) => 1699246750872437141327603,
                       ipow10(27) => 16352460426841680446427399,
                     );

sub primepi ($n) {
    $primepi_lookup{$n} //= Math::AnyNum->new(prime_count($n));
}

sub riemann_prime_power_count ($n) {

    my $sum = Math::AnyNum->new(0);

    foreach my $k (1 .. ilog2($n)) {
        $sum += primepi(iroot($n, $k)) / $k;
    }

    return $sum;
}

foreach my $k (0 .. 27) {
    my $riemann_pi = riemann_prime_power_count(ipow10($k));
    printf("RiemannPI(10^%s) = %s / %s\n", $k, $riemann_pi->nude);
}

__END__
RiemannPI(10^0) = 0 / 1
RiemannPI(10^1) = 16 / 3
RiemannPI(10^2) = 428 / 15
RiemannPI(10^3) = 445273 / 2520
RiemannPI(10^4) = 56175529 / 45045
RiemannPI(10^5) = 991892879 / 102960
RiemannPI(10^6) = 18296822833013 / 232792560
RiemannPI(10^7) = 3559637526370229 / 5354228880
RiemannPI(10^8) = 6427431691337929 / 1115464350
RiemannPI(10^9) = 14804074778750628149 / 291136195350
RiemannPI(10^10) = 9387415960571046321167 / 20629078984800
RiemannPI(10^11) = 594663752918349842404169 / 144403552893600
RiemannPI(10^12) = 200936708396848319452718531 / 5342931457063200
RiemannPI(10^13) = 296345083061712053722716462103 / 856326196254765600
RiemannPI(10^14) = 30189234512048649753828116713823 / 9419588158802421600
RiemannPI(10^15) = 92489654985220588144991271054976597 / 3099044504245996706400
RiemannPI(10^16) = 1146617973013522976708984977425080657 / 4106233968125945635980
RiemannPI(10^17) = 43091758212832458215850119943990751261 / 16424935872503782543920
RiemannPI(10^18) = 29968472027360099705216121701124772705819 / 1211339020597153962614100
RiemannPI(10^19) = 34589828635127927869863999345206682161220613 / 147783360512852783438920200
RiemannPI(10^20) = 138189551154910199110253731685916742453919111 / 62224572847516961447966400
RiemannPI(10^21) = 88080566389377854878591135538815093294467340937 / 4169046380783636417013748800
RiemannPI(10^22) = 82713438240421499874570664161132532019632247186099473 / 410555180440430163438262940577600
RiemannPI(10^23) = 263483420261441147355705259456363418174163088008435757 / 136851726813476721146087646859200
RiemannPI(10^24) = 199312549377508874879173849072922864723503113431443720379 / 10811286418264660970540924101876800
RiemannPI(10^25) = 1428216268887073538506983112166274277395419122408122239510533 / 8076030954443701744994070304101969600
RiemannPI(10^26) = 13723169359285085091924336231689687414362369542759969479728573 / 8076030954443701744994070304101969600
RiemannPI(10^27) = 21331406381807452349995058664653365273837322008799142085480723 / 1304476869229563439754033134419374400


================================================
FILE: Math/riemann_s_J_function.pl
================================================
#!/usr/bin/perl

# Riemann's J function
# J(x) = Σ 1/k π(⌊x^(1/k)⌋)

use strict;
use warnings;

use ntheory qw(prime_count);

sub J {
    my ($x) = @_;

    my $sum = 0;

    my $k = 1;
    while (1) {
        my $pi = prime_count(int($x**(1 / $k)));
        last if $pi == 0;
        $sum += 1 / $k++ * $pi;
    }

    $sum;
}

foreach my $k (1 .. 99) {
    printf("J(%2d) = %s\n", $k, J($k));
}


================================================
FILE: Math/roots_on_the_rise.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 21 February 2018
# https://github.com/trizen

# Solutions to x for:
#    1/x = (k/x)^2 * (k + x^2) - k*x

# See also:
#   https://projecteuler.net/problem=479

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload);
#use Math::GComplex qw(:overload);

sub roots ($k) {

    # Formulas from Wolfram|Alpha
    # https://www.wolframalpha.com/input/?i=1%2Fx+%3D+(k%2Fx)%5E2+*+(k%2Bx%5E2)++-+k*x

#<<<
    my $x1 = (2*$k**6 + 27 * $k**5 - 9*$k**3 + 3 * sqrt(3) * sqrt(4 * $k**11 + 27 * $k**10 -
    18*$k**8 - $k**6 + 4 *$k**3))**(1/3)/(3 * 2**(1/3) * $k) - (2**(1/3) * (3 * $k - $k**4)
    )/(3 * (2* $k**6 + 27 * $k**5 - 9 * $k**3 + 3*sqrt(3) * sqrt(4*$k**11 + 27*$k**10 - 18 *
    $k**8 - $k**6 + 4 *$k**3))**(1/3) *$k) + $k/3;

    my $x2 = -((1 - i * sqrt(3)) * (2 * $k**6 + 27 *$k**5 - 9 * $k**3 + 3 * sqrt(3) * sqrt(4 *
    $k**11 + 27* $k**10 - 18* $k**8 - $k**6 + 4 * $k**3))**(1/3))/(6 * 2**(1/3) * $k) +
    ((1 + i * sqrt(3)) * (3 * $k - $k**4))/(3 * 2**(2/3) * (2 * $k**6 + 27 * $k**5 - 9 *
    $k**3 + 3 * sqrt(3) * sqrt(4 * $k**11 + 27 * $k**10 - 18 * $k**8 - $k**6 + 4 * $k**3)
    )**(1/3) * $k) + $k/3;

    my $x3 = -((1 + i * sqrt(3)) * (2*$k**6 + 27 * $k**5 - 9 * $k**3 + 3 * sqrt(3) * sqrt(4 *
    $k**11 + 27 * $k**10 - 18 * $k**8 - $k**6 + 4 * $k**3))**(1/3))/(6 * 2**(1/3) * $k) +
    ((1 - i * sqrt(3)) * (3 * $k - $k**4))/(3 * 2**(2/3) * (2 *$k**6 + 27 * $k**5 - 9 * $k**3 +
    3 * sqrt(3) * sqrt(4 *$k**11 + 27 * $k**10 - 18 *$k**8 - $k**6 + 4 * $k**3))**(1/3) * $k) + $k/3;
#>>>

    return ($x1, $x2, $x3);
}

sub S ($n) {
    my $sum = 0;

    foreach my $k (1 .. $n) {

        my ($x1, $x2, $x3) = roots($k);

        foreach my $p (1 .. $n) {
            my $t = ($x1 + $x2)**$p * ($x2 + $x3)**$p * ($x3 + $x1)**$p;
            say "$k -> $t";
            $sum += $t;
        }

        say '';
    }

    return $sum;
}

sub S_int ($n) {
    my $sum = 0;
    foreach my $k (1 .. $n - 1) {
        my $p = ($k + 1)**2 - 1;
        $sum += ($p * ((-1)**$n * $p**$n - 1)) / ($p + 1);
    }
    return $sum;
}

say S(4);
say S_int(4);


================================================
FILE: Math/secant_numbers.pl
================================================
#!/usr/bin/perl

# Algorithm for computing the secant numbers (also known as Euler numbers):
#
#   1, 1, 5, 61, 1385, 50521, 2702765, 199360981, 19391512145, 2404879675441, 370371188237525, ...
#

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

# See also:
#   https://oeis.org/A000364
#   https://en.wikipedia.org/wiki/Euler_number

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub secant_numbers {
    my ($n) = @_;

    my @S = (Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $k (1 .. $n) {
        Math::GMPz::Rmpz_mul_ui($S[$k] = Math::GMPz::Rmpz_init(), $S[$k - 1], $k);
    }

    foreach my $k (1 .. $n) {
        foreach my $j ($k + 1 .. $n) {
            Math::GMPz::Rmpz_addmul_ui($S[$j], $S[$j - 1], ($j - $k + 2) * ($j - $k));
        }
    }

    return @S;
}

say join(', ', secant_numbers(10));


================================================
FILE: Math/semiprime_equationization.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 July 2015
# Website: https://github.com/trizen

# Split a semiprime into a group of equations.

use 5.016;
use strict;
use integer;
use warnings;

sub semiprime_equationization {
    my ($semiprime, $xlen, $ylen) = @_;

    $xlen -= 1;
    $ylen -= 1;

    my @map;
    my $mem = '0';
    my @result;

    my %vars;
    foreach my $j (0 .. $ylen) {
        foreach my $i (0 .. $xlen) {
            my $expr = '(' . join(' + ', "(x[$i] * y[$j])", grep { $_ ne '0' } $mem) . ')';

            $vars{"xy$i$j"} = $expr;
            my $n = "xy$i$j";

            if ($i == $xlen) {
                push @{$map[$j]}, "($n % 10)", "int($n / 10)";
                $mem = '0';
            }
            else {
                push @{$map[$j]}, "($n % 10)";
                $mem = "int($n / 10)";
            }
        }

        my $n = $ylen - $j;
        if ($n > 0) {
            push @{$map[$j]}, ((0) x $n);
        }

        my $m = $ylen - $n;
        if ($m > 0) {
            unshift @{$map[$j]}, ((0) x $m);
        }
    }

    my @number = reverse split //, $semiprime;
    my @mrange = (0 .. $#map);

    my %seen;
    my $initializer = sub {
        my ($str) = @_;
        while ($str =~ /\b(xy\d+)/g) {
            if (not $seen{$1}++) {
                my $init = "$1 = $vars{$1}";
                __SUB__->($init);
                push @result, $init;
            }
        }
    };

    foreach my $i (0 .. $#number) {
        my $expr = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')';
        $initializer->($expr);

        push @result, "n$i = $expr";
        my $n = "n$i";

        if ($i == 0 or $i == $#number) {
            push @result, "$number[$i] = $n";
            $mem = '0';
        }
        else {
            push @result, "$number[$i] = ($n % 10)";
            $mem = "int($n / 10)";
        }
    }

    return @result;
}

# 71 * 43
#say for semiprime_equationization('3053', 2, 2);

# 251 * 197
say for semiprime_equationization('49447', 3, 3);

# 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061
#say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50);


================================================
FILE: Math/semiprime_equationization_uncached.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 09 July 2015
# Website: https://github.com/trizen

# Split a semiprime into a group of equations.

use 5.010;
use strict;
use integer;
use warnings;

sub semiprime_equationization {
    my ($semiprime, $xlen, $ylen) = @_;

    $xlen -= 1;
    $ylen -= 1;

    my @map;
    my $mem = '0';

    foreach my $j (0 .. $ylen) {
        foreach my $i (0 .. $xlen) {
            my $n = '(' . join(' + ', "(x[$i] * y[$j])", grep { $_ ne '0' } $mem) . ')';

            if ($i == $xlen) {
                push @{$map[$j]}, "($n % 10)", "int($n / 10)";
                $mem = '0';
            }
            else {
                push @{$map[$j]}, "($n % 10)";
                $mem = "int($n / 10)";
            }
        }

        my $n = $ylen - $j;
        if ($n > 0) {
            push @{$map[$j]}, ((0) x $n);
        }

        my $m = $ylen - $n;
        if ($m > 0) {
            unshift @{$map[$j]}, ((0) x $m);
        }
    }

    my @number = reverse split //, $semiprime;

    my @result;
    my @mrange = (0 .. $#map);

    foreach my $i (0 .. $#number) {
        my $n = '(' . join(' + ', grep { $_ ne '0' } (map { $map[$_][$i] } @mrange), $mem) . ')';

        if ($i == 0 or $i == $#number) {
            push @result, "$number[$i] = $n";
            $mem = '0';
        }
        else {
            push @result, "$number[$i] = ($n % 10)";
            $mem = "int($n / 10)";
        }
    }

    return @result;
}

# 71 * 43
#say for semiprime_equationization('3053', 2, 2);

# 251 * 197
say for semiprime_equationization('49447', 3, 3);

# 37975227936943673922808872755445627854565536638199 * 40094690950920881030683735292761468389214899724061
#say for semiprime_equationization('1522605027922533360535618378132637429718068114961380688657908494580122963258952897654000350692006139', 50, 50);


================================================
FILE: Math/sequence_analyzer.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 April 2016
# Edit: 15 May 2021
# https://github.com/trizen

# Analyze a sequence of numbers and generate a report with the results.

# The sequence file must contain one term per line.
# Alternatively, the terms can be specified as command-line arguments.

use 5.014;
use strict;
use warnings;

package Sequence::Report {

    use Text::ASCIITable;
    use ntheory qw(LogarithmicIntegral);

    sub new {
        my ($class, %opt) = @_;
        bless \%opt, $class;
    }

    sub display {
        my ($self) = @_;

        my $percent = sub {
            sprintf('%.4g%%', $_[0] / $self->{count} * 100);
        };

        my $avg = sub {
            sprintf('%.2f', $_[0] / $self->{count});
        };

        my $t = Text::ASCIITable->new();
        my @columns = ('Label', 'Absolute' . ' ' x 30, 'Percentage' . ' ' x 10);
        $t->setCols(@columns);

        foreach my $row (
            ['Terms count', $self->{count}],

            (
               $self->{odds} || $self->{evens}
             ? !$self->{odds} || ($self->{odds} && $self->{evens} && $self->{evens} >= $self->{odds})
                   ? ['Evens', $self->{evens}, $percent->($self->{evens})]
                   : $self->{odds} ? ['Odds', $self->{odds}, $percent->($self->{odds})]
                 : ()
             : ()
            ),

              ($self->{pos} ? ["Positives", $self->{pos}, $percent->($self->{pos})] : ()),
              ($self->{neg}    ? ["Negatives", $self->{neg},    $percent->($self->{neg})]    : ()),
              ($self->{zeros}  ? ["Zeros",     $self->{zeros},  $percent->($self->{zeros})]  : ()),
              ($self->{primes} ? ['Primes',    $self->{primes}, $percent->($self->{primes})] : ()),

              (
                $self->{perfect_powers}
                ? ['Perfect powers', $self->{perfect_powers}, $percent->($self->{perfect_powers})]
                : ()
              ),

              (
                $self->{perfect_squares}
                ? ['Perfect squares', $self->{perfect_squares}, $percent->($self->{perfect_squares})]
                : ()
              ),

              (
                $self->{duplicates}
                ? ['Duplicated terms', $self->{duplicates}, $percent->($self->{duplicates})]
                : ()
              ),

              (
                $self->{increasing_consecutive}
                ? ['Cons. increasing terms',
                   $self->{increasing_consecutive} + 1,
                   $percent->($self->{increasing_consecutive} + 1)
                  ]
                : ()
              ),

              (
                $self->{decreasing_consecutive}
                ? ['Consecutive decreasing terms',
                   $self->{decreasing_consecutive} + 1,
                   $percent->($self->{decreasing_consecutive} + 1)
                  ]
                : ()
              ),

              (
                $self->{equal_consecutive}
                ? ['Consecutive equal terms', $self->{equal_consecutive} + 1, $percent->($self->{equal_consecutive} + 1)]
                : ()
              ),

              ['Minimum value', $self->{min}], ['Maximum value', $self->{max}],

              (
                  (ref($self->{divisors_avg}) && $self->{divisors_avg}->is_nan) || !$self->{divisors_avg}
                ? ()
                : ['Avg. number of divisors', sprintf('%.2f', $self->{divisors_avg})]
              ),

              (
                  (ref($self->{factors_avg}) && $self->{factors_avg}->is_nan) || !$self->{factors_avg}
                ? ()
                : ['Avg. number of prime factors', sprintf('%.2f', $self->{factors_avg})]
              ),

              (
                $self->{divisor_sum_avg}
                ? ['Divisor sum average', $self->{divisor_sum_avg}]
                : ()
              ),

              (
                ref($self->{arithmetic_mean}) && !$self->{arithmetic_mean}->is_real
                ? ()
                : ['Arithmetic mean', $self->{arithmetic_mean}]
              ),

              (
                ref($self->{geometric_mean}) && !$self->{geometric_mean}->is_real
                ? ()
                : ['Geometric mean', $self->{geometric_mean}]
              ),

              (
                ref($self->{harmonic_mean}) && !$self->{harmonic_mean}->is_real
                ? ()
                : ['Harmonic mean', $self->{harmonic_mean}]
              ),

              (
                ref($self->{lowest_ratio}) && !$self->{lowest_ratio}->is_real
                ? ()
                : ['Lowest consecutive ratio', $self->{lowest_ratio}]
              ),

              (
                ref($self->{highest_ratio}) && !$self->{highest_ratio}->is_real
                ? ()
                : ['Highest consecutive ratio', $self->{highest_ratio}]
              ),

              (
                  exists($self->{ratios_sum})
                ? ref($self->{ratios_sum}) && !$self->{ratios_sum}->is_real
                      ? ()
                      : ['Avg. consecutive ratio', $self->{ratios_sum} / ($self->{count} - 1)]
                : ()
              ),

              (
                ref($self->{lowest_diff}) && !$self->{lowest_diff}->is_real
                ? ()
                : ['Lowest consecutive difference', $self->{lowest_diff}]
              ),

              (
                ref($self->{highest_diff}) && !$self->{highest_diff}->is_real
                ? ()
                : ['Highest consecutive difference', $self->{highest_diff}]
              ),

              (
                  exists($self->{avg_diff})
                ? ref($self->{avg_diff}) && !$self->{avg_diff}->is_real
                      ? ()
                      : ['Avg. consecutive difference', $self->{avg_diff}]
                : ()
              ),
          ) {
            my ($label, $value, $extra) = @$row;
            $t->addRow($label, sprintf("%.15g", $value), defined($extra) ? $extra : ());
        }

        $t->alignCol({$columns[1] => 'right'});
        $t->alignCol({$columns[2] => 'right'});

        print $t;

        say "\n=> Summary:";

        # Number of primes
        if ($self->{primes}) {
            my $li_dist = LogarithmicIntegral($self->{count});
            my $log_dist = $self->{count} > 1 ? ($self->{count} / log($self->{count})) : 0;

            if ($self->{primes} == $self->{count}) {
                say "\tall terms are prime numbers";
            }
            elsif ($self->{primes} >= $li_dist) {
                if ($self->{primes} / $self->{count} * 100 > 80) {
                    say "\tcontains many primes (>80%)";
                }
                else {
                    printf("\tcontains about %.2f times more than a random number of primes\n", $self->{primes} / $li_dist);
                }
            }
            elsif ($self->{primes} < $li_dist and $self->{primes} > $log_dist) {
                printf("\tcontains a random number of primes (between %d and %d)\n", int($log_dist), int($li_dist));
            }
            else {
                printf("\tcontains about %.2f times less than a random number of primes\n", $li_dist / $self->{primes});
            }
        }
        elsif (($self->{evens} or $self->{odds}) and not $self->{neg}) {
            say "\tcontains no primes";
        }

        # Odd or even terms
        if ($self->{evens} and $self->{evens} == $self->{count}) {
            say "\tall terms are even";
        }
        elsif ($self->{odds} and $self->{odds} == $self->{count}) {
            say "\tall terms are odd";
        }
        elsif ($self->{evens} && $self->{odds} and $self->{evens} == $self->{odds}) {
            say "\tequal number of odds and evens";
        }

        # Increasing sequence
        if ($self->{increasing_consecutive} and $self->{increasing_consecutive} == $self->{count} - 1) {
            say "\tall terms are in a strictly increasing order";
        }

        # Decreasing sequence
        if ($self->{decreasing_consecutive} and $self->{decreasing_consecutive} == $self->{count} - 1) {
            say "\tall terms are in a strictly decreasing order";
        }

        # Geometric sequence
        if (    ref($self->{lowest_ratio}) && $self->{lowest_ratio}->is_real
            and ref($self->{highest_ratio}) && $self->{highest_ratio}->is_real
            and $self->{lowest_ratio} == $self->{highest_ratio}) {
            say "\tgeometric sequence (ratio = $self->{lowest_ratio})";

            if ($self->{increasing_consecutive} && $self->{increasing_consecutive} == $self->{count} - 1) {
                say "\tpossible closed-form: " . (
                    $self->{lowest_ratio} == 1 ? 'n' : (
                       $self->{min} == 1
                       ? "$self->{lowest_ratio}^(n-1)"
                       : (
                          $self->{min} == $self->{lowest_ratio} ? "$self->{lowest_ratio}^n" : (
                             "$self->{lowest_ratio}^(n" . do {
                                 my $log = $self->{min}->log($self->{lowest_ratio})->sub(1)->round(-30);
                                 $log->is_zero ? ''
                                   : (
                                      $log->is_int
                                        || length($log->as_rat) < 20
                                        || length($self->{min}->as_rat) > 20 ? (' ' . $log->sgn . ' ' . $log->abs)
                                      : (" + log($self->{min})/log($self->{lowest_ratio}) - 1")
                                     );
                               }
                               . ')'
                          )
                         )
                    )
                );

                if ($self->{min} > $self->{lowest_ratio}) {
                    my $factor = $self->{min} / $self->{lowest_ratio};
                    say(
                        "\tpossible closed-form: "
                          . (
                             ($factor == 1 ? '' : "$factor * ")
                             . (
                                $self->{lowest_ratio} == 1
                                ? 'n'
                                : "$self->{lowest_ratio}^n"
                               )
                            )
                       );
                }
            }
        }

        # Arithmetic sequence
        if (    ref($self->{lowest_diff}) && $self->{lowest_diff}->is_real
            and ref($self->{highest_diff}) && $self->{highest_diff}->is_real
            and $self->{lowest_diff} == $self->{highest_diff}) {
            say "\tarithmetic sequence (diff = $self->{lowest_diff})";

            if ($self->{increasing_consecutive} && $self->{increasing_consecutive} == $self->{count} - 1) {
                my $min = ($self->{min} - $self->{lowest_diff})->round(-20);
                say "\tpossible closed-form: "
                  . (
                     $self->{lowest_diff} == 0 ? $min
                     : (
                        ($self->{lowest_diff} == 1 ? 'n' : "$self->{lowest_diff}n")
                        . (
                           $min == 0 ? ''
                           : (' ' . $min->sgn . ' ' . $min->abs)
                          )
                       )
                    );
            }
        }

        # Perfect power sequence
        if ($self->{perfect_squares} && $self->{perfect_squares} == $self->{count}) {
            say "\tsequence of perfect squares";
        }
        elsif (
               $self->{perfect_powers}
               and (
                    $self->{perfect_powers} == $self->{count}
                    or (    $self->{perfect_squares}
                        and $self->{perfect_powers} + $self->{perfect_squares} == $self->{count})
                   )
          ) {
            say "\tsequence of perfect powers";
        }

        $self;
    }
}

package Sequence {

    use Math::AnyNum qw(Inf);
    use ntheory qw(factor divisors divisor_sum);
    use List::Util qw(all pairmap);

    sub new {
        my ($class, %opt) = @_;
        bless \%opt, $class;
    }

    sub analyze {
        my ($self) = @_;

        my $seq = $self->{sequence};

        my %data = (
                    geometric_mean => 1,
                    lowest_ratio   => Inf,
                    highest_ratio  => -Inf,
                    lowest_diff    => Inf,
                    highest_diff   => -Inf,
                    count          => scalar(@$seq),
                   );

        $data{count} > 0
          or die "ERROR: empty sequence of numbers!\n";

        my $min = Inf;
        my $max = -Inf;

        my $prev;

        my %seen;
        my $i = 0;

        foreach my $n (@$seq) {

            if ($seen{$n}++) {
                ++$data{duplicates};
            }

            my $cmp = $n <=> 0;

            if ($cmp == 0) {
                ++$data{zeros};
            }
            elsif ($cmp > 0) {
                ++$data{pos};
            }
            else {
                ++$data{neg};
            }

            $data{arithmetic_mean} += $n / $data{count};
            $data{geometric_mean} *= $n->root($data{count});
            $data{harmonic_mean} += $n->inv;

            if ($self->{is_int}) {

                if ($self->{is_pos}) {
                    if ($n->is_prime) {
                        ++$data{primes};
                        $data{factors_avg}     += 1 / $data{count};
                        $data{divisors_avg}    += 2 / $data{count};
                        $data{divisor_sum_avg} += ($n + 1) / $data{count};
                    }
                    else {
                        $data{factors_avg}     += factor($n) / $data{count};
                        $data{divisors_avg}    += divisors($n) / $data{count};
                        $data{divisor_sum_avg} += divisor_sum($n) / $data{count};
                    }
                }

                if ($n->is_square) {
                    ++$data{perfect_squares};
                }
                elsif ($n->is_power) {
                    ++$data{perfect_powers};
                }

                if ($n->is_even) {
                    ++$data{evens};
                }
                else {
                    ++$data{odds};
                }
            }

            if ($n < $min) {
                $min = $n;
            }

            if ($n > $max) {
                $max = $n;
            }

            if (defined($prev)) {

                {
                    my $diff = $n - $prev;
                    $data{avg_diff} += $diff / ($data{count} - 1);

                    if ($diff < $data{lowest_diff}) {
                        $data{lowest_diff} = $diff;
                    }

                    if ($diff > $data{highest_diff}) {
                        $data{highest_diff} = $diff;
                    }
                }

                {
                    my $div = $n / $prev;

                    $data{ratios_sum} += $div;

                    if ($div < $data{lowest_ratio}) {
                        $data{lowest_ratio} = $div;
                    }

                    if ($div > $data{highest_ratio}) {
                        $data{highest_ratio} = $div;
                    }
                }

                if (defined(my $cmp = $n <=> $prev)) {
                    if ($cmp > 0) {
                        ++$data{increasing_consecutive};
                    }
                    elsif ($cmp < 0) {
                        ++$data{decreasing_consecutive};
                    }
                    else {
                        ++$data{equal_consecutive};
                    }
                }
            }

            $prev = $n;

            if (++$i > 500) {
                while (my ($key, $value) = each %data) {
                    if (ref($value) eq 'Math::AnyNum') {
                        $data{$key} = $value->float;
                    }
                }
                $i = 0;
            }
        }

        $data{harmonic_mean} = $data{count} / $data{harmonic_mean};

        while (my ($key, $value) = each %data) {
            if (ref($value) eq 'Math::AnyNum') {
                $data{$key} = $value->round(-30);
            }
        }

        $data{min} = $min;
        $data{max} = $max;

        $data{equal} = $min == $max;

        Sequence::Report->new(%data);
    }
}

use Getopt::Long qw(GetOptions);

sub usage {
    print <<"EOT";
usage: $0 [options] [< sequence.txt]

options:
    -m  --map=type,type : map the sequence
    -r  --reverse!      : reverse the sequence
    -s  --sort!         : sort the sequence
    -u  --uniq!         : remove duplicated terms
    -p  --prec=i        : number of decimals of precision
    -f  --first=i       : read only the first i terms
    -o  --output=s      : output the sequence into this file

valid map types:
    sum     : consecutive sums
    ratio   : consecutive ratios
    prod    : consecutive products
    diff    : consecutive differences

    abs     : take the absolute value
    int     : take the integer part
    floor   : take the floor value
    ceil    : take the ceil value
    log     : natural logarithm of each term
    log=x   : base x logarithm of each term
    div=x   : divide each term by x
    mul=x   : multiply each term by x
    add=x   : add x to each term
    sub=x   : subtract x from each term
    exp     : exponential of each term (e^k)
    cos     : cos() of each term
    sin     : sin() of each term
    inv     : inverse value (1/k)
    sqr     : square each term (k^2)
    sqrt    : take the square root of each term (k^(1/2))
    pow     : rise each term to the nth power (k^n)
    pow=x   : rise each term to the i power (k^x)
    root    : take the nth root of each term (k^(1/n))
    root=x  : take the k root of each term (k^(1/x))

    padd    : consecutive pair sum
    pdiv    : consecutive pair ratio
    pmul    : consecutive pair product
    psub    : consecutive pair difference

example:
    $0 -u -m root=5,floor,sum < FibonacciSeq.txt
EOT
    exit;
}

my $map     = '';
my $reverse = 0;
my $sort    = 0;
my $uniq    = 0;
my $prec    = 32;
my $first   = undef;
my $output  = undef;

GetOptions(
           'm|map=s'    => \$map,
           'r|reverse!' => \$reverse,
           's|sort!'    => \$sort,
           'u|uniq!'    => \$uniq,
           'p|prec=i'   => \$prec,
           'f|first=i'  => \$first,
           'o|output=s' => \$output,
           'h|help'     => \&usage,
          )
  or die "Error in command-line arguments";

local $Math::AnyNum::PREC = 4 * $prec;

my @numbers;

my $value_re = qr/(?:=([-+]?\d+(?:\.\d+)?+)\b)?/;
my $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;

my @terms;

if (@ARGV) {
    @terms = (map { Math::AnyNum->new($_) } grep { /[0-9]/ } map { split(' ') } map { split(/\s*,\s*/) } @ARGV)
}
else {
    while (<>) {

        my $num = (split(' '))[-1];

        if ($num =~ /[0-9]/) {
            push @terms, Math::AnyNum->new($num);
        }
    }
}

foreach my $num (@terms) {

    push @numbers, $num;

    while ($map =~ /$trans_re/go) {
        if ($1 eq 'log') {
            $numbers[-1] = (defined($2)
              ? $numbers[-1]->log($2)
              : $numbers[-1]->log);
        }
        elsif ($1 eq 'sqrt') {
            $numbers[-1] = $numbers[-1]->sqrt;
        }
        elsif ($1 eq 'root') {
            $numbers[-1] = (defined($2)
              ? $numbers[-1]->root($2)
              : $numbers[-1]->root($.));
        }
        elsif ($1 eq 'pow') {
            $numbers[-1] = (defined($2)
              ? $numbers[-1]->pow($2)
              : $numbers[-1]->pow($.));
        }
        elsif ($1 eq 'sqr') {
            $numbers[-1] = $numbers[-1]->sqr;
        }
        elsif ($1 eq 'inv') {
            $numbers[-1] = $numbers[-1]->inv;
        }
        elsif ($1 eq 'abs') {
            $numbers[-1] = $numbers[-1]->abs;
        }
        elsif ($1 eq 'int') {
            $numbers[-1] = $numbers[-1]->int;
        }
        elsif ($1 eq 'cos') {
            $numbers[-1] = $numbers[-1]->cos;
        }
        elsif ($1 eq 'sin') {
            $numbers[-1] = $numbers[-1]->sin;
        }
        elsif ($1 eq 'ceil') {
            $numbers[-1] = $numbers[-1]->ceil;
        }
        elsif ($1 eq 'floor') {
            $numbers[-1] = $numbers[-1]->floor;
        }
        elsif ($1 eq 'exp') {
            $numbers[-1]->bexp;
        }
        elsif ($1 eq 'add') {
            $numbers[-1] = (defined($2)
              ? $numbers[-1]->add($2)
              : $numbers[-1]->add($.));
        }
        elsif ($1 eq 'sub') {
            $numbers[-1] = (defined($2)
              ? $numbers[-1]->sub($2)
              : $numbers[-1]->sub($.));
        }
        elsif ($1 eq 'mul') {
            $numbers[-1] = (defined($2)
              ? $numbers[-1]->mul($2)
              : $numbers[-1]->mul($.));
        }
        elsif ($1 eq 'div') {
            $numbers[-1] = (defined($2)
              ? $numbers[-1]->div($2)
              : $numbers[-1]->div($.));
        }
        else {
            die "ERROR: unknown map type: `$1`";
        }
    }

    if (defined($first) and $. >= $first) {
        last;
    }
}

if ($uniq) {
    my %seen;
    @numbers = grep { !$seen{$_->as_rat}++ } @numbers;
}

if ($sort) {
    @numbers = sort { $a <=> $b } @numbers;
}

if ($reverse) {
    @numbers = reverse(@numbers);
}

my $consecutive_re = qr/\b(ratio|diff|sum|prod)\b/;

if ($map =~ /$consecutive_re/o) {

    my @new;
    my $prev = shift @numbers;

    foreach my $num (@numbers) {
        while ($map =~ /$consecutive_re/go) {
            if ($1 eq 'ratio') {
                $prev /= $num;
            }
            elsif ($1 eq 'prod') {
                $prev *= $num;
            }
            elsif ($1 eq 'diff') {
                $prev -= $num;
            }
            elsif ($1 eq 'sum') {
                $prev += $num;
            }
            else {
                die "ERROR: unknown map type: `$1`";
            }
        }
        push @new, $prev;
    }

    @numbers = @new;
}

my $pair_re = qr/\b(pdiv|psub|padd|pmul)\b/;

if ($map =~ /$pair_re/o) {

    my @new;
    my $prev;

    foreach my $num (reverse(@numbers)) {
        if (defined($prev)) {
            while ($map =~ /$pair_re/go) {
                if ($1 eq 'pdiv') {
                    $prev /= $num;
                }
                elsif ($1 eq 'pmul') {
                    $prev *= $num;
                }
                elsif ($1 eq 'psub') {
                    $prev -= $num;
                }
                elsif ($1 eq 'padd') {
                    $prev += $num;
                }
                else {
                    die "ERROR: unknown map type: `$1`";
                }
            }
            unshift @new, $prev;
        }
        $prev = $num;
    }

    if ($uniq) {
        my %seen;
        @new = grep { !$seen{$_->as_rat}++ } @new;
    }

    if ($sort) {
        @new = sort { $a <=> $b } @new;
    }

    @numbers = @new;
}

use List::Util qw(all any min);

# Display the first 10 terms of the sequence
say "=> First 10 terms:";
say for @numbers[0 .. min(9, $#numbers)];
say '';

# Output the sequence into a file
if (defined($output)) {
    open my $fh, '>', $output;
    local $, = "\n";
    say {$fh} @numbers;
}

# Generate a report for the sequence
my $report = Sequence->new(
                           sequence => \@numbers,
                           is_int   => (all { $_->is_int } @numbers),
                           is_pos   => !(any { $_->is_neg } @numbers),
                          )->analyze;

# Display the report
$report->display;

__END__

First 10 terms:
6
18
54
162
486
1458
4374
13122
39366
118098

.------------------------------------------------------------------------------------------------.
| Label                          | Absolute                               | Percentage           |
+--------------------------------+----------------------------------------+----------------------+
| Terms count                    |                                    100 |                      |
| Evens                          |                                    100 |                 100% |
| Positives                      |                                    100 |                 100% |
| Cons. increasing terms         |                                    100 |                 100% |
| Minimum value                  |                                      6 |                      |
| Maximum value                  |                   1.03075504146402e+48 |                      |
| Avg. number of prime factors   |                                   51.5 |                      |
| Divisor sum average            |                   3.47879826494108e+46 |                      |
| Arithmetic mean                |                   1.54613256219603e+46 |                      |
| Geometric mean                 |                   2.48687157866749e+24 |                      |
| Harmonic mean                  |                                    400 |                      |
| Lowest consecutive ratio       |                                      3 |                      |
| Highest consecutive ratio      |                                      3 |                      |
| Avg. consecutive ratio         |                                      3 |                      |
| Lowest consecutive difference  |                                     12 |                      |
| Highest consecutive difference |                   6.87170027642682e+47 |                      |
| Avg. consecutive difference    |                   1.04116670854952e+46 |                      |
'--------------------------------+----------------------------------------+----------------------'

=> Summary:
    contains no primes
    all terms are even
    all terms are in a strictly increasing order
    geometric sequence (ratio = 3)
    possible closed-form: 3^(n + log(6)/log(3) - 1)
    possible closed-form: 2 * 3^n


================================================
FILE: Math/sequence_closed_form.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 April 2016
# Edit: 15 May 2021
# https://github.com/trizen

# Analyze a sequence of numbers and find a closed-form expression.

# Unfinished work...
# Use the script "sequence_analyzer.pl" instead.

use 5.010;
use strict;
use warnings;

package Sequence::ClosedForm {

    use Math::AnyNum qw(Inf);

    sub new {
        my ($class, %opt) = @_;
        bless \%opt, $class;
    }

    sub sub_n {
        my $n = 0;
        sub {
            $_[0] - ++$n;
        };
    }

    sub add_n {
        my $n = 0;
        sub {
            $_[0] + ++$n;
        };
    }

    sub mul_n {
        my $n = 1;
        sub {
            $_[0] * ++$n;
        };
    }

    sub div_n {
        my $n = 1;
        sub {
            $_[0] / ++$n;
        };
    }

    sub sub_constant {
        my (undef, $c) = @_;
        sub {
            $_[0] - $c;
        };
    }

    sub div_constant {
        my (undef, $c) = @_;
        sub {
            $_[0] / $c;
        };
    }

    sub add_constant {
        my (undef, $c) = @_;
        sub {
            $_[0] + $c;
        };
    }

    sub add_all {
        my $sum = 0;
        sub {
            $sum += $_[0];
            $sum;
        };
    }

    sub mul_all {
        my $prod = 1;
        sub {
            $prod *= $_[0];
            $prod;
        };
    }

    sub sub_consecutive {
        my $prev;
        sub {
            my ($term) = @_;
            if (defined($prev)) {
                $term = $term - $prev;
            }
            $prev = $_[0];
            $term;
        };
    }

    sub add_consecutive {
        my $prev;
        sub {
            my ($term) = @_;
            if (defined($prev)) {
                $term = $term + $prev;
            }
            $prev = $_[0];
            $term;
        };
    }

    sub div_consecutive {
        my $prev;
        sub {
            my ($term) = @_;
            if (defined($prev)) {
                $term = $term / $prev;
            }
            $prev = $_[0];
            $term;
        };
    }

    sub find_closed_form {
        my ($self, $seq) = @_;

        my %data = (
            diff_min => Inf,
            diff_max => -Inf,
            diff_avg => 0,

            ratio_min => Inf,
            ratio_max => -Inf,
            ratio_avg => 0,

            min => Inf,
            max => -Inf,
                   );

        my $count = @$seq - 1;
        return if $count <= 0;

        my $prev;
        foreach my $term (@{$seq}) {

            if ($term < $data{min}) {
                $data{min} = $term;
            }

            if ($term > $data{max}) {
                $data{max} = $term;
            }

            if (defined $prev) {
                my $diff = $term - $prev;

                if ($diff < $data{diff_min}) {
                    $data{diff_min} = $diff;
                }

                if ($diff > $data{diff_max}) {
                    $data{diff_max} = $diff;
                }

                $data{diff_avg} += $diff / $count;

                my $ratio = $term / $prev;

                if ($ratio < $data{ratio_min}) {
                    $data{ratio_min} = $ratio;
                }

                if ($ratio > $data{ratio_max}) {
                    $data{ratio_max} = $ratio;
                }

                $data{ratio_avg} += $ratio;

            }

            $prev = $term;
        }

        $data{ratio_avg} /= $count;

        my @closed_forms;

        if ($data{diff_avg} == $data{diff_max} and $data{diff_max} == $data{diff_min}) {
            my $min = ($data{min} - $data{diff_min})->round(-20);
            push @closed_forms,
              scalar {
                      factor => $data{diff_min},
                      offset => $min,
                      type   => 'arithmetic',
                     };
        }

        if ($data{ratio_avg} == $data{ratio_max} and $data{ratio_max} == $data{ratio_min}) {
            my $factor = $data{min} / $data{ratio_min};
            push @closed_forms,
              scalar {
                      factor => $factor,
                      base   => $data{ratio_min},
                      type   => 'geometric',
                     };
        }

        #foreach my $key (sort keys %data) {
        #    printf("%9s => %s\n", $key, $data{$key});
        #}
        #print "\n";

        return @closed_forms;
    }
}

use Math::AnyNum;
use List::Util qw(first);

my $seq       = Sequence::ClosedForm->new();
my @constants = (1 .. 5);                      #, #exp(1), atan2(0, -'inf'));

my @rules = (

    #['sub_consecutive', 'add_n'], # 'add_n'],
    #['add_constant', 'sub_consecutive'],
    ['sub_constant', 'sub_consecutive'],
    ['sub_constant', 'div_constant'],
    ['sub_constant'],

    #['add_constant', 'div_consecutive'],
    ['sub_constant', 'add_n',],
    ['sub_constant', 'div_consecutive', 'sub_constant'],

    #['sub_constant'],
    #['sub_constant', 'div_consecutive',],
    ['sub_constant', 'div_consecutive'],

    #['div_consecutive', 'sub_constant'],

    # ['sub_constant', 'sub_consecutive'],

    #['sub_constant'],
    #['add_n', 'div_consecutive',],
    #['div_consecutive',],
);

sub make_constant_obj {
    my ($method) = @_;

    my %cache;

    my %state = (
        i    => 0,
        done => 0,

        code => sub {
            my ($self, $n) = @_;
            my $i = $self->{i} - 1;
            my $sub = ($cache{$i} //= $seq->$method($constants[$i]));
            $sub->($n);
        }
    );

    bless \%state, 'Sequence::Constant';
}

sub generate_actions {
    map { /_constant\z/ ? [$_, make_constant_obj($_)] : [$_, $seq->$_] } @_;
}

my @numbers = (map { Math::AnyNum->new($_) } 1 .. 9);

#my @seq = map { 3**$_ + 2} @numbers;
#my @seq = map { 3 * $_  } @numbers;
#my @seq = map { $_ * ($_ + 1) / 2 + 1 } @numbers;
my @seq = map { $_->factorial + 2 } @numbers;

say "\nseq: @seq\n";

my %closed_forms = (
    sub_consecutive => sub {
        my ($n, $data) = @_;

        #"($data->{factor}*$n + $data->{offset})*($data->{factor}*$n + $data->{offset} + 1)/2";
        #"($n * ($n+1) / 2)";

        $data->{type} eq 'arithmetic'
          ? "($n * ($n+1) / 2)"
          : "($data->{base}**$n)";
    },
    add_n => sub {
        my ($n, $data) = @_;

        #"(2 * ($n) / $data->{factor})";
        #"($n / (2 * $data->{factor}))";
        #"($n - 1)";

        "($n * " . ($data->{factor} - 1) . " / $data->{factor})";
    },
    div_consecutive => sub {
        my ($n) = @_;
        "($n!)";
    },
    add_constant => sub {
        my ($n, $data, $const) = @_;

        $data->{type} eq 'arithmetic'
          ? "($data->{factor}*($n-$constants[$const->{i}-1+$data->{offset}]))"
          : die "geometric sequences are not supported, yet!";    # TODO: implement it
    },
    sub_constant => sub {
        my ($n, $data, $const) = @_;
        $data->{type} eq 'arithmetic'
          ? "($data->{factor}*($n+$constants[$const->{i}-1]+$data->{offset}))"
          : "($constants[$const->{i}-1] + $n)";                   # wrong
    },
    div_constant => sub {
        my ($n, $data, $const) = @_;
        $data->{type} eq 'geometric'
          ? "($constants[$const->{i}-1] * $data->{factor} * $data->{base}**$n)"
          : "($data->{factor} * $n)";                             # wrong
    },
);

sub fill_closed_form {
    my ($cf, $actions) = @_;

    my $result = 'n';
    foreach my $action (reverse @$actions) {
        my ($name, $obj) = @$action;

        #$report .= "name: $name" . (ref($obj) eq 'Sequence::Constant' ? (' (' . $constants[$obj->{i}-1] . ')') : '') . "\n";
        if (not exists($closed_forms{$name})) {
            warn "No closed-form for rule: $name\n";
            next;
        }
        $result = $closed_forms{$name}($result, $cf, $obj);
    }

    $result;

    #"$result / $cf->{factor} + $cf->{offset}";
}

say '-' x 80;

my %seen;

RULE: foreach my $rule (@rules) {
    my @actions   = generate_actions(@$rule);
    my @const_pos = grep { $rule->[$_] =~ /_constant\z/ } 0 .. $#{$rule};
    my $has_const = !!@const_pos;

  WHILE: while (1) {

        foreach my $group (grep { $_->[0] !~ /_constant\z/ } @actions) {
            my $method = $group->[0];
            $group->[1] = $seq->$method;
        }

        my @sequence;

        my $stop = $has_const;
        foreach my $pos (@const_pos) {
            my $constant = $actions[$pos][1];

            if ($constant->{done}) {
                if ($constant->{i} >= $#constants) {
                    $constant->{i} = 0;
                }
                else {
                    $constant->{i}++;
                }
            }
            else {
                if ($constant->{i} >= $#constants) {
                    $constant->{i}    = 0;
                    $constant->{done} = 1;
                }
                else {
                    $constant->{i}++;
                }

                $stop = 0;
                last;
            }
        }

        last if $stop;

        foreach my $term (@seq) {
            my $result = $term;

            foreach my $group (@actions) {
                my $action = $group->[1];
                if (ref($action) eq 'Sequence::Constant') {
                    $result = $action->{code}($action, $result);
                }
                else {
                    $result = $action->($result);
                }
            }

            next WHILE if ($result <= 0 or not $result->is_real);
            push @sequence, $result;
        }

        if ($sequence[0] >= $sequence[1]) {
            $has_const || last;
            next;
        }

        next if $seen{join(';', map { $_->as_rat } @sequence)}++;

        say "try: @sequence";
        my @closed_forms = $seq->find_closed_form(\@sequence);

        if (@closed_forms) {
            say "new: @sequence\n";
            foreach my $cf (@closed_forms) {
                if ($cf->{type} eq 'geometric') {
                    say "type: $cf->{type}";
                    say "base: $cf->{base}";
                    say "fact: $cf->{factor}";
                }
                elsif ($cf->{type} eq 'arithmetic') {
                    say "type: $cf->{type}";
                    say "fact: $cf->{factor}";
                    say "offs: $cf->{offset}";
                }
                foreach my $action (@actions) {
                    my ($name, $obj) = @$action;
                    say "name: $name" . (ref($obj) eq 'Sequence::Constant' ? " (constant: $constants[$obj->{i}-1])" : '');
                }
                my $filled = fill_closed_form($cf, \@actions);
                say "\n=> Possible closed-form: $filled";
            }
            say '-' x 80;
        }

        $has_const || last;
    }
}


================================================
FILE: Math/sequence_polynomial_closed_form.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 04 January 2019
# https://github.com/trizen

# Find a closed-form polynomial to a given sequence of numbers.

# See also:
#   https://www.youtube.com/watch?v=gur16QsZ0r4
#   https://en.wikipedia.org/wiki/Polynomial_interpolation
#   https://en.wikipedia.org/wiki/Vandermonde_matrix

use 5.020;
use warnings;

use Math::MatrixLUP;
use Math::AnyNum qw(ipow sum);

use List::Util qw(all);
use experimental qw(signatures);

sub find_poly_degree(@seq) {
    for (my $c = 1 ; ; ++$c) {
        @seq = map { $seq[$_ + 1] - $seq[$_] } 0 .. $#seq - 1;
        return $c if all { $_ == 0 } @seq;
    }
}

sub eval_poly ($S, $x) {
    sum(map { ($S->[$_] == 0) ? 0 : ($S->[$_] * ipow($x, $_)) } 0 .. $#{$S});
}

# An arbitrary sequence of numbers
my @seq = (
           @ARGV
           ? (map { Math::AnyNum->new($_) } grep { /[0-9]/ } map { split(' ') } map { split(/\s*,\s*/) } @ARGV)
           : (0, 1, 17, 98, 354, 979, 2275, 4676)
          );

# Find the lowest polygonal degree to express the sequence
my $c = find_poly_degree(@seq);

# Create a new cXc Vandermonde matrix
my $A = Math::MatrixLUP->build($c, sub ($n, $k) { ipow($n, $k) });

# Find the polygonal coefficients
my $S = $A->solve([@seq[0 .. $c - 1]]);

# Stringify the polynomial
my $P = join(' + ', map { ($S->[$_] == 0) ? () : "($S->[$_] * x^$_)" } 0 .. $#{$S});

if ($c == scalar(@seq)) {
    say "\n*** WARNING: the polynomial found may not be a closed-form to this sequence! ***\n";
}

say "Coefficients : [", join(', ', @$S), "]";
say "Polynomial   : $P";
say "Next 5 terms : [", join(', ', map { eval_poly($S, $_) } scalar(@seq) .. scalar(@seq) + 4), "]";

__END__
Coefficients : [0, -1/30, 0, 1/3, 1/2, 1/5]
Polynomial   : (-1/30 * x^1) + (1/3 * x^3) + (1/2 * x^4) + (1/5 * x^5)
Next 5 terms : [8772, 15333, 25333, 39974, 60710]


================================================
FILE: Math/sieve_of_eratosthenes.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 18 May 2017
# https://github.com/trizen

# A simple implementation of the sieve of Eratosthenes for prime numbers.

use 5.010;
use strict;
use warnings;

sub sieve_primes {
    my ($n) = @_;

    my @composite;
    foreach my $i (2 .. CORE::sqrt($n)) {
        if (!$composite[$i]) {
            for (my $j = $i**2 ; $j <= $n ; $j += $i) {
                $composite[$j] = 1;
            }
        }
    }

    my @primes;
    foreach my $p (2 .. $n) {
        $composite[$p] // push(@primes, $p);
    }

    return @primes;
}

my $n = shift(@ARGV) // 100;
my @primes = sieve_primes($n);
say join(' ', @primes);
say "PI($n) = ", scalar(@primes);


================================================
FILE: Math/sigma0_of_factorial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 July 2017
# https://github.com/trizen

# An efficient algorithm for computing sigma0(n!).

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(forprimes todigits vecsum);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub sigma0_of_factorial {
    my ($n) = @_;

    my $sigma0 = 1;

    forprimes {
        $sigma0 *= 1 + factorial_power($n, $_);
    } $n;

    return $sigma0;
}

say sigma0_of_factorial(10);     # 270
say sigma0_of_factorial(100);    # 39001250856960000


================================================
FILE: Math/sigma_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 August 2017
# https://github.com/trizen

# Efficient implementation of the `sigma_k(n)` function, where k > 0.

use 5.010;
use strict;
use warnings;

use ntheory qw(factor_exp);

sub sigma {
    my ($n, $k) = @_;

    my $sigma = 1;

    foreach my $p (factor_exp($n)) {
        $sigma *= (($p->[0]**($k * ($p->[1] + 1)) - 1) / ($p->[0]**$k - 1));
    }

    return $sigma;
}

say sigma(10,      1);    #=> 18
say sigma(100,     1);    #=> 217
say sigma(3628800, 2);    #=> 20993420690550


================================================
FILE: Math/sigma_of_factorial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 July 2017
# https://github.com/trizen

# An efficient algorithm for computing sigma_k(n!), where k > 0.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(forprimes vecsum todigits);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub sigma_of_factorial {
    my ($n, $a) = @_;

    my $sigma = 1;

    forprimes {
        my $p = $_;
        my $k = factorial_power($n, $p);
        $sigma *= (($p**($a * ($k + 1)) - 1) / ($p**$a - 1));
    } $n;

    return $sigma;
}

say sigma_of_factorial(10, 1);    # sigma_1(10!) = 15334088
say sigma_of_factorial(10, 2);    # sigma_2(10!) = 20993420690550
say sigma_of_factorial( 8, 3);    # sigma_3( 8!) = 78640578066960


================================================
FILE: Math/sigma_of_product_of_binomials.pl
================================================
#!/usr/bin/perl

# Formula for computing the sum of divisors of the product of binomials.

# Using the identities:
#   Product_{k=0..n} binomial(n, k) = Product_{k=1..n} k^(2*k - n - 1)
#                                   = hyperfactorial(n)/superfactorial(n)

# and the fact that the sigma function is multiplicative with:
#   sigma_m(p^k) = (p^(m*(k+1)) - 1)/(p^m - 1)

# See also:
#   https://oeis.org/A001142
#   https://oeis.org/A323444

# Paper:
#   Jeffrey C. Lagarias, Harsh Mehta
#   Products of binomial coefficients and unreduced Farey fractions
#   https://arxiv.org/abs/1409.4145

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(prod ipow);
use experimental qw(signatures);
use ntheory qw(primes todigits vecsum);

my @cache;

sub sum_of_digits ($n, $p) {
    return 0 if ($n <= 0);
    $cache[$n][$p] //= vecsum(todigits($n - 1, $p)) + sum_of_digits($n - 1, $p);
}

sub power_of_product_of_binomials ($n, $p) {
    (2 * sum_of_digits($n, $p) - ($n - 1) * vecsum(todigits($n, $p))) / ($p - 1);
}

sub sigma_of_binomial_product ($n, $m = 1) {
    prod(
        map {
            my $p = $_;
            my $k = power_of_product_of_binomials($n, $p);
            (ipow($p, $m * ($k + 1)) - 1) / (ipow($p, $m) - 1);
        } @{primes($n)}
    );
}

say sigma_of_binomial_product(10);    #=> 141699428035793200
say sigma_of_binomial_product(10, 2); #=> 1675051201226374788235139281367100


================================================
FILE: Math/sigma_p_adic.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 November 2016
# Website: https://github.com/trizen

# An interesting function that computes the sum of
# divisors (excluding the trivial divisors 1 and n),
# each divisor raised to its p-adic valuation ν_d(n!).

# For prime numbers, the value of `sigma_p_adic(p)` is 0.

# See also:
#   https://en.wikipedia.org/wiki/P-adic_order
#   https://en.wikipedia.org/wiki/Legendre%27s_formula

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(divisors forcomposites todigits vecsum);

sub factorial_power ($n, $p) {
    ($n - vecsum(todigits($n, $p))) / ($p - 1);
}

sub sigma_p_adic ($n) {

    my @d = divisors($n);

    shift @d;    # remove the first divisor (which is: 1)
    pop @d;      # remove the last  divisor (which is: n)

    my $s = 0;
    foreach my $d (@d) {
        $s += $d**factorial_power($n, $d);
    }

    return $s;
}

forcomposites {
    say $_, "\t", sigma_p_adic($_);
} 30;

__END__
4       8
6       25
8       144
9       81
10      281
12      1367
14      2097
15      854
16      33856
18      72394
20      266965
21      20026
22      524409
24      4271689
25      15625
26      8388777
27      1595052
28      33622565
30      71978959


================================================
FILE: Math/siqs_factorization.pl
================================================
#!/usr/bin/perl

=begin

This script factorizes a natural number given as a command line
parameter into its prime factors. It first attempts to use trial
division to find very small factors, then uses other special-purpose
factorization methods to find slightly larger factors. If any large
factors remain, it uses the Self-Initializing Quadratic Sieve (SIQS) [2]
to factorize those.

[2] Contini, Scott Patrick. 'Factoring integers with the self-
    initializing quadratic sieve.' (1997).

=cut

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use POSIX        qw(ULONG_MAX);
use experimental qw(signatures);

use ntheory qw(
  urandomm valuation sqrtmod invmod random_prime factor_exp vecmin
  is_square divisors todigits primes prime_iterator
);

use Math::Prime::Util::GMP qw(
  is_power powmod vecprod sqrtint rootint logint is_prime
  gcd sieve_primes consecutive_integer_lcm lucas_sequence
);

my $ZERO = Math::GMPz->new(0);
my $ONE  = Math::GMPz->new(1);

local $| = 1;

# Tuning parameters
use constant {
              MASK_LIMIT                => 200,         # show Cn if n > MASK_LIMIT, where n ~ log_10(N)
              LOOK_FOR_SMALL_FACTORS    => 1,
              TRIAL_DIVISION_LIMIT      => 1_000_000,
              PHI_FINDER_ITERATIONS     => 100_000,
              FERMAT_ITERATIONS         => 100_000,
              NEAR_POWER_ITERATIONS     => 1_000,
              PELL_ITERATIONS           => 50_000,
              FLT_ITERATIONS            => 200_000,
              HOLF_ITERATIONS           => 100_000,
              MBE_ITERATIONS            => 100,
              MILLER_RABIN_ITERATIONS   => 100,
              LUCAS_MILLER_ITERATIONS   => 50,
              SIQS_TRIAL_DIVISION_EPS   => 25,
              SIQS_MIN_PRIME_POLYNOMIAL => 400,
              SIQS_MAX_PRIME_POLYNOMIAL => 4000,
             };

my @small_primes = sieve_primes(2, TRIAL_DIVISION_LIMIT);

package Polynomial {

    sub new ($class, $coeff, $A = undef, $B = undef) {
        bless {
               a     => $A,
               b     => $B,
               coeff => $coeff,
              }, $class;
    }

    sub eval ($self, $x) {
        my $res = $ZERO;

        foreach my $k (@{$self->{coeff}}) {
            $res *= $x;
            $res += $k;
        }

        return $res;
    }
}

package FactorBasePrime {

    sub new ($class, $p, $t, $lp) {
        bless {
               p     => $p,
               soln1 => undef,
               soln2 => undef,
               t     => $t,
               lp    => $lp,
               ainv  => undef,
              }, $class;
    }
}

sub siqs_factor_base_primes ($n, $nf) {
    my @factor_base;

    foreach my $p (@small_primes) {
        my $t  = sqrtmod($n, $p) // next;
        my $lp = sprintf('%0.f', log($p) / log(2));
        push @factor_base, FactorBasePrime->new($p, $t, $lp);

        if (scalar(@factor_base) >= $nf) {
            last;
        }
    }

    return \@factor_base;
}

sub siqs_create_poly ($A, $B, $n, $factor_base, $first) {

    my $B_orig = $B;

    if (($B << 1) > $A) {
        $B = $A - $B;
    }

    # 0 < $B                   or die 'error';
    # 2 * $B <= $A             or die 'error';
    # ($B * $B - $n) % $A == 0 or die 'error';

    my $g = Polynomial->new([$A * $A, ($A * $B) << 1, $B * $B - $n], $A, $B_orig);
    my $h = Polynomial->new([$A, $B]);

    foreach my $fb (@$factor_base) {

        next if Math::GMPz::Rmpz_divisible_ui_p($A, $fb->{p});

#<<<
        $fb->{ainv}  = int(invmod($A, $fb->{p}))                         if $first;
        $fb->{soln1} = int(($fb->{ainv} * ( $fb->{t} - $B)) % $fb->{p});
        $fb->{soln2} = int(($fb->{ainv} * (-$fb->{t} - $B)) % $fb->{p});
#>>>

    }

    return ($g, $h);
}

sub siqs_find_first_poly ($n, $m, $factor_base) {
    my $p_min_i;
    my $p_max_i;

    foreach my $i (0 .. $#{$factor_base}) {
        my $fb = $factor_base->[$i];
        if (not defined($p_min_i) and $fb->{p} >= SIQS_MIN_PRIME_POLYNOMIAL) {
            $p_min_i = $i;
        }
        if (not defined($p_max_i) and $fb->{p} > SIQS_MAX_PRIME_POLYNOMIAL) {
            $p_max_i = $i - 1;
            last;
        }
    }

    # The following may happen if the factor base is small
    if (not defined($p_max_i)) {
        $p_max_i = $#{$factor_base};
    }

    if (not defined($p_min_i)) {
        $p_min_i = 5;
    }

    if ($p_max_i - $p_min_i < 20) {
        $p_min_i = vecmin($p_min_i, 5);
    }

    my $target0 = (log("$n") + log(2)) / 2 - log("$m");
    my $target1 = $target0 - log(($factor_base->[$p_min_i]{p} + $factor_base->[$p_max_i]{p}) / 2) / 2;

    # find q such that the product of factor_base[q_i] is approximately
    # sqrt(2 * n) / m; try a few different sets to find a good one
    my ($best_q, $best_a, $best_ratio);

    for (1 .. 30) {
        my $A     = $ONE;
        my $log_A = 0;

        my %Q;
        while ($log_A < $target1) {

            my $p_i = 0;
            while ($p_i == 0 or exists $Q{$p_i}) {
                $p_i = $p_min_i + urandomm($p_max_i - $p_min_i + 1);
            }

            my $fb = $factor_base->[$p_i];
            $A     *= $fb->{p};
            $log_A += log($fb->{p});
            $Q{$p_i} = $fb;
        }

        my $ratio = exp($log_A - $target0);

        # ratio too small seems to be not good
        if (   !defined($best_ratio)
            or ($ratio >= 0.9 and $ratio < $best_ratio)
            or ($best_ratio < 0.9 and $ratio > $best_ratio)) {
            $best_q     = \%Q;
            $best_a     = $A;
            $best_ratio = $ratio;
        }
    }

    my $A = $best_a;
    my $B = $ZERO;

    my @arr;

    foreach my $fb (values %$best_q) {
        my $p = $fb->{p};

        #($A % $p == 0) or die 'error';

        my $r = $A / $p;

        #$fb->{t} // die 'error';
        #gcd($r, $p) == 1 or die 'error';

        my $gamma = ($fb->{t} * int(invmod($r, $p))) % $p;

        if ($gamma > ($p >> 1)) {
            $gamma = $p - $gamma;
        }

        my $t = $r * $gamma;

        $B += $t;
        push @arr, $t;
    }

    my ($g, $h) = siqs_create_poly($A, $B, $n, $factor_base, 1);

    return ($g, $h, \@arr);
}

sub siqs_find_next_poly ($n, $factor_base, $i, $g, $arr) {

    # Compute the (i+1)-th polynomials for the Self-Initializing
    # Quadratic Sieve, given that g is the i-th polynomial.

    my $v = valuation($i, 2);
    my $z = ((($i >> ($v + 1)) & 1) == 0) ? -1 : 1;

    my $A = $g->{a};
    my $B = ($g->{b} + 2 * $z * $arr->[$v]) % $A;

    return siqs_create_poly($A, $B, $n, $factor_base, 0);
}

sub siqs_sieve ($factor_base, $m) {

    # Perform the sieving step of the SIQS. Return the sieve array.

    my @sieve_array = (0) x (2 * $m + 1);

    foreach my $fb (@$factor_base) {

        $fb->{p} > 100 or next;
        $fb->{soln1} // next;

        my $p   = $fb->{p};
        my $lp  = $fb->{lp};
        my $end = 2 * $m;

        my $i_start_1 = -int(($m + $fb->{soln1}) / $p);
        my $a_start_1 = int($fb->{soln1} + $i_start_1 * $p);

        for (my $i = $a_start_1 + $m ; $i <= $end ; $i += $p) {
            $sieve_array[$i] += $lp;
        }

        my $i_start_2 = -int(($m + $fb->{soln2}) / $p);
        my $a_start_2 = int($fb->{soln2} + $i_start_2 * $p);

        for (my $i = $a_start_2 + $m ; $i <= $end ; $i += $p) {
            $sieve_array[$i] += $lp;
        }
    }

    return \@sieve_array;
}

sub siqs_trial_divide ($n, $factor_base_info) {

    # Determine whether the given number can be fully factorized into
    # primes from the factors base. If so, return the indices of the
    # factors from the factor base. If not, return undef.

    my $factor_prod = $factor_base_info->{prod};

    state $g = Math::GMPz::Rmpz_init_nobless();
    state $t = Math::GMPz::Rmpz_init_nobless();

    Math::GMPz::Rmpz_set($t, $n);
    Math::GMPz::Rmpz_gcd($g, $t, $factor_prod);

    while (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {

        Math::GMPz::Rmpz_remove($t, $t, $g);

        if (Math::GMPz::Rmpz_cmp_ui($t, 1) == 0) {

            my $factor_index = $factor_base_info->{index};

            return [map { [$factor_index->{$_->[0]}, $_->[1]] } factor_exp($n)];
        }

        Math::GMPz::Rmpz_gcd($g, $t, $g);
    }

    return undef;
}

sub siqs_trial_division ($n, $sieve_array, $factor_base_info, $smooth_relations, $g, $h, $m, $req_relations) {

    # Perform the trial division step of the Self-Initializing Quadratic Sieve.

    my $limit = (log("$m") + log("$n") / 2) / log(2) - SIQS_TRIAL_DIVISION_EPS;

    foreach my $i (0 .. $#{$sieve_array}) {

        next if ((my $sa = $sieve_array->[$i]) < $limit);

        my $x  = $i - $m;
        my $gx = abs($g->eval($x));

        my $divisors_idx = siqs_trial_divide($gx, $factor_base_info) // next;

        my $u = $h->eval($x);
        my $v = $gx;

        #(($u * $u) % $n == ($v % $n)) or die 'error';

        push @$smooth_relations, [$u, $v, $divisors_idx];

        if (scalar(@$smooth_relations) >= $req_relations) {
            return 1;
        }
    }

    return 0;
}

sub siqs_build_matrix ($factor_base, $smooth_relations) {

    # Build the matrix for the linear algebra step of the Quadratic Sieve.
    my $fb = scalar(@$factor_base);
    my @matrix;

    foreach my $sr (@$smooth_relations) {
        my @row = (0) x $fb;
        foreach my $pair (@{$sr->[2]}) {
            $row[$pair->[0]] = $pair->[1] % 2;
        }
        push @matrix, \@row;
    }

    return \@matrix;
}

sub siqs_build_matrix_opt ($M) {

    # Convert the given matrix M of 0s and 1s into a list of numbers m
    # that correspond to the columns of the matrix.
    # The j-th number encodes the j-th column of matrix M in binary:
    # The i-th bit of m[i] is equal to M[i][j].

    my $m           = scalar(@{$M->[0]});
    my @cols_binary = ("") x $m;

    foreach my $mi (@$M) {
        foreach my $j (0 .. $#{$mi}) {
            $cols_binary[$j] .= $mi->[$j];
        }
    }

#<<<
    return ([map {
        Math::GMPz::Rmpz_init_set_str(scalar reverse($_), 2)
    } @cols_binary], scalar(@$M), $m);
#>>>
}

sub find_pivot_column_opt ($M, $j) {

    # For a matrix produced by siqs_build_matrix_opt, return the row of
    # the first non-zero entry in column j, or None if no such row exists.

    my $v = $M->[$j];

    if ($v == 0) {
        return undef;
    }

    return valuation($v, 2);
}

sub siqs_solve_matrix_opt ($M, $n, $m) {

    # Perform the linear algebra step of the SIQS. Perform fast
    # Gaussian elimination to determine pairs of perfect squares mod n.
    # Use the optimizations described in [1].

    # [1] Koç, Çetin K., and Sarath N. Arachchige. 'A Fast Algorithm for
    #    Gaussian Elimination over GF (2) and its Implementation on the
    #    GAPP.' Journal of Parallel and Distributed Computing 13.1
    #    (1991): 118-122.

    my @row_is_marked = (0) x $n;
    my @pivots        = (-1) x $m;

    foreach my $j (0 .. $m - 1) {

        my $i = find_pivot_column_opt($M, $j) // next;

        $pivots[$j]        = $i;
        $row_is_marked[$i] = 1;

        foreach my $k (0 .. $m - 1) {
            if ($k != $j and Math::GMPz::Rmpz_tstbit($M->[$k], $i)) {
                Math::GMPz::Rmpz_xor($M->[$k], $M->[$k], $M->[$j]);
            }
        }
    }

    my @perf_squares;
    foreach my $i (0 .. $n - 1) {
        if (not $row_is_marked[$i]) {
            my @perfect_sq_indices = ($i);
            foreach my $j (0 .. $m - 1) {
                if (Math::GMPz::Rmpz_tstbit($M->[$j], $i)) {
                    push @perfect_sq_indices, $pivots[$j];
                }
            }
            push @perf_squares, \@perfect_sq_indices;
        }
    }

    return \@perf_squares;
}

sub siqs_calc_sqrts ($n, $square_indices, $smooth_relations) {

    # Given on of the solutions returned by siqs_solve_matrix_opt and
    # the corresponding smooth relations, calculate the pair [a, b], such
    # that a^2 = b^2 (mod n).

    my $r1 = $ONE;
    my $r2 = $ONE;

    foreach my $i (@$square_indices) {
        ($r1 *= $smooth_relations->[$i][0]) %= $n;
        ($r2 *= $smooth_relations->[$i][1]);
    }

    $r2 = Math::GMPz->new(sqrtint($r2));

    return ($r1, $r2);
}

sub siqs_factor_from_square ($n, $square_indices, $smooth_relations) {

    # Given one of the solutions returned by siqs_solve_matrix_opt,
    # return the factor f determined by f = gcd(a - b, n), where
    # a, b are calculated from the solution such that a*a = b*b (mod n).
    # Return f, a factor of n (possibly a trivial one).

    my ($sqrt1, $sqrt2) = siqs_calc_sqrts($n, $square_indices, $smooth_relations);

    #(($sqrt1 * $sqrt1) % $n == ($sqrt2 * $sqrt2) % $n) or die 'error';

    return Math::GMPz->new(gcd($sqrt1 - $sqrt2, $n));
}

sub siqs_find_more_factors_gcd (@numbers) {
    my %res;

    foreach my $i (0 .. $#numbers) {
        my $n = $numbers[$i];
        $res{$n} = $n;
        foreach my $k ($i + 1 .. $#numbers) {
            my $m = $numbers[$k];

            my $fact = Math::GMPz->new(gcd($n, $m));
            if ($fact != 1 and $fact != $n and $fact != $m) {

                if (not exists($res{$fact})) {
                    say "SIQS: GCD found non-trivial factor: $fact";
                    $res{$fact} = $fact;
                }

                my $t1 = $n / $fact;
                my $t2 = $m / $fact;

                $res{$t1} = $t1;
                $res{$t2} = $t2;
            }
        }
    }

    return (values %res);
}

sub siqs_find_factors ($n, $perfect_squares, $smooth_relations) {

    # Perform the last step of the Self-Initializing Quadratic Field.
    # Given the solutions returned by siqs_solve_matrix_opt, attempt to
    # identify a number of (not necessarily prime) factors of n, and
    # return them.

    my @factors;
    my $rem = $n;

    my %non_prime_factors;
    my %prime_factors;

    foreach my $square_indices (@$perfect_squares) {
        my $fact = siqs_factor_from_square($n, $square_indices, $smooth_relations);

        if ($fact > 1 and $fact < $rem) {
            if (is_prime($fact)) {

                if (not exists $prime_factors{$fact}) {
                    say "SIQS: Prime factor found: $fact";
                    $prime_factors{$fact} = $fact;
                }

                $rem = check_factor($rem, $fact, \@factors);

                if ($rem == 1) {
                    last;
                }

                if (is_prime($rem)) {
                    push @factors, $rem;
                    $rem = 1;
                    last;
                }

                if (defined(my $root = check_perfect_power($rem))) {
                    say "SIQS: Perfect power detected with root: $root";
                    push @factors, $root;
                    $rem = 1;
                    last;
                }
            }
            else {
                if (not exists $non_prime_factors{$fact}) {
                    say "SIQS: Composite factor found: $fact";
                    $non_prime_factors{$fact} = $fact;
                }
            }
        }
    }

    if ($rem != 1 and keys(%non_prime_factors)) {
        $non_prime_factors{$rem} = $rem;

        my @primes;
        my @composites;

        foreach my $fact (siqs_find_more_factors_gcd(values %non_prime_factors)) {
            if (is_prime($fact)) {
                push @primes, $fact;
            }
            elsif ($fact > 1) {
                push @composites, $fact;
            }
        }

        foreach my $fact (@primes, @composites) {

            if ($fact != $rem and $rem % $fact == 0) {
                say "SIQS: Using non-trivial factor from GCD: $fact";
                $rem = check_factor($rem, $fact, \@factors);
            }

            if ($rem == 1 or is_prime($rem)) {
                last;
            }
        }
    }

    if ($rem != 1) {
        push @factors, $rem;
    }

    return @factors;
}

sub siqs_choose_range ($n) {

    # Choose m for sieving in [-m, m].

    $n = "$n";

    return sprintf('%.0f', exp(sqrt(log($n) * log(log($n))) / 2));
}

sub siqs_choose_nf ($n) {

    # Choose parameters nf (sieve of factor base)

    $n = "$n";

    return sprintf('%.0f', exp(sqrt(log($n) * log(log($n))))**(sqrt(2) / 4));
}

sub siqs_choose_nf2 ($n) {

    # Choose parameters nf (sieve of factor base)
    $n = "$n";

    return sprintf('%.0f', exp(sqrt(log($n) * log(log($n))) / 2));
}

sub siqs_factorize ($n, $nf) {

    # Use the Self-Initializing Quadratic Sieve algorithm to identify
    # one or more non-trivial factors of the given number n. Return the
    # factors as a list.

    my $m = siqs_choose_range($n);

    my @factors;
    my $factor_base = siqs_factor_base_primes($n, $nf);
    my $factor_prod = Math::GMPz->new(vecprod(map { $_->{p} } @$factor_base));

    my %factor_base_index;
    @factor_base_index{map { $_->{p} } @{$factor_base}} = 0 .. $#{$factor_base};

    my $factor_base_info = {
                            base  => $factor_base,
                            prod  => $factor_prod,
                            index => \%factor_base_index,
                           };

    my $smooth_relations         = [];
    my $required_relations_ratio = 1;

    my $success  = 0;
    my $prev_cnt = 0;
    my $i_poly   = 0;

    my ($g, $h, $arr);

    while (not $success) {

        say "*** Step 1/2: Finding smooth relations ***";
        say "SIQS sieving range: [-$m, $m]";

        my $required_relations = sprintf('%.0f', (scalar(@$factor_base) + 1) * $required_relations_ratio);
        say "Target: $required_relations relations.";
        my $enough_relations = 0;

        while (not $enough_relations) {
            if ($i_poly == 0) {
                ($g, $h, $arr) = siqs_find_first_poly($n, $m, $factor_base);
            }
            else {
                ($g, $h) = siqs_find_next_poly($n, $factor_base, $i_poly, $g, $arr);
            }

            if (++$i_poly >= (1 << $#{$arr})) {
                $i_poly = 0;
            }

            my $sieve_array = siqs_sieve($factor_base, $m);

            $enough_relations = siqs_trial_division($n, $sieve_array, $factor_base_info, $smooth_relations, $g, $h, $m, $required_relations);

            if (   scalar(@$smooth_relations) >= $required_relations
                or scalar(@$smooth_relations) > $prev_cnt) {
                printf("Progress: %d/%d relations.\r", scalar(@$smooth_relations), $required_relations);
                $prev_cnt = scalar(@$smooth_relations);
            }
        }

        say "\n\n*** Step 2/2: Linear Algebra ***";
        say "Building matrix for linear algebra step...";

        my $M = siqs_build_matrix($factor_base, $smooth_relations);
        my ($M_opt, $M_n, $M_m) = siqs_build_matrix_opt($M);

        say "Finding perfect squares using Gaussian elimination...";
        my $perfect_squares = siqs_solve_matrix_opt($M_opt, $M_n, $M_m);

        say "Finding factors from congruences of squares...\n";
        @factors = siqs_find_factors($n, $perfect_squares, $smooth_relations);

        if (scalar(@factors) > 1) {
            $success = 1;
        }
        else {
            say "Failed to find a solution. Finding more relations...";
            $required_relations_ratio += 0.05;
        }
    }

    return @factors;
}

sub check_factor ($n, $i, $factors) {

    while ($n % $i == 0) {

        $n /= $i;
        push @$factors, $i;

        if (is_prime($n)) {
            push @$factors, $n;
            return 1;
        }
    }

    return $n;
}

sub trial_division_small_primes ($n) {

    # Perform trial division on the given number n using all primes up
    # to upper_bound. Initialize the global variable small_primes with a
    # list of all primes <= upper_bound. Return (factors, rem), where
    # factors is the list of identified prime factors of n, and rem is the
    # remaining factor. If rem = 1, the function terminates early, without
    # fully initializing small_primes.

    say "[*] Trial division...";

    my $factors = [];
    my $rem     = $n;

    foreach my $p (@small_primes) {
        if (Math::GMPz::Rmpz_divisible_ui_p($rem, $p)) {
            $rem = check_factor($rem, $p, $factors);
            last if ($rem == 1);
        }
    }

    return ($factors, $rem);
}

sub fast_fibonacci_factor ($n, $upto) {

    my $g = Math::GMPz::Rmpz_init();

    my ($P, $Q) = (3, 1);

    my $U0 = Math::GMPz::Rmpz_init_set_ui(0);
    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);

    my $V0 = Math::GMPz::Rmpz_init_set_ui(2);
    my $V1 = Math::GMPz::Rmpz_init_set_ui($P);

    foreach my $k (2 .. $upto) {

        # my ($U, $V) = Math::Prime::Util::GMP::lucas_sequence($n, $P, $Q, $k);

        Math::GMPz::Rmpz_set($g, $U1);
        Math::GMPz::Rmpz_mul_ui($U1, $U1, $P);
        Math::GMPz::Rmpz_submul_ui($U1, $U0, $Q);
        Math::GMPz::Rmpz_mod($U1, $U1, $n);
        Math::GMPz::Rmpz_set($U0, $g);

        Math::GMPz::Rmpz_set($g, $V1);
        Math::GMPz::Rmpz_mul_ui($V1, $V1, $P);
        Math::GMPz::Rmpz_submul_ui($V1, $V0, $Q);
        Math::GMPz::Rmpz_mod($V1, $V1, $n);
        Math::GMPz::Rmpz_set($V0, $g);

        foreach my $param ([$U1, 0], [$V1, -$P, -2 * $Q, 0]) {

            my ($t, @deltas) = @$param;

            foreach my $delta (@deltas) {

                ($delta >= 0)
                  ? Math::GMPz::Rmpz_add_ui($g, $t, $delta)
                  : Math::GMPz::Rmpz_sub_ui($g, $t, -$delta);

                Math::GMPz::Rmpz_gcd($g, $g, $n);

                if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0
                    and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                    return $g;
                }
            }
        }
    }

    return undef;
}

sub fast_power_check ($n, $upto) {

    state $t = Math::GMPz::Rmpz_init_nobless();
    state $g = Math::GMPz::Rmpz_init_nobless();

    my $base_limit = vecmin(logint($n, 2), 150);

    foreach my $base (2 .. $base_limit) {

        Math::GMPz::Rmpz_set_ui($t, $base);

        foreach my $exp (2 .. $upto) {

            Math::GMPz::Rmpz_mul_ui($t, $t, $base);

            foreach my $k ($base <= 10 ? (1 .. ($base_limit >> 1)) : 1) {
                Math::GMPz::Rmpz_mul_ui($g, $t, $k);

                Math::GMPz::Rmpz_sub_ui($g, $g, 1);
                Math::GMPz::Rmpz_gcd($g, $g, $n);

                if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                    return Math::GMPz::Rmpz_init_set($g);
                }

                Math::GMPz::Rmpz_mul_ui($g, $t, $k);
                Math::GMPz::Rmpz_add_ui($g, $g, 1);
                Math::GMPz::Rmpz_gcd($g, $g, $n);

                if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                    return Math::GMPz::Rmpz_init_set($g);
                }
            }
        }
    }

    return undef;
}

sub cyclotomic_polynomial ($n, $x, $m) {

    $x = Math::GMPz::Rmpz_init_set_ui($x) if !ref($x);

    # Generate the squarefree divisors of n, along
    # with the number of prime factors of each divisor
    my @sd;
    foreach my $pe (factor_exp($n)) {
        my ($p) = @$pe;
        push @sd, map { [$_->[0] * $p, $_->[1] + 1] } @sd;
        push @sd, [$p, 1];
    }

    push @sd, [Math::GMPz::Rmpz_init_set_ui(1), 0];

    my $prod = Math::GMPz::Rmpz_init_set_ui(1);

    foreach my $pair (@sd) {
        my ($d, $c) = @$pair;

        my $base = Math::GMPz::Rmpz_init();
        my $exp  = CORE::int($n / $d);

        Math::GMPz::Rmpz_powm_ui($base, $x, $exp, $m);    # x^(n/d) mod m
        Math::GMPz::Rmpz_sub_ui($base, $base, 1);

        if ($c % 2 == 1) {
            Math::GMPz::Rmpz_invert($base, $base, $m) || return $base;
        }

        Math::GMPz::Rmpz_mul($prod, $prod, $base);
        Math::GMPz::Rmpz_mod($prod, $prod, $m);
    }

    return $prod;
}

sub cyclotomic_factorization ($n) {

    my $g          = Math::GMPz::Rmpz_init();
    my $base_limit = vecmin(1 + logint($n, 2), 1000);

    for (my $base = $base_limit ; $base >= 2 ; $base -= 1) {
        my $lim = 1 + logint($n, $base);

        foreach my $k (1 .. $lim) {
            my $c = cyclotomic_polynomial($k, $base, $n);
            Math::GMPz::Rmpz_gcd($g, $n, $c);
            if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0
                and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                return $g;
            }
        }
    }

    return undef;
}

sub fast_lucasVmod ($P, $n, $m) {    # assumes Q = 1

    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set($P));

    foreach my $bit (todigits($n, 2)) {

        if ($bit) {
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);
            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $m);
            Math::GMPz::Rmpz_sub($V1, $V1, $P);
            Math::GMPz::Rmpz_sub_ui($V2, $V2, 2);
            Math::GMPz::Rmpz_mod($V1, $V1, $m);
        }
        else {
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $m);
            Math::GMPz::Rmpz_sub($V2, $V2, $P);
            Math::GMPz::Rmpz_sub_ui($V1, $V1, 2);
            Math::GMPz::Rmpz_mod($V2, $V2, $m);
        }
    }

    return $V1;
}

sub chebyshev_factorization ($n, $B, $A = 127) {

    # The Chebyshev factorization method, taking
    # advantage of the smoothness of p-1 or p+1.

    my $x = Math::GMPz::Rmpz_init_set_ui($A);
    my $i = Math::GMPz::Rmpz_init_set_ui(2);

    Math::GMPz::Rmpz_invert($i, $i, $n);

    my $chebyshevTmod = sub ($A, $x) {
        Math::GMPz::Rmpz_mul_2exp($x, $x, 1);
        Math::GMPz::Rmpz_set($x, fast_lucasVmod($x, $A, $n));
        Math::GMPz::Rmpz_mul($x, $x, $i);
        Math::GMPz::Rmpz_mod($x, $x, $n);
    };

    my $g   = Math::GMPz::Rmpz_init();
    my $lnB = 2 * log($B);
    my $s   = sqrtint($B);

    foreach my $p (@{primes(2, $s)}) {
        for (1 .. int($lnB / log($p))) {
            $chebyshevTmod->($p, $x);    # T_k(x) (mod n)
        }
    }

    my $it = prime_iterator($s + 1);
    for (my $p = $it->() ; $p <= $B ; $p = $it->()) {

        $chebyshevTmod->($p, $x);    # T_k(x) (mod n)

        Math::GMPz::Rmpz_sub_ui($g, $x, 1);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);
            return $g;
        }
    }

    return undef;
}

sub fibonacci_factorization ($n, $bound) {

    # The Fibonacci factorization method, taking
    # advantage of the smoothness of `p - legendre(p, 5)`.

    my ($P, $Q) = (1, 0);

    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);

        if (Math::GMPz::Rmpz_si_kronecker($D, $n) == -1) {
            $Q = (1 - $D) / 4;
            last;
        }
    }

    state %cache;
    my $g = Math::GMPz::Rmpz_init();

    for (; ;) {
        return undef if $bound <= 1;

        my $d = ($cache{$bound} //= consecutive_integer_lcm($bound));
        my ($U, $V) = map { Math::GMPz::Rmpz_init_set_str($_, 10) } lucas_sequence($n, $P, $Q, $d);

        foreach my $t ($U, $V - 2, $V, $V + 2) {

            Math::GMPz::Rmpz_gcd($g, $t, $n);

            if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0
                and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                return $g;
            }
        }

        if ($U == 0) {
            say ":: p±1 seems to be $bound-smooth...";
            $bound >>= 1;
            next;
        }

        say "=> Lucas p±1...";
        return lucas_factorization($n, Math::GMPz::Rmpz_init_set_str($d, 10));
    }
}

sub lucas_factorization ($n, $d) {

    # The Lucas factorization method, taking
    # advantage of the smoothness of p-1 or p+1.

    my $Q;
    for (my $k = 2 ; ; ++$k) {
        my $D = (-1)**$k * (2 * $k + 1);

        if (Math::GMPz::Rmpz_si_kronecker($D, $n) == -1) {
            $Q = (1 - $D) / 4;
            last;
        }
    }

    my $s  = Math::GMPz::Rmpz_scan1($d, 0);
    my $U1 = Math::GMPz::Rmpz_init_set_ui(1);

    my ($V1, $V2) = (Math::GMPz::Rmpz_init_set_ui(2), Math::GMPz::Rmpz_init_set_ui(1));
    my ($Q1, $Q2) = (Math::GMPz::Rmpz_init_set_ui(1), Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $bit (split(//, substr(Math::GMPz::Rmpz_get_str($d, 2), 0, -$s - 1))) {

        Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
        Math::GMPz::Rmpz_mod($Q1, $Q1, $n);

        if ($bit) {
            Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
            Math::GMPz::Rmpz_mul($U1, $U1, $V2);
            Math::GMPz::Rmpz_mul($V1, $V1, $V2);

            Math::GMPz::Rmpz_powm_ui($V2, $V2, 2, $n);
            Math::GMPz::Rmpz_sub($V1, $V1, $Q1);
            Math::GMPz::Rmpz_submul_ui($V2, $Q2, 2);

            Math::GMPz::Rmpz_mod($V1, $V1, $n);
            Math::GMPz::Rmpz_mod($U1, $U1, $n);
        }
        else {
            Math::GMPz::Rmpz_set($Q2, $Q1);
            Math::GMPz::Rmpz_mul($U1, $U1, $V1);
            Math::GMPz::Rmpz_mul($V2, $V2, $V1);
            Math::GMPz::Rmpz_sub($U1, $U1, $Q1);

            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);
            Math::GMPz::Rmpz_sub($V2, $V2, $Q1);
            Math::GMPz::Rmpz_submul_ui($V1, $Q2, 2);

            Math::GMPz::Rmpz_mod($V2, $V2, $n);
            Math::GMPz::Rmpz_mod($U1, $U1, $n);
        }
    }

    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);
    Math::GMPz::Rmpz_mul_si($Q2, $Q1, $Q);
    Math::GMPz::Rmpz_mul($U1, $U1, $V1);
    Math::GMPz::Rmpz_mul($V1, $V1, $V2);
    Math::GMPz::Rmpz_sub($U1, $U1, $Q1);
    Math::GMPz::Rmpz_sub($V1, $V1, $Q1);
    Math::GMPz::Rmpz_mul($Q1, $Q1, $Q2);

    my $t = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_gcd($t, $U1, $n);

    if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0
        and Math::GMPz::Rmpz_cmp($t, $n) < 0) {
        return $t;
    }

    Math::GMPz::Rmpz_gcd($t, $V1, $n);

    if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0
        and Math::GMPz::Rmpz_cmp($t, $n) < 0) {
        return $t;
    }

    for (1 .. $s) {

        Math::GMPz::Rmpz_mul($U1, $U1, $V1);
        Math::GMPz::Rmpz_mod($U1, $U1, $n);
        Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);
        Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);
        Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $n);

        Math::GMPz::Rmpz_gcd($t, $U1, $n);

        if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0
            and Math::GMPz::Rmpz_cmp($t, $n) < 0) {
            return $t;
        }

        Math::GMPz::Rmpz_gcd($t, $V1, $n);

        if (    Math::GMPz::Rmpz_cmp_ui($t, 1) > 0
            and Math::GMPz::Rmpz_cmp($t, $n) < 0) {
            return $t;
        }
    }

    return undef;
}

sub pollard_pm1_lcm_find_factor ($n, $bound) {

    # Pollard p-1 method (LCM).

    my $g = Math::GMPz::Rmpz_init();
    my $t = Math::GMPz::Rmpz_init_set_ui(random_prime(1e6));

    foreach my $p (sieve_primes(2, $bound)) {

        Math::GMPz::Rmpz_powm_ui($t, $t, $p**int(log(ULONG_MAX >> 32) / log($p)), $n);
        Math::GMPz::Rmpz_sub_ui($g, $t, 1);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return undef if ($g == $n);
            return $g;
        }
    }

    return undef;
}

sub pollard_pm1_factorial_find_factor ($n, $bound2) {

    # Pollard p-1 method (factorial).

    my $bound1 = 1e5;

    state %cache;

    my $g = Math::GMPz::Rmpz_init();
    my $t = Math::GMPz::Rmpz_init_set_ui(random_prime(1e6));

    if (exists $cache{$n}) {
        $t      = $cache{$n}{value};
        $bound1 = $cache{$n}{bound};
    }
    else {
        foreach my $k (2 .. $bound1) {

            Math::GMPz::Rmpz_powm_ui($t, $t, $k, $n);
            Math::GMPz::Rmpz_sub_ui($g, $t, 1);
            Math::GMPz::Rmpz_gcd($g, $g, $n);

            if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
                return undef if ($g == $n);
                return $g;
            }
        }
    }

    while ($bound1 >= $bound2) {
        $bound2 *= 2;
    }

    foreach my $p (sieve_primes($bound1, $bound2)) {

        Math::GMPz::Rmpz_powm_ui($t, $t, $p, $n);
        Math::GMPz::Rmpz_sub_ui($g, $t, 1);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return undef if ($g == $n);
            return $g;
        }
    }

    $cache{$n}{value} = $t;
    $cache{$n}{bound} = $bound2 + 1;

    return undef;
}

sub pollard_rho_find_factor ($n, $max_iter) {

    # Pollard rho method, using the polynomial:
    #   f(x) = x^2 - 1, with x_0 = 1+floor(log_2(n)).

    state %cache;

    my $u = logint($n, 2) + 1;
    my $x = Math::GMPz::Rmpz_init_set_ui($u);
    my $y = Math::GMPz::Rmpz_init_set_ui($u * $u - 1);

    if (exists $cache{$n}) {
        $x = $cache{$n}{x};
        $y = $cache{$n}{y};
    }

    my $g = Math::GMPz::Rmpz_init();

    for (1 .. $max_iter) {

        # f(x) = x^2 - 1
        Math::GMPz::Rmpz_powm_ui($x, $x, 2, $n);
        Math::GMPz::Rmpz_sub_ui($x, $x, 1);

        # f(f(x)) = (x^2 - 1)^2 - 1 = (x^2 - 2) * x^2
        Math::GMPz::Rmpz_powm_ui($g, $y, 2, $n);
        Math::GMPz::Rmpz_sub_ui($y, $g, 2);
        Math::GMPz::Rmpz_mul($y, $y, $g);

        Math::GMPz::Rmpz_sub($g, $x, $y);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0) {
            return undef if ($g == $n);
            return $g;
        }
    }

    $cache{$n}{x} = $x;
    $cache{$n}{y} = $y;

    return undef;
}

sub pollard_pm1_ntheory_factor ($n, $max_iter) {
    my ($p, $q) = Math::Prime::Util::GMP::pminus1_factor($n, $max_iter);
    return $p if defined($q);
    return pollard_pm1_factorial_find_factor($n, $max_iter);
}

sub williams_pp1_ntheory_factor ($n, $max_iter) {
    my ($p, $q) = Math::Prime::Util::GMP::pplus1_factor($n, $max_iter);
    return $p if defined($q);
    return undef;
}

sub pollard_rho_ntheory_factor ($n, $max_iter) {
    my ($p, $q) =
        (rand(1) < 0.5)
      ? (Math::Prime::Util::GMP::prho_factor($n, $max_iter))
      : (Math::Prime::Util::GMP::pbrent_factor($n, $max_iter));
    return $p if defined($q);
    return pollard_rho_find_factor($n, $max_iter >> 1);
}

sub pollard_rho_sqrt_find_factor ($n, $max_iter) {

    # Pollard rho method, using the polynomial:
    #   f(x) = x^2 + c
    #
    # where
    #   c = floor(sqrt(n)) - (floor(sqrt(n))^2 - n)
    #   c = n + s - s^2, with s = floor(sqrt(n))
    #
    # and
    #   x_0 = 3^2 + c

    my $s = Math::GMPz->new(sqrtint($n));
    my $c = $n + $s - $s * $s;

    my $a0 = 3;
    my $a1 = ($a0 * $a0 + $c);
    my $a2 = ($a1 * $a1 + $c);

    my $g = Math::GMPz::Rmpz_init();

    for (1 .. $max_iter) {

        Math::GMPz::Rmpz_sub($g, $a2, $a1);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) != 0) {
            return undef if ($g == $n);
            return $g;
        }

        Math::GMPz::Rmpz_powm_ui($a1, $a1, 2, $n);
        Math::GMPz::Rmpz_add($a1, $a1, $c);

        Math::GMPz::Rmpz_powm_ui($a2, $a2, 2, $n);
        Math::GMPz::Rmpz_add($a2, $a2, $c);

        Math::GMPz::Rmpz_powm_ui($a2, $a2, 2, $n);
        Math::GMPz::Rmpz_add($a2, $a2, $c);
    }

    return undef;
}

sub pollard_rho_exp_find_factor ($n, $max_iter) {

    my $B = logint($n, 5)**2;

    if ($B > 50_000) {
        $B = 50_000;
    }

    my $e = Math::GMPz::Rmpz_init_set_str(consecutive_integer_lcm($B), 10);
    my $c = 2 * $e - 1;

    my $x = Math::GMPz::Rmpz_init_set_ui(1);
    my $y = Math::GMPz::Rmpz_init();
    my $g = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_powm($x, $x, $e, $n);
    Math::GMPz::Rmpz_add($x, $x, $c);
    Math::GMPz::Rmpz_mod($x, $x, $n);

    Math::GMPz::Rmpz_powm($y, $x, $e, $n);
    Math::GMPz::Rmpz_add($y, $y, $c);
    Math::GMPz::Rmpz_mod($y, $y, $n);

    for (1 .. $max_iter) {

        Math::GMPz::Rmpz_powm($x, $x, $e, $n);
        Math::GMPz::Rmpz_add($x, $x, $c);
        Math::GMPz::Rmpz_mod($x, $x, $n);

        Math::GMPz::Rmpz_powm($y, $y, $e, $n);
        Math::GMPz::Rmpz_add($y, $y, $c);
        Math::GMPz::Rmpz_mod($y, $y, $n);

        Math::GMPz::Rmpz_powm($y, $y, $e, $n);
        Math::GMPz::Rmpz_add($y, $y, $c);
        Math::GMPz::Rmpz_mod($y, $y, $n);

        Math::GMPz::Rmpz_sub($g, $x, $y);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);
            return $g;
        }
    }

    return undef;
}

sub phi_finder_factor ($n, $max_iter) {

    # Phi-finder algorithm for semiprimes, due to Kyle Kloster (2010)

    my $E  = $n - 2 * Math::GMPz->new(sqrtint($n)) + 1;
    my $E0 = Math::GMPz->new(powmod(2, -$E, $n));

    my $L = logint($n, 2);
    my $i = 0;

    # Repeat until E0 is a power of 2
    while (Math::GMPz::Rmpz_popcount($E0) != 1) {
        Math::GMPz::Rmpz_mul_2exp($E0, $E0, $L);
        Math::GMPz::Rmpz_mod($E0, $E0, $n);
        return undef if (++$i > $max_iter);
    }

    my $t = 0;

    foreach my $k (0 .. $L) {
        if (Math::GMPz->new(powmod(2, $k, $n)) == $E0) {
            $t = $k;
            last;
        }
    }

    my $phi = abs($i * $L - $E - $t);

    my $q = ($n - $phi + 1);
    my $p = ($q + Math::GMPz->new(sqrtint(abs($q * $q - 4 * $n)))) >> 1;

    (($n % $p) == 0) ? $p : undef;
}

sub FLT_find_factor ($n, $base = 2, $reps = 1e4) {

    # Find a prime factor of n if all the prime factors of n are close to each other.
    # Inpsired by Fermat's little theorem.

    state $z = Math::GMPz::Rmpz_init_nobless();
    state $t = Math::GMPz::Rmpz_init_nobless();

    my $g = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_set_ui($t, $base);
    Math::GMPz::Rmpz_set_ui($z, $base);

    Math::GMPz::Rmpz_powm($z, $z, $n, $n);

    # Cannot factor Fermat pseudoprimes
    if (Math::GMPz::Rmpz_cmp_ui($z, $base) == 0) {
        return undef;
    }

    my $multiplier = $base * $base;

    for (my $k = 1 ; $k <= $reps ; $k += 1) {

        Math::GMPz::Rmpz_mul_ui($t, $t, $multiplier);
        Math::GMPz::Rmpz_mod($t, $t, $n) if ($k % 10 == 0);
        Math::GMPz::Rmpz_sub($g, $z, $t);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0) {
            return undef if (Math::GMPz::Rmpz_cmp($g, $n) == 0);
            return $g;
        }
    }

    return undef;
}

sub sophie_germain_factor ($n) {

    # A simple factorization method, based on Sophie Germain's identity:
    #   x^4 + 4y^4 = (x^2 + 2xy + 2y^2) * (x^2 - 2xy + 2y^2)

    # This method is also effective for numbers of the form: n^4 + 4^(2k+1).

    state $w = Math::GMPz::Rmpz_init_nobless();
    state $z = Math::GMPz::Rmpz_init_nobless();

    my $sophie_germain_decomposition = sub ($n) {

        state $t = Math::GMPz::Rmpz_init();
        state $u = Math::GMPz::Rmpz_init();

        Math::GMPz::Rmpz_root($t, $n, 4);
        Math::GMPz::Rmpz_pow_ui($w, $t, 4);
        Math::GMPz::Rmpz_sub($u, $n, $w);
        Math::GMPz::Rmpz_div_2exp($u, $u, 2);

        if (Math::GMPz::Rmpz_root($u, $u, 4)) {

            # n = t^4 + 4*u^4
            Math::GMPz::Rmpz_pow_ui($z, $u, 4);
            Math::GMPz::Rmpz_mul_2exp($z, $z, 2);
            Math::GMPz::Rmpz_add($w, $w, $z);

            if (Math::GMPz::Rmpz_cmp($w, $n) == 0) {
                say "[*] Sophie Germain form detected: $t^4 + 4*$u^4";
                return ($t, $u);
            }
        }

        Math::GMPz::Rmpz_mul_2exp($t, $n, 2);
        Math::GMPz::Rmpz_root($t, $t, 4);
        Math::GMPz::Rmpz_div_2exp($t, $t, 1);
        Math::GMPz::Rmpz_pow_ui($z, $t, 4);
        Math::GMPz::Rmpz_mul_2exp($z, $z, 2);
        Math::GMPz::Rmpz_sub($u, $n, $z);

        if (Math::GMPz::Rmpz_root($u, $u, 4)) {

            # n = u^4 + 4*t^4
            Math::GMPz::Rmpz_pow_ui($w, $u, 4);
            Math::GMPz::Rmpz_add($w, $w, $z);

            if (Math::GMPz::Rmpz_cmp($w, $n) == 0) {
                say "[*] Sophie Germain form detected: $u^4 + 4*$t^4";
                return ($u, $t);
            }
        }

        return;
    };

    my ($x, $y) = $sophie_germain_decomposition->($n);

    if (!defined($x) or !defined($y)) {
        return undef;
    }

    my $p = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_mul($w, $x, $y);
    Math::GMPz::Rmpz_mul_2exp($w, $w, 1);
    Math::GMPz::Rmpz_mul($z, $x, $x);
    Math::GMPz::Rmpz_sub($p, $z, $w);
    Math::GMPz::Rmpz_mul($w, $y, $y);
    Math::GMPz::Rmpz_mul_2exp($w, $w, 1);
    Math::GMPz::Rmpz_add($p, $p, $w);

    return $p;
}

{
    state $state = Math::GMPz::zgmp_randinit_mt_nobless();
    Math::GMPz::zgmp_randseed_ui($state, scalar srand());

    sub MBE_find_factor ($n, $max_k = 1000) {

        my $t = Math::GMPz::Rmpz_init();
        my $g = Math::GMPz::Rmpz_init();

        my $a = Math::GMPz::Rmpz_init();
        my $b = Math::GMPz::Rmpz_init();
        my $c = Math::GMPz::Rmpz_init();

        foreach my $k (1 .. $max_k) {

            # Deterministic version
            # Math::GMPz::Rmpz_div_ui($t, $n, $k+1);

            # Randomized version
            Math::GMPz::Rmpz_urandomm($t, $state, $n, 1);

            Math::GMPz::Rmpz_set($a, $t);
            Math::GMPz::Rmpz_set($b, $t);
            Math::GMPz::Rmpz_set_ui($c, 1);

            foreach my $i (0 .. Math::GMPz::Rmpz_sizeinbase($b, 2) - 1) {

                if (Math::GMPz::Rmpz_tstbit($b, $i)) {

                    Math::GMPz::Rmpz_powm($c, $a, $c, $n);
                    Math::GMPz::Rmpz_sub_ui($g, $c, 1);
                    Math::GMPz::Rmpz_gcd($g, $g, $n);

                    if (Math::GMPz::Rmpz_cmp_ui($g, 1) > 0 and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                        return $g;
                    }
                }

                Math::GMPz::Rmpz_powm($a, $a, $a, $n);
            }
        }

        return undef;
    }
}

sub fermat_find_factor ($n, $max_iter) {

    # Fermat's factorization method, trying to represent `n` as a difference of two squares:
    #   n = a^2 - b^2, where n = (a-b) * (a+b).

    my $p = Math::GMPz::Rmpz_init();    # p = floor(sqrt(n))
    my $q = Math::GMPz::Rmpz_init();    # q = p^2 - n

    Math::GMPz::Rmpz_sqrtrem($p, $q, $n);
    Math::GMPz::Rmpz_neg($q, $q);

    for (my $j = 1 ; $j <= $max_iter ; ++$j) {

        Math::GMPz::Rmpz_addmul_ui($q, $p, 2);

        Math::GMPz::Rmpz_add_ui($q, $q, 1);
        Math::GMPz::Rmpz_add_ui($p, $p, 1);

        if (Math::GMPz::Rmpz_perfect_square_p($q)) {
            Math::GMPz::Rmpz_sqrt($q, $q);

            my $r = Math::GMPz::Rmpz_init();
            Math::GMPz::Rmpz_sub($r, $p, $q);

            return $r;
        }
    }

    return undef;
}

sub holf_ntheory_find_factor ($n, $max_iter) {
    my ($p, $q) = Math::Prime::Util::GMP::holf_factor($n, $max_iter);
    return $p if defined($q);
    return undef;
}

sub holf_find_factor ($n, $max_iter) {

    # Hart’s One-Line Factoring Algorithm

    my $m = Math::GMPz::Rmpz_init();
    my $s = Math::GMPz::Rmpz_init();

    foreach my $i (1 .. $max_iter) {

        Math::GMPz::Rmpz_mul_ui($s, $n, 4 * $i);
        Math::GMPz::Rmpz_sqrt($s, $s);
        Math::GMPz::Rmpz_add_ui($s, $s, 1);

        Math::GMPz::Rmpz_mul($m, $s, $s);
        Math::GMPz::Rmpz_mod($m, $m, $n);

        if (Math::GMPz::Rmpz_perfect_square_p($m)) {

            Math::GMPz::Rmpz_sqrt($m, $m);
            Math::GMPz::Rmpz_sub($m, $s, $m);
            Math::GMPz::Rmpz_gcd($m, $m, $n);

            if (    Math::GMPz::Rmpz_cmp_ui($m, 1) > 0
                and Math::GMPz::Rmpz_cmp($m, $n) < 0) {
                return $m;
            }
        }
    }

    return undef;
}

sub ecm_find_factor ($n, $B1, $ncurves) {
    my ($p, $q) = Math::Prime::Util::GMP::ecm_factor($n, $B1, $ncurves);
    return $p if defined($q);
    return undef;
}

sub miller_rabin_factor ($n, $tries) {

    # Miller-Rabin factorization method.
    # https://en.wikipedia.org/wiki/Miller%E2%80%93Rabin_primality_test

    my $D = $n - 1;
    my $s = Math::GMPz::Rmpz_scan1($D, 0);
    my $r = $s - 1;
    my $d = $D >> $s;

    if ($s > 20 and $tries > 10) {
        $tries = 1 + int(2 * (100 / $s));
    }

    my $x = Math::GMPz::Rmpz_init();
    my $g = Math::GMPz::Rmpz_init();

    for (1 .. $tries) {

        my $p = random_prime(1e7);
        Math::GMPz::Rmpz_powm($x, Math::GMPz::Rmpz_init_set_ui($p), $d, $n);

        foreach my $k (0 .. $r) {

            last if (Math::GMPz::Rmpz_cmp_ui($x, 1) == 0);
            last if (Math::GMPz::Rmpz_cmp($x, $D) == 0);

            foreach my $i (1, -1) {
                Math::GMPz::Rmpz_gcd($g, $x + $i, $n);
                if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0
                    and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                    return $g;
                }
            }

            Math::GMPz::Rmpz_powm_ui($x, $x, 2, $n);
        }
    }

    return undef;
}

sub lucas_miller_factor ($n, $j, $tries) {

    # Lucas-Miller factorization method.

    my $D = $n + $j;
    my $s = Math::GMPz::Rmpz_scan1($D, 0);
    my $r = $s;
    my $d = $D >> $s;

    $d = Math::GMPz::Rmpz_get_str($d, 10);

    if ($s > 10 and $tries > 5) {
        $tries //= 1 + int(100 / $s);
    }

    my $g = Math::GMPz::Rmpz_init();

    foreach my $i (1 .. $tries) {

        my $P = 1 + int(rand(1e6));
        my $Q = 1 + int(rand(1e6));

        $Q *= -1 if (rand(1) < 0.5);

        next if is_square($P * $P - 4 * $Q);

        my ($U1, $V1, $Q1) =
          map { Math::GMPz::Rmpz_init_set_str($_, 10) } lucas_sequence($n, $P, $Q, $d);

        foreach my $k (1 .. $r) {

            foreach my $t ($U1, $V1, $P) {
                if (ref($t)) {
                    Math::GMPz::Rmpz_gcd($g, $t, $n);
                }
                else {
                    Math::GMPz::Rmpz_sub_ui($g, $V1, $t);
                    Math::GMPz::Rmpz_gcd($g, $g, $n);
                }
                if (    Math::GMPz::Rmpz_cmp_ui($g, 1) > 0
                    and Math::GMPz::Rmpz_cmp($g, $n) < 0) {
                    return $g;
                }
            }

            Math::GMPz::Rmpz_mul($U1, $U1, $V1);
            Math::GMPz::Rmpz_mod($U1, $U1, $n);
            Math::GMPz::Rmpz_powm_ui($V1, $V1, 2, $n);
            Math::GMPz::Rmpz_submul_ui($V1, $Q1, 2);
            Math::GMPz::Rmpz_powm_ui($Q1, $Q1, 2, $n);
        }
    }

    return undef;
}

sub pell_find_factor ($n, $max_iter) {

    # Simple version of the continued-fraction factorization method.
    # Efficient for numbers that have factors relatively close to sqrt(n)

    my $x = Math::GMPz::Rmpz_init();
    my $y = Math::GMPz::Rmpz_init();
    my $z = Math::GMPz::Rmpz_init_set_ui(1);

    my $t = Math::GMPz::Rmpz_init();
    my $w = Math::GMPz::Rmpz_init();
    my $r = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_sqrt($x, $n);
    Math::GMPz::Rmpz_set($y, $x);

    Math::GMPz::Rmpz_add($w, $x, $x);
    Math::GMPz::Rmpz_set($r, $w);

    my $f2 = Math::GMPz::Rmpz_init_set($x);
    my $f1 = Math::GMPz::Rmpz_init_set_ui(1);

    foreach my $k (1 .. $max_iter) {

        # y = r*z - y
        Math::GMPz::Rmpz_mul($t, $r, $z);
        Math::GMPz::Rmpz_sub($y, $t, $y);

        # z = (n - y*y) / z
        Math::GMPz::Rmpz_mul($t, $y, $y);
        Math::GMPz::Rmpz_sub($t, $n, $t);
        Math::GMPz::Rmpz_divexact($z, $t, $z);

        # r = (x + y) / z
        Math::GMPz::Rmpz_add($t, $x, $y);

        # Floor division: floor((x+y)/z)
        # Math::GMPz::Rmpz_div($r, $t, $z);

        # Round (x+y)/z to nearest integer
        Math::GMPz::Rmpz_set($r, $z);
        Math::GMPz::Rmpz_addmul_ui($r, $t, 2);
        Math::GMPz::Rmpz_div($r, $r, $z);
        Math::GMPz::Rmpz_div_2exp($r, $r, 1);

        # f1 = (f1 + r*f2) % n
        Math::GMPz::Rmpz_addmul($f1, $f2, $r);
        Math::GMPz::Rmpz_mod($f1, $f1, $n);

        # swap f1 with f2
        ($f1, $f2) = ($f2, $f1);

        if (Math::GMPz::Rmpz_perfect_square_p($z)) {
            my $g = Math::GMPz->new(gcd($f1 - Math::GMPz->new(sqrtint($z)), $n));

            if ($g > 1 and $g < $n) {
                return $g;
            }
        }

        last if ($z == 1);
    }

    return undef;
}

sub store_factor ($rem, $f, $factors) {

    $f || return;

    if (ref($f) ne 'Math::GMPz') {
        $f =~ /^[0-9]+\z/ or return;
        $f = Math::GMPz->new($f);
    }

    $f < $$rem or return;

    $$rem % $f == 0 or die 'error';

    if (is_prime($f)) {
        say("`-> prime factor: ", $f);
        $$rem = check_factor($$rem, $f, $factors);
    }
    else {
        say("`-> composite factor: ", $f);

        $$rem /= $f;

        # Try to find a small factor of f
        my $f_factor = find_small_factors($f, $factors);

        if ($f_factor < $f) {
            $$rem *= $f_factor;
        }
        else {

            # Use SIQS to factorize f
            find_prime_factors($f, $factors);

            foreach my $p (@$factors) {
                if ($$rem % $p == 0) {
                    $$rem = check_factor($$rem, $p, $factors);
                    last if $$rem == 1;
                }
            }
        }
    }

    return 1;
}

sub find_small_factors ($rem, $factors) {

    # Some special-purpose factorization methods to attempt to find small prime factors.
    # Collect the identified prime factors in the `$factors` array and return 1 if all
    # prime factors were found, or otherwise the remaining factor.

    my %state = (
                 cyclotomic_check     => 1,
                 fast_power_check     => 1,
                 fast_fibonacci_check => 1,
                );

    my $len = length($rem);

    my @factorization_methods = (

        sub {
            say "=> Sophie Germain method...";
            sophie_germain_factor($rem);
        },

        sub {
            say "=> Miller-Rabin method...";
            miller_rabin_factor($rem, ($len > 1000) ? 15 : MILLER_RABIN_ITERATIONS);
        },

        sub {
            if ($len < 3000) {
                say "=> Lucas-Miller method (n+1)...";
                lucas_miller_factor($rem, +1, ($len > 1000) ? 10 : LUCAS_MILLER_ITERATIONS);
            }
        },

        sub {
            if ($len < 3000) {
                say "=> Lucas-Miller method (n-1)...";
                lucas_miller_factor($rem, -1, ($len > 1000) ? 10 : LUCAS_MILLER_ITERATIONS);
            }
        },

        sub {
            say "=> Phi finder method...";
            phi_finder_factor($rem, PHI_FINDER_ITERATIONS);
        },

        sub {
            say "=> Fermat's method...";
            fermat_find_factor($rem, FERMAT_ITERATIONS);
        },

        sub {
            say "=> HOLF method...";
            holf_find_factor($rem, HOLF_ITERATIONS);
        },

        sub {
            say "=> HOLF method (ntheory)...";
            holf_ntheory_find_factor($rem, 2 * HOLF_ITERATIONS);
        },

        sub {
            say "=> Pell method...";
            pell_find_factor($rem, PELL_ITERATIONS);
        },

        sub {
            say "=> Pollard p-1 (20K)...";
            pollard_pm1_ntheory_factor($rem, 20_000);
        },

        sub {
            say "=> Fermat's little theorem (base 2)...";
            FLT_find_factor($rem, 2, ($len > 1000) ? 1e4 : FLT_ITERATIONS);
        },

        sub {
            my $len_2 = $len * (log(10) / log(2));
            my $iter  = ($len_2 * MBE_ITERATIONS > 1_000) ? int(1_000 / $len_2) : MBE_ITERATIONS;
            if ($iter > 0) {
                say "=> MBE method ($iter iter)...";
                MBE_find_factor($rem, $iter);
            }
        },

        sub {
            say "=> Fermat's little theorem (base 3)...";
            FLT_find_factor($rem, 3, ($len > 1000) ? 1e4 : FLT_ITERATIONS);
        },

        sub {
            $state{fast_fibonacci_check} || return undef;
            say "=> Fast Fibonacci check...";
            my $f = fast_fibonacci_factor($rem, 2 * logint($rem, 2));
            $f // do { $state{fast_fibonacci_check} = 0 };
            $f;
        },

        sub {
            $state{cyclotomic_check} || return undef;
            say "=> Fast cyclotomic check...";
            my $f = cyclotomic_factorization($rem);
            $f // do { $state{cyclotomic_check} = 0 };
            $f;
        },

        sub {
            say "=> Pollard rho (10M)...";
            pollard_rho_ntheory_factor($rem, int sqrt(1e10));
        },

        sub {
            say "=> Pollard p-1 (500K)...";
            pollard_pm1_ntheory_factor($rem, 500_000);
        },

        sub {
            say "=> ECM (600)...";
            ecm_find_factor($rem, 600, 20);
        },

        sub {
            say "=> Williams p±1 (500K)...";
            williams_pp1_ntheory_factor($rem, 500_000);
        },

        sub {
            if ($len < 1000) {
                say "=> Chebyshev p±1 (500K)...";
                chebyshev_factorization($rem, 500_000, int(rand(1e6)) + 2);
            }
        },

        sub {
            say "=> Williams p±1 (1M)...";
            williams_pp1_ntheory_factor($rem, 1_000_000);
        },

        sub {
            if ($len < 1000) {
                say "=> Chebyshev p±1 (1M)...";
                chebyshev_factorization($rem, 1_000_000, int(rand(1e6)) + 2);
            }
        },

        sub {
            say "=> ECM (2K)...";
            ecm_find_factor($rem, 2000, 10);
        },

        sub {
            $state{fast_power_check} || return undef;
            say "=> Fast power check...";
            my $f = fast_power_check($rem, 500);
            $f // do { $state{fast_power_check} = 0 };
            $f;
        },

        sub {
            if ($len < 500) {
                say "=> Fibonacci p±1 (500K)...";
                fibonacci_factorization($rem, 500_000);
            }
        },

        sub {
            say "=> Pollard rho (12M)...";
            pollard_rho_ntheory_factor($rem, int sqrt(1e12));
        },

        sub {
            say "=> Pollard p-1 (5M)...";
            pollard_pm1_factorial_find_factor($rem, 5_000_000);
        },

        sub {
            say "=> Williams p±1 (3M)...";
            williams_pp1_ntheory_factor($rem, 3_000_000);
        },

        sub {
            say "=> Pollard rho (13M)...";
            pollard_rho_ntheory_factor($rem, int sqrt(1e13));
        },

        sub {
            say "=> Williams p±1 (5M)...";
            williams_pp1_ntheory_factor($rem, 5_000_000);
        },

        sub {
            if ($len > 40) {
                say "=> ECM (160K)...";
                ecm_find_factor($rem, 160_000, 80);
            }
        },

        sub {
            if ($len > 40) {
                say "=> Pollard rho (14M)...";
                pollard_rho_ntheory_factor($rem, int sqrt(1e14));
            }
        },

        sub {
            say "=> Pollard p-1 (8M)...";
            pollard_pm1_ntheory_factor($rem, 8_000_000);
        },

        sub {
            if ($len < 150) {
                say "=> Pollard rho-exp...";
                pollard_rho_exp_find_factor($rem, ($len > 50 ? 2 : 1) * 200);
            }
        },

        sub {
            if ($len > 50) {
                say "=> Pollard p-1 (10M)...";
                pollard_pm1_factorial_find_factor($rem, 10_000_000);
            }
        },

        sub {
            if ($len > 50) {
                say "=> Williams p±1 (10M)...";
                williams_pp1_ntheory_factor($rem, 10_000_000);
            }
        },

        sub {
            if ($len > 70) {
                say "=> Pollard rho (15M)...";
                pollard_rho_ntheory_factor($rem, int sqrt(1e15));
            }
        },

        sub {
            if ($len > 70) {
                say "=> Pollard p-1 (20M)...";
                pollard_pm1_factorial_find_factor($rem, 20_000_000);
            }
        },

        sub {
            if ($len > 70) {
                say "=> Williams p±1 (20M)...";
                williams_pp1_ntheory_factor($rem, 20_000_000);
            }
        },

        sub {
            if ($len > 70) {
                say "=> Pollard rho-exp...";
                pollard_rho_exp_find_factor($rem, 1000);
            }
        },

        sub {
            if ($len > 70) {
                say "=> Pollard rho (16M)...";
                pollard_rho_ntheory_factor($rem, int sqrt(1e16));
            }
        },

        sub {
            if ($len > 70) {
                say "=> Pollard p-1 (50M)...";
                pollard_pm1_factorial_find_factor($rem, 50_000_000);
            }
        },

        sub {
            if ($len > 70) {
                say "=> Pollard p+1 (50M)...";
                williams_pp1_ntheory_factor($rem, 50_000_000);
            }
        },

        sub {
            if ($len > 70) {
                say "=> Pollard rho (16M)...";
                pollard_rho_ntheory_factor($rem, int sqrt(1e16));
            }
        },
    );

  MAIN_LOOP: for (; ;) {

        if ($rem <= 1) {
            last;
        }

        if (is_prime($rem)) {
            push @$factors, $rem;
            $rem = 1;
            last;
        }

        $len = length($rem);

        if ($len >= 25 and $len <= 35) {    # factorize with SIQS directly
            return $rem;
        }

        printf("\n[*] Factoring %s (%s digits)...\n\n", ($len > MASK_LIMIT ? "C$len" : $rem), $len);

        say "=> Perfect power check...";

        if (defined(my $f = check_perfect_power($rem))) {
            my $exp = 1;

            for (my $t = $f ; $t < $rem ; ++$exp) {
                $t *= $f;
            }

            my @r = (is_prime($f) ? $f : factorize($f));
            push(@$factors, (@r) x $exp);
            return 1;
        }

        my $end = $#factorization_methods;

        for (my $i = 0 ; $i <= $end ; ++$i) {

            my $code = $factorization_methods[$i];
            my $f    = $code->();

            if (store_factor(\$rem, $f, $factors)) {

                # Move the successful factorization method at the top
                unshift(@factorization_methods, splice(@factorization_methods, $i, 1));

                next MAIN_LOOP;
            }
            else {

                # Move the unsuccessful factorization method at the bottom
                push @factorization_methods, splice(@factorization_methods, $i, 1);
                --$i;
                --$end;
            }
        }

        last;
    }

    return $rem;
}

sub check_perfect_power ($n) {

    # Check whether n is a perfect and return its perfect root.
    # Returns undef otherwise.

    if ((my $exp = is_power($n)) > 1) {
        my $root = Math::GMPz->new(rootint($n, $exp));
        say "`-> perfect power: $root^$exp";
        return $root;
    }

    return undef;
}

sub find_prime_factors ($n, $factors) {

    # Return one or more prime factors of the given number n. Assume
    # that n is not a prime and does not have very small factors.

    my %factors;

    if (defined(my $root = check_perfect_power($n))) {
        $factors{$root} = $root;
    }
    else {
        my $digits = length($n);

        say("\n[*] Using SIQS to factorize" . " $n ($digits digits)...\n");

        my $nf = siqs_choose_nf($n);
        my @sf = siqs_factorize($n, $nf);

        @factors{@sf} = @sf;
    }

    foreach my $f (values %factors) {
        find_all_prime_factors($f, $factors);
    }
}

sub find_all_prime_factors ($n, $factors) {

    # Return all prime factors of the given number n.
    # Assume that n does not have very small factors.

    if (!ref($n)) {
        $n = Math::GMPz->new($n);
    }

    my $rem = $n;

    while ($rem > 1) {

        if (is_prime($rem)) {
            push @$factors, $rem;
            last;
        }

        my @new_factors;
        find_prime_factors($rem, \@new_factors);

        foreach my $f (@new_factors) {

            $rem != $f     or die 'error';
            $rem % $f == 0 or die 'error';
            is_prime($f)   or die 'error';

            $rem = check_factor($rem, $f, $factors);

            last if ($rem == 1);
        }
    }
}

sub special_form_factorization ($n) {

    my %seen_divisor;
    my @near_power_params;
    my @diff_powers_params;
    my @cong_powers_params;
    my @sophie_params;

    #
    ## Close to a perfect power
    #

    my $near_power = sub ($r, $e, $k) {
        my @factors;

        foreach my $d (divisors($e)) {
            my $x = $r**$d;
            foreach my $j (1, -1) {

                my $t = $x - $k * $j;
                my $g = Math::GMPz->new(gcd($t, $n));

                if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {
                    push @factors, $g;
                }
            }
        }

        @factors;
    };

    foreach my $j (1 .. NEAR_POWER_ITERATIONS) {
        foreach my $k (1, -1) {
            my $u = $k * $j * $j;

            if ($n + $u > 0) {
                if (my $e = is_power($n + $u)) {
                    my $r = Math::GMPz->new(rootint($n + $u, $e));
                    say "[*] Near power detected: $r^$e ", sprintf("%s %s", ($k == 1) ? ('-', $u) : ('+', -$u));
                    push @near_power_params, [$r, $e, $j];
                }
            }
        }
    }

    #
    ## Difference of powers
    #

    my $diff_powers = sub ($r1, $e1, $r2, $e2) {
        my @factors;

        my @d1 = divisors($e1);
        my @d2 = divisors($e2);

        foreach my $d1 (@d1) {
            my $x = $r1**$d1;
            foreach my $d2 (@d2) {
                my $y = $r2**$d2;
                foreach my $j (1, -1) {

                    my $t = $x - $j * $y;
                    my $g = Math::GMPz->new(gcd($t, $n));

                    if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {
                        push @factors, $g;
                    }
                }
            }
        }

        @factors;
    };

    my $diff_power_check = sub ($r1, $e1) {

        my $u  = $r1**$e1;
        my $dx = abs($u - $n);

        if (Math::GMPz::Rmpz_perfect_power_p($dx)) {

            my $e2 = is_power($dx) || 1;
            my $r2 = Math::GMPz->new(rootint($dx, $e2));

            if ($u > $n) {
                say "[*] Difference of powers detected: ", sprintf("%s^%s - %s^%s", $r1, $e1, $r2, $e2);
            }
            else {
                say "[*] Sum of powers detected: ", sprintf("%s^%s + %s^%s", $r1, $e1, $r2, $e2);

                # Sophie Germain's identity:
                #   n^4 + 4^(2k+1) = n^4 + 4*(4^(2k)) = n^4 + 4*((2^k)^4)

                if ($r1 == 4 and ($e1 % 2 == 1) and $e2 == 4) {    # n = r1^(2k+1) + r2^4
                    push @sophie_params, [$r2, Math::GMPz->new(rootint($r1**($e1 - 1), 4))];
                }

                if ($r2 == 4 and ($e2 % 2 == 1) and $e1 == 4) {    # n = r2^(2k+1) + r1^4
                    push @sophie_params, [$r1, Math::GMPz->new(rootint($r2**($e2 - 1), 4))];
                }
            }

            push @diff_powers_params, [$r1, $e1, $r2, $e2];
        }
    };

    # Sum and difference of powers of the form a^k ± b^k, where a and b are small.
    foreach my $r1 (reverse 2 .. logint($n, 2)) {

        my $t = logint($n, $r1);

        $diff_power_check->(Math::GMPz->new($r1), $t);        # sum of powers
        $diff_power_check->(Math::GMPz->new($r1), $t + 1);    # difference of powers
    }

    # Sum and difference of powers of the form a^k ± b^k, where a and b are large.
    foreach my $e1 (reverse 2 .. logint($n, 2)) {

        my $t = Math::GMPz->new(rootint($n, $e1));

        $diff_power_check->($t,     $e1);                     # sum of powers
        $diff_power_check->($t + 1, $e1);                     # difference of powers
    }

    #
    ## Congruence of powers
    #

    my $cong_powers = sub ($r, $e1, $k, $e2) {

        my @factors;

        my @divs1 = divisors($e1);
        my @divs2 = divisors($e2);

        foreach my $d1 (@divs1) {
            my $x = $r**$d1;
            foreach my $d2 (@divs2) {
                my $y = $k**$d2;
                foreach my $j (-1, 1) {

                    my $t = $x - $j * $y;
                    my $g = Math::GMPz->new(gcd($t, $n));

                    if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {

                        if ($r == $k) {
                            say "[*] Congruence of powers: a^$d1 == b^$d2 (mod n) -> $g";
                        }
                        else {
                            say "[*] Congruence of powers: $r^$d1 == $k^$d2 (mod n) -> $g";
                        }

                        push @factors, $g;
                    }
                }
            }
        }

        @factors;
    };

    my @congrunce_range = reverse(2 .. 64);

    my $process_congruence = sub ($root, $e) {

        for my $j (1, 0) {

            my $k = $root + $j;
            my $u = Math::GMPz::Rmpz_init();

            ref($k)
              ? Math::GMPz::Rmpz_set($u, $k)
              : Math::GMPz::Rmpz_set_ui($u, $k);

            Math::GMPz::Rmpz_powm_ui($u, $u, $e, $n);

            foreach my $z ($u, $n - $u) {
                if (Math::GMPz::Rmpz_perfect_power_p($z)) {
                    my $t = is_power($z) || 1;

                    my $r1 = rootint($z, $t);
                    my $r2 = rootint($z, $e);

                    push @cong_powers_params, [Math::GMPz->new($r1), $t, Math::GMPz->new($k), $e];
                    push @cong_powers_params, [Math::GMPz->new($r2), $e, Math::GMPz->new($k), $e];
                }
            }
        }
    };

    for my $e (@congrunce_range) {
        my $root = Math::GMPz->new(rootint($n, $e));
        $process_congruence->($root, $e);
    }

    for my $root (@congrunce_range) {
        my $e = Math::GMPz->new(logint($n, $root));
        $process_congruence->($root, $e);
    }

    # Sophie Germain's identity
    # x^4 + 4y^4 = (x^2 + 2xy + 2y^2) * (x^2 - 2xy + 2y^2)
    my $sophie = sub ($A, $B) {
        my @factors;

        foreach my $f (
#<<<
            $A*$A + (($B*$B)<<1) - (($A*$B<<1)),
            $A*$A + (($B*$B)<<1) + (($A*$B)<<1),
#>>>
          ) {
            my $g = Math::GMPz->new(gcd($f, $n));

            if ($g > TRIAL_DIVISION_LIMIT and $g < $n and !$seen_divisor{$g}++) {
                push @factors, $g;
            }
        }

        @factors;
    };

    my $sophie_check_root = sub ($r1) {
        {
            my $x  = 4 * $r1**4;
            my $dx = $n - $x;

            if (is_power($dx, 4)) {
                my $r2 = Math::GMPz->new(rootint($dx, 4));
                say "[*] Sophie Germain special form detected: $r2^4 + 4*$r1^4";
                push @sophie_params, [$r2, $r1];
            }

        }

        {
            my $y  = $r1**4;
            my $dy = $n - $y;

            if (($dy % 4 == 0) and is_power($dy >> 2, 4)) {
                my $r2 = Math::GMPz->new(rootint($dy >> 2, 4));
                say "[*] Sophie Germain special form detected: $r1^4 + 4*$r2^4";
                push @sophie_params, [$r1, $r2];
            }
        }
    };

    # Try to find n = x^4 + 4*y^4, for x or y small.
    foreach my $r1 (map { Math::GMPz->new($_) } 2 .. logint($n, 2)) {
        $sophie_check_root->($r1);
    }

    {    # Try to find n = x^4 + 4*y^4 for x and y close to floor(n/5)^(1/4).
        my $k = Math::GMPz->new(rootint($n / 5, 4));

        for my $j (0 .. 1000) {
            $sophie_check_root->($k + $j);
        }
    }

    my @divisors;

    foreach my $args (@near_power_params) {
        push @divisors, $near_power->(@$args);
    }

    foreach my $args (@diff_powers_params) {
        push @divisors, $diff_powers->(@$args);
    }

    foreach my $args (@cong_powers_params) {
        push @divisors, $cong_powers->(@$args);
    }

    foreach my $args (@sophie_params) {
        push @divisors, $sophie->(@$args);
    }

    @divisors = sort { $a <=> $b } @divisors;

    my @factors;
    foreach my $d (@divisors) {
        my $g = Math::GMPz->new(gcd($n, $d));

        if ($g > TRIAL_DIVISION_LIMIT and $g < $n) {
            while ($n % $g == 0) {
                $n /= $g;
                push @factors, $g;
            }
        }
    }

    return sort { $a <=> $b } @factors;
}

sub verify_prime_factors ($n, $factors) {

    Math::GMPz->new(vecprod(@$factors)) == $n or die 'product of factors != n';

    foreach my $p (@$factors) {
        is_prime($p) or die "not prime detected: $p";
    }

    sort { $a <=> $b } @$factors;
}

sub fast_trial_factor ($n, $L = 1e5, $R = 1e6) {

    my @factors;
    my @P = sieve_primes(2, $L);

    my $g = Math::GMPz::Rmpz_init();
    my $t = Math::GMPz::Rmpz_init();

    while (1) {

        # say "L = $L with $#P";

        Math::GMPz::Rmpz_set_str($g, vecprod(@P), 10);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        # Early stop when n seems to no longer have small factors
        if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0) {
            last;
        }

        # Factorize n over primes in P
        foreach my $p (@P) {
            if (Math::GMPz::Rmpz_divisible_ui_p($g, $p)) {

                Math::GMPz::Rmpz_set_ui($t, $p);
                my $valuation = Math::GMPz::Rmpz_remove($n, $n, $t);
                push @factors, ($p) x $valuation;

                # Stop the loop early when no more primes divide `u` (optional)
                Math::GMPz::Rmpz_divexact_ui($g, $g, $p);
                last if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0);
            }
        }

        # Early stop when n has been fully factored
        if (Math::GMPz::Rmpz_cmp_ui($n, 1) == 0) {
            last;
        }

        # Early stop when the trial range has been exhausted
        if ($L > $R) {
            last;
        }

        @P = sieve_primes($L + 1, $L << 1);
        $L <<= 1;
    }

    return @factors;
}

sub factorize ($n) {

    # Factorize the given integer n >= 1 into its prime factors.

    my $orig = Math::GMPz::Rmpz_init_set($n);

    if ($n < 1) {
        die "Number needs to be an integer >= 1";
    }

    my $len = length($n);
    printf("\n[*] Factoring %s (%d digits)...\n", ($len > MASK_LIMIT ? "C$len" : $n), $len);

    return ()   if ($n <= 1);
    return ($n) if is_prime($n);

    if (my $e = is_power($n)) {
        my $root = Math::GMPz->new(rootint($n, $e));
        say "[*] Perfect power detected: $root^$e";
        my @factors = (is_prime($root) ? $root : factorize($root));
        return verify_prime_factors($n, [(@factors) x $e]);
    }

    my @divisors;

    if (defined(my $g = sophie_germain_factor($n))) {
        push @divisors, $g;
    }

    if (!@divisors) {
        push @divisors, (($n > ~0) ? special_form_factorization($n) : ());
    }

    if (!@divisors) {
        push @divisors, fast_trial_factor($n);
    }

    if (@divisors) {

        say "[*] Divisors found so far: ", join(', ', sort { $a <=> $b } @divisors);

        my @composite;
        my @factors;

        foreach my $d (@divisors) {
            $d > 1 or next;
            if (is_prime($d)) {
                push @factors, $d;
            }
            else {
                push @composite, $d;
            }
        }

        push @factors, map { factorize($_) } reverse @composite;
        my $rem = $orig / Math::GMPz->new(vecprod(@factors));

        if (is_prime($rem)) {
            push @factors, $rem;
        }
        elsif ($rem > 1) {
            push @factors, factorize($rem);
        }

        return verify_prime_factors($orig, \@factors);
    }

    my ($factors, $rem) = trial_division_small_primes($n);

    if (@$factors) {
        say "[*] Prime factors found so far: ", join(', ', @$factors);
    }
    else {
        say "[*] No small factors found...";
    }

    if ($rem != 1) {

        if (LOOK_FOR_SMALL_FACTORS) {
            say "[*] Trying to find more small factors...";
            $rem = find_small_factors($rem, $factors);
        }
        else {
            say "[*] Skipping the search for more small factors...";
        }

        if ($rem > 1) {
            find_all_prime_factors($rem, $factors);
        }
    }

    return verify_prime_factors($orig, $factors);
}

if (@ARGV) {
    my $n = eval { Math::GMPz->new($ARGV[0]) };

    if ($@) {    # evaluate the expression using PARI/GP
        chomp(my $str = `echo \Q$ARGV[0]\E | gp -q -f`);
        $n = Math::GMPz->new($str);
    }

    say "\nPrime factors: ", join(', ', factorize($n));
}
else {
    die "Usage: $0 \n";
}


================================================
FILE: Math/smallest_carmichael_divisible_by_n.pl
================================================
#!/usr/bin/perl

# Method for finding the smallest Carmichael number divisible by n.

# See also:
#   https://oeis.org/A135721
#   https://oeis.org/A253595

use 5.036;
use ntheory 0.74 qw(:all);

sub carmichael_from_multiple ($A, $B, $m, $L, $lo, $k, $callback) {

    # Largest possisble prime factor for Carmichael numbers <= B
    my $max_p = (1 + sqrtint(8 * $B + 1)) >> 2;

    my $hi = vecmin($max_p, rootint(divint($B, $m), $k));

    if ($lo > $hi) {
        return;
    }

    if ($k == 1) {

        $lo = vecmax($lo, cdivint($A, $m));
        $lo > $hi && return;

        my $t = invmod($m, $L) // return;
        $t > $hi && return;
        $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

        for (my $p = $t ; $p <= $hi ; $p += $L) {
            if ($m % $p != 0 and is_prime($p)) {
                my $n = $m * $p;
                if (($n - 1) % ($p - 1) == 0) {
                    $callback->($n);
                }
            }
        }

        return;
    }

    foreach my $p (@{primes($lo, $hi)}) {

        $m % $p == 0 and next;
        gcd($m, $p - 1) == 1 or next;

        __SUB__->($A, $B, $m * $p, lcm($L, $p - 1), $p + 1, $k - 1, $callback);
    }
}

sub carmichael_divisible_by ($m) {

    $m >= 1 or return;
    $m % 2 == 0 and return;
    is_square_free($m) || return;
    gcd($m, euler_phi($m)) == 1 or return;

    my $A = vecmax(561, $m);
    my $B = 2 * $A;

    my $L = vecmax(1, lcm(map { $_ - 1 } factor($m)));

    my @found;

    for (; ;) {
        for my $k ((is_prime($m) ? 2 : 1) .. 1000) {

            my @P;
            for (my $p = 3 ; scalar(@P) < $k ; $p = next_prime($p)) {
                if ($m % $p != 0 and $L % $p != 0) {
                    push @P, $p;
                }
            }

            last if (vecprod(@P, $m) > $B);

            my $callback = sub ($n) {
                push @found, $n;
                $B = vecmin($B, $n);
            };

            carmichael_from_multiple($A, $B, $m, $L, $P[0], $k, $callback);
        }

        last if @found;

        $A = $B + 1;
        $B = 2 * $A;
    }

    vecmin(@found);
}

carmichael_divisible_by(3) == 561             or die;
carmichael_divisible_by(3 * 5) == 62745       or die;
carmichael_divisible_by(7 * 19) == 1729       or die;
carmichael_divisible_by(47 * 89) == 62745     or die;
carmichael_divisible_by(5 * 47 * 89) == 62745 or die;
carmichael_divisible_by(3 * 47 * 89) == 62745 or die;
carmichael_divisible_by(3 * 89) == 62745      or die;

say join(', ', map { carmichael_divisible_by($_) } @{primes(3, 50)});
say join(', ', map { carmichael_divisible_by($_) } 1 .. 60);

__END__
561, 1105, 1729, 561, 1105, 561, 1729, 6601, 2465, 2821, 29341, 6601, 334153, 62745
561, 561, 1105, 1729, 561, 1105, 62745, 561, 1729, 6601, 2465, 2821, 561, 825265, 29341, 6601, 334153, 62745, 561, 2433601, 74165065


================================================
FILE: Math/smallest_k-gonal_inverse.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 08 March 2018
# https://github.com/trizen

# Given an integer `n`, find the smallest integer k>=3 such that `n` is a k-gonal number.

# Example:
#  a(12) = 5 since 12 is a pentagonal number, but not a square or triangular.

# See also:
#   https://oeis.org/A176774

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use ntheory qw(divisors);
use Math::AnyNum qw(:overload);

sub smallest_k_gonal_inverse ($n) {

    my @divisors = divisors(2 * $n);

    shift @divisors;
    pop @divisors;

    foreach my $d (reverse(@divisors)) {

        my $t = $d - 1;
        my $k = 2*$n / $d + 2*$d - 4;

        if ($k % $t == 0) {
            my $z = $k / $t;

            if ($z > 2 && $z < $n) {
                return $k / $t;
            }
        }
    }

    return $n;
}

foreach my $n (4000 .. 4030) {
    say "a($n) = ", smallest_k_gonal_inverse($n);
}


================================================
FILE: Math/smallest_k-gonal_inverse_brute_force.pl
================================================
#!/usr/bin/perl

# Given an integer `n`, find the smallest integer k>=3 such that `n` is a k-gonal number.

# Example:
#  a(12) = 5 since 12 is a pentagonal number, but not a square or triangular.

# Based on code by Chai Wah Wu.

# See also:
#   https://oeis.org/A176774

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload isqrt divmod ipolygonal_root polygonal);

sub polygonal_inverse ($n) {
    for (my $k = (isqrt(8 * $n + 1) - 1) >> 1 ; $k >= 2 ; --$k) {

        my ($x, $y) = divmod(
            2 * ($k * ($k - 2) + $n),
                 $k * ($k - 1)
        );

        return $x if $y == 0;
    }
}

foreach my $i (1 .. 31) {

    my $n = 2**$i + 1;
    my $k = polygonal_inverse($n);
    my $d = ipolygonal_root($n, $k);

    say "2^$i + 1 = P($d, $k)";

    die 'error' if $n != polygonal($d, $k);
}

__END__
2^1 + 1 = P(2, 3)
2^2 + 1 = P(2, 5)
2^3 + 1 = P(3, 4)
2^4 + 1 = P(2, 17)
2^5 + 1 = P(3, 12)
2^6 + 1 = P(5, 8)
2^7 + 1 = P(3, 44)
2^8 + 1 = P(2, 257)
2^9 + 1 = P(9, 16)
2^10 + 1 = P(5, 104)
2^11 + 1 = P(3, 684)
2^12 + 1 = P(17, 32)
2^13 + 1 = P(3, 2732)
2^14 + 1 = P(5, 1640)
2^15 + 1 = P(33, 64)
2^16 + 1 = P(2, 65537)
2^17 + 1 = P(3, 43692)
2^18 + 1 = P(65, 128)
2^19 + 1 = P(3, 174764)
2^20 + 1 = P(17, 7712)
2^21 + 1 = P(129, 256)
2^22 + 1 = P(5, 419432)
2^23 + 1 = P(3, 2796204)
2^24 + 1 = P(257, 512)
2^25 + 1 = P(33, 63552)
2^26 + 1 = P(5, 6710888)
2^27 + 1 = P(513, 1024)
2^28 + 1 = P(17, 1973792)
2^29 + 1 = P(3, 178956972)
2^30 + 1 = P(1025, 2048)
2^31 + 1 = P(3, 715827884)


================================================
FILE: Math/smallest_lucas-carmichael_divisible_by_n.pl
================================================
#!/usr/bin/perl

# Method for finding the smallest Lucas-Carmichael number divisible by n.

# See also:
#   https://oeis.org/A253597
#   https://oeis.org/A253598

use 5.036;
use ntheory 0.74 qw(:all);

sub lucas_carmichael_from_multiple ($A, $B, $m, $L, $lo, $k, $callback) {

    my $hi = vecmin(rootint(divint($B, $m), $k), sqrtint($B));

    if ($lo > $hi) {
        return;
    }

    if ($k == 1) {

        $lo = vecmax($lo, cdivint($A, $m));
        $lo > $hi && return;

        my $t = mulmod(invmod($m, $L) // (return), -1, $L);
        $t > $hi && return;
        $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

        for (my $p = $t ; $p <= $hi ; $p += $L) {
            if ($m % $p != 0 and is_prime($p)) {
                my $n = $m * $p;
                if (($n + 1) % ($p + 1) == 0) {
                    $callback->($n);
                }
            }
        }

        return;
    }

    foreach my $p (@{primes($lo, $hi)}) {

        $m % $p == 0 and next;
        gcd($m, $p + 1) == 1 or next;

        __SUB__->($A, $B, $m * $p, lcm($L, $p + 1), $p + 1, $k - 1, $callback);
    }
}

sub lucas_carmichael_divisible_by ($m) {

    $m >= 1 or return;
    $m % 2 == 0 and return;
    is_square_free($m) || return;
    gcd($m, divisor_sum($m)) == 1 or return;

    my $A = vecmax(399, $m);
    my $B = 2 * $A;

    my $L = vecmax(1, lcm(map { $_ + 1 } factor($m)));

    my @found;

    for (; ;) {
        for my $k ((is_prime($m) ? 2 : 1) .. 1000) {

            my @P;
            for (my $p = 3 ; scalar(@P) < $k ; $p = next_prime($p)) {
                if ($m % $p != 0 and $L % $p != 0) {
                    push @P, $p;
                }
            }

            last if (vecprod(@P, $m) > $B);

            my $callback = sub ($n) {
                push @found, $n;
                $B = vecmin($B, $n);
            };

            lucas_carmichael_from_multiple($A, $B, $m, $L, $P[0], $k, $callback);
        }

        last if @found;

        $A = $B + 1;
        $B = 2 * $A;
    }

    vecmin(@found);
}

lucas_carmichael_divisible_by(1) == 399      or die;
lucas_carmichael_divisible_by(3) == 399      or die;
lucas_carmichael_divisible_by(3 * 7) == 399  or die;
lucas_carmichael_divisible_by(7 * 19) == 399 or die;

say join(', ', map { lucas_carmichael_divisible_by($_) } @{primes(3, 50)});
say join(', ', map { lucas_carmichael_divisible_by($_) } 1 .. 100);

__END__
399, 935, 399, 935, 2015, 935, 399, 4991, 51359, 2015, 1584599, 20705, 5719, 18095
399, 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


================================================
FILE: Math/smallest_number_with_at_least_n_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 May 2021
# https://github.com/trizen

# Generate the smallest number that has at least n divisors.

# See also:
#   https://oeis.org/A061799 -- Smallest number with at least n divisors.

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(nth_prime);
use Math::AnyNum qw(:overload);

sub smallest_number_with_at_least_n_divisors ($threshold, $least_solution = Inf, $k = 1, $max_a = Inf, $sigma0 = 1, $n = 1) {

    if ($sigma0 >= $threshold) {
        return $n;
    }

    my $p = nth_prime($k);

    for (my $a = 1 ; $a <= $max_a ; ++$a) {
        $n *= $p;
        last if ($n > $least_solution);
        $least_solution = __SUB__->($threshold, $least_solution, $k + 1, $a, $sigma0 * ($a + 1), $n);
    }

    return $least_solution;
}

say smallest_number_with_at_least_n_divisors(60);      #=> 5040
say smallest_number_with_at_least_n_divisors(1000);    #=> 245044800


================================================
FILE: Math/smallest_number_with_n_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 May 2021
# https://github.com/trizen

# Generate the smallest number that has exactly n divisors.

# See also:
#   https://oeis.org/A005179 -- Smallest number with exactly n divisors.

use 5.020;
use warnings;
use experimental qw(signatures);

use ntheory qw(nth_prime);
use Math::AnyNum qw(:overload);

sub smallest_number_with_n_divisors ($threshold, $least_solution = Inf, $k = 1, $max_a = Inf, $sigma0 = 1, $n = 1) {

    if ($sigma0 == $threshold) {
        return $n;
    }

    if ($sigma0 > $threshold) {
        return $least_solution;
    }

    my $p = nth_prime($k);

    for (my $a = 1 ; $a <= $max_a ; ++$a) {
        $n *= $p;
        last if ($n > $least_solution);
        $least_solution = __SUB__->($threshold, $least_solution, $k + 1, $a, $sigma0 * ($a + 1), $n);
    }

    return $least_solution;
}

say smallest_number_with_n_divisors(60);      #=> 5040
say smallest_number_with_n_divisors(1000);    #=> 810810000


================================================
FILE: Math/smarandache_function.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 September 2016
# Website: https://github.com/trizen

# A decently efficient algorithm for computing the results of the Kempner-Smarandache function.

# See also: https://projecteuler.net/problem=549
#           https://en.wikipedia.org/wiki/Kempner_function
#           https://mathworld.wolfram.com/SmarandacheFunction.html

# ∑S(i) for 2 ≤ i ≤ 10^2 == 2012
# ∑S(i) for 2 ≤ i ≤ 10^6 == 64938007616
# ∑S(i) for 2 ≤ i ≤ 10^8 == 476001479068717

use utf8;
use 5.010;
use strict;
use warnings;

use ntheory qw(vecsum vecmax factor_exp factorialmod is_prime);

binmode(STDOUT, ':utf8');

my %cache;

sub smarandache {
    my ($n) = @_;

    return $n if is_prime($n);

    my @f = factor_exp($n);
    my $Ω = vecsum(map { $_->[1] } @f);

    (@f == $Ω)
      && return $f[-1][0];

    if (@f == 1) {

        my $ϕ = $f[0][0];

        ($Ω <= $ϕ)
          && return $ϕ * $Ω;

        exists($cache{$n})
          && return $cache{$n};

        my $m = $ϕ * $Ω;

        while (factorialmod($m - $ϕ, $n) == 0) {
            $m -= $ϕ;
        }

        return ($cache{$n} = $m);
    }

    vecmax(map { $_->[1] == 1 ? $_->[0] : smarandache($_->[0]**$_->[1]) } @f);
}

#
## Tests
#

#<<<
my @tests = (
    [40, 5],
    [72, 6],
    [1234, 617],
    [5224832089, 164],
    [688 * 2**15, 43],
    [891, 11],
    [704, 11],
);
#>>>

foreach my $test (@tests) {
    my ($n, $r) = @{$test};

    my $s = smarandache($n);

    say "S($n) = $s";

    if ($s != $r) {
        warn "\tHowever, that is incorrect! (expected: $r)";
    }
}

print "\n";

my $sum   = 0;
my $limit = 10**2;

for my $n (2 .. $limit) {
    $sum += smarandache($n);
}
say "∑S(i) for 2 ≤ i ≤ $limit == $sum";

if ($limit == 100 and $sum != 2012) {
    warn "However, that is incorrect (expected: 2012)!";
}


================================================
FILE: Math/smooth_numbers_generalized.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 06 March 2019
# https://github.com/trizen

# Generalized algorithm for generating numbers that are smooth over a set A of primes, below a given limit.

use 5.020;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use ntheory qw(:all);

sub check_valuation ($n, $p) {

    if ($p == 2) {
        return valuation($n, $p) < 5;
    }

    if ($p == 3) {
        return valuation($n, $p) < 3;
    }

    if ($p == 7) {
        return valuation($n, $p) < 3;
    }

    ($n % $p) != 0;
}

sub smooth_numbers ($limit, $primes) {

    my @h = (1);
    foreach my $p (@$primes) {

        say "Prime: $p";

        foreach my $n (@h) {
            if ($n * $p <= $limit and check_valuation($n, $p)) {
                push @h, $n * $p;
            }
        }
    }

    return \@h;
}

#
# Example for finding numbers `m` such that:
#     sigma(m) * phi(m) = n^k
# for some `n` and `k`, with `n > 1` and `k > 1`.
#
# See also: https://oeis.org/A306724
#

sub isok ($n) {
    is_power(Math::GMPz->new(divisor_sum($n)) * euler_phi($n));
}

my @smooth_primes;

foreach my $p (@{primes(4801)}) {

    if ($p == 2) {
        push @smooth_primes, $p;
        next;
    }

    my @f1 = factor($p - 1);
    my @f2 = factor($p + 1);

    if ($f1[-1] <= 7 and $f2[-1] <= 7) {
        push @smooth_primes, $p;
    }
}

my $h = smooth_numbers(10**15, \@smooth_primes);

say "\nFound: ", scalar(@$h), " terms";

my %table;

foreach my $n (@$h) {

    my $p = isok($n);

    if ($p >= 8) {
        say "a($p) = $n -> ", join(' * ', map { "$_->[0]^$_->[1]" } factor_exp($n));
        push @{$table{$p}}, $n;
    }
}

say '';

foreach my $k (sort { $a <=> $b } keys %table) {
    say "a($k) <= ", vecmin(@{$table{$k}});
}

__END__

# See: https://oeis.org/A306724

a(8) <= 498892319051
a(9) <= 14467877252479
a(10) <= 421652049419104
a(11) <= 12227909433154016
a(12) <= 377536703748630244
a(13) <= 926952707565364023467


================================================
FILE: Math/solutions_to_x_squared_equals_-1_mod_n.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 October 2017
# https://github.com/trizen

# Find all the positive solutions to the quadratic congruence: x^2 = -1 (mod n), where `n` is known.

# See also:
#   https://en.wikipedia.org/wiki/Quadratic_residue

use 5.010;
use strict;
use warnings;

use ntheory qw(sqrtmod factor_exp chinese mulmod forsetproduct);

sub solve_quadratic_congruence {
    my ($n) = @_;

    my %table;
    foreach my $f (factor_exp($n)) {
        my $pp = $f->[0]**$f->[1];
        my $r = sqrtmod($pp - 1, $pp) || return;
        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];
    }

    my %solutions;

    forsetproduct {
        undef $solutions{chinese(@_)};
    } values %table;

    return sort { $a <=> $b } keys %solutions;
}

foreach my $n (1 .. 1e5) {
    (my @solutions = solve_quadratic_congruence($n)) || next;

    say "x^2 = -1 (mod $n); x = { ", join(', ', @solutions), ' }';

    # Verify solutions
    foreach my $solution (@solutions) {
        if (mulmod($solution, $solution, $n) != $n - 1) {
            die "error for $n: $solution\n";
        }
    }
}

__END__
x^2 = -1 (mod 99850); x = { 29543, 46343, 53507, 70307 }
x^2 = -1 (mod 99853); x = { 4298, 34107, 65746, 95555 }
x^2 = -1 (mod 99857); x = { 316, 16054, 83803, 99541 }
x^2 = -1 (mod 99865); x = { 6763, 33183, 66682, 93102 }
x^2 = -1 (mod 99874); x = { 42617, 57257 }
x^2 = -1 (mod 99877); x = { 10118, 89759 }
x^2 = -1 (mod 99881); x = { 19913, 79968 }
x^2 = -1 (mod 99901); x = { 34569, 65332 }
x^2 = -1 (mod 99905); x = { 447, 4217, 14227, 17997, 20428, 24198, 34208, 37978, 61927, 65697, 75707, 79477, 81908, 85678, 95688, 99458 }
x^2 = -1 (mod 99914); x = { 48155, 51759 }
x^2 = -1 (mod 99917); x = { 17457, 19894, 80023, 82460 }
x^2 = -1 (mod 99929); x = { 28615, 71314 }
x^2 = -1 (mod 99937); x = { 6962, 11069, 88868, 92975 }
x^2 = -1 (mod 99961); x = { 37804, 62157 }
x^2 = -1 (mod 99965); x = { 5412, 45398, 54567, 94553 }
x^2 = -1 (mod 99970); x = { 707, 19287, 26853, 46847, 53123, 73117, 80683, 99263 }
x^2 = -1 (mod 99973); x = { 14119, 25170, 74803, 85854 }
x^2 = -1 (mod 99977); x = { 16545, 36384, 63593, 83432 }
x^2 = -1 (mod 99985); x = { 2302, 37692, 62293, 97683 }
x^2 = -1 (mod 99986); x = { 11031, 88955 }
x^2 = -1 (mod 99989); x = { 23040, 76949 }
x^2 = -1 (mod 99994); x = { 18245, 48879, 51115, 81749 }


================================================
FILE: Math/solutions_to_x_squared_equals_1_mod_n.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 03 October 2017
# https://github.com/trizen

# Find all the positive solutions to the quadratic congruence: x^2 = 1 (mod n), where `n` is known.

# See also:
#   https://projecteuler.net/problem=451
#   https://en.wikipedia.org/wiki/Quadratic_residue

use 5.010;
use strict;
use warnings;

use Test::More;

use ntheory qw(factor_exp chinese forsetproduct);

plan tests => 8;

sub solve_quadratic_congruence {
    my ($n) = @_;

    my %table;
    foreach my $f (factor_exp($n)) {
        my $pp = $f->[0]**$f->[1];

        if ($pp == 2) {
            push(@{$table{$pp}}, [1, $pp]);
        }
        elsif ($pp == 4) {
            push(@{$table{$pp}}, [1, $pp], [3, $pp]);
        }
        elsif ($pp % 2 == 0) {    # 2^k, where k >= 3
            push(@{$table{$pp}},
                [$pp / 2 - 1, $pp], [$pp - 1, $pp],
                [$pp / 2 + 1, $pp], [$pp + 1, $pp]);
        }
        else {                    # odd prime power
            push(@{$table{$pp}}, [1, $pp], [$pp - 1, $pp]);
        }
    }

    my @solutions;

    forsetproduct {
        push @solutions, chinese(@_);
    } values %table;

    return sort { $a <=> $b } @solutions;
}

is(join(' ', solve_quadratic_congruence(15)),   '1 4 11 14');
is(join(' ', solve_quadratic_congruence(77)),   '1 34 43 76');
is(join(' ', solve_quadratic_congruence(100)),  '1 49 51 99');
is(join(' ', solve_quadratic_congruence(175)),  '1 76 99 174');
is(join(' ', solve_quadratic_congruence(266)),  '1 113 153 265');
is(join(' ', solve_quadratic_congruence(299)),  '1 116 183 298');
is(join(' ', solve_quadratic_congruence(48)),   '1 7 17 23 25 31 41 47');
is(join(' ', solve_quadratic_congruence(1800)), '1 199 251 449 451 649 701 899 901 1099 1151 1349 1351 1549 1601 1799');

say "Solutions to x^2 = 1 (mod 5040): {", join(', ', solve_quadratic_congruence(5040)), '}';

__END__
Solutions 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}


================================================
FILE: Math/solutions_to_x_squared_equals_a_mod_n.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 October 2017
# https://github.com/trizen

# Find (almost) all the positive solutions to the quadratic congruence: x^2 = a (mod n), where `n` and `a` are known.

# For finding all the solutions for the special case `a = 1`, see:
#   https://github.com/trizen/perl-scripts/blob/master/Math/solutions_to_x%5E2%20=%201%20(mod%20n).pl

# For finding all the solutions to `x^2 = a (mod n)`, see:
#   https://github.com/trizen/sidef-scripts/blob/master/Math/square_root_modulo_n.sf
#   https://github.com/trizen/sidef-scripts/blob/master/Math/square_root_modulo_n_tonelli-shanks.sf

# See also:
#   https://en.wikipedia.org/wiki/Quadratic_residue

use 5.010;
use strict;
use warnings;

use ntheory qw(sqrtmod factor_exp chinese mulmod forsetproduct);

sub modular_square_root {
    my ($k, $n) = @_;

    my %table;
    foreach my $f (factor_exp($n)) {
        my $pp = $f->[0]**$f->[1];
        my $r = sqrtmod($k, $pp) || return;
        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];
    }

    my %solutions;

    forsetproduct {
        undef $solutions{chinese(@_)};
    } values %table;

    return sort { $a <=> $b } keys %solutions;
}

foreach my $n (2 .. 1000) {

    my $k = 1+int(rand($n));
    (my @solutions = modular_square_root($k, $n)) || next;

    say "x^2 = $k (mod $n); x = { ", join(', ', @solutions), ' }';

    # Verify solutions
    foreach my $solution (@solutions) {
        if (mulmod($solution, $solution, $n) != $k) {
            die "error for $n: $solution\n";
        }
    }
}

__END__
x^2 =  81 (mod 863); x = { 9, 854 }
x^2 = 459 (mod 865); x = { 247, 272, 593, 618 }
x^2 = 535 (mod 873); x = { 70, 124, 749, 803 }
x^2 = 685 (mod 877); x = { 135, 742 }
x^2 = 388 (mod 879); x = { 55, 238, 641, 824 }
x^2 = 441 (mod 883); x = { 21, 862 }
x^2 = 813 (mod 886); x = { 195, 691 }
x^2 =  83 (mod 887); x = { 227, 660 }
x^2 = 757 (mod 898); x = { 245, 653 }
x^2 = 848 (mod 907); x = { 162, 745 }
x^2 = 259 (mod 919); x = { 190, 729 }
x^2 = 121 (mod 929); x = { 11, 918 }
x^2 = 737 (mod 934); x = { 175, 759 }
x^2 = 509 (mod 935); x = { 38, 72, 302, 412, 523, 633, 863, 897 }
x^2 = 831 (mod 937); x = { 101, 836 }
x^2 = 511 (mod 939); x = { 220, 406, 533, 719 }
x^2 = 841 (mod 940); x = { 29, 159, 311, 441, 499, 629, 781, 911 }
x^2 = 427 (mod 941); x = { 380, 561 }
x^2 = 606 (mod 943); x = { 355, 424, 519, 588 }
x^2 = 865 (mod 954); x = { 127, 233, 721, 827 }
x^2 = 886 (mod 963); x = { 43, 385, 578, 920 }
x^2 = 142 (mod 967); x = { 143, 824 }
x^2 = 547 (mod 982); x = { 283, 699 }
x^2 = 563 (mod 983); x = { 386, 597 }
x^2 = 565 (mod 991); x = { 245, 746 }
x^2 = 866 (mod 997); x = { 350, 647 }


================================================
FILE: Math/solve_congruence_equation_example.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 24 August 2016
# License: GPLv3
# Website: https://github.com/trizen

# An example for how to solve a linear congruence equation.

# Solving for x in:
#    (10^5)x + 19541 = 0    (mod 19543)
#
# which is equivalent with:
#    (10^5)x = -19541       (mod 19543)

use 5.010;
use strict;
use warnings;

use ntheory qw(invmod);

my $k =  10**5;     # coefficient of x
my $r = -19541;     # congruent to this
my $m =  19543;     # modulo this number

say "x = ", (invmod($k, $m) * $r) % $m;


================================================
FILE: Math/solve_cubic_equation.pl
================================================
#!/usr/bin/perl

# Find all the solutions to a cubic equation.

# See also:
#   https://en.wikipedia.org/wiki/Cubic_equation#General_cubic_formula

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(:overload cbrt sgn);
use experimental qw(signatures);

sub solve_cubic_equation($a,$b,$c,$d) {

    my $D0 = ($b*$b - 3*$a*$c);
    my $D1 = (2*$b**3 - 9*$a*$b*$c + 27*$a*$a*$d);

    my @roots;
    my $z = (-1 + sqrt(-3))/2;

    my $C = cbrt(($D1 - (sgn($D0)||-1)*sqrt($D1*$D1 - 4*$D0**3))/2);

    foreach my $k (0..2) {
        my $t = ($C * $z**$k);
        my $x = -(($b + $t + $D0/$t))/(3*$a);
        push @roots, $x;
    }

    return @roots;
}

say ":: Solutions to: x^3 + 5*x^2 + 2*x - 8 = 0";
say for solve_cubic_equation(1, 5, 2, -8);

say "\n:: Solutions to: x^3 + 4*x^2 + 7*x + 6 = 0";
say for solve_cubic_equation(1, 4, 7, 6);

say "\n:: Solutions to: -36*x^3 + 8*x^2 - 82*x + 2850986 = 0:";
say for solve_cubic_equation(-36, 8, -82, 2850986);

say "\n:: Solutions to: 15*x^3 - 22*x^2 + 8*x - 7520940423059310542039581 = 0:";
say for solve_cubic_equation(15, -22, 8, -7520940423059310542039581);

__END__
:: Solutions to: x^3 + 5*x^2 + 2*x - 8 = 0
-4+2.12412254817660303603850719702361574078813940692e-58i
-2
1

:: Solutions to: x^3 + 4*x^2 + 7*x + 6 = 0
-2
-1-1.41421356237309504880168872420969807856967187538i
-1+1.41421356237309504880168872420969807856967187538i

:: Solutions to: -36*x^3 + 8*x^2 - 82*x + 2850986 = 0:
43
-21.3888888888888888888888888888888888888888888889+37.2053444322316098931489931056362914296357714346i
-21.3888888888888888888888888888888888888888888889-37.2053444322316098931489931056362914296357714346i

:: Solutions to: 15*x^3 - 22*x^2 + 8*x - 7520940423059310542039581 = 0:
-39721925.7666666666666666666666666666666666666667-68800394.4491263888002422566466396186371117612128i
79443853+7.88093052224943999146836047476866957980682147598e-51i
-39721925.7666666666666666666666666666666666666667+68800394.4491263888002422566466396186371117612128i


================================================
FILE: Math/solve_cubic_equation_real.pl
================================================
#!/usr/bin/perl

# Find a real solution to a cubic equation, using reduction to a depressed cubic, followed by the Cardano formula.

# Dividing ax^3 + bx^2 + cx + d = 0 by `a` and substituting `t - b/(3a)` for x we get the equation:
#   t^3 + pt + q = 0

# This allows us to use the Cardano formula to solve for `t`, which gives us:
#   x = t - b/(3a)

# Example (with x = 79443853):
#    15 x^3 - 22 x^2 + 8 x - 7520940423059310542039581 = 0

# See also:
#   https://en.wikipedia.org/wiki/Cubic_function

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload cbrt);

sub solve_cubic_equation ($a, $b, $c, $d) {

    my $p = (3*$a*$c - $b*$b) / (3*$a*$a);
    my $q = (2 * $b**3 - 9*$a*$b*$c + 27*$a*$a*$d) / (27 * $a**3);

    my $t = (cbrt(-($q/2) + sqrt(($q**2 / 4) + ($p**3 / 27))) +
             cbrt(-($q/2) - sqrt(($q**2 / 4) + ($p**3 / 27))));

    $t - $b/(3*$a);
}

say solve_cubic_equation(15, -22, 8, -7520940423059310542039581);    #=> 79443852.9999999999999999...


================================================
FILE: Math/solve_modular_cubic_equation.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 04 May 2022
# https://github.com/trizen

# Solve modular quadratic equations of the form:
#   a*x^3 + b*x^2 + c*x + d == 0 (mod m)

# Work in progress! Not all solutions are found.
# Sometimes, no solution is found, even if solutions do exist...

# See also:
#   https://en.wikipedia.org/wiki/Cubic_equation

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use List::Util qw(uniq);
use Math::AnyNum qw(:overload);
use experimental qw(signatures);

sub modular_cubic_equation ($A, $B, $C, $D, $M) {

    my $D0 = ($B * $B - 3 * $A * $C) % $M;
    my $D1 = (2 * $B**3 - 9 * $A * $B * $C + 27 * $A * $A * $D) % $M;

    my @S2 = allsqrtmod(($D1**2 - 4 * $D0**3) % (4 * $M), (4 * $M));
    my @S3;

    foreach my $s2 (@S2) {
        foreach my $r ($D1 + $s2, $D1 - $s2) {
            foreach my $s3 (allrootmod(($r / 2) % $M, 3, $M)) {
                my $nu = -($B + $s3 + $D0 / $s3) % $M;
                my $de = (3 * $A);

                my $x = ($nu / $de) % $M;
                if (($A * $x**3 + $B * $x**2 + $C * $x + $D) % $M == 0) {
                    push @S3, $x;
                }
            }
        }
    }

    return sort { $a <=> $b } uniq(@S3);
}

say join ' ', modular_cubic_equation(5, 3, -12, -640196464320, 432);        #=> 261
say join ' ', modular_cubic_equation(1, 1, 1,   -10**10 + 42,  10**10);     #=> 9709005706
say join ' ', modular_cubic_equation(1, 4, 6,   13 - 10**10,   10**10);     #=> 8614398889
say join ' ', modular_cubic_equation(1, 1, 1,   -10**10 - 10,  10**10);     #=> 8013600910


================================================
FILE: Math/solve_modular_quadratic_equation.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 04 May 2022
# https://github.com/trizen

# Solve modular quadratic equations of the form:
#   a*x^2 + b*x + c == 0 (mod m)

# Solving method:
#   D = b^2 - 4*a*c
#   t^2 == D (mod 4*m)

# By finding all the solutions to `t`, using `sqrtmod(D, 4*m)`, the candidate values for `x` are given by:
#   x_1 = (-b + t)/(2*a)
#   x_2 = (-b - t)/(2*a)

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use List::Util qw(uniq);
use Math::AnyNum qw(:overload);
use experimental qw(signatures);

sub modular_quadratic_equation ($A, $B, $C, $M) {

    my $D = ($B * $B - 4 * $A * $C);

    my @S;
    foreach my $t (allsqrtmod($D % (4 * $M), 4 * $M)) {
        for my $uv ([-$B + $t, 2 * $A], [-$B - $t, 2 * $A]) {
            my ($u, $v) = @$uv;
            my $x = ($u % $v == 0) ? (($u / $v) % $M) : divmod($u, $v, $M);
            if (($A * $x * $x + $B * $x + $C) % $M == 0) {
                push @S, $x;
            }
        }
    }

    return sort { $a <=> $b } uniq(@S);
}

say join ' ', modular_quadratic_equation(1, 1, -10**10 + 8,  10**10);
say join ' ', modular_quadratic_equation(4, 6, 10 - 10**10,  10**10);
say join ' ', modular_quadratic_equation(1, 1, -10**10 - 10, 10**10);

__END__
1810486343 2632873031 7367126968 8189513656
905243171 1316436515 5905243171 6316436515
263226214 1620648089 8379351910 9736773785


================================================
FILE: Math/solve_pell_equation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 31 August 2016
# Edit: 07 February 2018
# License: GPLv3
# https://github.com/trizen

# Find the smallest solution in positive integers to the Pell equation: x^2 - d*y^2 = ±1, where `d` is known.

# See also:
#   https://en.wikipedia.org/wiki/Pell%27s_equation
#   https://projecteuler.net/problem=66

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(is_square isqrt);

sub sqrt_convergents {
    my ($n) = @_;

    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;

    my @convergents = ($x);

    do {
        $y = int(($x + $y) / $z) * $z - $y;
        $z = int(($n - $y * $y) / $z);
        push @convergents, int(($x + $y) / $z);
    } until (($y == $x) && ($z == 1));

    return @convergents;
}

sub cfrac_denominator {
    my (@cfrac) = @_;

    my ($f1, $f2) = (0, 1);

    foreach my $n (@cfrac) {
        ($f1, $f2) = ($f2, $n * $f2 + $f1);
    }

    return $f1;
}

sub solve_pell {
    my ($d) = @_;

    return if is_square($d);

    my ($k, @period) = sqrt_convergents($d);

    my @solutions;

    my $x = cfrac_denominator($k, @period);
    my $p1 = 4 * $d * ($x * $x + 1);

    if (is_square($p1)) {
        push @solutions, [$x, isqrt($p1) / (2 * $d)];
        $x = cfrac_denominator($k, @period, @period);
    }

    my $p2 = 4 * $d * ($x * $x - 1);
    push @solutions, [$x, isqrt($p2) / (2 * $d)];

    return @solutions;
}

foreach my $d (1 .. 30) {

    my @solutions = solve_pell($d);

    foreach my $solution (@solutions) {
        my ($x, $y) = @$solution;
        printf("x^2 - %2dy^2 = %2d    minimum solution: x=%5s and y=%5s\n", $d, $x**2 - $d * $y**2, $x, $y);
    }
}

__END__
x^2 -  2y^2 = -1    minimum solution: x=    1 and y=    1
x^2 -  2y^2 =  1    minimum solution: x=    3 and y=    2
x^2 -  3y^2 =  1    minimum solution: x=    2 and y=    1
x^2 -  5y^2 = -1    minimum solution: x=    2 and y=    1
x^2 -  5y^2 =  1    minimum solution: x=    9 and y=    4
x^2 -  6y^2 =  1    minimum solution: x=    5 and y=    2
x^2 -  7y^2 =  1    minimum solution: x=    8 and y=    3
x^2 -  8y^2 =  1    minimum solution: x=    3 and y=    1
x^2 - 10y^2 = -1    minimum solution: x=    3 and y=    1
x^2 - 10y^2 =  1    minimum solution: x=   19 and y=    6
x^2 - 11y^2 =  1    minimum solution: x=   10 and y=    3
x^2 - 12y^2 =  1    minimum solution: x=    7 and y=    2
x^2 - 13y^2 = -1    minimum solution: x=   18 and y=    5
x^2 - 13y^2 =  1    minimum solution: x=  649 and y=  180
x^2 - 14y^2 =  1    minimum solution: x=   15 and y=    4
x^2 - 15y^2 =  1    minimum solution: x=    4 and y=    1
x^2 - 17y^2 = -1    minimum solution: x=    4 and y=    1
x^2 - 17y^2 =  1    minimum solution: x=   33 and y=    8
x^2 - 18y^2 =  1    minimum solution: x=   17 and y=    4
x^2 - 19y^2 =  1    minimum solution: x=  170 and y=   39
x^2 - 20y^2 =  1    minimum solution: x=    9 and y=    2
x^2 - 21y^2 =  1    minimum solution: x=   55 and y=   12
x^2 - 22y^2 =  1    minimum solution: x=  197 and y=   42
x^2 - 23y^2 =  1    minimum solution: x=   24 and y=    5
x^2 - 24y^2 =  1    minimum solution: x=    5 and y=    1
x^2 - 26y^2 = -1    minimum solution: x=    5 and y=    1
x^2 - 26y^2 =  1    minimum solution: x=   51 and y=   10
x^2 - 27y^2 =  1    minimum solution: x=   26 and y=    5
x^2 - 28y^2 =  1    minimum solution: x=  127 and y=   24
x^2 - 29y^2 = -1    minimum solution: x=   70 and y=   13
x^2 - 29y^2 =  1    minimum solution: x= 9801 and y= 1820
x^2 - 30y^2 =  1    minimum solution: x=   11 and y=    2


================================================
FILE: Math/solve_pell_equation_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 12 May 2018
# https://github.com/trizen

# Find the smallest solution in positive integers to the Pell equation: x^2 - d*y^2 = 1, where `d` is known.

# See also:
#   https://en.wikipedia.org/wiki/Pell%27s_equation

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(idiv isqrt is_square);

sub solve_pell ($n) {

    return () if is_square($n);

    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;
    my $r = $x + $x;

    my ($f1, $f2) = (1, $x);

    for (; ;) {

        $y = $r * $z - $y;
        $z = idiv($n - $y * $y, $z);
        $r = idiv($x + $y, $z);

        ($f1, $f2) = ($f2, $r * $f2 + $f1);

        if ($z == 1) {

            my $p = 4 * $n * ($f1 * $f1 - 1);

            if (is_square($p)) {
                return ($f1, idiv(isqrt($p), 2 * $n));
            }
        }
    }
}

foreach my $d (1 .. 100) {

    my ($x, $y) = solve_pell($d);

    if (defined($x)) {
        printf("x^2 - %2dy^2 = %2d    minimum solution: x=%15s and y=%15s\n", $d, $x**2 - $d * $y**2, $x, $y);
    }
}


================================================
FILE: Math/solve_pell_equation_generalized.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 May 2018
# https://github.com/trizen

# Find the smallest solution in positive integers to the generalized Pell equation:
#
#       x^2 - d*y^2 = n
#
# where `d` and `n` are given.

# See also:
#   https://en.wikipedia.org/wiki/Pell%27s_equation

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(idiv isqrt is_square irand);

sub solve_pell ($n, $u = 1) {

    return () if is_square($n);

    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;
    my $r = $x + $x;

    my ($f1, $f2) = (1, $x);

    for (1 .. 4 * $x * log($x) + 10) {

        $y = $r * $z - $y;
        $z = idiv($n - $y * $y, $z) || return;
        $r = idiv($x + $y, $z);

        ($f1, $f2) = ($f2, $r * $f2 + $f1);

        my $p = ($n * ($f1 * $f1 - $u)) << 2;

        if (is_square($p)) {
            my $t = isqrt($p) >> 1;
            $t % $n == 0 || next;
            return ($f1, idiv($t, $n));
        }
    }

    return ();
}

foreach my $d (1 .. 99) {
    my ($x, $y) = solve_pell($d, irand(1, 9) * (irand(0, 1) ? 1 : -1));

    if (defined($x)) {
        printf("x^2 - %2dy^2 = %2d    minimum solution: x=%15s and y=%15s\n", $d, $x**2 - $d * $y**2, $x, $y);
    }

}

__END__
x^2 -  2y^2 =  9    minimum solution: x=              3 and y=              0
x^2 -  5y^2 =  4    minimum solution: x=              2 and y=              0
x^2 - 14y^2 = -5    minimum solution: x=              3 and y=              1
x^2 - 15y^2 =  9    minimum solution: x=              3 and y=              0
x^2 - 21y^2 = -3    minimum solution: x=              9 and y=              2
x^2 - 28y^2 =  1    minimum solution: x=            127 and y=             24
x^2 - 29y^2 = -4    minimum solution: x=              5 and y=              1
x^2 - 31y^2 = -6    minimum solution: x=              5 and y=              1
x^2 - 47y^2 =  2    minimum solution: x=              7 and y=              1
x^2 - 53y^2 = -4    minimum solution: x=              7 and y=              1
x^2 - 58y^2 = -6    minimum solution: x=             38 and y=              5
x^2 - 61y^2 =  1    minimum solution: x=     1766319049 and y=      226153980
x^2 - 67y^2 =  9    minimum solution: x=            131 and y=             16
x^2 - 68y^2 =  1    minimum solution: x=             33 and y=              4
x^2 - 69y^2 = -5    minimum solution: x=              8 and y=              1
x^2 - 71y^2 =  1    minimum solution: x=           3480 and y=            413
x^2 - 89y^2 = -8    minimum solution: x=              9 and y=              1
x^2 - 92y^2 =  4    minimum solution: x=             48 and y=              5
x^2 - 93y^2 =  4    minimum solution: x=             29 and y=              3
x^2 - 95y^2 =  1    minimum solution: x=             39 and y=              4
x^2 - 97y^2 =  1    minimum solution: x=       62809633 and y=        6377352
x^2 - 98y^2 =  1    minimum solution: x=             99 and y=             10


================================================
FILE: Math/solve_pell_equation_simple.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 02 February 2019
# https://github.com/trizen

# Find the smallest solution in positive integers to Pell's equation: x^2 - d*y^2 = 1, where `d` is known.

# See also:
#   https://rosettacode.org/wiki/Pell%27s_equation
#   https://en.wikipedia.org/wiki/Pell%27s_equation

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(is_square isqrt idiv);
use experimental qw(signatures);

sub solve_pell ($n, $w = 1) {

    return () if is_square($n);

    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;
    my $r = 2 * $x;

    my ($e1, $e2) = (1, 0);
    my ($f1, $f2) = (0, 1);

    for (1 .. $n) {

        $y = $r * $z - $y;
        $z = ($n - $y * $y) / $z;
        $r = idiv(($x + $y), $z);

        my $A = $e2 + $x * $f2;
        my $B = $f2;

        if ($z == abs($w) and $A**2 - $n * $B**2 == $w) {
            return ($A, $B);
        }

        ($e1, $e2) = ($e2, $r * $e2 + $e1);
        ($f1, $f2) = ($f2, $r * $f2 + $f1);
    }

    return ();
}

foreach my $d(-3, -1, 1, 9) {
    foreach my $n (61, 109, 181, 277) {
        my ($x, $y) = solve_pell($n, $d);
        printf("x^2 - %3d*y^2 = %2s for x = %-21s and y = %s\n", $n, $x**2 - $n * $y**2, $x, $y);
    }
}

__END__
x^2 -  61*y^2 = -3 for x = 5639                  and y = 722
x^2 - 109*y^2 = -3 for x = 1399                  and y = 134
x^2 - 181*y^2 = -3 for x = 11262809              and y = 837158
x^2 - 277*y^2 = -3 for x = 233                   and y = 14
x^2 -  61*y^2 = -1 for x = 29718                 and y = 3805
x^2 - 109*y^2 = -1 for x = 8890182               and y = 851525
x^2 - 181*y^2 = -1 for x = 1111225770            and y = 82596761
x^2 - 277*y^2 = -1 for x = 8920484118            and y = 535979945
x^2 -  61*y^2 =  1 for x = 1766319049            and y = 226153980
x^2 - 109*y^2 =  1 for x = 158070671986249       and y = 15140424455100
x^2 - 181*y^2 =  1 for x = 2469645423824185801   and y = 183567298683461940
x^2 - 277*y^2 =  1 for x = 159150073798980475849 and y = 9562401173878027020
x^2 -  61*y^2 =  9 for x = 125                   and y = 16
x^2 - 109*y^2 =  9 for x = 3914405               and y = 374932
x^2 - 181*y^2 =  9 for x = 43805                 and y = 3256
x^2 - 277*y^2 =  9 for x = 108581                and y = 6524


================================================
FILE: Math/solve_quadratic_diophantine_reciprocals.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 February 2021
# https://github.com/trizen

# Algorithm for finding primitve solutions (x,y,z) with 1 <= x,y,z <= N and x <= y, to the Diophantine reciprocal equation:
#   1/x^2 + 1/y^2 = k/z^2

# A solution (x,y,z) is a primitive solution if gcd(x,y,z) = 1.

# It is easy to see that:
#   (x^2 + y^2)/k = v^4, for some integer v.

# Multiplying both sides by k, we have:
#   x^2 + y^2 = k * v^4

# By finding integer solutions (x,y) to the above Diophantine equation, we can then compute `z` as:
#   z = sqrt((x^2 * y^2 * k)/(x^2 + y^2))
#     = sqrt((x^2 * y^2) / v^4)

# We need to iterate over 1 <= v <= sqrt(N).

# See also:
#   https://projecteuler.net/problem=748

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

my %cache;

sub sum_of_two_squares_solutions ($n) {

    $n == 0 and return [0, 0];

    if (exists $cache{$n}) {
        return @{$cache{$n}};
    }

    my $prod1 = 1;
    my $prod2 = 1;

    my @prime_powers;

    foreach my $f (factor_exp($n)) {
        if ($f->[0] % 4 == 3) {    # p = 3 (mod 4)
            $f->[1] % 2 == 0 or return;    # power must be even
            $prod2 = mulint($prod2, powint($f->[0], $f->[1] >> 1));
        }
        elsif ($f->[0] == 2) {             # p = 2
            if ($f->[1] % 2 == 0) {        # power is even
                $prod2 = mulint($prod2, powint($f->[0], $f->[1] >> 1));
            }
            else {                         # power is odd
                $prod1 = mulint($prod1, $f->[0]);
                $prod2 = mulint($prod2, powint($f->[0], ($f->[1] - 1) >> 1));
                push @prime_powers, [$f->[0], 1];
            }
        }
        else {                             # p = 1 (mod 4)
            $prod1 = mulint($prod1, powint($f->[0], $f->[1]));
            push @prime_powers, $f;
        }
    }

    $prod1 == 1 and return [$prod2, 0];
    $prod1 == 2 and return [$prod2, $prod2];

    my %table;
    foreach my $f (@prime_powers) {

        my $pp = powint($f->[0], $f->[1]);
        my $r  = sqrtmod(-1, $pp);

        if (not defined($r)) {
            require Math::Sidef;
            $r = Math::Sidef::sqrtmod(-1, $pp);
        }

        push @{$table{$pp}}, [$r, $pp], [subint($pp, $r), $pp];
    }

    my @square_roots;

    forsetproduct {
        push @square_roots, chinese(@_);
    } values %table;

    my @solutions;

    foreach my $r (@square_roots) {

        my $s = $r;
        my $q = $prod1;

        while (mulint($s, $s) > $prod1) {
            ($s, $q) = (modint($q, $s), $s);
        }

        push @solutions, [mulint($prod2, $s), mulint($prod2, modint($q, $s))];
    }

    foreach my $f (@prime_powers) {
        for (my $i = $f->[1] % 2 ; $i < $f->[1] ; $i += 2) {

            my $sq = powint($f->[0], ($f->[1] - $i) >> 1);
            my $pp = powint($f->[0], $f->[1] - $i);

            push @solutions, map {
                [map { vecprod($sq, $prod2, $_) } @$_]
            } __SUB__->(divint($prod1, $pp));
        }
    }

    @{
        $cache{$n} = [
            do {
                my %seen;
                grep { !$seen{$_->[0]}++ } map {
                    [sort { $a <=> $b } @$_]
                } @solutions;
            }
        ]
     };
}

sub S ($N, $k) {

    my $total = 0;
    my $limit = sqrtint($N);

    my @solutions;

    foreach my $v (1 .. $limit) {

        my $w = powint($v, 4);

        foreach my $pair (sum_of_two_squares_solutions(mulint($k, $w))) {

            my ($x, $y) = @$pair;

            $y <= $N or next;

            my $t = vecprod($x, $x, $y, $y);

            modint($t, $w) == 0 or next;

            my $z = divint($t, $w);

            if (is_square($z)) {

                $z = sqrtint($z);
                $z <= $N or next;

                if (gcd($x, $y, $z) == 1) {
                    push @solutions, [$x, $y, $z];
                }
            }
        }
    }

    sort { $a->[0] <=> $b->[0] } @solutions;
}

my $N = 10000;
my $k = 5;

say <<"EOT";

:: Primitve solutions (x,y,z) with 1 <= x,y,z <= $N and x <= y, to equation:

    1/x^2 + 1/y^2 = $k/z^2
EOT

foreach my $triple (S($N, $k)) {
    my ($x, $y, $z) = @$triple;
    say "($x, $y, $z)";
}

__END__

:: Primitve solutions (x,y,z) with 1 <= x,y,z <= 10000 and x <= y, to equation:

    1/x^2 + 1/y^2 = 5/z^2

(1, 2, 2)
(10, 55, 22)
(17, 646, 38)
(26, 377, 58)
(247, 286, 418)
(374, 527, 682)
(407, 3034, 902)
(551, 1798, 1178)
(583, 6254, 1298)
(638, 1769, 1342)
(902, 3649, 1958)
(950, 1025, 1558)
(2015, 9230, 4402)
(2146, 2183, 3422)
(2318, 7991, 4978)
(2378, 2911, 4118)
(3286, 5353, 6262)
(5002, 6649, 8938)
(5135, 7930, 9638)


================================================
FILE: Math/solve_reciprocal_pythagorean_equation.pl
================================================
#!/usr/bin/perl

# Find all the primitive solutions to the inverse Pythagorean equation:
#   1/x^2 + 1/y^2 = 1/z^2
# such that x <= y and 1 <= x,y,z <= N.

# It can be shown that all the primitive solutions are generated from the following parametric form:
#
#   x = 2*a*b*(a^2 + b^2)
#   y = a^4 - b^4
#   z = 2*a*b*(a^2 - b^2)
#
# where gcd(a, b) = 1 and a+b is odd.

# See also:
#   https://oeis.org/A341990
#   https://math.stackexchange.com/questions/2688808/diophantine-equation-of-three-variables

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub S ($N) {

    my @solutions;
    my $limit = rootint($N, 4);

    foreach my $a (1 .. $limit) {
        foreach my $b (1 .. $a - 1) {

            ($a + $b) % 2 == 1 or next;
            gcd($a, $b) == 1   or next;

            my $aa = mulint($a, $a);
            my $ab = mulint($a, $b);
            my $bb = mulint($b, $b);

            my $x = vecprod(2, $ab, addint($aa, $bb));
            my $y = subint(powint($a, 4), powint($b, 4));
            my $z = vecprod(2, $ab, subint($aa, $bb));

            $x <= $N or next;
            $y <= $N or next;
            $z <= $N or next;

            push @solutions, [$x, $y, $z];
        }
    }

    sort { $a->[0] <=> $b->[0] } @solutions;
}

my $N = 10000;

say <<"EOT";

:: Primitve solutions (x,y,z) with 1 <= x,y,z <= $N and x <= y, to equation:

    1/x^2 + 1/y^2 = 1/z^2
EOT

foreach my $triple (S($N)) {
    my ($x, $y, $z) = @$triple;
    say "($x, $y, $z)";
}

__END__

:: Primitve solutions (x,y,z) with 1 <= x,y,z <= 10000 and x <= y, to equation:

    1/x^2 + 1/y^2 = 1/z^2

(20, 15, 12)
(136, 255, 120)
(156, 65, 60)
(444, 1295, 420)
(580, 609, 420)
(600, 175, 168)
(1040, 4095, 1008)
(1484, 2385, 1260)
(1640, 369, 360)
(2020, 9999, 1980)
(3060, 6545, 2772)
(3504, 4015, 2640)
(3640, 2145, 1848)
(3660, 671, 660)
(6540, 9919, 5460)
(6984, 6305, 4680)
(7120, 3471, 3120)
(7140, 1105, 1092)


================================================
FILE: Math/solve_sequence.pl
================================================
#!/usr/bin/perl

# Encode a sequence of n numbers into a polynomial of, at most, degree n-1.
# The polynomial will generate the given sequence of numbers, starting with index 0.

# See also:
#   https://yewtu.be/watch?v=4AuV93LOPcE
#   https://en.wikipedia.org/wiki/Polynomial_interpolation

use 5.014;
use warnings;
use experimental qw(signatures);

use Math::Polynomial;
use Math::AnyNum qw(:overload :all);
use List::Util qw(all);

sub binary_product (@arr) {

    while ($#arr > 0) {
        push @arr, shift(@arr)->mul(shift(@arr));
    }

    $arr[0];
}

sub poly_binomial ($n, $k) {
    my @terms;

    foreach my $i (0 .. $k - 1) {
        push @terms, $n;
        $n = $n->sub_const(1);
    }

    @terms || return Math::Polynomial->new(1);
    binary_product(@terms)->div_const(factorial($k));
}

sub array_differences (@arr) {

    my @result;

    foreach my $i (1 .. $#arr) {
        CORE::push(@result, $arr[$i] - $arr[$i - 1]);
    }

    @result;
}

sub solve_seq (@arr) {

    my $poly = Math::Polynomial->new();
    my $x    = Math::Polynomial->new(0, 1);

    for (my $k = 0 ; ; ++$k) {
        $poly += poly_binomial($x, $k)->mul_const($arr[0]);
        @arr = array_differences(@arr);
        last if all { $_ == 0 } @arr;
    }

    $poly;
}

if (@ARGV) {
    my @terms = (map { Math::AnyNum->new($_) } grep { /[0-9]/ } map { split(' ') } map { split(/\s*,\s*/) } @ARGV);
    say solve_seq(@terms);
}
else {
    say solve_seq(map { $_**2 } 0 .. 20);                   # (x^2)
    say solve_seq(map { faulhaber_sum($_, 2) } 0 .. 20);    # (1/3 x^3 + 1/2 x^2 + 1/6 x)
}


================================================
FILE: Math/sophie_germain_factorization_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 26 July 2019
# https://github.com/trizen

# A simple factorization method, based on Sophie Germain's identity:
#   x^4 + 4y^4 = (x^2 + 2xy + 2y^2) * (x^2 - 2xy + 2y^2)

# This method is also effective for numbers of the form: n^4 + 4^(2k+1).

# See also:
#   https://oeis.org/A227855 -- Numbers of the form x^4 + 4*y^4.
#   https://www.quora.com/What-is-Sophie-Germains-Identity

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub sophie_germain_factorization ($n, $verbose = 0) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz->new("$n");
    }

    my $f = sub ($A, $B) {
        my @factors;

        foreach my $f (
            $A**2 + 2 * $B**2 - 2 * $A * $B,
            $A**2 + 2 * $B**2 + 2 * $A * $B,
        ) {
            my $g = Math::GMPz->new(gcd($f, $n));

            if ($g > 1 and $g < $n) {
                while ($n % $g == 0) {
                    $n /= $g;
                    push @factors, $g;
                }
            }
        }

        @factors;
    };

    my $orig = $n;
    my @sophie_params;

    my $sophie_check_root = sub ($r1) {
        {
            my $x  = 4 * $r1**4;
            my $dx = $n - $x;

            if (is_power($dx, 4, \my $r2)) {
                $r2 = Math::GMPz->new($r2);
                say "[*] Sophie Germain special form detected: $r2^4 + 4*$r1^4" if $verbose;
                push @sophie_params, [$r2, $r1];
            }

        }

        {
            my $y  = $r1**4;
            my $dy = $n - $y;

            if (($dy % 4 == 0) and is_power($dy >> 2, 4, \my $r2)) {
                $r2 = Math::GMPz->new($r2);
                say "[*] Sophie Germain special form detected: $r1^4 + 4*$r2^4" if $verbose;
                push @sophie_params, [$r1, $r2];
            }
        }
    };

    # Try to find n = x^4 + 4*y^4, for x or y small.
    foreach my $r (map { Math::GMPz->new($_) } 2 .. logint($n, 2)) {
        $sophie_check_root->($r);
    }

    # Try to find n = x^4 + 4*y^4 for x,y close to floor(n/5)^(1/4).
    my $k = Math::GMPz->new(rootint($n / 5, 4));

    for my $j (0 .. 1000) {
        $sophie_check_root->($k + $j);
    }

    my @factors;

    foreach my $args (@sophie_params) {
        push @factors, $f->(@$args);
    }

    push @factors, $orig / vecprod(@factors);
    return sort { $a <=> $b } @factors;
}

if (@ARGV) {
    say join ', ', sophie_germain_factorization($ARGV[0], 1);
    exit;
}

say join ' * ', sophie_germain_factorization(powint(43,        4) + 4 * powint(372485613, 4));
say join ' * ', sophie_germain_factorization(powint(372485613, 4) + 4 * powint(97,        4));
say join ' * ', sophie_germain_factorization(powint(372485613, 4) + 4 * powint(372485629, 4));
say join ' * ', sophie_germain_factorization(powint(372485629, 4) + 4 * powint(372485511, 4));

say '';

say join ' * ', sophie_germain_factorization(powint(4, 117) + powint(53,  4));
say join ' * ', sophie_germain_factorization(powint(4, 213) + powint(240, 4));
say join ' * ', sophie_germain_factorization(powint(4, 251) + powint(251, 4));

__END__
277491031750210669 * 277491095817736105
138745459629795665 * 138745604154213509
138745543811525897 * 693727695218548205
138745455904945045 * 693727455337830721

166153499473114453560556010453601017 * 166153499473114514665395754616490745
13164036458569648337239753460419861813422875717854660184319779072 * 13164036458569648337239753460497746266300898132282617629258080512
3618502788666131106986593281521497099061968496512379043906292883903830095385 * 3618502788666131106986593281521497141767405545090156208559806116590740633113


================================================
FILE: Math/sorting_algorithms.pl
================================================
#!/usr/bin/perl

use 5.016;
use List::Util qw(min max shuffle);

############################################
# For performance comparisons, execute:
############################################
##    perl -d:NYTProf sorting_algorithms.pl
##    nytprofhtml --open -m
############################################

{
    # LAZY SORT
    sub lazysort {
        my (@A) = @_;

        my $end = $#A;

        while (1) {
            my $swapped;
            for (my $i = 0 ; $i < $end ; $i++) {
                if ($A[$i] > $A[$i + 1]) {
                    @A[$i + 1, $i] = @A[$i, $i + 1];
                    $swapped //= 1;
                    $i++;
                }
            }
            $swapped || return \@A;
        }
    }
}

{
    # QUICK SORT
    sub quick_sort {
        my (@a) = @_;
        @a < 2 ? @a : do {
            my $p = pop @a;
            __SUB__->(grep $_ < $p, @a), $p, __SUB__->(grep $_ >= $p, @a);
          }
    }
}

{
    # QUICK SORT (with partition)
    sub _partition {
        my ($array, $first, $last) = @_;
        my $i     = $first;
        my $j     = $last - 1;
        my $pivot = $array->[$last];
      SCAN: {
            do {
                # $first <= $i <= $j <= $last - 1
                # Point 1.
                # Move $i as far as possible.
                while ($array->[$i] <= $pivot) {
                    $i++;
                    last SCAN if $j < $i;
                }

                # Move $j as far as possible.
                while ($array->[$j] >= $pivot) {
                    $j--;
                    last SCAN if $j < $i;
                }

                # $i and $j did not cross over, so swap a low and a high value.
                @$array[$j, $i] = @$array[$i, $j];
            } while (--$j >= ++$i);
        }

        # $first - 1 <= $j < $i <= $last
        # Point 2.
        # Swap the pivot with the first larger element (if there is one)
        if ($i < $last) {
            @$array[$last, $i] = @$array[$i, $last];
            ++$i;
        }

        # Point 3.
        return ($i, $j);    # The new bounds exclude the middle.
    }

    sub _quicksort_recurse {
        my ($array, $first, $last) = @_;
        if ($last > $first) {
            my ($first_of_last, $last_of_first) = _partition($array, $first, $last);
            __SUB__->($array, $first,         $last_of_first);
            __SUB__->($array, $first_of_last, $last);
        }
    }

    sub _quicksort_iterate {
        my ($array, $first, $last) = @_;
        my @stack = ($first, $last);
        do {
            if ($last > $first) {
                my ($last_of_first, $first_of_last) = _partition $array, $first, $last;

                # Larger first.
                if ($first_of_last - $first > $last - $last_of_first) {
                    push @stack, $first, $first_of_last;
                    $first = $last_of_first;
                }
                else {
                    push @stack, $last_of_first, $last;
                    $last = $first_of_last;
                }
            }
            else {
                ($first, $last) = splice @stack, -2, 2;    # Double pop.
            }
        } while @stack;
    }

    sub quick_sort2 {
        my @arr = @_;

        # The recursive version is bad with BIG lists
        # because the function call stack gets REALLY deep.
        _quicksort_recurse(\@arr, 0, $#arr);
    }

    sub quick_sort3 {
        my @arr = @_;
        _quicksort_iterate(\@arr, 0, $#arr);
    }

}

{
    # BUBBLE SORT
    sub bubble_sort {
        for my $i (0 .. $#_) {
            for my $j ($i + 1 .. $#_) {
                $_[$j] < $_[$i] && do {
                    @_[$i, $j] = @_[$j, $i];
                };
            }
        }
    }
}

{
    # BUBBLE SORT SMART
    sub bubblesmart {
        my @array = @_;
        my $start = 0;         # The start index of the bubbling scan.
        my $i     = $#array;
        while (1) {
            my $new_start;     # The new start index of the bubbling scan.
            my $new_end = 0;   # The new end index of the bubbling scan.
            for (my $j = $start || 1 ; $j <= $i ; $j++) {
                if ($array[$j - 1] > $array[$j]) {
                    @array[$j, $j - 1] = @array[$j - 1, $j];
                    $new_end = $j - 1;
                    $new_start = $j - 1 unless defined $new_start;
                }
            }
            last unless defined $new_start;    # No swaps: we're done.
            $i     = $new_end;
            $start = $new_start;
        }
    }
}

{
    # COCKTAIL SORT
    sub cocktailSort {                         #( A : list of sortable items ) defined as:
        my @A       = @_;
        my $swapped = 1;
        while ($swapped == 1) {
            $swapped = 0;
            for (my $i = 0 ; $i < ($#A - 1) ; $i += 1) {

                if ($A[$i] > $A[$i + 1]) {     # test whether the two
                                               # elements are in the wrong
                                               # order
                    ($A[$i + 1], $A[$i]) = ($A[$i], $A[$i + 1]);    # let the two elements
                                                                    # change places
                    $swapped = 1;
                }
            }
            if ($swapped == 0) {

                # we can exit the outer loop here if no swaps occurred.
            }
            else {
                $swapped = 0;
                for (my $i = ($#A - 1) ; $i > 0 ; $i -= 1) {

                    if ($A[$i] > $A[$i + 1]) {
                        ($A[$i + 1], $A[$i]) = ($A[$i], $A[$i + 1]);
                        $swapped = 1;
                    }
                }
            }

            #  if no elements have been swapped,
            #  then the list is sorted
        }
        return (@A);
    }
}

{
    # COMB SORT
    sub combSort {
        my @arr   = @_;
        my $gap   = @arr;
        my $swaps = 1;
        while ($gap > 1 or $swaps) {
            $gap /= 1.25 if $gap > 1;
            $swaps = 0;
            foreach my $i (0 .. $#arr - $gap) {
                if ($arr[$i] > $arr[$i + $gap]) {
                    @arr[$i, $i + $gap] = @arr[$i + $gap, $i];
                    $swaps = 1;
                }
            }
        }
        return @arr;
    }
}

{
    # GNOME SORT
    sub gnome_sort {
        my @a = @_;

        my $size = scalar(@a);
        my $i    = 1;
        my $j    = 2;
        while ($i < $size) {
            if ($a[$i - 1] <= $a[$i]) {
                $i = $j;
                $j++;
            }
            else {
                @a[$i, $i - 1] = @a[$i - 1, $i];
                $i--;
                if ($i == 0) {
                    $i = $j;
                    $j++;
                }
            }
        }
        return @a;
    }
}

{
    # HEAP SORT
    sub heap_sort {
        my (@list) = @_;
        my $count = scalar @list;
        _heapify($count, \@list);

        my $end = $count - 1;
        while ($end > 0) {
            @list[0, $end] = @list[$end, 0];
            _sift_down(0, $end - 1, \@list);
            --$end;
        }
    }

    sub _heapify {
        my ($count, $list) = @_;
        my $start = ($count - 2) / 2;
        while ($start >= 0) {
            _sift_down($start, $count - 1, $list);
            --$start;
        }
    }

    sub _sift_down {
        my ($start, $end, $list) = @_;

        my $root = $start;
        while ($root * 2 + 1 <= $end) {
            my $child = $root * 2 + 1;
            ++$child if $child + 1 <= $end and $$list[$child] < $$list[$child + 1];
            if ($$list[$root] < $$list[$child]) {
                @$list[$root, $child] = @$list[$child, $root];
                $root = $child;
            }
            else {
                return;
            }
        }
    }
}

{
    # HEAP SORT (2)
    sub heap_sort2 {
        use integer;
        my (@array) = @_;
        for (my $index = 1 + @array / 2 ; $index-- ;) {
            _heapify2(\@array, $index);
        }
        for (my $last = @array ; --$last ;) {
            @array[0, $last] = @array[$last, 0];
            _heapify2(\@array, 0, $last);
        }
    }

    sub _heapify2 {
        use integer;
        my ($array, $index, $last) = @_;
        $last = @$array unless defined $last;
        my $swap = $index;
        my $high = $index * 2 + 1;
        for (my $try = $index * 2 ; $try < $last and $try <= $high ; ++$try) {
            $swap = $try if $$array[$try] > $$array[$swap];
        }
        unless ($swap == $index) {

            # The heap is in disorder: must reshuffle.
            @{$array}[$swap, $index] = @{$array}[$index, $swap];
            __SUB__->($array, $swap, $last);
        }
    }
}

{
    # MERGE SORT (simple)
    sub merge_sort {
        my @x = @_;
        return @x if @x < 2;
        my $m = int @x / 2;
        my @a = __SUB__->(@x[0 .. $m - 1]);
        my @b = __SUB__->(@x[$m .. $#x]);
        for (@x) {
            $_ =
                !@a            ? shift @b
              : !@b            ? shift @a
              : $a[0] <= $b[0] ? shift @a
              :                  shift @b;
        }
        @x;
    }
}

{
    # MERGE SORT (recursive + iterative)
    {
        my @work;    # A global work array.

        sub _merge {
            my ($array, $first, $middle, $last) = @_;
            my $n = $last - $first + 1;

            # Initialize work with relevant elements from the array.
            for (my $i = $first, my $j = 0 ; $i <= $last ;) {
                $work[$j++] = $array->[$i++];
            }

            # Now do the actual merge. Proceed through the work array
            # and copy the elements in order back to the original array
            # $i is the index for the merge result, $j is the index in
            # first half of the working copy, $k the index in the second half.
            $middle = int(($first + $last) / 2) if $middle > $last;
            my $n1 = $middle - $first + 1;    # The size of the 1st half.
            for (my $i = $first, my $j = 0, my $k = $n1 ; $i <= $last ; $i++) {
                $array->[$i] =
                    $j < $n1 && ($k == $n || $work[$j] < $work[$k])
                  ? $work[$j++]
                  : $work[$k++];
            }
        }
    }

    sub _mergesort_recurse {
        my ($array, $first, $last) = @_;
        if ($last > $first) {
            my $middle = int(($last + $first) / 2);
            __SUB__->($array, $first,      $middle);
            __SUB__->($array, $middle + 1, $last);
            _merge($array, $first, $middle, $last);
        }
    }

    sub merge_sort2 {
        my @array = @_;
        _mergesort_recurse(\@array, 0, $#array);
    }

    {

        sub merge_sort3 {
            my @array = @_;
            my $N     = @array;
            my $Nt2   = $N * 2;    # N times 2.
            my $Nm1   = $N - 1;    # N minus 1.
            for (my $size = 2 ; $size < $Nt2 ; $size *= 2) {
                for (my $first = 0 ; $first < $N ; $first += $size) {
                    my $last = $first + $size - 1;
                    _merge(\@array, $first, int(($first + $last) / 2), $last < $N ? $last : $Nm1);
                }
            }
        }
    }
}

{
    # SHELL SORT
    sub shell_sort {
        my (@a, $h, $i, $j, $k) = @_;
        for ($h = @a ; $h = int $h / 2 ;) {
            for $i ($h .. $#a) {
                $k = $a[$i];
                for ($j = $i ; $j >= $h and $k < $a[$j - $h] ; $j -= $h) {
                    $a[$j] = $a[$j - $h];
                }
                $a[$j] = $k;
            }
        }
        @a;
    }
}

{
    # SHELL SORT (2)
    sub shell_sort2 {
        my @array = @_;
        my $i;    # The initial index for the bubbling scan.
        my $j;    # The running index for the bubbling scan.
        my $shell = (2 << log(scalar @array) / log(2)) - 1;
        do {
            $shell = int(($shell - 1) / 2);
            for ($i = $shell ; $i < @array ; $i++) {
                for ($j = $i - $shell ; $j >= 0 && $array[$j] > $array[$j + $shell] ; $j -= $shell) {
                    @array[$j, $j + $shell] = @array[$j + $shell, $j];
                }
            }
        } while $shell > 1;
    }
}

{
    # SELECTION SORT
    sub selection_sort {
        my @a = @_;
        foreach my $i (0 .. $#a - 1) {
            my $min = $i + 1;
            $a[$_] < $a[$min] and $min = $_ foreach ($min .. $#a);
            @a[$i, $min] = @a[$min, $i] if $a[$i] > $a[$min];
        }
        return @a;
    }
}

{
    # SELECTION SORT (2)
    sub selection_sort2 {
        my @array = @_;
        my $i;    # The starting index of a minimum-finding scan.
        my $j;    # The running index of a minimum-finding scan.
        for ($i = 0 ; $i < $#array ; $i++) {
            my $m = $i;            # The index of the minimum element.
            my $x = $array[$m];    # The minimum value.
            for ($j = $i + 1 ; $j < @array ; $j++) {
                ($m, $x) = ($j, $array[$j])    # Update minimum.
                  if $array[$j] < $x;
            }

            # Swap if needed.
            @array[$m, $i] = @array[$i, $m] unless $m == $i;
        }
    }
}

{
    # INSERTION SORT
    sub insertion_sort {
        my (@list) = @_;
        foreach my $i (1 .. $#list) {
            my $j = $i;
            my $k = $list[$i];
            while ($j > 0 and $k < $list[$j - 1]) {
                $list[$j] = $list[$j - 1];
                --$j;
            }
            $list[$j] = $k;
        }
        return @list;
    }
}

{
    # INSERTION SORT (2)
    sub insertion_sort2 {
        my @array = @_;
        my $i;    # The initial index for the minimum element.
        my $j;    # The running index for the minimum-finding scan.
        for ($i = 0 ; $i < $#array ; $i++) {
            my $m = $i;            # The final index for the minimum element.
            my $x = $array[$m];    # The minimum value.
            for ($j = $i + 1 ; $j < @array ; $j++) {
                ($m, $x) = ($j, $array[$j])    # Update minimum.
                  if $array[$j] < $x;
            }

            # The double-splice simply moves the $m-th element to be
            # the $i-th element. Note: splice is O(N), not O(1).
            # As far as the time complexity of the algorithm is concerned
            # it makes no difference whether we do the block movement
            # using the preceding loop or using splice(). Still, splice()
            # is faster than moving the block element by element.
            splice @array, $i, 0, splice @array, $m, 1 if $m > $i;
        }
    }
}

{
    # STRAND SORT
    sub _strand_merge {
        my ($x, $y) = @_;
        my @out;
        while (@$x and @$y) {
            my $cmp = $$x[-1] <=> $$y[-1];
            if    ($cmp == 1)  { unshift @out, pop @$x }
            elsif ($cmp == -1) { unshift @out, pop @$y }
            else               { splice @out, 0, 0, pop @$x, pop @$y }
        }
        return @$x, @$y, @out;
    }

    sub _strand {
        my $x = shift;
        my @out = shift @$x // return;
        if (@$x) {
            for (-@$x .. -1) {
                if ($x->[$_] >= $out[-1]) {
                    push @out, splice @$x, $_, 1;
                }
            }
        }
        return @out;
    }

    sub strand_sort {
        my @x = @_;
        my @out;
        while (my @strand = _strand(\@x)) {
            @out = _strand_merge(\@out, \@strand);
        }
        @out;
    }
}

{
    # NIGHT SORT
    sub night_sort {
        my (@arr) = @_;

        my $max = 0;
        my $min = 0;

        my @indices = $max;

        my $swapped;
        foreach my $i (1 .. $#arr) {
            my $cmp = $arr[$i - 1] <=> $arr[$i];

            push @indices,
                $cmp == -1 ? $indices[-1] + 1
              : $cmp == 1 ? do { $swapped //= 1; $indices[-1] - 1 }
              :             $indices[-1];

            $min = $indices[-1] if $indices[-1] < $min;
            $max = $indices[-1] if $indices[-1] > $max;
        }
        unless ($swapped) {
            return @arr;
        }

        my @fetch;
        for my $i ($min .. $max) {
            for my $j (0 .. $#indices) {
                if ($indices[$j] == $i) {
                    push @fetch, $j;
                }
            }
        }
        __SUB__->(@arr[@fetch]);
    }
}

{
    # MORNING SORT
    sub morning_sort {
        my (@arr) = @_;
        @arr < 2 ? @arr : do {
            my $p = splice(@arr, int rand @arr, 1);
            __SUB__->(grep $_ <= $p, @arr), $p, __SUB__->(grep $_ > $p, @arr);
          }
    }
}

{
    # AFTERNOON SORT
    sub afternoon_sort {
        my (@arr) = @_;

        my @new;
        for (@arr) {
            push @{$new[int(log($_ + 1) * (10**(1 + int(log($_ + 1) / log(10)))))]}, $_;
        }

        map { defined($_) ? @{$_} : () } @new;
    }
}

{
    # SAC SORT
    sub sac_sort {
        my (@arr, @sac) = @_;

        @arr > 1 || return @arr;

        for (@arr) {
            my $i = 0;
            for (; $i <= $#sac ; ++$i) {
                last if $sac[$i] > $_;
            }
            splice @sac, $i, 0, $_;
        }

        @sac;
    }
}

{
    # SAC SORT SMART
    sub sac_sort_smart {
        my (@arr, @sac) = @_;

        @arr > 1 || return @arr;

        my $c1 = 0;
        my $c2 = 1;
        my $j  = 0;

        for (@arr) {
            if ($c1 < $c2) {
                my $i = 0;
                for (; $i <= $#sac ; ++$i) {
                    last if $sac[$i] > $_;
                    ++$c1;
                }
                splice @sac, $i, 0, $_;
            }
            else {
                my $i = $j;
                for (; $i > 0 ; --$i) {
                    last if $sac[$i - 1] < $_;
                    ++$c2;
                }
                splice @sac, $i, 0, $_;
            }
            ++$j;
        }

        @sac;
    }
}

{
    # COUNTING SORT
    sub counting_sort {
        my ($a, $min, $max) = @_;

        my @cnt = (0) x ($max - $min + 1);
        $cnt[$_ - $min]++ foreach @$a;

        my $i = $min;
        @$a = map { ($i++) x $_ } @cnt;
    }
}

{
    # BEADSORT
    sub beadsort {
        my @data = @_;

        my @columns;
        my @rows;

        for my $datum (@data) {
            for my $column (0 .. $datum - 1) {
                ++$rows[$columns[$column]++];
            }

        }

        return reverse @rows;
    }
}

{
    # PANCAKE
    sub pancake {
        my @x = @_;
        for my $idx (0 .. $#x - 1) {
            my $min = $idx;
            $x[$min] > $x[$_] and $min = $_ for $idx + 1 .. $#x;

            next if $x[$min] == $x[$idx];

            @x[$min .. $#x] = reverse @x[$min .. $#x] if $x[$min] != $x[-1];
            @x[$idx .. $#x] = reverse @x[$idx .. $#x];
        }
        @x;
    }
}

{
    # BINSERTION SORT
    sub _binary_search {
        my ($array_ref, $value, $left, $right, $middle) = @_;

        $array_ref->[$middle = int(($right + $left) / 2)] > $value
          ? ($right = $middle - 1)
          : ($left = $middle + 1)
          while ($left <= $right);

        ++$middle while ($array_ref->[$middle] < $value);

        $middle;
    }

    sub binsertion_sort {
        my (@list) = @_;

        foreach my $i (1 .. $#list) {
            if ((my $k = $list[$i]) < $list[$i - 1]) {
                splice(@list, $i, 1);
                splice(@list, _binary_search(\@list, $k, 0, $i - 1), 0, $k);
            }
        }

        return @list;
    }
}

##########################################################

# Random
my @arr = map { int(rand($_) + rand(500)) } 0 .. 500;

# Reversed
#my @arr = reverse(0..500);

# Sorted
#my @arr = (0..500);

##########################################################

afternoon_sort(map $_, @arr);
#beadsort(map $_, @arr);        # pretty slow
binsertion_sort(map $_, @arr);
bubble_sort(map $_, @arr);
bubblesmart(map $_, @arr);
cocktailSort(map $_, @arr);
combSort(map $_, @arr);
counting_sort([map $_, @arr], min(@arr), max(@arr));
gnome_sort(map $_, @arr);
heap_sort(map $_, @arr);
heap_sort2(map $_, @arr);
insertion_sort(map $_, @arr);
insertion_sort2(map $_, @arr);
lazysort(map $_, @arr);
merge_sort(map $_, @arr);
merge_sort2(map $_, @arr);
merge_sort3(map $_, @arr);
morning_sort(map $_, @arr);
#night_sort(map $_, @arr);       # too sleepy
pancake(map $_, @arr);
quick_sort(map $_, @arr);
quick_sort2(map $_, @arr);
quick_sort3(map $_, @arr);
sac_sort(map $_, @arr);
sac_sort_smart(map $_, @arr);
selection_sort(map $_, @arr);
selection_sort2(map $_, @arr);
shell_sort(map $_, @arr);
shell_sort2(map $_, @arr);
strand_sort(map $_, @arr);


================================================
FILE: Math/sphere_volume.pl
================================================
#!/usr/bin/perl

# Author: Trizen

# OLD: V = (4/3) * PI * r^3
# NEW: V = r^4 * PI / (r * 0.75)
#
#      V = r^2 * PI * (r * 0.75^(-1))
#      0.75^(-1) = 1.33333
#
#      r^2 * r = r^3
#      1.33333 = 4/3
#      V = r^3 * PI * (4/3)

use 5.010;

say sprintf('%.32f', ($ARGV[0] || die "usage: $0 \n")**4 * atan2('inf', 0) * 2 / ($ARGV[0] * 0.75)) =~ /^(.+?\.\d+?)(?=0*$)/;


================================================
FILE: Math/sqrt_mod_p_tonelli-shanks_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 11 April 2018
# https://github.com/trizen

# An efficient implementation of the Tonelli-Shanks algorithm, using Math::GMPz.

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use experimental qw(signatures);

sub sqrt_mod ($n, $p) {

    if (ref($n) ne 'Math::GMPz') {
        $n = Math::GMPz::Rmpz_init_set_str("$n", 10);
    }

    if (ref($p) ne 'Math::GMPz') {
        $p = Math::GMPz::Rmpz_init_set_str("$p", 10);
    }

    my $q = Math::GMPz::Rmpz_init_set($p);

    if (Math::GMPz::Rmpz_divisible_p($n, $p)) {
        Math::GMPz::Rmpz_mod($q, $q, $p);
        return $q;
    }

    if (Math::GMPz::Rmpz_legendre($n, $p) != 1) {
        die "Not a quadratic residue!";
    }

    if (Math::GMPz::Rmpz_tstbit($p, 1) == 1) {    # p = 3 (mod 4)

        # q = n ^ ((p+1) / 4) (mod p)
        Math::GMPz::Rmpz_add_ui($q, $q, 1);       # q = p+1
        Math::GMPz::Rmpz_fdiv_q_2exp($q, $q, 2);  # q = (p+1)/4
        Math::GMPz::Rmpz_powm($q, $n, $q, $p);    # q = n^q (mod p)
        return $q;
    }

    Math::GMPz::Rmpz_sub_ui($q, $q, 1);           # q = p-1

    # Factor out 2^s from q
    my $s = Math::GMPz::Rmpz_remove($q, $q, Math::GMPz::Rmpz_init_set_ui(2));

    # Search for a non-residue mod p by picking the first w such that (w|p) is -1
    my $w = 2;
    while (Math::GMPz::Rmpz_ui_kronecker($w, $p) != -1) { ++$w }
    $w = Math::GMPz::Rmpz_init_set_ui($w);

    Math::GMPz::Rmpz_powm($w, $w, $q, $p);    # w = w^q (mod p)
    Math::GMPz::Rmpz_add_ui($q, $q, 1);       # q = q+1
    Math::GMPz::Rmpz_fdiv_q_2exp($q, $q, 1);  # q = (q+1) / 2

    my $n_inv = Math::GMPz::Rmpz_init();

    Math::GMPz::Rmpz_powm($q, $n, $q, $p);    # q = n^q (mod p)
    Math::GMPz::Rmpz_invert($n_inv, $n, $p);

    my $y = Math::GMPz::Rmpz_init();

    for (; ;) {
        Math::GMPz::Rmpz_powm_ui($y, $q, 2, $p);    # y = q^2 (mod p)
        Math::GMPz::Rmpz_mul($y, $y, $n_inv);
        Math::GMPz::Rmpz_mod($y, $y, $p);           # y = y * n^-1 (mod p)

        my $i = 0;

        for (; Math::GMPz::Rmpz_cmp_ui($y, 1) ; ++$i) {
            Math::GMPz::Rmpz_powm_ui($y, $y, 2, $p);    #  y = y ^ 2 (mod p)
        }

        if ($i == 0) {                                # q^2 * n^-1 = 1 (mod p)
            return $q;
        }

        if ($s - $i == 1) {
            Math::GMPz::Rmpz_mul($q, $q, $w);
        }
        else {
            Math::GMPz::Rmpz_powm_ui($y, $w, 1 << ($s - $i - 1), $p);
            Math::GMPz::Rmpz_mul($q, $q, $y);
        }

        Math::GMPz::Rmpz_mod($q, $q, $p);
    }

    return $q;
}

say sqrt_mod('1030',                                               '10009');
say sqrt_mod('44402',                                              '100049');
say sqrt_mod('665820697',                                          '1000000009');
say sqrt_mod('881398088036',                                       '1000000000039');
say sqrt_mod('41660815127637347468140745042827704103445750172002', '100000000000000000000000000000000000000000000000577');


================================================
FILE: Math/square_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 30 July 2018
# https://github.com/trizen

# Generate all the square divisors of a given number.

use 5.036;
use ntheory qw(:all);

sub square_divisors($n) {

    my @d = (1);
    my @pp = grep { $_->[1] > 1 } factor_exp($n);

    foreach my $pp (@pp) {
        my ($p, $e) = @$pp;

        my @t;
        for (my $i = 2 ; $i <= $e ; $i += 2) {
            my $u = powint($p, $i);
            push @t, map { mulint($_, $u) } @d;
        }

        push @d, @t;
    }

    return sort { $a <=> $b } @d;
}

say join(', ', square_divisors(3628800));


================================================
FILE: Math/square_product_subsets.pl
================================================
#!/usr/bin/perl

# Find subsets of integers whose product is a square, using Gaussian elimination on a GF(2) matrix of vector exponents.

# Code inspired by:
#   https://github.com/martani/Quadratic-Sieve/blob/master/matrix.c

# See also:
#   https://btravers.weebly.com/uploads/6/7/2/9/6729909/quadratic_sieve_slides.pdf

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use List::Util qw(first);
use ntheory qw(factor_exp prime_count);
use Math::AnyNum qw(:overload is_square);

sub getbit ($n, $k) {
    ($n >> $k) & 1;
}

sub setbit ($n, $k) {
    (1 << $k) | $n;
}

sub gaussian_elimination ($rows, $n) {

    my @A = @$rows;
    my $m = $#A;
    my @I = map { 1 << $_ } 0 .. $m;

    my $nrow = -1;
    my $mcol = $m < $n ? $m : $n;

    foreach my $col (0 .. $mcol) {
        my $npivot = -1;

        foreach my $row ($nrow+1 .. $m) {
            if (getbit($A[$row], $col)) {
                $npivot = $row;
                $nrow++;
                last;
            }
        }

        next if ($npivot == -1);

        if ($npivot != $nrow) {
            @A[$npivot, $nrow] = @A[$nrow, $npivot];
            @I[$npivot, $nrow] = @I[$nrow, $npivot];
        }

        foreach my $row ($nrow+1 .. $m) {
            if (getbit($A[$row], $col)) {
                $A[$row] ^= $A[$nrow];
                $I[$row] ^= $I[$nrow];
            }
        }
    }

    return (\@A, \@I);
}

sub exponents_signature(@factors) {
    my $sig = 0;

    foreach my $p (@factors) {
        if ($p->[1] & 1) {
            $sig = setbit($sig, prime_count($p->[0]) - 1);
        }
    }

    return $sig;
}

sub find_square_subsets(@set) {

    my $max_prime = 2;

    my @rows;
    foreach my $n (@set) {
        my @factors = factor_exp($n);

        if (@factors) {
            my $p = $factors[-1][0];
            $max_prime = $p if ($p > $max_prime);
        }

        push @rows, exponents_signature(@factors);
    }

    if (@rows < prime_count($max_prime)) {
        push @rows, (0) x (prime_count($max_prime) - @rows);
    }

    my ($A, $I) = gaussian_elimination(\@rows, prime_count($max_prime) - 1);

    my $LR = (first { $A->[-$_] } 1 .. @$A) - 1;

    my @square_subsets;

    foreach my $solution (@{$I}[@$I - $LR .. $#$I]) {

        my @terms;
        my $prod = 1;

        foreach my $i (0 .. $#set) {
            if (getbit($solution, $i)) {

                $prod *= $set[$i];

                push @terms, $set[$i];
                push @square_subsets, [@terms] if is_square($prod);
            }
        }
    }

    return @square_subsets;
}

my @Q = (
    10, 97, 24, 35, 75852, 54, 12, 13, 11,
    33, 37, 48, 57, 58, 63, 68, 377, 15,
    20, 26, 7, 3, 17, 29, 43, 41, 4171, 78
);

#@Q = (10, 24, 35, 52, 54, 78);

my @S = find_square_subsets(@Q);

foreach my $solution (@S) {
    say join(' ', @$solution);
}

__END__
12 48
10 24 35 12 63
24 54
24 12 13 58 377
10 24 15
10 24 12 20
24 12 13 26
10 24 35 12 7
12 3
68 17
24 12 58 29
75852 43
12 11 33
97 75852 4171
24 13 78


================================================
FILE: Math/square_root_convergents.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 April 2018
# https://github.com/trizen

# Find the convergents of a square root for a non-square positive integer.

# See also:
#    https://en.wikipedia.org/wiki/Pell%27s_equation#Solutions
#    https://en.wikipedia.org/wiki/Continued_fraction#Infinite_continued_fractions
#    https://www.wolframalpha.com/input/?i=Convergents%5BSqrt%5B61%5D%5D

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload isqrt idiv);

sub sqrt_convergents ($n, $callback, $count = 10) {
    my $x = isqrt($n);
    my $y = $x;
    my $z = 1;

    my $r = $x + $x;

    my ($e1, $e2) = (1, 0);
    my ($f1, $f2) = (0, 1);

    for (1 .. $count) {
        $y = $r * $z - $y;
        $z = idiv($n - $y * $y, $z);
        $r = idiv($x + $y, $z);

        $callback->($e2 + $x * $f2, $f2);

        ($f1, $f2) = ($f2, $r * $f2 + $f1);
        ($e1, $e2) = ($e2, $r * $e2 + $e1);

        $y = $x if ($z == 1);
    }
}

sqrt_convergents(61, sub ($n, $d) {
        printf("%20s / %-20s =~ %s\n", $n, $d, ($n / $d)->as_dec);
}, 20)

__END__
           7 / 1                    =~ 7
           8 / 1                    =~ 8
          39 / 5                    =~ 7.8
         125 / 16                   =~ 7.8125
         164 / 21                   =~ 7.80952380952380952380952380952380952380952380952
         453 / 58                   =~ 7.81034482758620689655172413793103448275862068966
        1070 / 137                  =~ 7.8102189781021897810218978102189781021897810219
        1523 / 195                  =~ 7.81025641025641025641025641025641025641025641026
        5639 / 722                  =~ 7.81024930747922437673130193905817174515235457064
       24079 / 3083                 =~ 7.81024975673045734674018812844631852092118066818
       29718 / 3805                 =~ 7.81024967148488830486202365308804204993429697766
      440131 / 56353                =~ 7.81024967614856351924476070484268805564921122212
      469849 / 60158                =~ 7.81024967585358555803051963163669004953622128395
     2319527 / 296985               =~ 7.81024967590955772177045978753135680253211441655
     7428430 / 951113               =~ 7.81024967590601747636716142035699228167420695543
     9747957 / 1248098              =~ 7.81024967590685987799035011673762797472634360443
    26924344 / 3447309              =~ 7.81024967590662745927330564216900776808809422074
    63596645 / 8142716              =~ 7.81024967590666308391450714970287555159728031777
    90520989 / 11590025             =~ 7.81024967590665248780740334900054141384509524354
   335159612 / 42912791             =~ 7.81024967590665449842216042298437312082544339752


================================================
FILE: Math/square_root_method.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 01 October 2016
# Website: https://github.com/trizen

# Approximate the square root of a number.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(:overload);

sub square_root {
    my ($n) = @_;

    my $eps = 10**-($Math::AnyNum::PREC >> 2);

    my $m = $n;
    my $r = 0.0;

    while (abs($m - $r) > $eps) {
        $m = ($m + $r) / 2;
        $r = $n / $m;
    }

    $r;
}

say square_root(1234);


================================================
FILE: Math/square_root_modulo_n_tonelli-shanks.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 30 October 2017
# https://github.com/trizen

# Find all the solutions to the congruence equation:
#   x^2 = a (mod n)

# Defined for any values of `a` and `n` for which `kronecker(a, n) = 1`.

# When `kronecker(a, n) != 1`, for example:
#
#   a = 472
#   n = 972
#
# which represents:
#   x^2 = 472 (mod 972)
#
# this algorithm may fail find all the solutions, although there exist four solutions in this case:
#   x = {38, 448, 524, 934}

# Code inspired from:
#   https://github.com/Magtheridon96/Square-Root-Modulo-N

use 5.020;
use warnings;

use experimental qw(signatures);

use List::Util qw(uniq);
use ntheory qw(factor_exp is_prime chinese forsetproduct);
use Math::AnyNum qw(:overload kronecker powmod invmod valuation ipow mulmod);

sub tonelli_shanks ($n, $p) {

    $n %= $p;

    my $q = $p - 1;
    my $s = valuation($q, 2);

    $s == 1
      and return powmod($n, ($p + 1) >> 2, $p);

    $q >>= $s;

    my $z = 1;
    for (my $i = 2 ; $i < $p ; ++$i) {
        if (kronecker($i, $p) == -1) {
            $z = $i;
            last;
        }
    }

    my $c = powmod($z, $q, $p);
    my $r = powmod($n, ($q + 1) >> 1, $p);
    my $t = powmod($n, $q, $p);

    while (($t - 1) % $p != 0) {

        my $k = 1;
        my $v = mulmod($t, $t, $p);

        for (my $i = 1 ; $i < $s ; ++$i) {
            if (($v - 1) % $p == 0) {
                $k = powmod($c, 1 << ($s - $i - 1), $p);
                $s = $i;
                last;
            }
            $v = mulmod($v, $v, $p);
        }

        $r = mulmod($r, $k, $p);
        $c = mulmod($k, $k, $p);
        $t = mulmod($t, $c, $p);
    }

    return $r;
}

sub sqrt_mod_n ($a, $n) {

    $a %= $n;

    return 0 if ($a == 0);

    if (($n & ($n - 1)) == 0) {    # n is a power of 2

        if ($a % 8 == 1) {

            my $k = valuation($n, 2);

            $k == 1 and return (1);
            $k == 2 and return (1, 3);
            $k == 3 and return (1, 3, 5, 7);

            if ($a == 1) {
                return (1, ($n >> 1) - 1, ($n >> 1) + 1, $n - 1);
            }

            my @roots;

            foreach my $s (sqrt_mod_n($a, $n >> 1)) {
                my $i = ((($s * $s - $a) >> ($k - 1)) % 2);
                my $r = ($s + ($i << ($k - 2)));
                push(@roots, $r, $n - $r);
            }

            return uniq(@roots);
        }

        return;
    }

    if (is_prime($n)) {    # n is a prime
        kronecker($a, $n) == 1 or return;
        my $r = tonelli_shanks($a, $n);
        return ($r, $n - $r);
    }

    my @pe = factor_exp($n);    # factorize `n` into prime powers

    if (@pe == 1) {             # `n` is an odd prime power

        my $p = Math::AnyNum->new($pe[0][0]);

        kronecker($a, $p) == 1 or return;

        my $r = tonelli_shanks($a, $p);
        my ($r1, $r2) = ($r, $n - $r);

        my $pk = $p;
        my $pi = $p * $p;

        for (1 .. $pe[0][1]-1) {

            my $x = $r1;
            my $y = invmod(2, $pk) * invmod($x, $pk);

            $r1 = ($pi + $x - $y * ($x * $x - $a + $pi)) % $pi;
            $r2 = ($pi - $r1);

            $pk *= $p;
            $pi *= $p;
        }

        return ($r1, $r2);
    }

    my @chinese;

    foreach my $f (@pe) {
        my $m = ipow($f->[0], $f->[1]);
        my @r = sqrt_mod_n($a, $m);
        push @chinese, [map { [$_, $m] } @r];
    }

    my @roots;

    forsetproduct {
        push @roots, chinese(@_);
    } @chinese;

    return uniq(@roots);
}

say join(' ', sqrt_mod_n(993, 2048));    #=> 369 1679 655 1393
say join(' ', sqrt_mod_n(441, 920));     #=> 761 481 209 849 531 251 899 619 301 21 669 389 71 711 439 159
say join(' ', sqrt_mod_n(841, 905));     #=> 391 876 29 514
say join(' ', sqrt_mod_n(289, 992));     #=> 417 513 975 79 913 17 479 575
say join(' ', sqrt_mod_n(472, 972));     #=> 448 524

# The algorithm works for arbitrary large integers
say join(' ', sqrt_mod_n(13**18 * 5**7 - 1, 13**18 * 5**7));    #=> 633398078861605286438568 2308322911594648160422943 6477255756527023177780182 8152180589260066051764557


================================================
FILE: Math/squarefree_almost_prime_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 March 2021
# https://github.com/trizen

# Generate all the squarefree k-almost prime divisors of n.

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub squarefree_almost_prime_divisors ($n, $k) {

    if ($k == 0) {
        return (1);
    }

    my @factor_exp  = factor_exp($n);
    my @factors     = map { $_->[0] } @factor_exp;
    my %valuations  = map { @$_ } @factor_exp;
    my $factors_end = $#factors;

    if ($k == 1) {
        return @factors;
    }

    my @list;

    sub ($m, $k, $i = 0) {

        if ($k == 1) {

            my $L = divint($n, $m);

            foreach my $j ($i .. $factors_end) {
                my $q = $factors[$j];
                last if ($q > $L);
                push(@list, mulint($m, $q));
            }

            return;
        }

        my $L = rootint(divint($n, $m), $k);

        foreach my $j ($i .. $factors_end - 1) {
            my $q = $factors[$j];
            last if ($q > $L);
            __SUB__->(mulint($m, $q), $k - 1, $j + 1);
        }
    }->(1, $k);

    sort { $a <=> $b } @list;
}

my $n = vecprod(@{primes(15)});

foreach my $k (0 .. prime_omega($n)) {
    my @divisors = squarefree_almost_prime_divisors($n, $k);
    printf("%2d-squarefree almost prime divisors of %s: [%s]\n", $k, $n, join(', ', @divisors));
}

__END__
 0-squarefree almost prime divisors of 30030: [1]
 1-squarefree almost prime divisors of 30030: [2, 3, 5, 7, 11, 13]
 2-squarefree almost prime divisors of 30030: [6, 10, 14, 15, 21, 22, 26, 33, 35, 39, 55, 65, 77, 91, 143]
 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]
 4-squarefree almost prime divisors of 30030: [210, 330, 390, 462, 546, 770, 858, 910, 1155, 1365, 1430, 2002, 2145, 3003, 5005]
 5-squarefree almost prime divisors of 30030: [2310, 2730, 4290, 6006, 10010, 15015]
 6-squarefree almost prime divisors of 30030: [30030]


================================================
FILE: Math/squarefree_almost_primes_from_factor_list.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 29 March 2021
# https://github.com/trizen

# Generate all the squarefree k-almost primes <= n, using a given list of prime factors.

use 5.020;
use ntheory qw(:all);
use experimental qw(signatures);

sub squarefree_almost_primes ($n, $k, $factors) {

    my $factors_end = $#{$factors};

    if ($k == 0) {
        return (1);
    }

    if ($k == 1) {
        return @$factors;
    }

    my @list;

    sub ($m, $k, $i = 0) {

        if ($k == 1) {

            my $L = divint($n, $m);

            foreach my $j ($i .. $factors_end) {
                my $q = $factors->[$j];
                last if ($q > $L);
                push(@list, mulint($m, $q));
            }

            return;
        }

        my $L = rootint(divint($n, $m), $k);

        foreach my $j ($i .. $factors_end - 1) {
            my $q = $factors->[$j];
            last if ($q > $L);
            __SUB__->(mulint($m, $q), $k - 1, $j + 1);
        }
    }->(1, $k);

    sort { $a <=> $b } @list;
}

my $n       = 1e6;                  # limit
my @factors = @{primes(17)};        # prime list

foreach my $k (0 .. scalar(@factors)) {
    my @divisors = squarefree_almost_primes($n, $k, \@factors);
    printf("%2d-squarefree almost primes <= %s: [%s]\n", $k, $n, join(', ', @divisors));
}

__END__
 0-squarefree almost primes <= 1000000: [1]
 1-squarefree almost primes <= 1000000: [2, 3, 5, 7, 11, 13, 17]
 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]
 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]
 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]
 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]
 6-squarefree almost primes <= 1000000: [30030, 39270, 46410, 72930, 102102, 170170, 255255]
 7-squarefree almost primes <= 1000000: [510510]


================================================
FILE: Math/squarefree_almost_primes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 March 2021
# Edit: 14 March 2026
# https://github.com/trizen

# Generate squarefree k-almost prime numbers in range [a,b]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime

use 5.036;
use ntheory 0.074 qw(:all);

sub squarefree_almost_primes ($A, $B, $k, $callback) {

    $A = vecmax($A, pn_primorial($k));

    sub ($m, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));

            if ($lo > $hi) {
                return;
            }

            forprimes {
                $callback->(mulint($m, $_));
            } $lo, $hi;

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {
            __SUB__->(mulint($m, $p), $p+1, $k-1);
        }
    }->(1, 2, $k);
}

# Generate squarefree 5-almost primes in the range [3000, 10000]

my $k    = 5;
my $from = 3000;
my $upto = 10000;

my @arr; squarefree_almost_primes($from, $upto, $k, sub ($n) { push @arr, $n });

my @test = grep { is_almost_prime($k, $_) && is_square_free($_) } $from..$upto;   # just for testing
join(' ', sort { $a <=> $b } @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);


================================================
FILE: Math/squarefree_almost_primes_in_range_from_factor_list.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 17 March 2023
# https://github.com/trizen

# Generate all the squarefree k-almost primes in a given range [A, B], using a given list of prime factors.

use 5.036;
use ntheory 0.74 qw(:all);

sub squarefree_almost_primes_in_range ($A, $B, $k, $factors) {

    $A = vecmax($A, pn_primorial($k));

    my $factors_end = $#{$factors};

    if ($k == 0) {
        return (($A > 1) ? () : 1);
    }

    my @list;

    sub ($m, $k, $i = 0) {

        my $lo = $factors->[$i];
        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));

            if ($lo > $hi) {
                return;
            }

            foreach my $j ($i .. $factors_end) {
                my $q = $factors->[$j];
                last if ($q > $hi);
                next if ($q < $lo);
                push(@list, mulint($m, $q));
            }

            return;
        }

        foreach my $j ($i .. $factors_end - 1) {
            my $q = $factors->[$j];
            last if ($q > $hi);
            next if ($q < $lo);
            __SUB__->(mulint($m, $q), $k - 1, $j + 1);
        }
      }
      ->(1, $k);

    sort { $a <=> $b } @list;
}

my $from    = 1;
my $upto    = 1e6;
my @factors = @{primes(17)};    # prime list

foreach my $k (0 .. scalar(@factors)) {
    my @divisors = squarefree_almost_primes_in_range($from, $upto, $k, \@factors);
    printf("%2d-squarefree almost primes in range [%s, %s]: [%s]\n", $k, $from, $upto, join(', ', @divisors));
}

__END__
 0-squarefree almost primes in range [1, 1000000]: [1]
 1-squarefree almost primes in range [1, 1000000]: [2, 3, 5, 7, 11, 13, 17]
 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]
 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]
 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]
 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]
 6-squarefree almost primes in range [1, 1000000]: [30030, 39270, 46410, 72930, 102102, 170170, 255255]
 7-squarefree almost primes in range [1, 1000000]: [510510]


================================================
FILE: Math/squarefree_almost_primes_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 March 2021
# Edit: 04 April 2024
# https://github.com/trizen

# Generate all the squarefree k-almost prime numbers in range [A,B].

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime

use 5.036;
use ntheory qw(:all);
use Math::GMPz;

sub squarefree_almost_primes ($A, $B, $k) {

    $A = vecmax($A, pn_primorial($k));
    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();

    my @values = sub ($m, $lo, $k) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        my @lst;

        if ($k == 1) {

            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            foreach my $p (@{primes($lo, $hi)}) {
                my $v = Math::GMPz::Rmpz_init();
                Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                push @lst, $v;
            }

            return @lst;
        }

        my $z = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {
            Math::GMPz::Rmpz_mul_ui($z, $m, $p);
            push @lst, __SUB__->($z, $p + 1, $k - 1);
        }

        return @lst;
      }
      ->(Math::GMPz->new(1), 2, $k);

    sort { Math::GMPz::Rmpz_cmp($a, $b) } @values;
}

# Generate squarefree 5-almost primes in the range [3000, 10000]

my $k    = 5;
my $from = 3000;
my $upto = 10000;

my @arr  = squarefree_almost_primes($from, $upto, $k);
my @test = grep { is_almost_prime($k, $_) && is_square_free($_) } $from .. $upto;    # just for testing

join(' ', @arr) eq join(' ', @test) or die "Error: not equal!";

say join(', ', @arr);


================================================
FILE: Math/squarefree_divisors.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 08 July 2018
# https://github.com/trizen

# Generate the squarefree divisors of a given number.

# See also:
#   https://oeis.org/A048250

use 5.036;
use ntheory qw(:all);

sub squarefree_divisors($n) {

    my @d = (1);
    my @pp = map { $_->[0] } factor_exp($n);

    foreach my $p (@pp) {
        push @d, map { mulint($_, $p) } @d;
    }

    return sort { $a <=> $b } @d;
}

foreach my $n (1 .. 20) {
    my @d = squarefree_divisors($n);
    say "squarefree divisors of $n: [@d]";
}

__END__
squarefree divisors of 1: [1]
squarefree divisors of 2: [1 2]
squarefree divisors of 3: [1 3]
squarefree divisors of 4: [1 2]
squarefree divisors of 5: [1 5]
squarefree divisors of 6: [1 2 3 6]
squarefree divisors of 7: [1 7]
squarefree divisors of 8: [1 2]
squarefree divisors of 9: [1 3]
squarefree divisors of 10: [1 2 5 10]
squarefree divisors of 11: [1 11]
squarefree divisors of 12: [1 2 3 6]
squarefree divisors of 13: [1 13]
squarefree divisors of 14: [1 2 7 14]
squarefree divisors of 15: [1 3 5 15]
squarefree divisors of 16: [1 2]
squarefree divisors of 17: [1 17]
squarefree divisors of 18: [1 2 3 6]
squarefree divisors of 19: [1 19]
squarefree divisors of 20: [1 2 5 10]


================================================
FILE: Math/squarefree_fermat_overpseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 28 August 2022
# Edit: 04 September 2022
# https://github.com/trizen

# Generate all the squarefree Fermat overpseudoprimes to a given base with n prime factors in a given range [a,b]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use ntheory 0.74 qw(:all);
use Memoize qw(memoize);

memoize('inverse_znorder_primes');

sub inverse_znorder_primes ($base, $lambda) {
    my %seen;
    grep { !$seen{$_}++ } factor(subint(powint($base, $lambda), 1));
}

sub iterate_over_primes ($x, $y, $base, $lambda, $callback) {

    if ($lambda > 1 and $lambda <= 135) {
        foreach my $p (inverse_znorder_primes($base, $lambda)) {

            next if $p < $x;
            last if $p > $y;

            #znorder($base, $p) == $lambda or next;

            $callback->($p);
        }
        return;
    }

    if ($lambda > 1) {
        for (my $w = $lambda * cdivint($x - 1, $lambda) ; $w <= $y ; $w += $lambda) {
            if (is_prime($w + 1) and powmod($base, $lambda, $w + 1) == 1) {
                $callback->($w + 1);
            }
        }
        return;
    }

    for (my $p = next_prime($x - 1) ; $p <= $y ; $p = next_prime($p)) {
        $callback->($p);
    }
}

sub squarefree_fermat_overpseudoprimes_in_range ($A, $B, $k, $base, $callback) {

    $A = vecmax($A, pn_primorial($k));

    my $F;
    $F = sub ($m, $lambda, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));

            if ($lo > $hi) {
                return;
            }

            iterate_over_primes(
                $lo, $hi, $base, $lambda,
                sub ($p) {
                    if (powmod($base, $lambda, $p) == 1) {
                        if (($m * $p - 1) % $lambda == 0 and znorder($base, $p) == $lambda) {
                            $callback->($m * $p);
                        }
                    }
                }
            );

            return;
        }

        iterate_over_primes(
            $lo, $hi, $base, $lambda,
            sub ($p) {
                if ($base % $p != 0) {
                    my $z = znorder($base, $p);
                    if (($z == $lambda or $lambda == 1) and gcd($z, $m) == 1) {
                        $F->($m * $p, $z, $p + 1, $k - 1);
                    }
                }
            }
        );
    };

    $F->(1, 1, 2, $k);
    undef $F;
}

# Generate all the squarefree Fermat overpseudoprimes to base 2 with 3 prime factors in the range [13421773, 412346200100]

my $k    = 3;
my $base = 2;
my $from = 13421773;
my $upto = 412346200100;

my @arr; squarefree_fermat_overpseudoprimes_in_range($from, $upto, $k, $base, sub ($n) { push @arr, $n });

say join(', ', sort { $a <=> $b } @arr);

__END__
13421773, 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


================================================
FILE: Math/squarefree_fermat_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 28 August 2022
# https://github.com/trizen

# Generate all the squarefree Fermat pseudoprimes to a given base with n prime factors in a given range [A,B]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (in range) (simple):
#   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)));

# PARI/GP program (in range) (faster):
#   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)));

use 5.036;
use ntheory 0.74 qw(:all);

sub squarefree_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    my @list;

    sub ($m, $L, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            my $t = invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime($p) and $base % $p != 0) {
                    if (($m * $p - 1) % znorder($base, $p) == 0) {
                        push(@list, $m * $p);
                    }
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;
            my $z = znorder($base, $p);
            gcd($m, $z) == 1 or next;

            __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1);
        }
      }
      ->(1, 1, 2, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the squarefree Fermat pseudoprimes to base 2 with 5 prime factors in the range [100, 10^8]

my $k    = 5;
my $base = 2;
my $from = 100;
my $upto = 1e8;

my @arr = squarefree_fermat_pseudoprimes_in_range($from, $upto, $k, $base);

say join(', ', sort { $a <=> $b } @arr);

# Run some tests

if (1) {    # true to run some tests
    foreach my $k (2 .. 6) {

        my $lo           = pn_primorial($k);
        my $hi           = mulint($lo, 1000);
        my @omega_primes = grep { is_square_free($_) } @{omega_primes($k, $lo, $hi)};

        foreach my $base (2 .. 100) {
            my @this = grep { is_pseudoprime($_, $base) } @omega_primes;
            my @that = squarefree_fermat_pseudoprimes_in_range($lo, $hi, $k, $base);
            join(' ', @this) eq join(' ', @that)
              or die "Error for k = $k and base = $base with hi = $hi\n(@this) != (@that)";
        }
    }
}

__END__
825265, 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


================================================
FILE: Math/squarefree_fermat_pseudoprimes_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 February 2023
# https://github.com/trizen

# Generate all the squarefree Fermat pseudoprimes to a given base with n prime factors in a given range [A,B]. (not in sorted order)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

# PARI/GP program (in range):
#   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)));

# PARI/GP program (in range) (faster):
#   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)));

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub squarefree_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    my @list;

    sub ($m, $L, $lo, $k) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            Math::GMPz::Rmpz_invert($v, $m, $L);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime($p) and $base % $p != 0) {
                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                    Math::GMPz::Rmpz_sub_ui($u, $v, 1);
                    if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {
                        push(@list, Math::GMPz::Rmpz_init_set($v));
                    }
                }
            }

            return;
        }

        my $t   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;
            my $z = znorder($base, $p);
            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);
            Math::GMPz::Rmpz_mul_ui($t, $m, $p);

            __SUB__->($t, $lcm, $p + 1, $k - 1);
        }
      }
      ->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the squarefree Fermat pseudoprimes to base 2 with 5 prime factors in the range [100, 10^8]

my $k    = 5;
my $base = 3;
my $from = 100;
my $upto = 1e8;

my @arr = squarefree_fermat_pseudoprimes_in_range($from, $upto, $k, $base);
say join(', ', @arr);

__END__
825265, 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


================================================
FILE: Math/squarefree_lucas_U_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 06 September 2022
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Lucas_sequence
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use ntheory 0.74 qw(:all);

sub lucas_znorder ($P, $Q, $D, $n) {

    foreach my $d (divisors($n - kronecker($D, $n))) {
        my ($u, $v) = lucas_sequence($n, $P, $Q, $d);
        if ($u == 0) {
            return $d;
        }
    }

    return undef;
}

sub squarefree_lucas_U_pseudoprimes_in_range ($A, $B, $k, $P, $Q) {

    $A = vecmax($A, pn_primorial($k));
    my $D = $P * $P - 4 * $Q;

    my @list;

    sub ($m, $L, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            foreach my $j (1, -1) {

                my $t = mulmod(invmod($m, $L), $j, $L);
                $t > $hi && next;
                $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

                for (my $p = $t ; $p <= $hi ; $p += $L) {
                    if (is_prime($p)) {
                        my $n = $m * $p;
                        my $w = $n - kronecker($D, $n);
                        if ($w % $L == 0 and $w % lucas_znorder($P, $Q, $D, $p) == 0) {
                            push(@list, $n);
                        }
                    }
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $D % $p == 0 and next;

            my $z = lucas_znorder($P, $Q, $D, $p) // next;
            gcd($m, $z) == 1 or next;

            __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1);
        }
      }
      ->(1, 1, 2, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the squarefree Fibonacci pseudoprimes in the range [1, 64681]

my $from = 1;
my $upto = 64681;
my ($P, $Q) = (1, -1);

my @arr;
foreach my $k (2 .. 100) {
    last if pn_primorial($k) > $upto;
    push @arr, squarefree_lucas_U_pseudoprimes_in_range($from, $upto, $k, $P, $Q);
}

say join(', ', sort { $a <=> $b } @arr);

__END__
323, 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


================================================
FILE: Math/squarefree_strong_fermat_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 September 2022
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use ntheory 0.74 qw(:all);

sub squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    if ($A > $B) {
        return;
    }

    my @list;

    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            my $t = invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {

                is_prime($p) || next;
                $base % $p == 0 and next;

                my $val = valuation($p - 1, 2);
                if ($val > $k_exp and powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p)) {
                    my $n = $m * $p;
                    if (($n - 1) % znorder($base, $p) == 0) {
                        push @list, $n;
                    }
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $val = valuation($p - 1, 2);
            $val > $k_exp                                                   or next;
            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

            my $z = znorder($base, $p);
            if (gcd($m, $z) == 1) {
                __SUB__->($m * $p, lcm($L, $z), $p + 1, $k - 1, $k_exp, $congr);
            }
        }
    };

    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.
    $generator->(1, 1, 2, $k, 0, 1);

    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.
    foreach my $v (0 .. logint($B, 2)) {
        $generator->(1, 1, 2, $k, $v, -1);
    }

    return sort { $a <=> $b } @list;
}

# Generate all the squarefree strong Fermat pseudoprimes to base 2 with 3 prime factors in the range [1, 10^8]

my $k    = 3;
my $base = 2;
my $from = 1;
my $upto = 1e8;

my @arr = squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);
say join(', ', @arr);

__END__
15841, 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


================================================
FILE: Math/squarefree_strong_fermat_pseudoprimes_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 February 2023
# https://github.com/trizen

# 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)

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    my @list;

    my $generator = sub ($m, $L, $lo, $k, $k_exp, $congr) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            Math::GMPz::Rmpz_invert($v, $m, $L);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {

                is_prime($p) || next;
                $base % $p == 0 and next;

                my $val = valuation($p - 1, 2);
                if ($val > $k_exp and powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p)) {
                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                    Math::GMPz::Rmpz_sub_ui($u, $v, 1);
                    if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {
                        push(@list, Math::GMPz::Rmpz_init_set($v));
                    }
                }
            }

            return;
        }

        my $t   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $val = valuation($p - 1, 2);
            $val > $k_exp                                                   or next;
            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

            my $z = znorder($base, $p);
            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);
            Math::GMPz::Rmpz_mul_ui($t, $m, $p);

            __SUB__->($t, $lcm, $p + 1, $k - 1, $k_exp, $congr);
        }
    };

    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.
    $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, 0, 1);

    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.
    foreach my $v (0 .. logint($B, 2)) {
        $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, $v, -1);
    }

    return sort { $a <=> $b } @list;
}

# Generate all the squarefree strong Fermat pseudoprimes to base 2 with 3 prime factors in the range [1, 10^8]

my $k    = 3;
my $base = 2;
my $from = 1;
my $upto = 1e8;

my @arr = squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);
say join(', ', @arr);

__END__
15841, 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


================================================
FILE: Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 09 March 2023
# https://github.com/trizen

# Generate all the squarefree k-omega strong Fermat pseudoprimes in range [A,B] to multiple given bases. (not in sorted order)

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use ntheory 0.74 qw(:all);

sub squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $bases) {

    $A = vecmax($A, pn_primorial($k));
    $A > $B and return;

    my @bases     = @$bases;
    my $bases_lcm = lcm(@bases);

    my @list;

    sub ($m, $L, $lo, $k) {

        my $hi = rootint(divint($B, $m), $k);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            $lo = vecmax($lo, cdivint($A, $m));
            $lo > $hi && return;

            my $t = invmod($m, $L) // return;
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime($p) and $bases_lcm % $p != 0 and $m % $p != 0) {
                    my $v = $m * $p;
                    if (is_strong_pseudoprime($v, @bases)) {
                        push(@list, $v);
                    }
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $bases_lcm % $p == 0 and next;

            my $lcm = lcm(map { znorder($_, $p) } @bases);
            gcd($m, $lcm) == 1 or next;

            __SUB__->($m * $p, lcm($L, $lcm), $p + 1, $k - 1);
        }
      }
      ->(1, 1, 2, $k);

    return sort { $a <=> $b } @list;
}

# Generate all the strong Fermat pseudoprimes to base 2,3 in range [1, 54029741]

my $from  = 1;
my $upto  = 54029741;
my @bases = (2, 3);

my @arr;
foreach my $k (2 .. 100) {
    last if pn_primorial($k) > $upto;
    push @arr, squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, \@bases);
}

say join(', ', sort { $a <=> $b } @arr);

__END__
1373653, 1530787, 1987021, 2284453, 3116107, 5173601, 6787327, 11541307, 13694761, 15978007, 16070429, 16879501, 25326001, 27509653, 27664033, 28527049, 54029741


================================================
FILE: Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 23 December 2023
# https://github.com/trizen

# Generate all the squarefree k-omega strong Fermat pseudoprimes in range [A,B] to multiple given bases. (not in sorted order)

# See also:
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub k_squarefree_strong_fermat_pseudoprimes_in_range ($A, $B, $k, $bases) {

    $A = vecmax($A, pn_primorial($k));

    my @bases     = @$bases;
    my $bases_lcm = lcm(@bases);

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    my @list;

    my $generator = sub ($m, $L, $lo, $k) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $k);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        if ($k == 1) {

            Math::GMPz::Rmpz_cdiv_q($u, $A, $m);

            if (Math::GMPz::Rmpz_fits_ulong_p($u)) {
                $lo = vecmax($lo, Math::GMPz::Rmpz_get_ui($u));
            }
            elsif (Math::GMPz::Rmpz_cmp_ui($u, $lo) > 0) {
                if (Math::GMPz::Rmpz_cmp_ui($u, $hi) > 0) {
                    return;
                }
                $lo = Math::GMPz::Rmpz_get_ui($u);
            }

            if ($lo > $hi) {
                return;
            }

            Math::GMPz::Rmpz_invert($v, $m, $L);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {

                is_prime($p) || next;
                $bases_lcm % $p == 0 and next;

                Math::GMPz::Rmpz_mul_ui($v, $m, $p);
                Math::GMPz::Rmpz_sub_ui($u, $v, 1);
                if (vecall { is_strong_pseudoprime($v, $_) } @bases) {
                    push(@list, Math::GMPz::Rmpz_init_set($v));
                }
            }

            return;
        }

        my $t   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            $bases_lcm % $p == 0 and next;

            my $z = lcm(map { znorder($_, $p) } @bases);
            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);
            Math::GMPz::Rmpz_mul_ui($t, $m, $p);

            __SUB__->($t, $lcm, $p + 1, $k - 1);
        }
      }
      ->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k);

    return sort { $a <=> $b } @list;
}

sub squarefree_strong_fermat_pseudoprimes_in_range ($from, $upto, $bases) {

    my @arr;

    for (my $k = 2 ; ; ++$k) {
        last if pn_primorial($k) > $upto;
        push @arr, k_squarefree_strong_fermat_pseudoprimes_in_range($from, $upto, $k, $bases);
    }

    return sort { $a <=> $b } @arr;
}

my @bases = (17, 31);

my $lo = Math::GMPz->new(2);
my $hi = 2 * $lo;

say ":: Searching for the smallest strong pseudoprime to bases: (@bases)";

while (1) {

    say ":: Sieving range: [$lo, $hi]";
    my @arr = squarefree_strong_fermat_pseudoprimes_in_range($lo, $hi, \@bases);

    if (@arr) {
        say "\nFound: $arr[0]";
        say "All terms: @arr\n" if (@arr > 1);
        last;
    }

    $lo = $hi + 1;
    $hi = 2 * $lo;
}

__END__
:: Searching for the smallest strong pseudoprime to bases: (17 31)
:: Sieving range: [2, 4]
:: Sieving range: [5, 10]
:: Sieving range: [11, 22]
:: Sieving range: [23, 46]
:: Sieving range: [47, 94]
:: Sieving range: [95, 190]
:: Sieving range: [191, 382]
:: Sieving range: [383, 766]
:: Sieving range: [767, 1534]
:: Sieving range: [1535, 3070]
:: Sieving range: [3071, 6142]
:: Sieving range: [6143, 12286]
:: Sieving range: [12287, 24574]
:: Sieving range: [24575, 49150]
:: Sieving range: [49151, 98302]
:: Sieving range: [98303, 196606]
:: Sieving range: [196607, 393214]

Found: 197209
All terms: 197209 269011

perl script.pl  0.19s user 0.01s system 98% cpu 0.205 total


================================================
FILE: Math/stern_brocot_encoding.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 February 2018
# https://github.com/trizen

# Encode a given fraction into an integer, using the Stern-Brocot tree.

# The decoding function decodes a given integer back into a fraction.

# See also:
#   https://en.wikipedia.org/wiki/Stern%E2%80%93Brocot_tree

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(:overload abs);

sub stern_brocot_encode ($r) {

    my ($m, $n) = abs($r)->nude;

    my $enc = '';

    for (; ;) {
        if ((($m <=> $n) || last) < 0) {
            $enc .= '0';
            $n -= $m;
        }
        else {
            $enc .= '1';
            $m -= $n;
        }
    }

    return $enc;
}

sub stern_brocot_decode ($e) {

    my ($a, $b, $c, $d) = (1, 0, 0, 1);

    foreach my $bit (split(//, $e)) {
        if ($bit) {
            $a += $b;
            $c += $d;
        }
        else {
            $b += $a;
            $d += $c;
        }
    }

    ($c + $d) / ($a + $b);
}

say stern_brocot_encode(5 / 7);      # 0110
say stern_brocot_encode(43 / 97);    # 001110111111111
say stern_brocot_encode(97 / 43);    # 110001000000000

say '';

say stern_brocot_decode(stern_brocot_encode(5 / 7));      # 5/7
say stern_brocot_decode(stern_brocot_encode(43 / 97));    # 43/97
say stern_brocot_decode(stern_brocot_encode(97 / 43));    # 97/43

say "\n=> Tests:";

foreach my $n (1 .. 10) {

    my $f = Math::AnyNum::factorial($n);
    say "dec($n!) = ", stern_brocot_decode($f->as_bin);

    die "[0] error for dec($n!)" if (Math::AnyNum->new(stern_brocot_encode(stern_brocot_decode($f->as_bin)), 2) != $f);

    my $r1 = Math::AnyNum::fibonacci($n) / Math::AnyNum::lucas($n);
    die "[1] error for $r1" if (stern_brocot_decode(stern_brocot_encode($r1)) != $r1);

    my $r2 = Math::AnyNum::lucas($n) / $n**2;
    die "[2] error for $r2" if (stern_brocot_decode(stern_brocot_encode($r2)) != $r2);
}


================================================
FILE: Math/stern_brocot_sequence.pl
================================================
#!/usr/bin/perl

# Coded by Trizen
# Date: 14 May 2015
# https://github.com/trizen

use 5.010;
use strict;
use warnings;

# Inspired from: https://www.youtube.com/watch?v=DpwUVExX27E

#
## Create and return the sequence as an array
#
sub stern_brocot {
    my ($n) = @_;

    my @fib = (1, 1);
    foreach my $i (1 .. $n) {
        push @fib, $fib[$i] + $fib[$i - 1], $fib[$i];
    }
    return @fib;
}

say join(" ", stern_brocot(15));

#
## Print the sequence as it is generated
#
sub stern_brocot_realtime(&$) {
    my ($callback, $n) = @_;

    my @fib = (1, 1);
    foreach my $i (1 .. $n) {
        push @fib, $fib[0] + $fib[1], $fib[1];
        $callback->($fib[0]);
        shift @fib;
    }
    $callback->($_) for @fib;
}

{
    local $| = 1;
    my $i = 0;
    stern_brocot_realtime {
        my ($n) = @_;
        print "$n ";
    } 15;
}
print "\n";


================================================
FILE: Math/strong_fermat_pseudoprimes_in_range.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 September 2022
# https://github.com/trizen

# Generate all the k-omega strong Fermat pseudoprimes in range [A,B]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

=for comment

# PARI/GP program (slow):

strong_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)<=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));

# PARI/GP program (fast):

strong_check(p, base, e, r) = my(tv=valuation(p-1, 2)); tv > e && Mod(base, p)^((p-1)>>(tv-e)) == r;
strong_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));

=cut

use 5.036;
use ntheory 0.74 qw(:all);

sub strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));
    $A > $B and return;

    my %seen;
    my @list;

    my $generator = sub ($m, $L, $lo, $j, $k_exp, $congr) {

        my $hi = rootint(divint($B, $m), $j);

        if ($lo > $hi) {
            return;
        }

        if ($j == 1) {

            if ($L == 1) {    # optimization
                foreach my $p (@{primes($lo, $hi)}) {

                    $base % $p == 0 and next;

                    my $val = valuation($p - 1, 2);
                    $val > $k_exp                                                   or next;
                    powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

                    for (my $v = (($m == 1) ? ($p * $p) : ($m * $p)) ; $v <= $B ; $v *= $p) {
                        $v >= $A                       or next;
                        powmod($base, $v - 1, $v) == 1 or last;
                        push(@list, $v) if !$seen{$v}++;
                    }
                }
                return;
            }

            my $t = invmod($m, $L);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {
                if (is_prime_power($p) and gcd($m, $p) == 1 and gcd($base, $p) == 1) {

                    my $val = valuation($p - 1, 2);
                    $val > $k_exp                                                   or next;
                    powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

                    my $v = $m * $p;
                    $v >= $A                           or next;
                    ($v - 1) % znorder($base, $p) == 0 or next;
                    push(@list, $v) if !$seen{$v}++;
                }
            }

            return;
        }

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $val = valuation($p - 1, 2);
            $val > $k_exp                                                   or next;
            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

            my $z = znorder($base, $p);
            gcd($m, $z) == 1 or next;

            for (my ($q, $v) = ($p, $m * $p) ; $v <= $B ; ($q, $v) = ($q * $p, $v * $p)) {

                if ($q > $p) {
                    powmod($base, $z, $q) == 1 or last;
                }

                __SUB__->($v, lcm($L, $z), $p + 1, $j - 1, $k_exp, $congr);
            }
        }
    };

    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.
    $generator->(1, 1, 2, $k, 0, 1);

    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.
    foreach my $v (0 .. logint($B, 2)) {
        $generator->(1, 1, 2, $k, $v, -1);
    }

    return sort { $a <=> $b } @list;
}

# Generate all the Fermat pseudoprimes to base 3 in range [1, 10^5]

my $from = 1;
my $upto = 1e5;
my $base = 3;

my @arr;
foreach my $k (1 .. 100) {
    last if pn_primorial($k) > $upto;
    push @arr, strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);
}

say join(', ', sort { $a <=> $b } @arr);

# Run some tests

if (0) {    # true to run some tests
    foreach my $k (1 .. 5) {

        say "Testing k = $k";

        my $lo           = pn_primorial($k);
        my $hi           = mulint($lo, 10000);
        my $omega_primes = omega_primes($k, $lo, $hi);

        foreach my $base (2 .. 100) {
            my @this = grep { is_strong_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;
            my @that = strong_fermat_pseudoprimes_in_range($lo, $hi, $k, $base);
            join(' ', @this) eq join(' ', @that)
              or die "Error for k = $k and base = $base with hi = $hi\n(@this) != (@that)";
        }
    }
}

__END__
121, 703, 1891, 3281, 8401, 8911, 10585, 12403, 16531, 18721, 19345, 23521, 31621, 44287, 47197, 55969, 63139, 74593, 79003, 82513, 87913, 88573, 97567


================================================
FILE: Math/strong_fermat_pseudoprimes_in_range_mpz.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 September 2022
# https://github.com/trizen

# Generate all the k-omega strong Fermat pseudoprimes in range [A,B]. (not in sorted order)

# Definition:
#   k-omega primes are numbers n such that omega(n) = k.

# See also:
#   https://en.wikipedia.org/wiki/Almost_prime
#   https://en.wikipedia.org/wiki/Prime_omega_function
#   https://trizenx.blogspot.com/2020/08/pseudoprimes-construction-methods-and.html

=for comment

# PARI/GP program (slow):

strong_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)<=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));

# PARI/GP program (fast):

strong_check(p, base, e, r) = my(tv=valuation(p-1, 2)); tv > e && Mod(base, p)^((p-1)>>(tv-e)) == r;
strong_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));

=cut

use 5.036;
use Math::GMPz;
use ntheory 0.74 qw(:all);

sub strong_fermat_pseudoprimes_in_range ($A, $B, $k, $base) {

    $A = vecmax($A, pn_primorial($k));

    $A = Math::GMPz->new("$A");
    $B = Math::GMPz->new("$B");

    my $u = Math::GMPz::Rmpz_init();
    my $v = Math::GMPz::Rmpz_init();

    my %seen;
    my @list;

    my $generator = sub ($m, $L, $lo, $j, $k_exp, $congr) {

        Math::GMPz::Rmpz_tdiv_q($u, $B, $m);
        Math::GMPz::Rmpz_root($u, $u, $j);

        my $hi = Math::GMPz::Rmpz_get_ui($u);

        if ($lo > $hi) {
            return;
        }

        if ($j == 1) {

            Math::GMPz::Rmpz_invert($v, $m, $L);

            if (Math::GMPz::Rmpz_cmp_ui($v, $hi) > 0) {
                return;
            }

            if (Math::GMPz::Rmpz_fits_ulong_p($L)) {
                $L = Math::GMPz::Rmpz_get_ui($L);
            }

            my $t = Math::GMPz::Rmpz_get_ui($v);
            $t > $hi && return;
            $t += $L * cdivint($lo - $t, $L) if ($t < $lo);

            for (my $p = $t ; $p <= $hi ; $p += $L) {

                if (is_prime_power($p) and Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $p) == 1 and gcd($base, $p) == 1) {

                    my $val = valuation($p - 1, 2);
                    $val > $k_exp                                                   or next;
                    powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

                    Math::GMPz::Rmpz_mul_ui($v, $m, $p);

                    if ($k == 1 and is_prime($p) and Math::GMPz::Rmpz_cmp_ui($m, 1) == 0) {
                        ## ok
                    }
                    elsif (Math::GMPz::Rmpz_cmp($v, $A) >= 0) {
                        Math::GMPz::Rmpz_sub_ui($u, $v, 1);
                        if (Math::GMPz::Rmpz_divisible_ui_p($u, znorder($base, $p))) {
                            push(@list, Math::GMPz::Rmpz_init_set($v)) if !$seen{Math::GMPz::Rmpz_get_str($v, 10)}++;
                        }
                    }
                }
            }

            return;
        }

        my $u   = Math::GMPz::Rmpz_init();
        my $v   = Math::GMPz::Rmpz_init();
        my $lcm = Math::GMPz::Rmpz_init();

        foreach my $p (@{primes($lo, $hi)}) {

            $base % $p == 0 and next;

            my $val = valuation($p - 1, 2);
            $val > $k_exp                                                   or next;
            powmod($base, ($p - 1) >> ($val - $k_exp), $p) == ($congr % $p) or next;

            my $z = znorder($base, $p);
            Math::GMPz::Rmpz_gcd_ui($Math::GMPz::NULL, $m, $z) == 1 or next;
            Math::GMPz::Rmpz_lcm_ui($lcm, $L, $z);

            Math::GMPz::Rmpz_set_ui($u, $p);

            for (Math::GMPz::Rmpz_mul_ui($v, $m, $p) ; Math::GMPz::Rmpz_cmp($v, $B) <= 0 ; Math::GMPz::Rmpz_mul_ui($v, $v, $p)) {
                __SUB__->($v, $lcm, $p + 1, $j - 1, $k_exp, $congr);
                Math::GMPz::Rmpz_mul_ui($u, $u, $p);
                powmod($base, $z, $u) == 1 or last;
            }
        }
    };

    # Case where 2^d == 1 (mod p), where d is the odd part of p-1.
    $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, 0, 1);

    # Cases where 2^(d * 2^v) == -1 (mod p), for some v >= 0.
    foreach my $v (0 .. logint($B, 2)) {
        $generator->(Math::GMPz->new(1), Math::GMPz->new(1), 2, $k, $v, -1);
    }

    return sort { $a <=> $b } @list;
}

# Generate all the strong Fermat pseudoprimes to base 3 in range [1, 10^5]

my $from = 1;
my $upto = 1e5;
my $base = 3;

my @arr;
foreach my $k (1 .. 100) {
    last if pn_primorial($k) > $upto;
    push @arr, strong_fermat_pseudoprimes_in_range($from, $upto, $k, $base);
}

say join(', ', sort { $a <=> $b } @arr);

# Run some tests

if (0) {    # true to run some tests
    foreach my $k (1 .. 5) {

        say "Testing k = $k";

        my $lo           = pn_primorial($k) * 4;
        my $hi           = mulint($lo, 1000);
        my $omega_primes = omega_primes($k, $lo, $hi);

        foreach my $base (2 .. 100) {
            my @this = grep { is_strong_pseudoprime($_, $base) and !is_prime($_) } @$omega_primes;
            my @that = strong_fermat_pseudoprimes_in_range($lo, $hi, $k, $base);
            join(' ', @this) eq join(' ', @that)
              or die "Error for k = $k and base = $base with hi = $hi\n(@this) != (@that)";
        }
    }
}

__END__
121, 703, 1891, 3281, 8401, 8911, 10585, 12403, 16531, 18721, 19345, 23521, 31621, 44287, 47197, 55969, 63139, 74593, 79003, 82513, 87913, 88573, 97567


================================================
FILE: Math/sub-unit_squares.pl
================================================
#!/usr/bin/perl

# Efficient algorithm for generating sub-unit squares.

# A sub-unit square is a square number that remains a square after having a 1 subtracted from each digit in the square.

# See also:
#   https://oeis.org/A061844
#   https://rosettacode.org/wiki/Sub-unit_squares

use 5.036;
use ntheory      qw(:all);
use Math::GMP    qw(:constant);
#use Math::AnyNum qw(:overload);

sub difference_of_two_squares_solutions ($n) {    # solutions x to x^2 - y^2 = n

    my @solutions;
    my $limit = sqrtint($n);

    foreach my $divisor (divisors($n)) {

        last if $divisor > $limit;

        my $p = $divisor;
        my $q = $n / $divisor;

        ($p + $q) % 2 == 0 or next;

        my $x = ($q + $p) >> 1;
        unshift @solutions, $x;
    }

    return @solutions;
}

my $N    = 34;         # how many terms to compute
my %seen = (1 => 1);

my $index = 1;
say($index, ': ', 1);

OUTER: for (my $n = 1 ; ; ++$n) {

    my $r = (10**$n - 1) / 9;

    foreach my $x (difference_of_two_squares_solutions($r)) {

        my $xsqr = $x**2;
        my @d    = todigits($xsqr);

        next if $d[0] == 1;
        next if !vecall { $_ } @d;
        next if !is_square(fromdigits([map { $_ - 1 } @d]));

        if (!$seen{$xsqr}++) {
            say(++$index, ': ', $xsqr);
            last OUTER if ($index >= $N);
        }
    }
}

__END__
1: 1
2: 36
3: 3136
4: 24336
5: 5973136
6: 71526293136
7: 318723477136
8: 264779654424693136
9: 24987377153764853136
10: 31872399155963477136
11: 58396845218255516736
12: 517177921565478376336
13: 252815272791521979771662766736
14: 518364744896318875336864648336
15: 554692513628187865132829886736
16: 658424734191428581711475835136
17: 672475429414871757619952152336
18: 694688876763154697414122245136
19: 711197579293752874333735845136
20: 975321699545235187287523246336
21: 23871973274358556957126877486736
22: 25347159162241162461433882565136
23: 34589996454813135961785697637136
24: 2858541763747552538199941619545257144336
25: 214785886789716796533667464535274377236736
26: 233292528132679183463629157143235636286736
27: 244671849793441155421899813243325528686736
28: 271571567929448516411695557685613529966736
29: 322388381596588665613523969581347191316736
30: 385414415625146742626881165526237149942336
31: 494827714874767379344736911473964125592336
32: 729191918879671448289782722539515523333136
33: 739265858539339252384919139328667324488336
34: 451616391374794616993675837721511769881724292768597136


================================================
FILE: Math/sum_factorial.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13th October 2013
# https://trizenx.blogspot.com

# This script generates sums of consecutive numbers for factorial numbers.

use 5.010;
use strict;
use warnings;

sub sum_x {
    my ($x, $y, $z) = @_;
    ($x + $y) * (($y - $x) / $z + 1) / 2;
}

sub factorial {
    my ($n) = @_;

    my $fact = 1;
    $fact *= $_ for 2 .. $n;

    $fact;
}

foreach my $i (1 .. 9) {
    my $fact = factorial($i);

  O: for (my $o = 1 ; $o <= int sqrt($fact) ; $o++) {
      N: for (my $n = 1 ; $n <= $fact ; $n++) {
          M: for (my $m = $n ; $m <= $fact ; $m++) {

                my $sum = sum_x($n, $m, $o);

                if ($sum == $fact) {
                    printf "%2d. %10d:%5d %10d .. %d\n", $i, $fact, $o, $n, $m;
                }
            }
        }

        last if $o >= 1;
    }

    say '';
}


================================================
FILE: Math/sum_of_an_even_number_of_positive_squares.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 October 2017
# https://github.com/trizen

# Algorithm for representing a positive integer `n` as a sum of an even number of positive squares.

# Example:
#   9925 = 5^2 * 397
#   9925 = (3^2 + 4^2) * (6^2 + 19^2)
#   9925 = 18^2 + 24^2 + 57^2 + 76^2

# This algorithm is efficient when the factorization of `n` is known.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(sqrtmod factor_exp vecprod vecsum forsetproduct);

sub primitive_sum_of_two_squares ($p) {

    if ($p == 2) {
        return [1, 1];
    }

    my $s = sqrtmod($p - 1, $p) || return;
    my $q = $p;

    while ($s * $s > $p) {
        ($s, $q) = ($q % $s, $s);
    }

    return [$s, $q % $s];
}

sub sum_of_squares_solution ($n) {

    my @primitives;
    my $left_prod = 1;

    foreach my $f (factor_exp($n)) {
        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)
            $f->[1] % 2 == 0 or return;    # power must be even
            $left_prod *= $f->[0]**($f->[1] >> 1);
        }
        elsif ($f->[0] == 2) {             # p = 2
            if ($f->[1] % 2 == 0) {        # power is even
                $left_prod *= $f->[0]**($f->[1] >> 1);
            }
            else {                         # power is odd
                push @primitives, [1, 1];
                $left_prod *= $f->[0]**(($f->[1] - 1) >> 1);
            }
        }
        else {                             # p = 1 (mod 4)
            push @primitives, primitive_sum_of_two_squares($f->[0]**$f->[1]);
        }
    }

    my @solution;

    forsetproduct {
        push @solution, vecprod($left_prod, @_);
    } @primitives;

    return sort { $a <=> $b } @solution;
}

foreach my $n (1..1e5) {
    (my @solution = sum_of_squares_solution($n)) || next;

    say "$n = ", join(' + ', map { "$_^2" } @solution);

    # Verify solution
    if ((my $sum = vecsum(map { $_**2 } @solution)) != $n) {
        die "error for $n -> $sum";
    }
}

__END__
99872 = 156^2 + 156^2 + 160^2 + 160^2
99873 = 108^2 + 297^2
99874 = 116^2 + 116^2 + 191^2 + 191^2
99877 = 79^2 + 306^2
99881 = 5^2 + 316^2
99892 = 28^2 + 32^2 + 42^2 + 48^2 + 112^2 + 128^2 + 168^2 + 192^2
99901 = 26^2 + 315^2
99905 = 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
99908 = 208^2 + 238^2
99909 = 39^2 + 66^2 + 156^2 + 264^2
99914 = 111^2 + 111^2 + 194^2 + 194^2
99917 = 24^2 + 30^2 + 196^2 + 245^2
99920 = 60^2 + 120^2 + 128^2 + 256^2
99929 = 220^2 + 227^2
99937 = 36^2 + 96^2 + 105^2 + 280^2
99944 = 124^2 + 124^2 + 186^2 + 186^2
99945 = 42^2 + 84^2 + 135^2 + 270^2
99954 = 144^2 + 144^2 + 171^2 + 171^2
99956 = 10^2 + 316^2
99961 = 156^2 + 275^2
99965 = 48^2 + 96^2 + 133^2 + 266^2
99970 = 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
99972 = 174^2 + 264^2
99973 = 10^2 + 17^2 + 160^2 + 272^2
99976 = 82^2 + 82^2 + 208^2 + 208^2
99977 = 16^2 + 64^2 + 75^2 + 300^2
99985 = 26^2 + 52^2 + 139^2 + 278^2
99986 = 68^2 + 68^2 + 213^2 + 213^2
99989 = 217^2 + 230^2
99994 = 16^2 + 16^2 + 30^2 + 30^2 + 104^2 + 104^2 + 195^2 + 195^2
99997 = 171^2 + 266^2
100000 = 152^2 + 152^2 + 164^2 + 164^2


================================================
FILE: Math/sum_of_digits.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 12 May 2018
# https://github.com/trizen

# Two algorithms for computing the sum of the digits of an integer, in a given base.

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use Math::AnyNum qw(idiv divmod irand sumdigits ipow2);

sub sumdigits_1 ($n, $k) {

    my $N = $n;
    my $S = 0;

    while ($n >= 1) {
        $n = idiv($n, $k);
        $S += $n;
    }

    return ($N - $S * ($k - 1));
}

sub sumdigits_2 ($n, $k) {

    my $m = 0;
    my $S = 0;

    while ($n >= 1) {
        ($n, $m) = divmod($n, $k);
        $S += $m;
    }

    return $S;
}

my $n = irand(2, ipow2(100000));
my $k = irand(2, 1000);

say sumdigits($n, $k);    # provided by Math::AnyNum
say sumdigits_1($n, $k);
say sumdigits_2($n, $k);


================================================
FILE: Math/sum_of_digits_subquadratic_algorithm.pl
================================================
#!/usr/bin/perl

# Subquadratic algorithm for computing the sum of digits of a given integer in a given base.

# Based on the FastIntegerOutput algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub FastSumOfDigits ($A, $B) {

    # Find k such that B^(2k - 2) <= A < B^(2k)
    my $k = (logint($A, $B) >> 1) + 1;

    sub ($A, $k) {

        if ($A < $B) {
            return $A;
        }

        my ($Q, $R) = divrem($A, powint($B, $k));
        my $t = ($k + 1) >> 1;

        vecsum(__SUB__->($Q, $t), __SUB__->($R, $t));
    }->($A, $k);
}

foreach my $B (2 .. 100) {    # run some tests
    my $N = factorial($B);    # int(rand(~0));

    my $x = vecsum(todigits($N, $B));
    my $y = FastSumOfDigits($N, $B);

    if ($x != $y) {
        die "Error for: FastSumOfDigits($N, $B)";
    }
}

say join ', ', FastSumOfDigits(5040, 10);    #=> 9
say join ', ', FastSumOfDigits(5040, 11);    #=> 20
say join ', ', FastSumOfDigits(5040, 12);    #=> 13
say join ', ', FastSumOfDigits(5040, 13);    #=> 24


================================================
FILE: Math/sum_of_digits_subquadratic_algorithm_mpz.pl
================================================
#!/usr/bin/perl

# Subquadratic algorithm for computing the sum of digits of a given integer in a given base.

# Based on the FastIntegerOutput algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use ntheory qw(:all);
use experimental qw(signatures);

sub FastSumOfDigits ($A, $B) {

    $A = Math::GMPz->new("$A");

    # Find k such that B^(2k - 2) <= A < B^(2k)
    my $k = (logint($A, $B) >> 1) + 1;

    my $Q = Math::GMPz::Rmpz_init();
    my $R = Math::GMPz::Rmpz_init();

    sub ($A, $k) {

        if (Math::GMPz::Rmpz_cmp_ui($A, $B) < 0) {
            return Math::GMPz::Rmpz_get_ui($A);
        }

        my $w = ($k + 1) >> 1;
        my $t = Math::GMPz::Rmpz_init();

        Math::GMPz::Rmpz_ui_pow_ui($t, $B, $k);
        Math::GMPz::Rmpz_divmod($Q, $R, $A, $t);
        Math::GMPz::Rmpz_set($t, $Q);

        __SUB__->($R, $w) + __SUB__->($t, $w);
    }->($A, $k);
}

foreach my $B (2 .. 300) {    # run some tests
    my $N = factorial($B);    # int(rand(~0));

    my $x = vecsum(todigits($N, $B));
    my $y = FastSumOfDigits($N, $B);

    if ($x != $y) {
        die "Error for FastSumOfDigits($N, $B): $x != $y";
    }
}

say join ', ', FastSumOfDigits(5040, 10);    #=> 9
say join ', ', FastSumOfDigits(5040, 11);    #=> 20
say join ', ', FastSumOfDigits(5040, 12);    #=> 13
say join ', ', FastSumOfDigits(5040, 13);    #=> 24


================================================
FILE: Math/sum_of_k-powerful_numbers_in_range.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 28 February 2021
# Edit: 11 April 2024
# https://github.com/trizen

# Fast recursive algorithm for computing the sum of k-powerful numbers in a given range [A,B].
# A positive integer n is considered k-powerful, if for every prime p that divides n, so does p^k.

# Example:
#   2-powerful = a^2 * b^3,             for a,b >= 1
#   3-powerful = a^3 * b^4 * c^5,       for a,b,c >= 1
#   4-powerful = a^4 * b^5 * c^6 * d^7, for a,b,c,d >= 1

# OEIS:
#   https://oeis.org/A001694 -- 2-powerful numbers
#   https://oeis.org/A036966 -- 3-powerful numbers
#   https://oeis.org/A036967 -- 4-powerful numbers
#   https://oeis.org/A069492 -- 5-powerful numbers
#   https://oeis.org/A069493 -- 6-powerful numbers

# See also:
#   https://oeis.org/A118896 -- Number of powerful numbers <= 10^n.

use 5.036;
use ntheory 0.74 qw(:all);
use Math::AnyNum qw(faulhaber_sum);

sub powerful_sum_in_range ($A, $B, $k = 2) {

    return 0 if ($A > $B);

    my $sum = 0;

    sub ($m, $r) {

        my $from = 1;
        my $upto = rootint(divint($B, $m), $r);

        if ($r <= $k) {

            if ($A > $m) {

                # Optimization by Dana Jacobsen (from Math::Prime::Util::PP)
                my $l = cdivint($A, $m);
                if (($l >> $r) == 0) {
                    $from = 2;
                }
                else {
                    $from = rootint($l, $r);
                    $from++ if (powint($from, $r) != $l);
                }
            }

            return if ($from > $upto);
            $sum += $m * (faulhaber_sum($upto, $r) - faulhaber_sum($from - 1, $r));
            return;
        }

        foreach my $v ($from .. $upto) {
            gcd($m, $v) == 1   or next;
            is_square_free($v) or next;
            __SUB__->(mulint($m, powint($v, $r)), $r - 1);
        }
      }
      ->(1, 2 * $k - 1);

    return $sum;
}

require Math::Sidef;

foreach my $k (2 .. 10) {

    my $lo = int rand powint(10, $k - 1);
    my $hi = int rand powint(10, $k);

    my $c1 = powerful_sum_in_range($lo, $hi, $k);
    my $c2 = Math::Sidef::powerful_sum($k, $lo, $hi);

    $c1 eq $c2 or die "Error for [$lo, $hi] -- ($c1 != $c2)\n";

    printf("Sum of %2d-powerful in range 10^j .. 10^(j+1): {%s}\n",
           $k, join(", ", map { powerful_sum_in_range(powint(10, $_), powint(10, $_ + 1), $k) } 0 .. $k + 7));
}

__END__
Sum of  2-powerful in range 10^j .. 10^(j+1): {22, 502, 19545, 628164, 20656197, 668961441, 21437300251, 685328369991, 21824118507902, 693905863243612}
Sum of  3-powerful in range 10^j .. 10^(j+1): {9, 220, 6121, 136410, 3529846, 80934268, 1811337810, 41811161255, 929876351992, 20679545550210, 457363233598112}
Sum of  4-powerful in range 10^j .. 10^(j+1): {1, 193, 2493, 60370, 1440893, 26780053, 516891583, 9990376094, 193432085418, 3626702483663, 68456092587576, 1272728145913757}
Sum of  5-powerful in range 10^j .. 10^(j+1): {1, 96, 1868, 35009, 746121, 14039356, 230448956, 4041417437, 70765409052, 1214243920880, 21187881376824, 365947199216587, 6015063920839580}
Sum of  6-powerful in range 10^j .. 10^(j+1): {1, 64, 1625, 24108, 427138, 7503765, 142877197, 2128546916, 37085174023, 547117264876, 9207435088386, 149796088225544, 2342746880282546, 36741577488049351}
Sum 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}
Sum 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}
Sum 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}
Sum 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}


================================================
FILE: Math/sum_of_natural_powers_in_constant_base.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 September 2016
# Website: https://github.com/trizen

# Sum of increasing powers in constant base.

# Example:
#    ∑b^i for 0 ≤ i ≤ n == cf(b, n)
#
# where `b` can be any real number != 1.

use 5.010;
use strict;
use warnings;

sub cf {
    my ($base, $n) = @_;
    ($base ** ($n+1) - 1) / ($base-1);
}

say cf(3, 13);
say cf(-10.5, 4);
say cf(3.1415926535897932384626433832795, 10);


================================================
FILE: Math/sum_of_perfect_powers.pl
================================================
#!/usr/bin/perl

# Efficient formula for computing the sum of perfect powers <= n.

# Formula:
#   a(n) = faulhaber(n,1) - Sum_{1..floor(log_2(n))} mu(k) * (faulhaber(floor(n^(1/k)), k) - 1)
#        = 1 - Sum_{2..floor(log_2(n))} mu(k) * (faulhaber(floor(n^(1/k)), k) - 1)
#
# where:
#   faulhaber(n,k) = Sum_{j=1..n} j^k.

# See also:
#   https://oeis.org/A069623

use 5.036;
use ntheory      qw(moebius);
use Math::AnyNum qw(faulhaber_sum sum ipow iroot ilog2);

sub perfect_power_sum ($n) {
    1 - sum(map { moebius($_) * (faulhaber_sum(iroot($n, $_), $_) - 1) } 2 .. ilog2($n));
}

foreach my $n (0 .. 15) {
    printf("a(10^%d) = %s\n", $n, perfect_power_sum(ipow(10, $n)));
}

__END__
a(10^0) = 1
a(10^1) = 22
a(10^2) = 452
a(10^3) = 13050
a(10^4) = 410552
a(10^5) = 11888199
a(10^6) = 361590619
a(10^7) = 11120063109
a(10^8) = 345454923761
a(10^9) = 10800726331772
a(10^10) = 338846269199225
a(10^11) = 10659098451968490
a(10^12) = 335867724220740686
a(10^13) = 10595345580446344714
a(10^14) = 334502268562161605300
a(10^15) = 10566065095217905939231


================================================
FILE: Math/sum_of_prime-power_exponents_of_factorial.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 January 2019
# https://github.com/trizen

# Efficient program for computing the sum of exponents in prime-power factorization of n!.

# See also:
#   https://oeis.org/A022559    -- Sum of exponents in prime-power factorization of n!.
#   https://oeis.org/A071811    -- Sum_{k <= 10^n} number of primes (counted with multiplicity) dividing k

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub sum_of_exponents_of_factorial ($n) {

    return 0 if ($n <= 1);

    my $s = sqrtint($n);
    my $u = divint($n, $s+1);

    my $total = 0;
    my $prev  = prime_power_count($n);

    for my $k (1 .. $s) {
        my $curr = prime_power_count(divint($n, ($k + 1)));
        $total += $k * ($prev - $curr);
        $prev = $curr;
    }

    forprimes {
        for (my $q = $_; $q <= $u; $q *= $_) {
            $total += divint($n, $q);
        }
    } $u;

    return $total;
}

sub sum_of_exponents_of_factorial_2 ($n) {

    my $s = sqrtint($n);
    my $total = 0;

    for my $k (1 .. $s) {
        $total += prime_power_count(divint($n,$k));
        $total += divint($n,$k) if is_prime_power($k);
    }

    $total -= prime_power_count($s) * $s;

    return $total;
}

foreach my $k (1 .. 11) {       # takes ~4s
    say "a(10^$k) = ", sum_of_exponents_of_factorial(powint(10,$k));
}

__END__
a(10^1)  = 15
a(10^2)  = 239
a(10^3)  = 2877
a(10^4)  = 31985
a(10^5)  = 343614
a(10^6)  = 3626619
a(10^7)  = 37861249
a(10^8)  = 392351272
a(10^9)  = 4044220058
a(10^10) = 41518796555
a(10^11) = 424904645958
a(10^12) = 4337589196099
a(10^13) = 44189168275565


================================================
FILE: Math/sum_of_prime-power_exponents_of_product_of_binomials.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 15 January 2019
# https://github.com/trizen

# Program for computing the sum of the exponents in prime-power factorization of Product_{k=0..n} binomial(n, k).

#~ a(10^1) = 33
#~ a(10^2) = 1847
#~ a(10^3) = 94677
#~ a(10^4) = 6344339
#~ a(10^5) = 481640842
#~ a(10^6) = 39172738473
#~ a(10^7) = 3310162914057

# See also:
#   https://oeis.org/A323444

# Paper:
#   Jeffrey C. Lagarias, Harsh Mehta
#   Products of binomial coefficients and unreduced Farey fractions
#   https://arxiv.org/abs/1409.4145

use 5.010;
use strict;
use warnings;

use ntheory qw(factor);

sub sum_of_exponents_of_product_of_binomials {
    my ($n) = @_;

    return 0 if ($n <= 1);

    my ($r, $t) = (0, 0);

    foreach my $k (1 .. $n) {
        my $z = factor($k);
        $t += $z;
        $r += $k * $z - $t;
    }

    return $r;
}

foreach my $k (1 .. 7) {
    say "a(10^$k) = ", sum_of_exponents_of_product_of_binomials(10**$k);
}


================================================
FILE: Math/sum_of_prime_powers.pl
================================================
#!/usr/bin/perl

# Three sublinear algorithms for computing the sum of prime powers <= n,
# based on the sublinear algorithm for computing the sum of primes <= n.

# See also:
#   https://oeis.org/A074793

use 5.036;
use Math::GMPz;
use ntheory                qw(:all);
use Math::Prime::Util::GMP qw(faulhaber_sum);

sub sum_of_primes ($n, $k = 1) {    # Sum_{p prime <= n} p^k

    return sum_primes($n) if ($k == 1);    # optimization

    $n > ~0 and return undef;
    $n <= 1 and return 0;

    my $r = sqrtint($n);
    my @V = map { divint($n, $_) } 1 .. $r;
    push @V, CORE::reverse(1 .. $V[-1] - 1);

    my $t = Math::GMPz::Rmpz_init_set_ui(0);
    my $u = Math::GMPz::Rmpz_init();

    my %S;
    @S{@V} = map { Math::GMPz::Rmpz_init_set_str(faulhaber_sum($_, $k), 10) } @V;

    foreach my $p (2 .. $r) {
        if ($S{$p} > $S{$p - 1}) {
            my $cp = $S{$p - 1};
            my $p2 = $p * $p;
            Math::GMPz::Rmpz_ui_pow_ui($t, $p, $k);
            foreach my $v (@V) {
                last if ($v < $p2);
                Math::GMPz::Rmpz_sub($u, $S{divint($v, $p)}, $cp);
                Math::GMPz::Rmpz_submul($S{$v}, $u, $t);
            }
        }
    }

    $S{$n} - 1;
}

sub sum_of_prime_powers ($n) {

    # a(n) = Sum_{p prime <= n} p
    # b(n) = Sum_{p prime <= n^(1/2)} p^2
    # c(n) = Sum_{p prime <= n^(1/3)} f(p)

    # sum_of_prime_powers(n) = a(n) + b(n) + c(n)

    my $ps1 = sum_of_primes($n);
    my $ps2 = sum_of_primes(sqrtint($n), 2);

    # f(p) = (Sum_{k=1..floor(log_p(n))} p^k) - p^2 - p
    #      = (p^(1+floor(log_p(n))) - 1)/(p-1) - p^2 - p - 1

    my $ps3 = 0;
    foreach my $p (@{primes(rootint($n, 3))}) {
        $ps3 += divint(powint($p, logint($n, $p) + 1) - 1, $p - 1) - $p * $p - $p - 1;
    }

    return vecsum($ps1, $ps2, $ps3);
}

sub sum_of_prime_powers_2 ($n) {

    # a(n) = Sum_{p prime <= n} p
    # b(n) = Sum_{p prime <= n^(1/2)} f(p)

    # sum_of_prime_powers(n) = a(n) + b(n)

    my $ps1 = sum_of_primes($n);

    # f(p) = (Sum_{k=1..floor(log_p(n))} p^k) - p
    #      = (p^(1+floor(log_p(n))) - 1)/(p-1) - p - 1

    my $ps2 = 0;
    forprimes {
        $ps2 += divint(powint($_, logint($n, $_) + 1) - 1, $_ - 1) - $_ - 1;
    } sqrtint($n);

    return vecsum($ps1, $ps2);
}

sub sum_of_prime_powers_3 ($n) {

    # a(n) = Sum_{k=1..floor(log_2(n))} Sum_{p prime <= n^(1/k)} p^k.
    vecsum(map { sum_of_primes(rootint($n, $_), $_) } 1 .. logint($n, 2));
}

foreach my $n (0 .. 10) {
    say "a(10^$n) = ", sum_of_prime_powers(powint(10, $n));
}

foreach my $k (1 .. 100) {
    my $n = int(rand(1e3)) + 1;

    my $x = sum_of_prime_powers($n);
    my $y = sum_of_prime_powers_2($n);
    my $z = sum_of_prime_powers_3($n);

    $x == $y or die "error";
    $x == $z or die "error";
}

__END__
a(10^0) = 0
a(10^1) = 38
a(10^2) = 1375
a(10^3) = 82674
a(10^4) = 5850315
a(10^5) = 457028152
a(10^6) = 37610438089
a(10^7) = 3204814813355
a(10^8) = 279250347324393
a(10^9) = 24740607755154524
a(10^10) = 2220853189506845580
a(10^11) = 201467948093608962539
a(10^12) = 18435613572072500152927


================================================
FILE: Math/sum_of_primes_generalized.pl
================================================
#!/usr/bin/perl

# Simple implementation of the prime-summation function:
#   Sum_{p prime <= n} p^k, for any fixed k >= 0.

use 5.020;
use warnings;
use experimental qw(signatures);

use Math::GMPz;
use ntheory qw(divint sqrtint);
use Math::Prime::Util::GMP qw(faulhaber_sum);

sub sum_of_primes ($n, $k = 1) {

    $n > ~0 and return undef;
    $n <= 1 and return 0;

    my $r = sqrtint($n);
    my @V = map { divint($n, $_) } 1 .. $r;
    push @V, CORE::reverse(1 .. $V[-1] - 1);

    my $t = Math::GMPz::Rmpz_init_set_ui(0);
    my $u = Math::GMPz::Rmpz_init();

    my %S;
    @S{@V} = map { Math::GMPz::Rmpz_init_set_str(faulhaber_sum($_, $k), 10) } @V;

    foreach my $p (2 .. $r) {
        if ($S{$p} > $S{$p - 1}) {
            my $cp = $S{$p - 1};
            my $p2 = $p * $p;
            Math::GMPz::Rmpz_ui_pow_ui($t, $p, $k);
            foreach my $v (@V) {
                last if ($v < $p2);
                Math::GMPz::Rmpz_sub($u, $S{divint($v, $p)}, $cp);
                Math::GMPz::Rmpz_submul($S{$v}, $u, $t);
            }
        }
    }

    $S{$n} - 1;
}

say sum_of_primes(100, 0);      #=> 25
say sum_of_primes(1e8);         #=> 279209790387276
say sum_of_primes(1e8, 2);      #=> 18433608754948081174274


================================================
FILE: Math/sum_of_sigma.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 January 2018
# https://github.com/trizen

# Sum of the sigma(k) function, for 1 <= k <= n, where `sigma(k)` is `Sum_{d|k} d`.

# See also:
#   https://oeis.org/A024916
#   https://oeis.org/A072692

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(faulhaber_sum isqrt);

sub partial_sum_of_sigma {    # O(sqrt(n)) complexity
    my ($n) = @_;

    my $s = isqrt($n);
    my $u = int($n / ($s + 1));

    my $sum  = 0;
    my $prev = faulhaber_sum($n, 1);    # n-th triangular number

    foreach my $k (1 .. $s) {
        my $curr = faulhaber_sum(int($n/($k+1)), 1);
        $sum += $k * ($prev - $curr);
        $prev = $curr;
    }

    foreach my $k (1 .. $u) {
        $sum += $k * int($n / $k);
    }

    return $sum;
}

foreach my $k (0 .. 10) {
    say "a(10^$k) = ", partial_sum_of_sigma(10**$k);
}

__END__
a(10^0) = 1
a(10^1) = 87
a(10^2) = 8299
a(10^3) = 823081
a(10^4) = 82256014
a(10^5) = 8224740835
a(10^6) = 822468118437
a(10^7) = 82246711794796
a(10^8) = 8224670422194237
a(10^9) = 822467034112360628


================================================
FILE: Math/sum_of_sigma_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 January 2018
# https://github.com/trizen

# Sum of the sigma_2(k) function, for 1 <= k <= n, where `sigma_2(k)` is `Sum_{d|k} d^2`.

# See also:
#   https://oeis.org/A188138

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(isqrt faulhaber_sum);

sub partial_sum_of_sigma2 {    # O(sqrt(n)) complexity
    my ($n) = @_;

    my $s = isqrt($n);
    my $u = int($n / ($s + 1));

    my $sum  = 0;
    my $prev = faulhaber_sum($n, 2);

    foreach my $k (1 .. $s) {
        my $curr = faulhaber_sum(int($n / ($k + 1)), 2);
        $sum += $k * ($prev - $curr);
        $prev = $curr;
    }

    foreach my $k (1 .. $u) {
        $sum += $k * $k * int($n / $k);
    }

    return $sum;
}

foreach my $k (0 .. 9) {
    say "a(10^$k) = ", partial_sum_of_sigma2(10**$k);
}

__END__
a(10^0) = 1
a(10^1) = 469
a(10^2) = 407819
a(10^3) = 401382971
a(10^4) = 400757638164
a(10^5) = 400692683389101
a(10^6) = 400686363385965077
a(10^7) = 400685705322499946270
a(10^8) = 400685641565621401132515
a(10^9) = 400685635084923815073475174


================================================
FILE: Math/sum_of_the_number_of_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 18 August 2017
# https://github.com/trizen

# Sum of the number of divisors, `d(k)`, for 1 <= k <= n.

# Formula with O(sqrt(n)) complexity:
#   Sum_{k=1..n} d(k) = (2 * Sum_{k=1..floor(sqrt(n))} floor(n/k)) - floor(sqrt(n))^2

use 5.010;
use strict;
use warnings;

sub sum_of_sigma0 {
    my ($n) = @_;

    my $s = int(sqrt($n));

    my $sum = 0;
    foreach my $k (1 .. $s) {
        $sum += int($n / $k);
    }

    $sum *= 2;
    $sum -= $s**2;

    return $sum;
}

say sum_of_sigma0(100);      #=> 482
say sum_of_sigma0(1234);     #=> 8979
say sum_of_sigma0(98765);    #=> 1151076


================================================
FILE: Math/sum_of_the_number_of_divisors_of_gcd_x_y.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 January 2019
# https://github.com/trizen

# Fast formula for computing:
#   a(n) = sum of the number of divisors of gcd(x,y) with x*y <= n.

# See also:
#   https://oeis.org/A268732    -- Sum of the numbers of divisors of gcd(x,y) with x*y <= n.
#   https://oeis.org/A034444    -- Partial sums of A034444: sum of number of unitary divisors from 1 to n.
#   https://oeis.org/A180361    -- Sum of number of unitary divisors (A034444) from 1 to 10^n

# Adrian Dudek, on the Success of Mishandling Euclid's Lemma:
#   https://arxiv.org/abs/1602.03555

# Asymptotic formula:
#   a(n) ~ 1/6 * π^2 * n * (2 * (-12 * log(A) + γ + log(2) + log(π)) + log(n) + 2*γ - 1) + O(sqrt(n)*log(n))
#
# where γ is the Euler-Mascheroni constant and "A" is the Glaisher-Kinkelin constant.

# Alternative asymptotic formula:
#   a(n) ~ (n * zeta(2) * (log(n) + 2*γ - 1 + c)) + O(sqrt(n)*log(n))
#
#  where γ is the Euler-Mascheroni and c = 2*Zeta'(2)/Zeta(2) = -1.1399219861890656127997287200...

use 5.020;
use strict;
use warnings;

use ntheory qw(moebius);
use experimental qw(signatures);
use Math::AnyNum qw(:overload pi EulerGamma isqrt zeta round);

sub asymptotic_formula($n) {

    # c = 2*Zeta'(2)/Zeta(2) = (12 * Zeta'(2))/π^2 = 2*(-12*log(A) + γ + log(2) + log(π))
    my $c = -1.13992198618906561279972872003946000480696456161386195911639472087583455473348121357;

    # Asymptotic formula based on Merten's theorem (1874) (see: https://oeis.org/A064608)
    ($n * zeta(2) * (log($n) + 2 * EulerGamma + $c - 1));
}

sub asymptotic_formula2($n) {

    # The Glaisher-Kinkelin constant
    my $A = 1.28242712910062263687534256886979172776768892732500119206374002174040630885882646112973649195820237439420646120399;

    # Asymptotic formula in terms of the Glaisher-Kinkelin constant
    zeta(2) * $n * (2 * (-12 * log($A) + EulerGamma + log(2*pi)) + log($n) + 2*EulerGamma - 1);
}

sub sum_of_number_of_divisors_of_gcd ($n) {    # based on formula by Jerome Raulin (https://oeis.org/A064608)

    my $total = 0;

    foreach my $k (1 .. isqrt($n)) {
        my $t = 0;
        foreach my $j (1 .. isqrt($n / ($k * $k))) {
            $t += int($n / ($j * $k * $k));
        }

        my $r = isqrt($n / ($k * $k));
        $total += (2 * $t - $r * $r);
    }

    return $total;
}

say join(', ', map { sum_of_number_of_divisors_of_gcd($_) } 1 .. 20);

foreach my $k (1 .. 8) {

    my $n = 10**$k;
    my $t = sum_of_number_of_divisors_of_gcd($n);
    my $u = asymptotic_formula($n);

    printf("a(10^%s) = %10s ~ %-15s -> %s\n", $k, $t, round($u, -2), $t / $u);
}

__END__
[0, 1, 3, 5, 9, 11, 15, 17, 23, 27, 31, 33, 41, 43, 47, 51, 60, 62, 70, 72, 80]

a(10^1)  =                31 ~ 21.66                -> 1.43085716814724731567697388362262512087796085132
a(10^2)  =               629 ~ 595.41               -> 1.05640884486870073219427770179934635115325018838
a(10^3)  =              9823 ~ 9741.73              -> 1.00834196073027036381381492602216565392721426965
a(10^4)  =            135568 ~ 135293.35            -> 1.00202999682691312076763529313619057317755443274
a(10^5)  =           1732437 ~ 1731693.62           -> 1.00042928187585922855456102384841804396816671626
a(10^6)  =          21107131 ~ 21104536.81          -> 1.00012292075282086768302929969619689628662614091
a(10^7)  =         248928748 ~ 248921374.75         -> 1.00002962076965424120327637576433900637540389794
a(10^8)  =        2867996696 ~ 2867973813.70        -> 1.00000797855916535575678041071686222727851109258
a(10^9)  =       32467409097 ~ 32467338798.29       -> 1.00000216521302261846703873643427029189711363986
a(10^10) =      362549612240 ~ 362549394595.78      -> 1.00000060031604804834071744691960444929352043683
a(10^11) =     4004254692640 ~ 4004254012086.08     -> 1.00000016995772897612356184672572401706556174343
a(10^12) =    43830142939380 ~ 43830140782143.61    -> 1.00000004921810301432497497420018745129768545890
a(10^13) =   476177421208658 ~ 476177414434264.13   -> 1.00000001422661735697513455710167585383336332082
a(10^14) =  5140534231877816 ~ 5140534210470921.03  -> 1.00000000416433275074901946766616776434113033877
a(10^15) = 55192942833495679 ~ 55192942765992007.53 -> 1.00000000122304896383936291361582837193299642341


================================================
FILE: Math/sum_of_the_number_of_unitary_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 January 2019
# https://github.com/trizen

# Two fast algorithms for computing the sum of number of unitary divisors from 1 to n.
#   a(n) = Sum_{k=1..n} usigma_0(k)

# Based on the formula:
#   a(n) = Sum_{k=1..n} moebius(k)^2 * floor(n/k)

# See also:
#   https://oeis.org/A034444    -- Partial sums of A034444: sum of number of unitary divisors from 1 to n.
#   https://oeis.org/A180361    -- Sum of number of unitary divisors (A034444) from 1 to 10^n
#   https://oeis.org/A268732    -- Sum of the numbers of divisors of gcd(x,y) with x*y <= n.

# Asymptotic formula:
#   a(n) ~ n*log(n)/zeta(2) + O(n)

# Better asymptotic formula:
#   a(n) ~ (n/zeta(2))*(log(n) + 2*γ - 1 - c) + O(sqrt(n) * log(n))
#
# where γ is the Euler-Mascheroni constant and c = 2*zeta'(2)/zeta(2) = -1.1399219861890656127997287200...

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);
use Math::AnyNum qw(:overload zeta EulerGamma round);

sub squarefree_count ($n) {
    my $count = 0;

    my $k = 1;
    foreach my $mu (moebius(1, sqrtint($n))) {
        if ($mu) {
            $count += $mu * divint($n, $k * $k);
        }
        ++$k;
    }

    return $count;
}

sub asymptotic_formula($n) {

    # c = 2*Zeta'(2)/Zeta(2) = (12 * Zeta'(2))/π^2 = 2 (-12 log(A) + γ + log(2) + log(π))
    my $c = -1.13992198618906561279972872003946000480696456161386195911639472087583455473348121357;

    # Asymptotic formula based on Merten's theorem (1874) (see: https://oeis.org/A064608)
    ($n / zeta(2)) * (log($n) + 2 * EulerGamma - 1 - $c);
}

sub unitary_divisors_partial_sum_1 ($n) {    # O(sqrt(n)) complexity

    my $total = 0;

    my $s = sqrtint($n);
    my $u = divint($n, $s + 1);

    my $prev = squarefree_count($n);

    for my $k (1 .. $s) {
        my $curr = squarefree_count(divint($n, $k + 1));
        $total += $k * ($prev - $curr);
        $prev = $curr;
    }

    forsquarefree {
        $total += divint($n, $_);
    } $u;

    return $total;
}

sub unitary_divisors_partial_sum_2 ($n) {    # based on formula by Jerome Raulin (https://oeis.org/A064608)

    my $total = 0;

    my $k = 1;
    foreach my $mu (moebius(1, sqrtint($n))) {
        if ($mu) {

            my $t = 0;
            foreach my $j (1 .. sqrtint(divint($n, $k * $k))) {
                $t += divint($n, $j * $k * $k);
            }

            my $r = sqrtint(divint($n, $k * $k));
            $total += $mu * (2 * $t - $r * $r);
        }
        ++$k;
    }

    return $total;
}

say join(', ', map { unitary_divisors_partial_sum_1($_) } 1 .. 20);
say join(', ', map { unitary_divisors_partial_sum_2($_) } 1 .. 20);

foreach my $k (0 .. 7) {

    my $n = 10**$k;
    my $t = unitary_divisors_partial_sum_2($n);
    my $u = asymptotic_formula($n);

    printf("a(10^%s) = %10s ~ %-15s -> %s\n", $k, $t, round($u, -2), $t / $u);
}

__END__
[0, 1, 3, 5, 7, 9, 13, 15, 17, 19, 23, 25, 29, 31, 35, 39, 41, 43, 47, 49, 53]
[0, 1, 3, 5, 7, 9, 13, 15, 17, 19, 23, 25, 29, 31, 35, 39, 41, 43, 47, 49, 53]

a(10^0)  =            1 ~ 0.79            -> 1.27085398285349342897812915198984638968899591751
a(10^1)  =           23 ~ 21.87           -> 1.05182461403816051734935994402113331145060974294
a(10^2)  =          359 ~ 358.65          -> 1.00098140095602073835866744824992972185806123685
a(10^3)  =         4987 ~ 4986.28         -> 1.00014357239778054254970740667091143421188177813
a(10^4)  =        63869 ~ 63860.88        -> 1.00012715302552355451250212258735392366329621935
a(10^5)  =       778581 ~ 778589.19       -> 0.999989484576929013867264739526374966823956960403
a(10^6)  =      9185685 ~ 9185695.75      -> 0.99999882923368455522780513812504287278271814501
a(10^7)  =    105854997 ~ 105854996.37    -> 1.00000000598372061072117962943109677794267023891
a(10^8)  =   1198530315 ~ 1198530351.90   -> 0.999999969211002320383540850995519903094748492418
a(10^9)  =  13385107495 ~ 13385107401.37  -> 1.00000000699496540213133746406895764726726792391
a(10^10) = 147849112851 ~ 147849112837.28 -> 1.00000000009281141854332921757852421030396550125


================================================
FILE: Math/sum_of_the_sum_of_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 19 August 2017
# https://github.com/trizen

# Sum of the sum of divisors, `sigma(k)`, for 1 <= k <= n.

# Algorithm due to Peter Polm (August 18, 2014) (see: A024916).

use 5.010;
use strict;
use warnings;

sub sum_of_sigma {
    my ($n) = @_;

    my $s = 0;
    my $d = 1;
    my $q = $n;

    for (; $d < $q ; ++$d, $q = int($n / $d)) {
        $s += $q * (2 * $d + $q + 1) >> 1;
    }

    $s - $d * ($d * ($d - 1) >> 1) + ($q * ($q + 1) >> 1);
}

say sum_of_sigma(13);       #=> 141
say sum_of_sigma(64);       #=> 3403
say sum_of_sigma(1234);     #=> 1252881
say sum_of_sigma(10**8);    #=> 8224670422194237


================================================
FILE: Math/sum_of_three_cubes_problem.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 01 June 2016
# Website: https://github.com/trizen

# An attempt at creating a new algorithm for finding
# integer solutions to the following equation: x^3 + y^3 + z^3 = n

# The concept of the algorithm is to use modular exponentiation,
# based on the relations:
#
#       (x^3 mod n) + (y^3 mod n) + (z^3 mod n) = n
# or:
#       (x^3 mod n) + (y^3 mod n) + (z^3 mod n) = 2n       ; this is more common (?)
#

# This leads to the following conjecture:
#       x = a * n + k
#       y = b * n + j
#
# for every term x and y in a valid equation: x^3 + y^3 + z^3 = n

# Less generally, we can say:
#
#       x = a * n + s1 + psum(P(k))
#       y = b * n + s2 + psum(P(k))

# where `s1` and `s2` are the starting points for the corresponding terms
# and `psum(P(k))` is a partial sum of the remainders of n in the form: (k^3 mod n).

# Example:
#    39 = 134476^3 + 117367^3 - 159380^3
#
#    39 = 1 + 13 + 25
#
#    P(1)  = {15, 6, 18}                ; returned by get_pos_steps(39, 1)
#    P(13) = {35}                       ; returned by get_pos_steps(39, 13)
#    P(25) = {6, 15, 18}                ; returned by get_pos_steps(39, 25)
#
#    s1 = 1                             ; returned by get_pos_steps(39, 1)
#    s2 = 4                             ; returned by get_pos_steps(39, 25)
#    s3 = 13                            ; returned by get_pos_steps(39, 13)
#
#    117367 = a * 39 + s1 + 15
#    134476 = b * 39 + s2 + 0
#   -159380 = c * 39 + s3 + 0
#
# then we find:
#    a =  3009
#    b =  3448
#    c = -4087
#
# which results to:
#    117367 =  3009 * 39 + 16
#    134476 =  3448 * 39 + 4
#   -159380 = -4087 * 39 + 13
#

# For n=74:
#
#   2*74 = 68 + 29 + 51
#
#   P(68) = {2, 52, 20}
#   P(29) = {18, 24, 32}
#   P(51) = {8, 6, 60}
#
#   s1 = 6
#   s2 = 5
#   s3 = 17
#
#   x = a * 74 + s1 + (2 + 52)
#   y = b * 74 + s2 + (0)
#   z = c * 74 + s3 + (18)
#
#   x = a * 74 + 60
#   y = b * 74 + 5
#   z = c * 74 + 35
#
#   a =  894997732304
#   b =  3830406833753
#   c = -3846625575080

# We can also easily observe that any valid solution satisfies:
#
#    is_cube(x^3 + y^3 - n) or
#    is_cube(x^3 - y^3 - n)
#

# Currently, in this code, we show how to calculate the steps
# of a given term and how to collect and filter potential valid solutions.

# To actually find a solution, more work is required...

# Inspired by:
#      https://www.youtube.com/watch?v=wymmCdLdPvM

# See also:
#   https://mathoverflow.net/questions/138886/which-integers-can-be-expressed-as-a-sum-of-three-cubes-in-infinitely-many-ways

use 5.014;
use strict;
use warnings;

#use integer;
#use Math::AnyNum qw(:overload);

use ntheory qw(powmod is_power);
use List::Util qw(pairmap any sum0);

use Data::Dump qw(pp);

# (a^3 % 33) + (b^3 % 33) + (c^3 % 33) = 66

sub get_pos_steps {
    my ($n, $k) = @_;

    my @steps;
    foreach my $i (1 .. 2 * $n) {
        if (powmod($i, 3, $n) == $k) {
            push @steps, $i;
        }
    }

    ($steps[0], [map { $steps[$_] - $steps[$_ - 1] } 1 .. $#steps]);
}

sub get_neg_steps {
    my ($n, $k) = @_;

    my @steps;
    foreach my $i (1 .. 2 * $n) {
        if (powmod(-$i, 3, $n) == $k) {
            push @steps, -$i;
        }
    }

    ($steps[0], [map { $steps[$_] - $steps[$_ - 1] } 1 .. $#steps]);
}

sub get_partitions {
    my ($n) = @_;

    my @p;
    my %seen;
    foreach my $i (1 .. $n) {
        foreach my $j ($i .. $n - $i) {
            foreach my $k ($j .. $n - $j - $i) {
                if ($i + $j + $k == $n) {
                    my $v = join(' ', sort { $a <=> $b } ($i, $j, $k));
                    next if (exists $seen{$v});
                    $seen{$v} = 1;
                    push @p, [$i, $j, $k];
                }
            }
        }
    }

    return @p;
}

#use Math::AnyNum qw(:overload);

#~ my $n = 33;
#~ my $x = 0;
#~ my $y = 0;
#~ my $z = 0;

#~ my $n = 42;
#~ my $x = 0;
#~ my $y = 0;
#~ my $z = 0;

#~ my $n = 74;
#~ my $x = 66229832190556;
#~ my $y = 283450105697727;
#~ my $z = -284650292555885;

# First solution for n=33 was found by Andrew Booker
# See also:
#   https://people.maths.bris.ac.uk/~maarb/papers/cubesv1.pdf
#   https://www.bradyharanblog.com/blog/33-and-the-sum-of-three-cubes

my $n = 33;
my $x = 8866128975287528;
my $y = -8778405442862239;
my $z = -2736111468807040;

say powmod($x, 3, 33) + powmod($y, 3, 33) + powmod($z, 3, 33);

#~ my $n = 30;
#~ my $x = 2_220_422_932;
#~ my $y = -2_218_888_517;
#~ my $z = -283_059_965;

#~ my $n = 52;
#~ my $x = -61922712865;
#~ my $y = 23961292454;
#~ my $z = 60702901317;

#~ my $n = 75;
#~ my $x = -435203231;
#~ my $y = 435203083;
#~ my $z = 4381159;

#~ my $n = 75;
#~ my $x = 2_576_191_140_760;
#~ my $y = 1_217_343_443_218;
#~ my $z = -2_663_786_047_493;

#~ my $n = 75;
#~ my $x = 59_897_299_698_355;
#~ my $y = -47_258_398_396_091;
#~ my $z = -47_819_328_945_509;

#~ my $n = 87;
#~ my $x = 4271;
#~ my $y =-4126;
#~ my $z = -1972;

#~ my $n = 39;
#~ my $x = -159380;
#~ my $y = 134476;
#~ my $z = 117367;

#$x **= 3;
#$y **= 3;
#$z **= 3;

my @partitions = (get_partitions($n), get_partitions(2 * $n));
my @valid;

F1: foreach my $p (@partitions) {
    my @data;
    foreach my $k (@{$p}) {
        my $ok = 0;
        my $data = {k => $k};

        {
            my ($start, $steps) = get_pos_steps($n, $k);
            if (defined($start)) {
                $ok ||= 1;
                $data->{pos} = {
                                start => $start,
                                steps => $steps,
                               };
            }
        }

        {
            my ($start, $steps) = get_neg_steps($n, $k);
            if (defined($start)) {
                $ok ||= 1;
                $data->{neg} = {
                                start => $start,
                                steps => $steps,
                               };
            }
        }
        $ok || next F1;
        push @data, $data;
    }
    push @valid, \@data;
}

#
## Experimenting with various optimization ideas
#
foreach my $solution (@valid) {
    my $count = 0;
    foreach my $k ($x, $y, $z) {
        ++$count if any {
            my $s = $_;

            any {
                (($k % $n) == sum0(@{$s->{pos}{steps}}[0 .. $_]) + $s->{pos}{start})
                  or (($k % (-$n)) == sum0(@{$s->{neg}{steps}}[0 .. $_]) + $s->{neg}{start})
            }
            (-1 .. int(@{$s->{pos}{steps}} / 2) - 1);

            #~ any {
            #~ ($k % sum(@{$s->{pos}{steps}}[0 .. $_]) == $s->{pos}{start})
            #~ or ($k % sum(@{$s->{neg}{steps}}[0 .. $_]) == $s->{neg}{start})
            #~ }
            #~ int(@{$s->{pos}{steps}} / 2) .. $#{$s->{pos}{steps}};

            #(any      { $k % $_ == $s->{pos}{start} } @{$s->{pos}{steps}})
            #or (any { $k % $_ == $s->{neg}{start} } @{$s->{neg}{steps}})
        }
        @{$solution};
    }
    if ($count >= 3) {
        pp $solution;
    }
}

say scalar @valid;

my %seen;
pp [sort {$a <=> $b} grep{!$seen{$_}++} map { map {$_->{pos}{start}}@{$_} } @valid];


================================================
FILE: Math/sum_of_triangular_numbers_solutions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 02 March 2018
# https://github.com/trizen

# Find representations for a given number (n) as a sum of three triangular
# numbers, where the index (k) of one triangular number is also given.

# Equivalent with finding solutions to `x` and `y` in the following equation:
#
#   n = k*(k+1)/2 + x*(x+1)/2 + y*(y+1)/2
#
# where `n` and `k` are given.

# Example:
#   n = 1234
#   k = 42

# Solutions:
#   1234 = 42*(42+1)/2 +  3*( 3+1)/2 + 25*(25+1)/2
#   1234 = 42*(42+1)/2 + 10*(10+1)/2 + 23*(23+1)/2
#   1234 = 42*(42+1)/2 + 12*(12+1)/2 + 22*(22+1)/2

# When k=0, `n` will be represented as a sum of two triangular numbers only (if possible):
#   1234 = 17*(17+1)/2 + 46*(46+1)/2

# See also:
#   https://projecteuler.net/problem=621
#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(sqrtmod factor_exp chinese is_polygonal forsetproduct);

sub sum_of_two_squares ($n) {

    $n == 0 and return [0, 0];

    my $prod1 = 1;
    my $prod2 = 1;

    my @prime_powers;

    foreach my $f (factor_exp($n)) {
        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)
            $f->[1] % 2 == 0 or return;    # power must be even
            $prod2 *= $f->[0]**($f->[1] >> 1);
        }
        elsif ($f->[0] == 2) {             # p = 2
            if ($f->[1] % 2 == 0) {        # power is even
                $prod2 *= $f->[0]**($f->[1] >> 1);
            }
            else {                         # power is odd
                $prod1 *= $f->[0];
                $prod2 *= $f->[0]**(($f->[1] - 1) >> 1);
                push @prime_powers, [$f->[0], 1];
            }
        }
        else {                             # p = 1 (mod 4)
            $prod1 *= $f->[0]**$f->[1];
            push @prime_powers, $f;
        }
    }

    $prod1 == 1 and return [$prod2, 0];
    $prod1 == 2 and return [$prod2, $prod2];

    my %table;
    foreach my $f (@prime_powers) {
        my $pp = $f->[0]**$f->[1];
        my $r = sqrtmod($pp - 1, $pp);
        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];
    }

    my @square_roots;

    forsetproduct {
        push @square_roots, chinese(@_);
    } values %table;

    my @solutions;

    foreach my $r (@square_roots) {

        my $s = $r;
        my $q = $prod1;

        while ($s * $s > $prod1) {
            ($s, $q) = ($q % $s, $s);
        }

        push @solutions, [$prod2 * $s, $prod2 * ($q % $s)];
    }

    foreach my $f (@prime_powers) {
        for (my $i = $f->[1] % 2 ; $i < $f->[1] ; $i += 2) {

            my $sq = $f->[0]**(($f->[1] - $i) >> 1);
            my $pp = $f->[0]**($f->[1] - $i);

            push @solutions, map {
                [map { $sq * $prod2 * $_ } @$_]
            } __SUB__->($prod1 / $pp);
        }
    }

    return sort { $a->[0] <=> $b->[0] } do {
        my %seen;
        grep { !$seen{$_->[0]}++ } map {
            [sort { $a <=> $b } @$_]
        } @solutions;
    };
}

sub sum_of_triangles ($n, $k) {

    my $z = ($n - $k * ($k + 1) / 2) * 8 + 1;

    return if $z <= 0;

    my @result;
    my @solutions = sum_of_two_squares($z + 1);

    foreach my $s (@solutions) {

        is_polygonal(($s->[0]**2 - 1)/8, 3, \my $x);
        is_polygonal(($s->[1]**2 - 1)/8, 3, \my $y);

        push @result, [$x, $y];
    }

    return @result;
}

my $n = 1234;
my $k = 42;

my @solutions = sum_of_triangles($n, $k);

foreach my $s (@solutions) {
    say "$n = $k*($k+1)/2 + $s->[0]*($s->[0]+1)/2 + $s->[1]*($s->[1]+1)/2";
}


================================================
FILE: Math/sum_of_two_primes.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 August 2015
# Website: https://github.com/trizen

# This script counts the numbers which CANNOT be written as the sum of two primes

use 5.010;
use strict;
use warnings;

use ntheory qw(primes);

my $primes = primes(10000);
unshift @{$primes}, 1;    # consider 1 as being prime

my %seen;
for my $i (0 .. $#{$primes}) {
    for my $j ($i .. $#{$primes}) {
        undef $seen{$primes->[$i] + $primes->[$j]};
    }
}

my $count = 0;
foreach my $n (1 .. 2 * $primes->[-1]) {
    exists($seen{$n}) || ++$count;
}

say "$count numbers, from a total of ", 2 * $primes->[-1], ", CANNOT be written as the sum of two primes.";

__END__
8772 numbers, from a total of 19946, CANNOT be written as the sum of two primes.


================================================
FILE: Math/sum_of_two_squares_all_solutions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 25 October 2017
# https://github.com/trizen

# A recursive algorithm for finding all the non-negative integer solutions to the equation:
#   a^2 + b^2 = n
# for any given positive integer `n` for which such a solution exists.

# Example:
#   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

# This algorithm is efficient when the factorization of `n` can be computed.

# Blog post:
#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html

# See also:
#   https://oeis.org/A001481

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

use Math::GMPz;
use ntheory qw(sqrtmod factor_exp chinese forsetproduct);

sub sum_of_two_squares_solutions ($n) {

    $n < 0  and return;
    $n == 0 and return [0, 0];

    my %sqrtmod_cache;

    my $find_solutions = sub ($factor_exp) {

        my $prod1 = 1;
        my $prod2 = 1;

        my @prod1_factor_exp;

        foreach my $f (@$factor_exp) {
            my ($p, $e) = @$f;
            if ($p % 4 == 3) {    # p = 3 (mod 4)
                $e % 2 == 0 or return;    # power must be even
                $prod2 *= Math::GMPz->new($p)**($e >> 1);
            }
            elsif ($p == 2) {             # p = 2
                if ($e % 2 == 0) {        # power is even
                    $prod2 *= Math::GMPz->new($p)**($e >> 1);
                }
                else {                    # power is odd
                    $prod1 *= $p;
                    $prod2 *= Math::GMPz->new($p)**(($e - 1) >> 1);
                    push @prod1_factor_exp, [$p, 1];
                }
            }
            else {                        # p = 1 (mod 4)
                $prod1 *= Math::GMPz->new($p)**$e;
                push @prod1_factor_exp, $f;
            }
        }

        $prod1 == 1 and return [$prod2, 0];
        $prod1 == 2 and return [$prod2, $prod2];

        my @congruences;

        foreach my $pe (@prod1_factor_exp) {
            my ($p, $e) = @$pe;
            my $pp  = Math::GMPz->new($p)**$e;
            my $key = Math::GMPz::Rmpz_get_str($pp, 10);
            my $r = (
                $sqrtmod_cache{$key} //= sqrtmod(-1, $pp) // do {
                    require Math::Sidef;
                    Math::Sidef::sqrtmod(-1, $pp);
                }
            );
            $r = Math::GMPz->new("$r") if ref($r);
            push @congruences, [[$r, $pp], [$pp - $r, $pp]];
        }

        my @square_roots;

        forsetproduct {
            push @square_roots, Math::GMPz->new(chinese(@_));
        } @congruences;

        my @solutions;

        foreach my $r (@square_roots) {

            my $s = $r;
            my $q = $prod1;

            while ($s * $s > $prod1) {
                ($s, $q) = ($q % $s, $s);
            }

            push @solutions, [$prod2 * $s, $prod2 * ($q % $s)];
        }

        foreach my $pe (@prod1_factor_exp) {
            my ($p, $e) = @$pe;

            for (my $i = $e % 2 ; $i < $e ; $i += 2) {

                my @factor_exp;
                foreach my $pp (@prod1_factor_exp) {
                    if ($pp->[0] == $p) {
                        push(@factor_exp, [$p, $i]) if ($i > 0);
                    }
                    else {
                        push @factor_exp, $pp;
                    }
                }

                my $sq = $prod2 * Math::GMPz->new($p)**(($e - $i) >> 1);

                push @solutions, map {
                    [map { $_ * $sq } @$_]
                } __SUB__->(\@factor_exp);
            }
        }

        return @solutions;
    };

    my @factor_exp = factor_exp($n);
    my @solutions  = $find_solutions->(\@factor_exp);

    @solutions = sort { $a->[0] <=> $b->[0] } do {
        my %seen;
        grep { !$seen{$_->[0]}++ } map {
            [sort { $a <=> $b } @$_]
        } @solutions;
    };

    return @solutions;
}

# Run some tests

use Test::More tests => 6;

is_deeply([sum_of_two_squares_solutions(2025)],   [[0, 45],  [27,  36]],);
is_deeply([sum_of_two_squares_solutions(164025)], [[0, 405], [243, 324]]);
is_deeply([sum_of_two_squares_solutions(99025)],  [[41, 312], [48, 311], [95, 300], [104, 297], [183, 256], [220, 225]]);

is_deeply(
          [grep { my @arr = sum_of_two_squares_solutions($_); @arr > 0 } -10 .. 160],
          [0,   1,   2,   4,   5,   8,   9,   10,  13,  16,  17,  18,  20,  25,  26,  29,  32,  34,  36,  37,  40,  41,
           45,  49,  50,  52,  53,  58,  61,  64,  65,  68,  72,  73,  74,  80,  81,  82,  85,  89,  90,  97,  98,  100,
           101, 104, 106, 109, 113, 116, 117, 121, 122, 125, 128, 130, 136, 137, 144, 145, 146, 148, 149, 153, 157, 160
          ]
         );

do {
    use bigint try => 'GMP';
    is_deeply(
              [sum_of_two_squares_solutions(Math::GMPz->new("11392163240756069707031250"))],
              [[39309472125,   3374998963875],
               [216763660575,  3368260197225],
               [477329304375,  3341305130625],
               [729359177085,  3295481517405],
               [735019741071,  3294223614297],
               [907262616645,  3251005657515],
               [982736803125,  3228992353125],
               [1151205969375, 3172835964375],
               [1224793301193, 3145162095999],
               [1393801568775, 3074000720175],
               [1622919634875, 2959441687125],
               [1847545189875, 2824666354125],
               [1993551800625, 2723584854375],
               [2056446956025, 2676413487825],
               [2194367046795, 2564549961435],
               [2198769707673, 2560776252111],
               [2386646521875, 2386646521875]
              ]
             );

    is_deeply([sum_of_two_squares_solutions(2**128 + 1)],
              [[1, 18446744073709551616], [8479443857936402504, 16382350221535464479]]);

    is_deeply(
              [sum_of_two_squares_solutions(13**18 * 5**7)],
              [[75291211970,   2963091274585],
               [100083884615,  2962357487570],
               [124869548830,  2961416259815],
               [149646468985,  2960267657230],
               [154416779750,  2960022656375],
               [179181003625,  2958626849750],
               [203932680250,  2957023863625],
               [228670076375,  2955213810250],
               [253391459750,  2953196816375],
               [258150241063,  2952784638466],
               [282850264814,  2950521038023],
               [307530481817,  2948050825694],
               [332189163826,  2945374174457],
               [356824584103,  2942491271746],
               [481345955350,  2924702504425],
               [505803171575,  2920572173350],
               [530224968650,  2916237327575],
               [554609636425,  2911698270650],
               [578955467350,  2906955320425],
               [583639307225,  2906018552450],
               [607936593550,  2901032879225],
               [632191308775,  2895844059550],
               [656401754450,  2890452456775],
               [680566235225,  2884858448450],
               [802350873038,  2853386013959],
               [826200069721,  2846571993278],
               [849991411282,  2839558639801],
               [873723231719,  2832346444642],
               [897393869198,  2824935912839],
               [901945120375,  2823486084250],
               [925540625750,  2815839700375],
               [949071319625,  2807996135750],
               [972535554250,  2799955939625],
               [977046452345,  2798385051790],
               [1000429281410, 2790111094745],
               [1023742054855, 2781641758610],
               [1046983140190, 2772977636455],
               [1070150909945, 2764119334990],
               [1186462080890, 2716226499895],
               [1209150070505, 2706203018090],
               [1231753388710, 2695990032905],
               [1254270452695, 2685588259510],
               [1276699685690, 2674998426295],
               [1281008818375, 2672937536750],
               [1303331253250, 2662124398375],
               [1325562421625, 2651124843250],
               [1347700766750, 2639939641625],
               [1369744738375, 2628569576750],
               [1373978929622, 2626358804329],
               [1395908335991, 2614769317862],
               [1417739993098, 2602996730711],
               [1439472372169, 2591041867258],
               [1461103951382, 2578905564649],
               [1569204922025, 2514592328950],
               [1590192225050, 2501373094025],
               [1611068173975, 2487978699050],
               [1631831306950, 2474410081975],
               [1652480170025, 2460668192950],
               [1656443419150, 2458002007175],
               [1676954116825, 2444054737150],
               [1697347384850, 2429936320825],
               [1717621795175, 2415647746850],
               [1838087734327, 2325298292486],
               [1857481600234, 2309835659287],
               [1876745394953, 2294211278554],
               [1895877769526, 2278426244393],
               [1899547017625, 2275368057250],
               [1918520912750, 2259392877625],
               [1937360462375, 2243259482750],
               [1956064347250, 2226969002375],
               [1974631257625, 2210522577250],
               [1978190975930, 2207337566135],
               [1996592834665, 2190706671530],
               [2014854880870, 2173922371465],
               [2032975835735, 2156985841270],
               [2050954430330, 2139898266935]
              ]
             )
      if 0;
};

my @nums = (@ARGV ? (map { Math::GMPz->new($_) } @ARGV) : (map { int rand(~0) } 1 .. 20));

foreach my $n (@nums) {
    (my @solutions = sum_of_two_squares_solutions($n)) || next;

    say "$n = " . join(' = ', map { "$_->[0]^2 + $_->[1]^2" } @solutions);

    # Verify solutions
    foreach my $solution (@solutions) {
        if ($n != $solution->[0]**2 + $solution->[1]**2) {
            die "error for $n: (@$solution)\n";
        }
    }
}

__END__
999826 = 99^2 + 995^2 = 315^2 + 949^2 = 525^2 + 851^2 = 699^2 + 715^2
999828 = 318^2 + 948^2
999844 = 312^2 + 950^2 = 410^2 + 912^2
999848 = 62^2 + 998^2
999850 = 43^2 + 999^2 = 321^2 + 947^2 = 565^2 + 825^2
999853 = 387^2 + 922^2
999857 = 401^2 + 916^2 = 544^2 + 839^2
999860 = 154^2 + 988^2 = 698^2 + 716^2
999869 = 262^2 + 965^2 = 613^2 + 790^2
999881 = 341^2 + 940^2 = 484^2 + 875^2
999882 = 309^2 + 951^2 = 651^2 + 759^2
999890 = 421^2 + 907^2 = 473^2 + 881^2
999892 = 324^2 + 946^2
999898 = 213^2 + 977^2 = 697^2 + 717^2
999909 = 222^2 + 975^2 = 678^2 + 735^2
999914 = 667^2 + 745^2
999917 = 109^2 + 994^2
999937 = 44^2 + 999^2 = 89^2 + 996^2
999938 = 77^2 + 997^2
999940 = 126^2 + 992^2 = 178^2 + 984^2 = 306^2 + 952^2 = 448^2 + 894^2 = 578^2 + 816^2 = 696^2 + 718^2
999941 = 370^2 + 929^2 = 446^2 + 895^2
999944 = 638^2 + 770^2
999946 = 585^2 + 811^2
999949 = 243^2 + 970^2 = 290^2 + 957^2 = 450^2 + 893^2 = 493^2 + 870^2
999952 = 444^2 + 896^2
999953 = 568^2 + 823^2
999954 = 327^2 + 945^2 = 375^2 + 927^2
999956 = 500^2 + 866^2
999961 = 644^2 + 765^2
999962 = 239^2 + 971^2 = 541^2 + 841^2
999968 = 452^2 + 892^2
999970 = 247^2 + 969^2 = 627^2 + 779^2
999973 = 63^2 + 998^2 = 118^2 + 993^2 = 273^2 + 962^2 = 442^2 + 897^2 = 622^2 + 783^2 = 658^2 + 753^2
999981 = 141^2 + 990^2
999986 = 365^2 + 931^2 = 695^2 + 719^2
999997 = 194^2 + 981^2 = 454^2 + 891^2
1000000 = 0^2 + 1000^2 = 280^2 + 960^2 = 352^2 + 936^2 = 600^2 + 800^2


================================================
FILE: Math/sum_of_two_squares_all_solutions_2.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 November 2025
# https://github.com/trizen

# A fast algorithm for finding all the non-negative integer solutions to the equation:
#   a^2 + b^2 = n
# for any given positive integer `n` for which such a solution exists.

# Example:
#   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

# This algorithm is efficient when the factorization of `n` can be computed.

# Blog post:
#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html

# See also:
#   https://oeis.org/A001481

use 5.036;
use Math::GMPz qw();
use ntheory    qw(factor_exp sqrtmod powint);

# Find a solution to x^2 + y^2 = p, for prime numbers `p` congruent to 1 mod 4.
sub primitive_sum_of_two_squares ($p) {

    if ($p == 2) {
        return (1, 1);
    }

    my $s = Math::GMPz->new(sqrtmod(-1, $p) || return);
    my $q = $p;

    while ($s * $s > $p) {
        ($s, $q) = ($q % $s, $s);
    }

    return ($s, $q % $s);
}

# Multiply two representations (a,b) and (c,d),
# return all distinct sign/ordering variations.
sub combine_pairs($A, $B, $C, $D) {
#<<<
    return (
        [$A * $C - $B * $D, $A * $D + $B * $C],
        [$A * $C + $B * $D, $A * $D - $B * $C],
    );
#>>>
}

# Multiply two *sets* of representations
sub multiply_sets($A, $B) {
    my %seen;
    my @new;
    for my $p (@$A) {
        for my $q (@$B) {
            for my $r (combine_pairs(@$p, @$q)) {
                my ($x, $y) = @$r;

                $x = -$x if ($x < 0);
                $y = -$y if ($y < 0);

                if ($x > $y) {
                    ($x, $y) = ($y, $x);
                }

                my $key = "$x,$y";
                next if $seen{$key}++;
                push @new, [$x, $y];
            }
        }
    }
    return @new;
}

sub sum_of_two_squares_solutions($n) {

    $n < 0  and return;
    $n == 0 and return [0, 0];

    my @factors = factor_exp($n);

    # Start with representation of 1
    my @reps = ([0, 1]);    # (0^2 + 1^2 = 1)

    # Handle primes p ≡ 3 (mod 4) with even exponent: they contribute as a perfect square factor s^2.
    # Multiply each (x,y) by s where s = product p^{e/2} over such primes.
    my $square_scale = Math::GMPz->new(1);

    foreach my $pp (@factors) {
        my ($p, $k) = @$pp;

        # Handle primes 3 mod 4
        if ($p % 4 == 3) {
            if ($k % 2 != 0) {
                return;    # no solutions
            }

            # p^{2t} contributes factor (p^t)^2 which is a square; doesn't change reps aside from scaling
            # We multiply by p^{k/2} as a scaling factor on both coordinates.
            $square_scale *= powint($p, ($k >> 1));
            next;
        }

        # Representation of p = x^2 + y^2
        my ($x, $y) = primitive_sum_of_two_squares($p);

        # Use binary exponentiation to get representations for p^k
        my @acc   = ([0, 1]);
        my @base  = ([$x, $y]);
        my $exp_k = $k;

        while ($exp_k > 0) {
            if ($exp_k & 1) {
                @acc = multiply_sets(\@acc, \@base);
            }
            @base = multiply_sets(\@base, \@base);
            $exp_k >>= 1;
        }
        @reps = multiply_sets(\@reps, \@acc);
    }

    if ($square_scale != 1) {
        @reps = map { [$_->[0] * $square_scale, $_->[1] * $square_scale] } @reps;
    }

    # Sort final reps
    @reps = sort { $a->[0] <=> $b->[0] } map {
        [sort { $a <=> $b } @$_]
    } @reps;

    return @reps;
}

# Run some tests

use Test::More tests => 8;

is_deeply([sum_of_two_squares_solutions(2025)],   [[0, 45],  [27,  36]],);
is_deeply([sum_of_two_squares_solutions(164025)], [[0, 405], [243, 324]]);
is_deeply([sum_of_two_squares_solutions(99025)],  [[41, 312], [48, 311], [95, 300], [104, 297], [183, 256], [220, 225]]);

is_deeply(
          [grep { my @arr = sum_of_two_squares_solutions($_); @arr > 0 } -10 .. 160],
          [0,   1,   2,   4,   5,   8,   9,   10,  13,  16,  17,  18,  20,  25,  26,  29,  32,  34,  36,  37,  40,  41,
           45,  49,  50,  52,  53,  58,  61,  64,  65,  68,  72,  73,  74,  80,  81,  82,  85,  89,  90,  97,  98,  100,
           101, 104, 106, 109, 113, 116, 117, 121, 122, 125, 128, 130, 136, 137, 144, 145, 146, 148, 149, 153, 157, 160
          ]
         );

is_deeply(
          [sum_of_two_squares_solutions(1777574759925022720)],
          [[110080512, 1328705024],
           [146744832, 1325156864],
           [151045632, 1324673536],
           [243249664, 1310879232],
           [347689472, 1287123456],
           [402252288, 1271128576],
           [463025664, 1250272768],
           [490100224, 1239909888],
           [494122496, 1238312448],
           [591927808, 1194653184],
           [673967616, 1150366208],
           [697867776, 1136026112],
           [722402816, 1120584192],
           [775551488, 1084478976],
           [885287424, 996915712],
           [912489984, 972078592]
          ]
         );

do {
    use bigint try => 'GMP';
    is_deeply(
              [sum_of_two_squares_solutions(Math::GMPz->new("11392163240756069707031250"))],
              [[39309472125,   3374998963875],
               [216763660575,  3368260197225],
               [477329304375,  3341305130625],
               [729359177085,  3295481517405],
               [735019741071,  3294223614297],
               [907262616645,  3251005657515],
               [982736803125,  3228992353125],
               [1151205969375, 3172835964375],
               [1224793301193, 3145162095999],
               [1393801568775, 3074000720175],
               [1622919634875, 2959441687125],
               [1847545189875, 2824666354125],
               [1993551800625, 2723584854375],
               [2056446956025, 2676413487825],
               [2194367046795, 2564549961435],
               [2198769707673, 2560776252111],
               [2386646521875, 2386646521875]
              ]
             );

    is_deeply([sum_of_two_squares_solutions(2**128 + 1)], [[1, 18446744073709551616], [8479443857936402504, 16382350221535464479]]);

    is_deeply(
              [sum_of_two_squares_solutions(13**18 * 5**7)],
              [[75291211970,   2963091274585],
               [100083884615,  2962357487570],
               [124869548830,  2961416259815],
               [149646468985,  2960267657230],
               [154416779750,  2960022656375],
               [179181003625,  2958626849750],
               [203932680250,  2957023863625],
               [228670076375,  2955213810250],
               [253391459750,  2953196816375],
               [258150241063,  2952784638466],
               [282850264814,  2950521038023],
               [307530481817,  2948050825694],
               [332189163826,  2945374174457],
               [356824584103,  2942491271746],
               [481345955350,  2924702504425],
               [505803171575,  2920572173350],
               [530224968650,  2916237327575],
               [554609636425,  2911698270650],
               [578955467350,  2906955320425],
               [583639307225,  2906018552450],
               [607936593550,  2901032879225],
               [632191308775,  2895844059550],
               [656401754450,  2890452456775],
               [680566235225,  2884858448450],
               [802350873038,  2853386013959],
               [826200069721,  2846571993278],
               [849991411282,  2839558639801],
               [873723231719,  2832346444642],
               [897393869198,  2824935912839],
               [901945120375,  2823486084250],
               [925540625750,  2815839700375],
               [949071319625,  2807996135750],
               [972535554250,  2799955939625],
               [977046452345,  2798385051790],
               [1000429281410, 2790111094745],
               [1023742054855, 2781641758610],
               [1046983140190, 2772977636455],
               [1070150909945, 2764119334990],
               [1186462080890, 2716226499895],
               [1209150070505, 2706203018090],
               [1231753388710, 2695990032905],
               [1254270452695, 2685588259510],
               [1276699685690, 2674998426295],
               [1281008818375, 2672937536750],
               [1303331253250, 2662124398375],
               [1325562421625, 2651124843250],
               [1347700766750, 2639939641625],
               [1369744738375, 2628569576750],
               [1373978929622, 2626358804329],
               [1395908335991, 2614769317862],
               [1417739993098, 2602996730711],
               [1439472372169, 2591041867258],
               [1461103951382, 2578905564649],
               [1569204922025, 2514592328950],
               [1590192225050, 2501373094025],
               [1611068173975, 2487978699050],
               [1631831306950, 2474410081975],
               [1652480170025, 2460668192950],
               [1656443419150, 2458002007175],
               [1676954116825, 2444054737150],
               [1697347384850, 2429936320825],
               [1717621795175, 2415647746850],
               [1838087734327, 2325298292486],
               [1857481600234, 2309835659287],
               [1876745394953, 2294211278554],
               [1895877769526, 2278426244393],
               [1899547017625, 2275368057250],
               [1918520912750, 2259392877625],
               [1937360462375, 2243259482750],
               [1956064347250, 2226969002375],
               [1974631257625, 2210522577250],
               [1978190975930, 2207337566135],
               [1996592834665, 2190706671530],
               [2014854880870, 2173922371465],
               [2032975835735, 2156985841270],
               [2050954430330, 2139898266935]
              ]
             );
};

my @nums = (@ARGV ? (map { Math::GMPz->new($_) } @ARGV) : (map { int rand(~0) } 1 .. 20));

foreach my $n (@nums) {
    (my @solutions = sum_of_two_squares_solutions($n)) || next;

    say "$n = " . join(' = ', map { "$_->[0]^2 + $_->[1]^2" } @solutions);

    # Verify solutions
    foreach my $solution (@solutions) {
        if ($n != $solution->[0]**2 + $solution->[1]**2) {
            die "error for $n: (@$solution)\n";
        }
    }
}


================================================
FILE: Math/sum_of_two_squares_all_solutions_tonelli-shanks.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 November 2025
# https://github.com/trizen

# A fast algorithm for finding all the non-negative integer solutions to the equation:
#   a^2 + b^2 = n
# for any given positive integer `n` for which such a solution exists.

# Example:
#   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

# This algorithm is efficient when the factorization of `n` can be computed.

# Blog post:
#   https://trizenx.blogspot.com/2017/10/representing-integers-as-sum-of-two.html

# See also:
#   https://oeis.org/A001481

use 5.036;
use Math::GMPz qw();
use ntheory    qw(:all);

# Tonelli-Shanks: modular square root of n mod p (p odd prime)
# Returns a root r such that r^2 ≡ n (mod p), or undef if none.
sub tonelli_shanks ($n, $p) {

    return 0 if $n == 0;

    # check solution existence
    return undef if kronecker($n, $p) == -1;    # == -1 mod p

    $n %= $p;

    # simple case p % 4 == 3
    if ($p % 4 == 3) {
        return powmod($n, ($p + 1) >> 2, $p);
    }

    # Factor p-1 = q * 2^s with q odd
    my $q = $p - 1;
    my $s = valuation($q, 2);
    $q >>= $s;

    # find a quadratic non-residue z
    my $z = 2;
    while (kronecker($z, $p) != -1) { $z++; }

    my $c = powmod($z,                $q, $p);
    my $r = powmod($n, ($q + 1) >> 1, $p);
    my $t = powmod($n,                $q, $p);
    my $m = $s;

    while ($t != 1) {

        # find least i (0 < i < m) such that t^(2^i) == 1
        my $i  = 1;
        my $tt = mulmod($t, $t, $p);
        while ($i < $m && $tt != 1) {
            $tt = mulmod($tt, $tt, $p);
            $i++;
        }
        my $b = powmod($c, 1 << ($m - $i - 1), $p);
        $r = mulmod($r, $b, $p);
        $c = mulmod($b, $b, $p);
        $t = mulmod($t, $c, $p);
        $m = $i;
    }
    return $r;
}

# Find a solution to x^2 + y^2 = p, for prime numbers `p` congruent to 1 mod 4.
sub primitive_sum_of_two_squares ($p) {

    if ($p == 2) {
        return (1, 1);
    }

    my $s = Math::GMPz->new(tonelli_shanks(-1, $p) || return);
    my $q = $p;

    while ($s * $s > $p) {
        ($s, $q) = ($q % $s, $s);
    }

    return ($s, $q % $s);
}

# Multiply two representations (a,b) and (c,d),
# return all distinct sign/ordering variations.
sub combine_pairs($A, $B, $C, $D) {
#<<<
    return (
        [$A * $C - $B * $D, $A * $D + $B * $C],
        [$A * $C + $B * $D, $A * $D - $B * $C],
    );
#>>>
}

# Multiply two *sets* of representations
sub multiply_sets($A, $B) {
    my %seen;
    my @new;
    for my $p (@$A) {
        for my $q (@$B) {
            for my $r (combine_pairs(@$p, @$q)) {
                my ($x, $y) = @$r;

                $x = -$x if ($x < 0);
                $y = -$y if ($y < 0);

                if ($x > $y) {
                    ($x, $y) = ($y, $x);
                }

                my $key = "$x,$y";
                next if $seen{$key}++;
                push @new, [$x, $y];
            }
        }
    }
    return @new;
}

sub sum_of_two_squares_solutions($n) {

    $n < 0  and return;
    $n == 0 and return [0, 0];

    my @factors = factor_exp($n);

    # Start with representation of 1
    my @reps = ([0, 1]);    # (0^2 + 1^2 = 1)

    # Handle primes p ≡ 3 (mod 4) with even exponent: they contribute as a perfect square factor s^2.
    # Multiply each (x,y) by s where s = product p^{e/2} over such primes.
    my $square_scale = Math::GMPz->new(1);

    foreach my $pp (@factors) {
        my ($p, $k) = @$pp;

        # Handle primes 3 mod 4
        if ($p % 4 == 3) {

            if ($k % 2 != 0) {
                return;    # no solutions
            }

            # p^{2t} contributes factor (p^t)^2 which is a square; doesn't change reps aside from scaling
            # We multiply by p^{k/2} as a scaling factor on both coordinates.
            $square_scale *= powint($p, $k >> 1);
            next;
        }

        # Representation of p = x^2 + y^2
        my ($x, $y) = primitive_sum_of_two_squares($p);

        # Use binary exponentiation to get representations for p^k
        my @acc   = ([0, 1]);
        my @base  = ([$x, $y]);
        my $exp_k = $k;

        while ($exp_k > 0) {
            if ($exp_k & 1) {
                @acc = multiply_sets(\@acc, \@base);
            }
            @base = multiply_sets(\@base, \@base);
            $exp_k >>= 1;
        }
        @reps = multiply_sets(\@reps, \@acc);
    }

    if ($square_scale != 1) {
        @reps = map { [$_->[0] * $square_scale, $_->[1] * $square_scale] } @reps;
    }

    # Sort final reps
    @reps = sort { $a->[0] <=> $b->[0] } map {
        [sort { $a <=> $b } @$_]
    } @reps;

    return @reps;
}

# Run some tests

use Test::More tests => 8;

is_deeply([sum_of_two_squares_solutions(2025)],   [[0, 45],  [27,  36]],);
is_deeply([sum_of_two_squares_solutions(164025)], [[0, 405], [243, 324]]);
is_deeply([sum_of_two_squares_solutions(99025)],  [[41, 312], [48, 311], [95, 300], [104, 297], [183, 256], [220, 225]]);

is_deeply(
          [grep { my @arr = sum_of_two_squares_solutions($_); @arr > 0 } -10 .. 160],
          [0,   1,   2,   4,   5,   8,   9,   10,  13,  16,  17,  18,  20,  25,  26,  29,  32,  34,  36,  37,  40,  41,
           45,  49,  50,  52,  53,  58,  61,  64,  65,  68,  72,  73,  74,  80,  81,  82,  85,  89,  90,  97,  98,  100,
           101, 104, 106, 109, 113, 116, 117, 121, 122, 125, 128, 130, 136, 137, 144, 145, 146, 148, 149, 153, 157, 160
          ]
         );

is_deeply(
          [sum_of_two_squares_solutions(1777574759925022720)],
          [[110080512, 1328705024],
           [146744832, 1325156864],
           [151045632, 1324673536],
           [243249664, 1310879232],
           [347689472, 1287123456],
           [402252288, 1271128576],
           [463025664, 1250272768],
           [490100224, 1239909888],
           [494122496, 1238312448],
           [591927808, 1194653184],
           [673967616, 1150366208],
           [697867776, 1136026112],
           [722402816, 1120584192],
           [775551488, 1084478976],
           [885287424, 996915712],
           [912489984, 972078592]
          ]
         );

do {
    use bigint try => 'GMP';
    is_deeply(
              [sum_of_two_squares_solutions(Math::GMPz->new("11392163240756069707031250"))],
              [[39309472125,   3374998963875],
               [216763660575,  3368260197225],
               [477329304375,  3341305130625],
               [729359177085,  3295481517405],
               [735019741071,  3294223614297],
               [907262616645,  3251005657515],
               [982736803125,  3228992353125],
               [1151205969375, 3172835964375],
               [1224793301193, 3145162095999],
               [1393801568775, 3074000720175],
               [1622919634875, 2959441687125],
               [1847545189875, 2824666354125],
               [1993551800625, 2723584854375],
               [2056446956025, 2676413487825],
               [2194367046795, 2564549961435],
               [2198769707673, 2560776252111],
               [2386646521875, 2386646521875]
              ]
             );

    is_deeply([sum_of_two_squares_solutions(2**128 + 1)], [[1, 18446744073709551616], [8479443857936402504, 16382350221535464479]]);

    is_deeply(
              [sum_of_two_squares_solutions(13**18 * 5**7)],
              [[75291211970,   2963091274585],
               [100083884615,  2962357487570],
               [124869548830,  2961416259815],
               [149646468985,  2960267657230],
               [154416779750,  2960022656375],
               [179181003625,  2958626849750],
               [203932680250,  2957023863625],
               [228670076375,  2955213810250],
               [253391459750,  2953196816375],
               [258150241063,  2952784638466],
               [282850264814,  2950521038023],
               [307530481817,  2948050825694],
               [332189163826,  2945374174457],
               [356824584103,  2942491271746],
               [481345955350,  2924702504425],
               [505803171575,  2920572173350],
               [530224968650,  2916237327575],
               [554609636425,  2911698270650],
               [578955467350,  2906955320425],
               [583639307225,  2906018552450],
               [607936593550,  2901032879225],
               [632191308775,  2895844059550],
               [656401754450,  2890452456775],
               [680566235225,  2884858448450],
               [802350873038,  2853386013959],
               [826200069721,  2846571993278],
               [849991411282,  2839558639801],
               [873723231719,  2832346444642],
               [897393869198,  2824935912839],
               [901945120375,  2823486084250],
               [925540625750,  2815839700375],
               [949071319625,  2807996135750],
               [972535554250,  2799955939625],
               [977046452345,  2798385051790],
               [1000429281410, 2790111094745],
               [1023742054855, 2781641758610],
               [1046983140190, 2772977636455],
               [1070150909945, 2764119334990],
               [1186462080890, 2716226499895],
               [1209150070505, 2706203018090],
               [1231753388710, 2695990032905],
               [1254270452695, 2685588259510],
               [1276699685690, 2674998426295],
               [1281008818375, 2672937536750],
               [1303331253250, 2662124398375],
               [1325562421625, 2651124843250],
               [1347700766750, 2639939641625],
               [1369744738375, 2628569576750],
               [1373978929622, 2626358804329],
               [1395908335991, 2614769317862],
               [1417739993098, 2602996730711],
               [1439472372169, 2591041867258],
               [1461103951382, 2578905564649],
               [1569204922025, 2514592328950],
               [1590192225050, 2501373094025],
               [1611068173975, 2487978699050],
               [1631831306950, 2474410081975],
               [1652480170025, 2460668192950],
               [1656443419150, 2458002007175],
               [1676954116825, 2444054737150],
               [1697347384850, 2429936320825],
               [1717621795175, 2415647746850],
               [1838087734327, 2325298292486],
               [1857481600234, 2309835659287],
               [1876745394953, 2294211278554],
               [1895877769526, 2278426244393],
               [1899547017625, 2275368057250],
               [1918520912750, 2259392877625],
               [1937360462375, 2243259482750],
               [1956064347250, 2226969002375],
               [1974631257625, 2210522577250],
               [1978190975930, 2207337566135],
               [1996592834665, 2190706671530],
               [2014854880870, 2173922371465],
               [2032975835735, 2156985841270],
               [2050954430330, 2139898266935]
              ]
             );
};

my @nums = (@ARGV ? (map { Math::GMPz->new($_) } @ARGV) : (map { int rand(~0) } 1 .. 20));

foreach my $n (@nums) {
    (my @solutions = sum_of_two_squares_solutions($n)) || next;

    say "$n = " . join(' = ', map { "$_->[0]^2 + $_->[1]^2" } @solutions);

    # Verify solutions
    foreach my $solution (@solutions) {
        if ($n != $solution->[0]**2 + $solution->[1]**2) {
            die "error for $n: (@$solution)\n";
        }
    }
}


================================================
FILE: Math/sum_of_two_squares_multiple_solutions.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 October 2017
# https://github.com/trizen

# Algorithm for finding solutions to the equation a^2 + b^2 = n,
# for any given positive integer `n` for which such a solution exists.

# The number of returned solutions is at least as many as
# the number of unique prime factors p = 1 (mod 4) in `n`.

# For numbers with primes powers p^k = 1 (mod 4), for k > 1, not all the possible solutions are returned.
# For example, when n = 9925 = 5^2 * 397, only the following two solutions are returned: [58, 81], [33, 94].
# The missing solution for 9925, is: [30, 95].

# This algorithm is efficient when the factorization of `n` is known.

# See also:
#   https://oeis.org/A001481

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);
use ntheory qw(sqrtmod factor_exp chinese forsetproduct);

sub sum_of_two_squares_solution ($n) {

    $n == 0 and return [0, 0];

    my $prod1 = 1;
    my $prod2 = 1;

    my @prime_powers;

    foreach my $f (factor_exp($n)) {
        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)
            $f->[1] % 2 == 0 or return;    # power must be even
            $prod2 *= $f->[0]**($f->[1] >> 1);
        }
        elsif ($f->[0] == 2) {             # p = 2
            if ($f->[1] % 2 == 0) {        # power is even
                $prod2 *= $f->[0]**($f->[1] >> 1);
            }
            else {                         # power is odd
                $prod1 *= $f->[0];
                $prod2 *= $f->[0]**(($f->[1] - 1) >> 1);
                push @prime_powers, $f->[0];
            }
        }
        else {                             # p = 1 (mod 4)
            $prod1 *= $f->[0]**$f->[1];
            push @prime_powers, $f->[0]**$f->[1];
        }
    }

    $prod1 == 1 and return [$prod2, 0];
    $prod1 == 2 and return [$prod2, $prod2];

    my %table;
    foreach my $pp (@prime_powers) {
        my $r = sqrtmod($pp - 1, $pp);
        push @{$table{$pp}}, [$r, $pp], [$pp - $r, $pp];
    }

    my @square_roots;

    forsetproduct {
        push @square_roots, chinese(@_);
    } values %table;

    my @solutions;
    foreach my $r (@square_roots) {

        my $s = $r;
        my $q = $prod1;

        while ($s * $s > $prod1) {
            ($s, $q) = ($q % $s, $s);
        }

        push @solutions, [$prod2 * $s, $prod2 * ($q % $s)];
    }

    return sort { $a->[0] <=> $b->[0] } do {
        my %seen;
        grep { !$seen{$_->[0]}++ } map {
            [sort { $a <=> $b } @$_]
        } @solutions;
    };
}

foreach my $n (1 .. 1e5) {
    (my @solutions = sum_of_two_squares_solution($n)) || next;

    say "$n = " . join(' = ', map { "$_->[0]^2 + $_->[1]^2" } @solutions);

    # Verify solutions
    foreach my $solution (@solutions) {
        if ($n != $solution->[0]**2 + $solution->[1]**2) {
            die "error for $n: (@$solution)\n";
        }
    }
}

__END__
999826 = 99^2 + 995^2 = 315^2 + 949^2 = 699^2 + 715^2 = 525^2 + 851^2
999828 = 318^2 + 948^2
999844 = 410^2 + 912^2 = 312^2 + 950^2
999848 = 62^2 + 998^2
999850 = 43^2 + 999^2 = 321^2 + 947^2
999853 = 387^2 + 922^2
999857 = 544^2 + 839^2 = 401^2 + 916^2
999860 = 698^2 + 716^2 = 154^2 + 988^2
999869 = 262^2 + 965^2 = 613^2 + 790^2
999881 = 484^2 + 875^2 = 341^2 + 940^2
999882 = 309^2 + 951^2 = 651^2 + 759^2
999890 = 421^2 + 907^2 = 473^2 + 881^2
999892 = 324^2 + 946^2
999898 = 697^2 + 717^2 = 213^2 + 977^2
999909 = 678^2 + 735^2 = 222^2 + 975^2
999914 = 667^2 + 745^2
999917 = 109^2 + 994^2
999937 = 89^2 + 996^2 = 44^2 + 999^2
999938 = 77^2 + 997^2
999940 = 696^2 + 718^2 = 126^2 + 992^2 = 448^2 + 894^2 = 178^2 + 984^2
999941 = 446^2 + 895^2 = 370^2 + 929^2
999944 = 638^2 + 770^2
999946 = 585^2 + 811^2
999949 = 243^2 + 970^2 = 450^2 + 893^2
999952 = 444^2 + 896^2
999953 = 568^2 + 823^2
999954 = 375^2 + 927^2 = 327^2 + 945^2
999956 = 500^2 + 866^2
999961 = 644^2 + 765^2
999962 = 541^2 + 841^2 = 239^2 + 971^2
999968 = 452^2 + 892^2
999970 = 627^2 + 779^2 = 247^2 + 969^2
999973 = 658^2 + 753^2 = 118^2 + 993^2 = 63^2 + 998^2 = 622^2 + 783^2
999981 = 141^2 + 990^2
999986 = 365^2 + 931^2 = 695^2 + 719^2
999997 = 194^2 + 981^2 = 454^2 + 891^2
1000000 = 352^2 + 936^2


================================================
FILE: Math/sum_of_two_squares_solution.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 24 October 2017
# https://github.com/trizen

# Algorithm for finding a solution to the equation a^2 + b^2 = n,
# for any given positive integer `n` for which such a solution exists.

# This algorithm is efficient when the factorization of `n` is known.

# See also:
#   https://oeis.org/A001481

use 5.020;
use strict;
use warnings;

use ntheory qw(sqrtmod factor_exp);
use experimental qw(signatures);

sub sum_of_two_squares_solution ($n) {

    $n == 0 and return (0, 0);

    my $prod1 = 1;
    my $prod2 = 1;

    foreach my $f (factor_exp($n)) {
        if ($f->[0] % 4 == 3) {            # p = 3 (mod 4)
            $f->[1] % 2 == 0 or return;    # power must be even
            $prod2 *= $f->[0]**($f->[1] >> 1);
        }
        elsif ($f->[0] == 2) {             # p = 2
            if ($f->[1] % 2 == 0) {        # power is even
                $prod2 *= $f->[0]**($f->[1] >> 1);
            }
            else {                         # power is odd
                $prod1 *= $f->[0];
                $prod2 *= $f->[0]**(($f->[1] - 1) >> 1);
            }
        }
        else {                             # p = 1 (mod 4)
            $prod1 *= $f->[0]**$f->[1];
        }
    }

    $prod1 == 1 and return ($prod2, 0);
    $prod1 == 2 and return ($prod2, $prod2);

    my $s = sqrtmod($prod1 - 1, $prod1) || return;
    my $q = $prod1;

    while ($s * $s > $prod1) {
        ($s, $q) = ($q % $s, $s);
    }

    return ($prod2 * $s, $prod2 * ($q % $s));
}

foreach my $n (0 .. 1e5) {
    my ($x, $y, $z) = sum_of_two_squares_solution($n);

    if (defined($x) and defined($y)) {
        say "f($n) = $x^2 + $y^2";

        if ($n != $x**2 + $y**2) {
            warn "error for $n\n";
        }
    }
}

__END__
f(999909) = 735^2 + 678^2
f(999914) = 745^2 + 667^2
f(999917) = 994^2 + 109^2
f(999937) = 996^2 + 89^2
f(999938) = 997^2 + 77^2
f(999940) = 718^2 + 696^2
f(999941) = 895^2 + 446^2
f(999944) = 770^2 + 638^2
f(999946) = 811^2 + 585^2
f(999949) = 970^2 + 243^2
f(999952) = 896^2 + 444^2
f(999953) = 823^2 + 568^2
f(999954) = 927^2 + 375^2
f(999956) = 866^2 + 500^2
f(999961) = 765^2 + 644^2
f(999962) = 841^2 + 541^2
f(999968) = 892^2 + 452^2
f(999970) = 779^2 + 627^2
f(999973) = 753^2 + 658^2
f(999981) = 990^2 + 141^2
f(999986) = 931^2 + 365^2
f(999997) = 981^2 + 194^2
f(1000000) = 936^2 + 352^2


================================================
FILE: Math/sum_remainders.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 March 2021
# https://github.com/trizen

# Let's consider the following function:
#   a(n,v) = Sum_{k=1..n} (v mod k)

# The goal is to compute a(n,v) in sublinear time with respect to v.

# Formula:
#   a(n,v) = n*v - A024916(v) + Sum_{k=n+1..v} k*floor(v/k).

# Formula derived from:
#   a(n,v) = Sum_{k=1..n} (v - k*floor(v/k))
#          = n*v - Sum_{k=1..n} k*floor(v/k)
#          = n*v - Sum_{k=1..v} k*floor(v/k) + Sum_{k=n+1..v} k*floor(v/k)

# Related problem:
#   Is there a sublinear formula for computing: Sum_{1<=k<=n, gcd(k,n)=1} k*floor(n/k) ?

# See also:
#   https://oeis.org/A099726 -- Sum of remainders of the n-th prime mod k, for k = 1,2,3,...,n.
#   https://oeis.org/A340976 -- Sum_{1 < k < n} sigma(n) mod k, where sigma = A000203.
#   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.

use 5.020;
use strict;
use warnings;

use ntheory qw(:all);
use experimental qw(signatures);

sub triangular ($n) {    # Sum_{k=1..n} k = n-th triangular number
    divint(mulint($n, addint($n, 1)), 2);
}

sub sum_of_sigma ($n) {    # A024916(n) = Sum_{k=1..n} sigma(k) = Sum_{k=1..n} k*floor(n/k)

    my $T = 0;
    my $s = sqrtint($n);

    foreach my $k (1 .. $s) {
        my $t = divint($n, $k);
        $T = vecsum($T, triangular($t), mulint($k, $t));
    }

    subint($T, mulint(triangular($s), $s));
}

sub g ($a, $b) {    # g(a,b) = Sum_{k=a..b} k*floor(b/k)

    my $T = 0;

    while ($a <= $b) {

        my $t = divint($b, $a);
        my $u = divint($b, $t);

        $T = addint($T, mulint($t, subint(triangular($u), triangular(subint($a, 1)))));
        $a = addint($u, 1);
    }

    return $T;
}

sub sum_remainders ($n, $v) {    # sub-linear formula
    addint(subint(mulint($n, $v), sum_of_sigma($v)), g(addint($n, 1), $v));
}

say sprintf "[%s]", join(', ', map { sum_remainders($_,     nth_prime($_)) } 1 .. 20);      #=> A099726
say sprintf "[%s]", join(', ', map { sum_remainders($_ - 1, divisor_sum($_)) } 1 .. 20);    #=> A340976

foreach my $k (1 .. 8) {
    say("A099726(10^$k) = ", sum_remainders(powint(10, $k), nth_prime(powint(10, $k))));
}

__END__
A099726(10^1) = 30
A099726(10^2) = 2443
A099726(10^3) = 248372
A099726(10^4) = 25372801
A099726(10^5) = 2437160078
A099726(10^6) = 252670261459
A099726(10^7) = 24690625139657
A099726(10^8) = 2516604108737704


================================================
FILE: Math/super_pandigital_numbers.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 20 August 2017
# https://github.com/trizen

# Generate the smallest super-pandigital numbers that are simultaneously pandigital in all bases from 2 to n inclusively.

# Brute-force solution.

# See also:
#   # https://projecteuler.net/problem=571

use 5.010;
use strict;
use warnings;

use List::Util qw(uniq all min);
use ntheory qw(todigits fromdigits);
use Algorithm::Combinatorics qw(variations);

my $base  = shift(@ARGV) // 10;    # pandigital in all bases 2..$base
my $first = 10;                    # generate first n numbers

my @digits = (1, 0, 2 .. $base - 1);
my @bases  = reverse(2 .. $base - 1);

my $sum  = 0;
my $iter = variations(\@digits, $base);

while (defined(my $t = $iter->next)) {

    if ($t->[0]) {
        my $d = fromdigits($t, $base);

        if (all { uniq(todigits($d, $_)) == $_ } @bases) {
            say "Found: $d";
            $sum += $d;
            last if --$first == 0;
        }
    }
}

say "Sum: $sum";

__END__

First 10 super-pandigital numbers in bases 2 up to 10:

1093265784
1367508924
1432598706
1624573890
1802964753
2381059764
2409758631
2578693140
2814609357
2814759360

Sum: 20319792309


================================================
FILE: Math/tangent_numbers.pl
================================================
#!/usr/bin/perl

# Algorithm for computing the tangent numbers:
#
#   1, 2, 16, 272, 7936, 353792, 22368256, 1903757312, 209865342976, 29088885112832, ...
#

# Algorithm presented in the book:
#
#   Modern Computer Arithmetic
#           - by Richard P. Brent and Paul Zimmermann
#

# See also:
#   https://oeis.org/A000182
#   https://mathworld.wolfram.com/TangentNumber.html
#   https://en.wikipedia.org/wiki/Alternating_permutation

use 5.010;
use strict;
use warnings;

use Math::GMPz;

sub tangent_numbers {
    my ($n) = @_;

    my @T = (Math::GMPz::Rmpz_init_set_ui(1));

    foreach my $k (1 .. $n - 1) {
        Math::GMPz::Rmpz_mul_ui($T[$k] = Math::GMPz::Rmpz_init(), $T[$k - 1], $k);
    }

    foreach my $k (1 .. $n - 1) {
        foreach my $j ($k .. $n - 1) {
            Math::GMPz::Rmpz_mul_ui($T[$j], $T[$j], $j - $k + 2);
            Math::GMPz::Rmpz_addmul_ui($T[$j], $T[$j - 1], $j - $k);

        }
    }

    return @T;
}

say join(', ', tangent_numbers(10));


================================================
FILE: Math/trial_division_fast.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 31 January 2022
# https://github.com/trizen

# Fast adaptive trial-division algorithm.

use 5.020;
use strict;
use warnings;

use Math::GMPz;
use Time::HiRes qw(gettimeofday tv_interval);
use Math::Prime::Util::GMP qw(:all);

use experimental qw(signatures);

sub fast_trial_factor ($n, $L = 1e4, $R = 1e6) {

    $n = Math::GMPz->new("$n");

    my @P = sieve_primes(2, $L);

    my $g = Math::GMPz::Rmpz_init();
    my $t = Math::GMPz::Rmpz_init();

    my @factors;

    while (1) {

        # say "L = $L with $#P";

        Math::GMPz::Rmpz_set_str($g, vecprod(@P), 10);
        Math::GMPz::Rmpz_gcd($g, $g, $n);

        # Early stop when n seems to no longer have small factors
        if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0) {
            last;
        }

        # Factorize n over primes in P
        foreach my $p (@P) {
            if (Math::GMPz::Rmpz_divisible_ui_p($g, $p)) {

                Math::GMPz::Rmpz_set_ui($t, $p);
                my $valuation = Math::GMPz::Rmpz_remove($n, $n, $t);
                push @factors, ($p) x $valuation;

                # Stop the loop early when no more primes divide `g` (optional)
                Math::GMPz::Rmpz_divexact_ui($g, $g, $p);
                last if (Math::GMPz::Rmpz_cmp_ui($g, 1) == 0);
            }
        }

        # Early stop when n has been fully factored or the trial range has been exhausted
        if ($L >= $R or Math::GMPz::Rmpz_cmp_ui($n, 1) == 0) {
            last;
        }

        @P = sieve_primes($L + 1, $L << 1);
        $L <<= 1;
    }

    return (\@factors, $n);
}

my $n = consecutive_integer_lcm(138861);

# $n = vecprod($n, Math::GMPz->new(2)**128 + 1);

say "Length of n = ", length($n);

my $t0 = [gettimeofday];
my ($f, $r) = fast_trial_factor($n);
my $elapsed = tv_interval($t0, [gettimeofday]);

say "remainder = $r";
say "bigomega(n) = ", scalar(@$f);
say "Factorization took $elapsed seconds.";

__END__
Length of n = 60336
remainder = 1
bigomega(n) = 13034
Factorization took 0.490573 seconds.


================================================
FILE: Math/triangle_hyperoperation.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 16 October 2016
# Website: https://github.com/trizen

# Efficient implementation of the triangle hyperoperation, modulo some n.

# For definition, see:
#   https://www.youtube.com/watch?v=sW_IkMQEAwo

# See also:
#   https://www.youtube.com/watch?v=9DeOnCKfSuY

use strict;
use integer;
use warnings;

use ntheory qw(powmod forprimes);

sub triangle {
    my ($n, $k, $mod) = @_;
    return $n if $k == 1;
    powmod($n, triangle($n, $k - 1, $mod), $mod);
}

# let z = triangle(10, 10) + 23
# Question: what are the prime factors of z?

forprimes {
    my $r = (triangle(10, 10, ${_}) + 23) % ${_};
    print "$_ divides z\n" if $r == 0;
} 1e5;


================================================
FILE: Math/triangle_interior_angles.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 22 January 2018
# https://github.com/trizen

# Formula for finding the interior angles of a triangle, given its side lengths.

use 5.010;
use strict;
use warnings;

use Math::AnyNum qw(acos rad2deg);

my $x = 3;
my $y = 4;
my $z = 5;

say rad2deg(acos(($y**2 + $z**2 - $x**2) / (2 * $y * $z)));     # 36.869...
say rad2deg(acos(($x**2 - $y**2 + $z**2) / (2 * $x * $z)));     # 53.130...
say rad2deg(acos(($x**2 + $y**2 - $z**2) / (2 * $x * $y)));     # 90


================================================
FILE: Math/tribonacci_primality_test.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 18 May 2019
# https://github.com/trizen

# A new primality test, using a Tribonacci-like sequence.

# Sequence definition:
#   T(0) = 0
#   T(1) = 0
#   T(2) = 9
#   T(n) = T(n-1) + 3*T(n-2) + 9*T(n-3)

# Closed form:
#   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))

# The sequence starts as:
#   0, 0, 9, 9, 36, 144, 333, 1089, 3384, 9648, 29601, 89001, 264636, 798048, ...

# When p is a prime > 5 congruent to {1,3} mod 8, then T(p) == 0 (mod p).
# When p is a prime > 5 congruent to {5,7} mod 8, then T(p) == 4 (mod p).

# Counter-examples:
#   for n == 1 (mod 8): 88561,107185,162401,221761,226801,334153,410041,665281,825265,1569457,1615681,2727649, ...
#   for n == 3 (mod 8): 80375707,154287451,267559627,326266051,478614067,573183451,643767931,2433943891,4297753027, ....

# See also:
#   https://trizenx.blogspot.com/2020/01/primality-testing-algorithms.html

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(:overload);
use Math::MatrixLUP;

use ntheory qw(is_prime);
use experimental qw(signatures);

my $A = Math::MatrixLUP->new([[0, 3, 0], [0, 0, 3], [1, 1, 1]]);
my $B = Math::MatrixLUP->new([[4, 2, 3], [1, 5, 3], [1, 2, 6]]);
my $I = Math::MatrixLUP->new([[1, 0, 0], [0, 1, 0], [0, 0, 1]]);

sub is_tribonacci_prime ($n) {

    my $r = $n % 8;

    if ($r == 1 or $r == 3) {
        return ($A->powmod($n - 1, $n) == $I);
    }

    if ($r == 5 or $r == 7) {
        return ($A->powmod($n + 1, $n) == $B);
    }

    return;
}

local $| = 1;
foreach my $n (7 .. 1e3) {
    if (is_tribonacci_prime($n)) {
        if (not is_prime($n)) {
            say "\nCounter-example: $n\n";
        }
        print($n, ", ");
    }
    elsif (is_prime($n)) {
        say "\nMissed prime: $n\n";
    }
}


================================================
FILE: Math/trip2mars.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# License: GPLv3
# Date: 15 October 2013
# https://trizenx.blogspot.com

# This program solves the "Trip to Mars" problem
# See: https://www.youtube.com/watch?v=k-zrgRv9tFU

use 5.010;
use strict;
use warnings;

my %max = (
           hours  => 0,
           games  => 0,
           movies => 0,
          );

foreach my $x (0 .. 200) {
    foreach my $y (0 .. 200 - $x) {

        next if 8 * $x + 3 * $y > 1200;
        next if 0.2 * $x + 0.8 * $y > 130;

        my $hours = 4 * $x + 2 * $y;

        if ($hours > $max{hours}) {
            $max{hours}  = $hours;
            $max{games}  = $x;
            $max{movies} = $y;
        }
    }
}

say "To maximize the time on breaks, you need to buy $max{games} games and $max{movies} movies.";


================================================
FILE: Math/unique_permutations.pl
================================================
#!/usr/bin/perl

# Generate only the unique permutations of a given array.

# Optimized Unique Permutation DFS without explicit key tracking
# Recursively branches unique factors only at each depth.

use 5.036;

sub unique_permutations($array, $callback) {
    sub ($items, $current_perm) {

        if (!@$items) {
            $callback->($current_perm);
            return;
        }

        my %level_seen;
        for my $i (0 .. $#$items) {
            my $item = $items->[$i];

            # Skip iterations for duplicate elements in the same level
            next if $level_seen{$item}++;

            my @new_items = @$items;
            splice(@new_items, $i, 1);

            my @new_perm = (@$current_perm, $item);
            __SUB__->(\@new_items, \@new_perm);
        }
    }->($array, []);
}

unique_permutations(
    [3, 2, 2, 3],
    sub ($perm) {
        say "(@$perm)";
    }
);

__END__
(3 2 2 3)
(3 2 3 2)
(3 3 2 2)
(2 3 2 3)
(2 3 3 2)
(2 2 3 3)


================================================
FILE: Math/unitary_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 01 July 2018
# https://github.com/trizen

# A simple algorithm for generating the unitary divisors of a given number.

# See also:
#   https://en.wikipedia.org/wiki/Unitary_divisor

use 5.010;
use strict;
use warnings;

use ntheory qw(forcomb factor_exp vecprod powint);

# This algorithm nicely illustrates the identity:
#
#   2^n = Sum_{k=0..n} binomial(n, k)
#
# which is the number of divisors of a squarefree number that is the product of `n` primes.

sub udivisors {
    my ($n) = @_;

    my @pp  = map { powint($_->[0], $_->[1]) } factor_exp($n);
    my $len = scalar(@pp);

    my @d;
    foreach my $k (0 .. $len) {
        forcomb {
            push @d, vecprod(@pp[@_]);
        } $len, $k;
    }

    return sort { $a <=> $b } @d;
}

say join(' ', udivisors(5040));


================================================
FILE: Math/unitary_divisors_fast.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 01 July 2018
# https://github.com/trizen

# A simple algorithm for generating the unitary divisors of a given number.

# See also:
#   https://en.wikipedia.org/wiki/Unitary_divisor

use 5.010;
use strict;
use warnings;

use ntheory qw(factor_exp powint mulint);

sub udivisors {
    my ($n) = @_;

    my @d  = (1);
    my @pp = map { powint($_->[0], $_->[1]) } factor_exp($n);

    foreach my $p (@pp) {
        push @d, map { mulint($_, $p) } @d;
    }

    return sort { $a <=> $b } @d;
}

say join(' ', udivisors(5040));


================================================
FILE: Math/unitary_squarefree_divisors.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 June 2018
# https://github.com/trizen

# Generate the unitary squarefree divisors of a given number.

# See also:
#   https://oeis.org/A092261

use 5.010;
use strict;
use warnings;

use ntheory qw(factor_exp);

sub unitary_squarefree_divisors {
    my ($n) = @_;

    my @d  = (1);
    my @pp = map { $_->[0] } grep { $_->[1] == 1 } factor_exp($n);

    foreach my $p (@pp) {
        push @d, map { $_ * $p } @d;
    }

    return sort { $a <=> $b } @d;
}

foreach my $n (1 .. 30) {
    my @d = unitary_squarefree_divisors($n);
    say "a($n) = [@d]";
}


================================================
FILE: Math/wilson_prime_formula.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 27 September 2014
# Edit: 15 May 2021
# https://github.com/trizen

# See also:
#   https://en.wikipedia.org/wiki/Wilson's_theorem

use 5.020;
use strict;
use warnings;

use Math::AnyNum qw(factorial);
use experimental qw(signatures);

sub is_wilson_prime($n) {
    factorial($n-1) % $n == $n-1;
}

for my $n (2..100) {
    if (is_wilson_prime($n)) {
        print($n, ", ");
    }
}


================================================
FILE: Math/yahtzee.pl
================================================
#!/usr/bin/perl

# One-Roll Yahtzee Fever

# https://www.youtube.com/watch?v=dXGhzY2p2ug

my (@list) = (0) x 5;
my $count = 0;

do {
    foreach my $num (@list) {
        $num = int(rand 6) + 1;
    }
    ++$count;
} until ((grep { $_ == $list[0] } @list) == @list);

print "Rolls: $count\tNumber: $list[0]\n";


================================================
FILE: Math/zequals.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 21 February 2013
# https://github.com/trizen

# Zequals and estimations
# https://www.youtube.com/watch?v=aOJOfh2_4PE

# Example: 722 * 49 ~~ 700 * 50

use 5.010;
use strict;
use warnings;

sub round {    # doesn't work as you expect!
    my ($num) = @_;

    my $i = 10;
    while ($i < $num) {
        if ($num % $i >= $i / 2) {
            $num += $i - $num % $i;
        }
        else {
            $num -= $num % $i;
        }
        $i *= 10;
    }

    return $num;
}

sub round_right {    # this works as expected.
    my ($num) = @_;

    my $i    = 10**int(log($num) / log(10));
    my $base = $i * int($num / $i);

    if ($num - $base >= $i / 2) {
        return $num + ($i - ($num - $base));
    }
    else {
        return $num - ($num - $base);
    }
}

sub zequal {
    my ($x, $y) = @_;
    return (round($x) * round($y));
}

sub zequal_right {
    my ($x, $y) = @_;
    return (round_right($x) * round_right($y));
}

{
    my ($x, $y) = (shift || 345, shift || 342);

    say "Zequal simple ($x, $y) ~~ ", zequal($x, $y);
    say "Zequal right  ($x, $y) ~~ ", zequal_right($x, $y);
    say "Reality       ($x, $y) == ", $x * $y;
}


================================================
FILE: Math/zeta_2n.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 06 September 2015
# Website: https://github.com/trizen

# Calculate zeta(2n) using a closed-form formula.
# See: https://en.wikipedia.org/wiki/Riemann_zeta_function

use 5.010;
use strict;
use warnings;

use Memoize qw(memoize);
use Math::AnyNum qw(:overload pi);

sub bernoulli_number {
    my ($n) = @_;

    return 0 if $n > 1 && $n % 2;    # Bn = 0 for all odd n > 1

    my @A;
    for my $m (0 .. $n) {
        $A[$m] = 1 / ($m + 1);

        for (my $j = $m ; $j > 0 ; $j--) {
            $A[$j - 1] = $j * ($A[$j - 1] - $A[$j]);
        }
    }

    return $A[0];                    # which is Bn
}

sub factorial {
    $_[0] < 2 ? 1 : factorial($_[0] - 1) * $_[0];
}

memoize('factorial');

sub zeta_2n {
    my ($n2) = 2 * $_[0];
    ((-1)**($_[0] + 1) * 2**($n2 - 1) * pi**$n2 * bernoulli_number($n2)) / factorial($n2);
}

for my $i (1 .. 10) {
    say "zeta(", 2 * $i, ") = ", zeta_2n($i);
}


================================================
FILE: Math/zeta_for_primes.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 22 September 2015
# Website: https://github.com/trizen

# Zeta-prime formula
#   Sum of 1/P(n)^p
# where P(n) is a prime number and p is a positive integer.

use 5.010;
use strict;
use warnings;

use ntheory qw(nth_prime);

my @sums;
foreach my $i (1 .. 100000) {
    foreach my $p (1 .. 10) {
        $sums[$p - 1] += 1 / nth_prime($i)**$p;
    }
}

foreach my $p (0 .. $#sums) {
    printf("zp(%d) = %s\n", $p + 1, $sums[$p]);
}

__END__
#
## From i=1..1000000
#
zp(1) = 3.06821904805445
zp(2) = 0.452247416351722
zp(3) = 0.174762639299271
zp(4) = 0.0769931397642436
zp(5) = 0.035755017483924
zp(6) = 0.0170700868506365
zp(7) = 0.00828383285613359
zp(8) = 0.00406140536651783
zp(9) = 0.00200446757496245
zp(10) = 0.00099360357443698


================================================
FILE: Math/zeta_function.pl
================================================
#!/usr/bin/perl

use 5.010;
use strict;
use warnings;

sub zeta {
    my ($n) = @_;
    my $sum = 0;

    foreach my $i (1 .. 1000000) {
        $sum += (1 / $i**$n);
    }

    $sum;
}

say zeta(2);


================================================
FILE: Math/zeta_prime_count_approx.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 07 January 2016
# Website: https://github.com/trizen

# A basic approximation for the number of primes less than or equal with `n`
# based on the zeta function. More precisely, on the value of ζ(2).

# The formula is:
#
#   pi(2) = 1
#   pi(n) = pi(n-1) + log(ζ(2)) / (log10(^n) + log(1 / (1 - n^(-2))))
#
# where log10(^n) is the common logarithm of the initial "n".

# It's based on the fact that:
#             ∞
# log(ζ(s)) = Σ (π(n) - π(n-1)) * log(1 / (1 - n^(-s)))
#            n=2

use 5.010;
use strict;
use warnings;

no warnings 'recursion';
use ntheory qw(prime_count);

my $lz = log(1.64493406684822643647241516664602518922);    # log(ζ(2))

sub pi {
    my ($n, $lb) = @_;

    return 0 if $n <= 1;
    return 1 if $n == 2;

    pi($n - 1, $lb) + ($lz / ($lb + log(1 / (1 - $n**(-2)))));
}

for (my $i = 10 ; $i <= 3000 ; $i += 100) {
    printf("pi(%4d) =~ %4s   (actual: %4s)\n", $i, int(pi($i, log($i) / log(10))), prime_count($i));
}

__END__
pi(  10) =~    4   (actual:    4)
pi( 110) =~   27   (actual:   29)
pi( 210) =~   45   (actual:   46)
pi( 310) =~   62   (actual:   63)
pi( 410) =~   78   (actual:   80)
pi( 510) =~   94   (actual:   97)
pi( 610) =~  109   (actual:  111)
pi( 710) =~  124   (actual:  127)
pi( 810) =~  139   (actual:  140)
pi( 910) =~  153   (actual:  155)
pi(1010) =~  167   (actual:  169)
pi(1110) =~  182   (actual:  186)
pi(1210) =~  196   (actual:  197)
pi(1310) =~  209   (actual:  214)
pi(1410) =~  223   (actual:  223)
pi(1510) =~  237   (actual:  239)
pi(1610) =~  250   (actual:  254)
pi(1710) =~  263   (actual:  267)
pi(1810) =~  277   (actual:  279)
pi(1910) =~  290   (actual:  292)
pi(2010) =~  303   (actual:  304)
pi(2110) =~  316   (actual:  317)
pi(2210) =~  329   (actual:  329)
pi(2310) =~  342   (actual:  343)
pi(2410) =~  355   (actual:  357)
pi(2510) =~  368   (actual:  368)
pi(2610) =~  380   (actual:  379)
pi(2710) =~  393   (actual:  394)
pi(2810) =~  406   (actual:  409)
pi(2910) =~  418   (actual:  421)


================================================
FILE: Media/wimp-viewer
================================================
#!/usr/bin/perl

# List and play the most recent videos from: https://www.wimp.com/

# Requires 'youtube-viewer' and 'mpv'

use 5.010;
use strict;
use warnings;

use open ':std' => ':utf8';

use Encode qw(encode_utf8);
use XML::Fast qw(xml2hash);
use Term::ANSIColor qw(colored);
use Getopt::Std qw(getopts);

my $appname = 'wimp-viewer';
my $version = '0.33';

my $BASE_URL = 'https://www.wimp.com';

require Term::ReadLine;
my $term = Term::ReadLine->new($appname);

require WWW::Mechanize;
my $mech = WWW::Mechanize->new(
              autocheck     => 1,
              env_proxy     => 1,
              show_progress => 0,
              agent => 'Mozilla/5.0 (X11; Linux i686) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/36.0.1941.0 Safari/537.36',
);

$mech->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());

sub output_usage {
    print <<"HELP";
usage: $0 [options] [url]

options:
        -f       : fullscreen mode
        -r    : play i of random videos and exit

        -v       : print the version number and exit
        -h       : print this help message and exit
HELP
}

sub output_version {
    say "$appname $version";
}

my %opt;
if (@ARGV) {
    getopts('r:fvh', \%opt);
}

if ($opt{h}) {
    output_usage();
    exit 0;
}

if ($opt{v}) {
    output_version();
    exit 0;
}

if (exists $opt{r}) {

    if (defined($opt{r}) and $opt{r} > 0) {
        for my $i (1 .. $opt{r}) {
            play_random_video();
        }
    }
    else {
        die "error: option '-r' requires a positive integer!\n";
    }

    exit;
}

# Play the command-line URIs
foreach my $url (@ARGV) {
    play($url);
    exit;
}

sub play {
    my ($url) = @_;

    my $resp    = $mech->get($url);
    my $content = $resp->decoded_content // $resp->content;

    my $real_url = $mech->uri;

    if (   $content =~ m{\byoutube\.com/watch\?v=([\w-]{11})"}
        or $content =~ m{
    get($url)->decoded_content));
    push @results, @{$hash_xml->{rss}{channel}{item}};
}

sub play_picked_videos {
    my (@list) = @_;

    $#list >= 0 or return;
    foreach my $num (@list) {
        play($results[$num - 1]->{link});
    }

    return 1;
}

sub play_random_video {
    play("$BASE_URL/random/");
    return 1;
}

sub parse_date {
    my ($date) = @_;

    # Turns "Mon, 06 Feb 2012 00:00:00 -0600" into "Feb 06"
    if ($date =~ /^\S+ (\d+) (\S+)/) {
        return "$2 $1";
    }

    return $date // '';
}

{
    print "\n";
    my $num = 0;
    foreach my $video (@results) {
        $video->{title} =~ s/\s*\[VIDEO\]//;
        printf "%s. %s [%s]\n", colored(sprintf("%2d", ++$num), 'bold'), $video->{title}, parse_date($video->{pubDate});
    }

    {
        my $line = $term->readline(colored("\n=>> Insert a number ('?' for help)", 'bold') . "\n> ");
        if ($line eq 'help' or $line eq '?') {
            print "\n", <<'STDIN_HELP';
i               : play the corresponding video
all             : play all the video results
3-8, 3..8       : same as 3 4 5 6 7 8
/my?[regex]*$/  : play videos matched by a regex (/i)
q, quit, exit   : exit application
STDIN_HELP
            redo;
        }
        elsif ($line =~ /^(?:q|quit|exit)\z/) {
            exit 0;
        }
        elsif ($line eq 'all') {
            play_picked_videos(1 .. @results);
        }
        elsif ($line =~ m{^/(.*?)/\h*$}) {
            my $match = eval { qr/$1/i };

            if ($@) {
                warn "\nError in regex: $@\n";
                redo;
            }

            play_picked_videos(grep { $results[$_ - 1]->{'title'} =~ /$match/ } 1 .. @results) || do {
                warn "\n(X_X) No video matched by the regex: /$match/\n";
                redo;
            };
        }

        elsif ($line =~ /\d/ and not $line =~ /(?>\s|^)[^\d-]/) {
            $line =~ s/(\d+)(?>-|\.\.)(\d+)/join q{ }, $1 .. $2;/eg;    # '2..5' or '2-5' to '2 3 4 5'
            play_picked_videos(grep { $_ > 0 and $_ <= @results if /^\d+$/ } split(/[\s[:punct:]]+/, $line));
        }

        elsif ($line =~ /^(?:r|random)\z/) {
            play_random_video();
        }

        elsif ($line =~ m{^https?://.}) {
            play($_);
        }
    }
    redo;
}


================================================
FILE: Microphone/Alsa/raw_from_microphone.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 07 April 2014
# Website: https://github.com/trizen

# Read raw data from microphone (via ALSA/arecord)

use 5.010;
use strict;
use warnings;

use Time::HiRes qw(sleep);

use constant {
        HW_PARAMS_FILE => '/proc/asound/card0/pcm0c/sub0/hw_params',
};

open(my $pipe_h, '-|', 'arecord', '-t', 'raw', '/dev/stdout') // exit $!;
sleep 0.1;    # /proc can't be instant

sub parse_config {
    my ($file) = @_;

    open my $fh, '<', $file or return;

    my %table;
    while (<$fh>) {
        if (/^([^:]+):\h*(.*\S)/) {
            $table{$1} = $2;
        }
    }

    close $fh;
    return \%table;
}

# Read the hardware parameters file
my $hw_params = parse_config(HW_PARAMS_FILE) // die "can't read config file: $!";

while (read($pipe_h, (my $buffer), $hw_params->{buffer_size})) {

    # Here some interesting stuff needs to be written :)
    #say length($buffer);

    print "\n";

    my $i    = 0;
    my @data = "";
    foreach my $char (split(//, $buffer)) {

        my $step = 20;             # a lower value means greater precision
        my $ord  = ord($char);
        my $mod  = $ord % $step;

        if ($mod > ($step / 2)) {
            $ord += ($step - $mod);
        }
        else {
            $ord -= $mod;
        }

        if ($ord >= 127) {
            $ord %= 127;
        }

        if ($ord <= 32) {
            $ord += 32;
        }

        if ($ord == ord('-')) {    # '-' is for the background noise
            if ($data[-1] ne '') {
                ++$#data;
                $data[-1] = '';
            }
            next;
        }

        $data[-1] .= chr $ord;
    }

    my @sen;
    foreach my $seq (@data) {
        my $len = length($seq);
        if ((my $i = $len - ($len % 2)) > 0) {
            push @sen, 'x' x $i;
        }
    }

    print "@sen\n";

    ## Recursive self-recording
    ## WARNING: code too awesome to be executed =D
    #open my $fh, '>:raw', '/tmp/x';
    #print $fh $buffer;
    #close $fh;
    #system 'aplay', '/tmp/x';
}

__END__
access: MMAP_INTERLEAVED
format: S32_LE
subformat: STD
channels: 2
rate: 48000 (48000/1)
period_size: 1024
buffer_size: 16384

__DATA__
xxxx 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
16384
xxxxx 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
16384
xxxx 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
16384
xxxxx 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
16384
xxxxxxx 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
16384
xxx 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
16384
xxxxx 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
16384
xxxxx 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
16384
xxxx 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
16384
xxxxxx 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
16384
xxx 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
16384
xxxxx 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
16384
x 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


================================================
FILE: Microphone/Julius/julius_voice_control_concept.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 April 2014
# Website: https://github.com/trizen

# Voice control - take actions based on vocal commands
# This script depends on the 'julius', which also needs
# an acoustic model for the English language.
# An open-source acoustic model can be downloaded from:
#    https://www.voxforge.org/home/downloads

# Configuration files: https://github.com/trizen/config-files/tree/master/.voxforge/julius

use utf8;
use 5.010;
use strict;
use warnings;
use List::Util qw(sum);

no if $] >= 5.018, warnings => 'experimental';

my $config = "$ENV{HOME}/.voxforge/julius/perl.jconf";
my @julius = qw(julius -input mic);

open(my $pipe_h, '-|', @julius, '-C', $config) // exit $!;

sub take_action {
    my ($command) = @_;

    given ($command) {
        when (' START MUSIC ') {
            say "Starting music...";
        }
        when (' START TERM ') {
            say "Opening the terminal...";
        }
        default {
            warn "WARN: Invalid command `$command'!\n";
        }
    }
}

my @buffer;
while (<$pipe_h>) {

    if (!/\S/) {
        my %conf;
        foreach my $line (@buffer) {
            if ($line =~ /^(\w+):\h*(.*\S)/) {
                $conf{$1} = $2;
            }
        }

        if (exists $conf{cmscore1} and exists $conf{sentence1}) {
            my @vals = split(' ', $conf{cmscore1});
            if (sum(@vals) == @vals) {    # 'cmscore1' must be: 1.000 1.000 1.000 1.000
                take_action($conf{sentence1});
            }
        }

        $#buffer = -1;
    }

    push @buffer, $_;
}

__END__
pass1_best:  START MUSIC
pass1_best_wordseq: 0 2 3
pass1_best_phonemeseq: sil | y ah ng | w ah n
pass1_best_score: -4008.542480
### Recognition: 2nd pass (RL heuristic best-first)
STAT: 00 _default: 7 generated, 7 pushed, 5 nodes popped in 100
sentence1:  START MUSIC 
wseq1: 0 2 3 1
phseq1: sil | y ah ng | w ah n | sil
cmscore1: 1.000 1.000 1.000 1.000
score1: -11499.305664

#################################
## __VOCA_FILE__ (perl.voca)
#################################
% NS_B
        sil

% NS_E
        sil

% CMD
START      y ah ng

% THING
MUSIC     w ah n
TERM      s eh v ax n

######################################
## __GRAMMAR_FILE__ (perl.grammar)
######################################
S : NS_B CMD THING_LOOP NS_E
THING_LOOP: THING_LOOP THING
THING_LOOP: THING


================================================
FILE: Microphone/Julius/voice_control.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 April 2014
# Website: https://github.com/trizen

# Voice control - take actions based on vocal commands
# Configuration, grammar and .voca files: https://github.com/trizen/config-files/tree/master/.voxforge/julius

use utf8;
use 5.010;
use strict;
use warnings;
use List::Util qw(sum);

no if $] >= 5.018, warnings => 'experimental';

my %forks;
my $config = "$ENV{HOME}/.voxforge/julius/perl.jconf";
my @julius = qw(julius -input mic);

open(my $pipe_h, '-|', @julius, '-C', $config) // exit $!;

sub take_action {
    my ($command) = @_;

    given ($command) {
        when (' PLAY MUSIC ') {
            say "Starting music...";
            push @{$forks{music}}, scalar fork();
            if ($forks{music}[-1] == 0) {
                exec "mpv $ENV{HOME}/*.mp3";
            }
        }
        when (' STOP MUSIC ') {
            say "Stoping music...";
            if (ref $forks{music} eq 'ARRAY' and @{$forks{music}} > 0) {
                kill 1, $forks{music}[-1];
                pop @{$forks{music}};
            }
        }
        when (' RUN TERM ') {
            say "Opening the terminal...";
        }
        when (' RUN EDITOR ') {
            say "Running editor...";
        }
        when (' PRESS ENTER ') {
            print "\n";
        }
        default {
            warn "WARN: Invalid command `$command'!\n";
        }
    }
}

my @buffer;
while (<$pipe_h>) {

    if (!/\S/) {
        my %conf;
        foreach my $line (@buffer) {
            if ($line =~ /^(\w+):\h*(.*\S)/) {
                $conf{$1} = $2;
            }
        }

        if (exists $conf{cmscore1} and exists $conf{sentence1}) {
            my @vals = split(' ', $conf{cmscore1});
            say "got: $conf{sentence1} ($conf{cmscore1})";

            # 'cmscore1' should be: 1.000 1.000 1.000 1.000 (with minor tolerance)
            if (sum(@vals) >= scalar(@vals) - 0.300) {
                take_action($conf{sentence1});
            }
        }

        $#buffer = -1;
    }

    push @buffer, $_;
}

__END__
pass1_best:  START MUSIC
pass1_best_wordseq: 0 2 3
pass1_best_phonemeseq: sil | y ah ng | w ah n
pass1_best_score: -4008.542480
### Recognition: 2nd pass (RL heuristic best-first)
STAT: 00 _default: 7 generated, 7 pushed, 5 nodes popped in 100
sentence1:  START MUSIC 
wseq1: 0 2 3 1
phseq1: sil | y ah ng | w ah n | sil
cmscore1: 1.000 1.000 1.000 1.000
score1: -11499.305664


================================================
FILE: Monitoring/file-monitor
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 10 April 2012
# https://github.com/trizen

# Monitor a path for updated files, new files and deleted files.

use 5.010;
use strict;
use warnings;

use File::Find qw(find);
use Time::HiRes qw(sleep);
use Getopt::Std qw(getopts);
use File::Spec::Functions qw(rel2abs);

sub usage {
    print <<"USAGE";
usage: $0 [options] [files] [dirs]

options:
        -c [i] : monitor for changes interval (in sec)
        -n [i] : monitor for new files interval (in sec)
        -v     : verbose mode
USAGE
    exit 1;
}

# Arguments
my %opts;
getopts('c:n:v', \%opts);

my %files;
my @files       = grep { -f } @ARGV;
my @directories = grep { -d } @ARGV;

if (!@files and !@directories) {
    usage();
}
else {
    if (@directories) {
        populate_files(1);
    }
    foreach my $file (map { rel2abs($_) } @files) {
        $files{$file} = [-M $file, 0];
    }
}

my $monitor_for_changes_interval   = $opts{c} // 8;
my $monitor_for_new_files_interval = $opts{n} // $monitor_for_changes_interval**2;

sub populate_files {
    my ($first_time) = @_;
    find {
        no_chdir => 1,
        wanted   => sub {
            -f or return;
            -M _ // return;
            $files{$_} =
              exists $files{$_}
              ? [$files{$_}[0] => 0]
              : [-M _ => $first_time ? 0 : 1];
          }
         } => @directories;
}

my $track = 0;

while (1) {
    while (my ($file, $info) = each %files) {
        if (not -f $file) {
            printf "[DELETED]: %s\n", $file;
            delete $files{$file};
        }
        elsif ($info->[1]) {
            printf "[CREATED]: %s\n", $file;
            $files{$file}[1] = 0;
        }
        elsif (-M _ != $info->[0]) {
            printf "[UPDATED]: %s\n", $file;
            $files{$file}[0] = -M _;
        }
    }

    sleep $monitor_for_changes_interval;
    printf STDERR "[TOTAL_F]: %d\n", scalar keys %files if $opts{v};

    if (($track += $monitor_for_changes_interval) >= $monitor_for_new_files_interval) {
        warn "[$track] Looking for new files...\n" if $opts{v};
        populate_files(0) if @directories;
        $track = 0;
    }
}


================================================
FILE: Other/concatenation_weirdness.pl
================================================
#!/usr/bin/perl

# Weird order of concatenation of variables, when the variables are mutated during concatenation.

# In older versions of Perl, the first statement correctly returns "abc".
# In newer versions of Perl, both statements return incorrect values.

use 5.010;
use strict;
use warnings;

my $x = 'a';
my $y = 'b';

say ($x . $y . ++$y);       #=> expected "abc", but got "acc"
say ($x . ++$x);            #=> expected "ab", but got "bb"


================================================
FILE: Other/lexical_subs_recursion_bug.pl
================================================
#!/usr/bin/perl

# Perl bug when using recursion in a `my sub {}` with a parent function.

use 5.014;
use strict;
use warnings;

# Discovered by catb0t:
#   https://github.com/catb0t/multifactor/commit/d2a8ad217704182f3b71557aa81a1a62f0ea2414

sub factorial {
    my ($n) = @_;

    my sub my_func {
        my ($n) = @_;
        $n <= 1 ? 1 : $n * factorial($n - 1);
    }

    my_func($n);
}

say factorial(5);

__END__
Can't undef active subroutine at bug.pl line 17.


================================================
FILE: Other/tail_recursion.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 04 January 2017
# https://github.com/trizen

# A simple example for tail-recursion in Perl.

use 5.016;
use strict;
use warnings;

sub factorial {
    my ($n, $fac) = @_;
    return $fac if $n == 0;
    @_ = ($n-1, $n*$fac);
    goto __SUB__;
}

say factorial(5, 1);


================================================
FILE: Other/yafu_factorization.pl
================================================
#!/usr/bin/perl

# Factorize a given number, using the `YAFU` tool, and parse the output into an array of `Math::GMPz` objects.

# See also:
#   https://sourceforge.net/projects/yafu/

use 5.020;
use strict;
use warnings;
use Math::GMPz;

use experimental qw(signatures);
use File::Spec::Functions qw(rel2abs curdir tmpdir);

sub yafu_factor ($n) {

    $n = Math::GMPz->new($n);    # validate the number

    my $dir = rel2abs(curdir());

    chdir(tmpdir());
    my $output = qx(yafu 'factor($n)');
    chdir($dir);

    my @factors;

    while ($output =~ /^P\d+ = (\d+)/mg) {
        push @factors, Math::GMPz->new($1);
    }

    return sort { $a <=> $b } @factors;
}

my $n = shift() || die "usage: $0 [n]\n";

my @factors = yafu_factor($n);
say "$n = [", join(', ', @factors), ']';


================================================
FILE: README.md
================================================
perl-scripts
============

A nice collection of day-to-day Perl scripts.

### Summary

* Analyzers
    * [Char counter](./Analyzers/char_counter.pl)
    * [Chr freq](./Analyzers/chr_freq.pl)
    * [Dieharder](./Analyzers/dieharder.pl)
    * [First letter top](./Analyzers/first_letter_top.pl)
    * kcal
        * [Kcal](./Analyzers/kcal/kcal.pl)
    * [Kernel config diff](./Analyzers/kernel_config_diff.pl)
    * [Perl code analyzer](./Analyzers/perl_code_analyzer.pl)
    * [Perl code spellcheck](./Analyzers/perl_code_spellcheck.pl)
    * [Reptop](./Analyzers/reptop.pl)
    * [Text stats](./Analyzers/text_stats.pl)
    * [Unidecode word top](./Analyzers/unidecode_word_top.pl)
    * [Wcer](./Analyzers/wcer.pl)
    * [Word suffix top](./Analyzers/word_suffix_top.pl)
* Audio
    * [Auto-mp3tags](./Audio/auto-mp3tags.pl)
    * [Group audio files](./Audio/group_audio_files.pl)
    * [Mkv audio to opus](./Audio/mkv_audio_to_opus.pl)
    * [Recompress audio track](./Audio/recompress_audio_track.pl)
    * [Rem-mp3tags](./Audio/rem-mp3tags.pl)
    * [Wave-cmp](./Audio/wave-cmp.pl)
    * [Wave-cmp2](./Audio/wave-cmp2.pl)
* Benchmarks
    * [Array range vs shift](./Benchmarks/array_range_vs_shift.pl)
    * [Compression algorithms](./Benchmarks/compression_algorithms.pl)
    * [Json vs storable](./Benchmarks/json_vs_storable.pl)
    * [Schwartzian transform](./Benchmarks/schwartzian_transform.pl)
    * [Types of variables](./Benchmarks/types_of_variables.pl)
* Book tools
    * [Rosettacode to markdown](./Book%20tools/rosettacode_to_markdown.pl)
    * [Update summary](./Book%20tools/update_summary.pl)
* Compression
    * [Bbwr file compression](./Compression/bbwr_file_compression.pl)
    * [Bqof file compression](./Compression/bqof_file_compression.pl)
    * [Bwac file compression](./Compression/bwac_file_compression.pl)
    * [Bwad file compression](./Compression/bwad_file_compression.pl)
    * [Bwaz file compression](./Compression/bwaz_file_compression.pl)
    * [Bwlz2 file compression](./Compression/bwlz2_file_compression.pl)
    * [Bwlz file compression](./Compression/bwlz_file_compression.pl)
    * [Bwlza2 file compression](./Compression/bwlza2_file_compression.pl)
    * [Bwlza file compression](./Compression/bwlza_file_compression.pl)
    * [Bwlzad2 file compression](./Compression/bwlzad2_file_compression.pl)
    * [Bwlzad file compression](./Compression/bwlzad_file_compression.pl)
    * [Bwlzhd file compression](./Compression/bwlzhd_file_compression.pl)
    * [Bwlzss file compression](./Compression/bwlzss_file_compression.pl)
    * [Bwrl2 file compression](./Compression/bwrl2_file_compression.pl)
    * [Bwrl file compression](./Compression/bwrl_file_compression.pl)
    * [Bwrla file compression](./Compression/bwrla_file_compression.pl)
    * [Bwrlz2 file compression](./Compression/bwrlz2_file_compression.pl)
    * [Bwrlz file compression](./Compression/bwrlz_file_compression.pl)
    * [Bwrm file compression](./Compression/bwrm_file_compression.pl)
    * [Bwt2 file compression](./Compression/bwt2_file_compression.pl)
    * [Bwt file compression](./Compression/bwt_file_compression.pl)
    * [Bww file compression](./Compression/bww_file_compression.pl)
    * [Bzip2 compressor](./Compression/bzip2_compressor.pl)
    * [Bzip2 decompressor](./Compression/bzip2_decompressor.pl)
    * [Bzip2 file compression](./Compression/bzip2_file_compression.pl)
    * [Compress](./Compression/compress.pl)
    * [Gzip2 file compression](./Compression/gzip2_file_compression.pl)
    * [Gzip block type 1](./Compression/gzip_block_type_1.pl)
    * [Gzip block type 1 huffman only](./Compression/gzip_block_type_1_huffman_only.pl)
    * [Gzip block type 2](./Compression/gzip_block_type_2.pl)
    * [Gzip block type 2 huffman only](./Compression/gzip_block_type_2_huffman_only.pl)
    * [Gzip block type 2 simple](./Compression/gzip_block_type_2_simple.pl)
    * [Gzip comment](./Compression/gzip_comment.pl)
    * [Gzip decompressor](./Compression/gzip_decompressor.pl)
    * [Gzip file compression](./Compression/gzip_file_compression.pl)
    * [Gzip store](./Compression/gzip_store.pl)
    * [Hfm file compression](./Compression/hfm_file_compression.pl)
    * High-level
        * [Ablz file compression](./Compression/High-level/ablz_file_compression.pl)
        * [Bbwr file compression](./Compression/High-level/bbwr_file_compression.pl)
        * [Blzss2 file compression](./Compression/High-level/blzss2_file_compression.pl)
        * [Blzss file compression](./Compression/High-level/blzss_file_compression.pl)
        * [Brlzss file compression](./Compression/High-level/brlzss_file_compression.pl)
        * [Bwac file compression](./Compression/High-level/bwac_file_compression.pl)
        * [Bwad file compression](./Compression/High-level/bwad_file_compression.pl)
        * [Bwlz2 file compression](./Compression/High-level/bwlz2_file_compression.pl)
        * [Bwlz3 file compression](./Compression/High-level/bwlz3_file_compression.pl)
        * [Bwlz file compression](./Compression/High-level/bwlz_file_compression.pl)
        * [Bwlza2 file compression](./Compression/High-level/bwlza2_file_compression.pl)
        * [Bwlza file compression](./Compression/High-level/bwlza_file_compression.pl)
        * [Bwlzad2 file compression](./Compression/High-level/bwlzad2_file_compression.pl)
        * [Bwlzad file compression](./Compression/High-level/bwlzad_file_compression.pl)
        * [Bwlzb file compression](./Compression/High-level/bwlzb_file_compression.pl)
        * [Bwlzhd2 file compression](./Compression/High-level/bwlzhd2_file_compression.pl)
        * [Bwlzhd file compression](./Compression/High-level/bwlzhd_file_compression.pl)
        * [Bwlzss file compression](./Compression/High-level/bwlzss_file_compression.pl)
        * [Bwrl2 file compression](./Compression/High-level/bwrl2_file_compression.pl)
        * [Bwrm2 file compression](./Compression/High-level/bwrm2_file_compression.pl)
        * [Bwrm file compression](./Compression/High-level/bwrm_file_compression.pl)
        * [Bwt2 file compression](./Compression/High-level/bwt2_file_compression.pl)
        * [Bwt file compression](./Compression/High-level/bwt_file_compression.pl)
        * [Bzip2 file compression](./Compression/High-level/bzip2_file_compression.pl)
        * [Gzip file compression](./Compression/High-level/gzip_file_compression.pl)
        * [Hblz file compression](./Compression/High-level/hblz_file_compression.pl)
        * [Lz255 file compression](./Compression/High-level/lz255_file_compression.pl)
        * [Lz2ss file compression](./Compression/High-level/lz2ss_file_compression.pl)
        * [Lz4 file compression](./Compression/High-level/lz4_file_compression.pl)
        * [Lz772 file compression](./Compression/High-level/lz772_file_compression.pl)
        * [Lz77 file compression](./Compression/High-level/lz77_file_compression.pl)
        * [Lz77f file compression](./Compression/High-level/lz77f_file_compression.pl)
        * [Lzac file compression](./Compression/High-level/lzac_file_compression.pl)
        * [Lzb file compression](./Compression/High-level/lzb_file_compression.pl)
        * [Lzbbw file compression](./Compression/High-level/lzbbw_file_compression.pl)
        * [Lzbf file compression](./Compression/High-level/lzbf_file_compression.pl)
        * [Lzbh file compression](./Compression/High-level/lzbh_file_compression.pl)
        * [Lzbw2 file compression](./Compression/High-level/lzbw2_file_compression.pl)
        * [Lzbw3 file compression](./Compression/High-level/lzbw3_file_compression.pl)
        * [Lzbw4 file compression](./Compression/High-level/lzbw4_file_compression.pl)
        * [Lzbw5 file compression](./Compression/High-level/lzbw5_file_compression.pl)
        * [Lzbw file compression](./Compression/High-level/lzbw_file_compression.pl)
        * [Lzbwa file compression](./Compression/High-level/lzbwa_file_compression.pl)
        * [Lzbwad file compression](./Compression/High-level/lzbwad_file_compression.pl)
        * [Lzbwd file compression](./Compression/High-level/lzbwd_file_compression.pl)
        * [Lzbwh file compression](./Compression/High-level/lzbwh_file_compression.pl)
        * [Lzbws file compression](./Compression/High-level/lzbws_file_compression.pl)
        * [Lzhd2 file compression](./Compression/High-level/lzhd2_file_compression.pl)
        * [Lzhd file compression](./Compression/High-level/lzhd_file_compression.pl)
        * [Lzih file compression](./Compression/High-level/lzih_file_compression.pl)
        * [Lzmrl2 file compression](./Compression/High-level/lzmrl2_file_compression.pl)
        * [Lzmrl file compression](./Compression/High-level/lzmrl_file_compression.pl)
        * [Lzop file compression](./Compression/High-level/lzop_file_compression.pl)
        * [Lzsbw file compression](./Compression/High-level/lzsbw_file_compression.pl)
        * [Lzss2 file compression](./Compression/High-level/lzss2_file_compression.pl)
        * [Lzss77 file compression](./Compression/High-level/lzss77_file_compression.pl)
        * [Lzss file compression](./Compression/High-level/lzss_file_compression.pl)
        * [Lzssf file compression](./Compression/High-level/lzssf_file_compression.pl)
        * [Lzssm file compression](./Compression/High-level/lzssm_file_compression.pl)
        * [Lzw file compression](./Compression/High-level/lzw_file_compression.pl)
        * [Mblz file compression](./Compression/High-level/mblz_file_compression.pl)
        * [Mbwr file compression](./Compression/High-level/mbwr_file_compression.pl)
        * [Mrl file compression](./Compression/High-level/mrl_file_compression.pl)
        * [Mybzip2 file compression](./Compression/High-level/mybzip2_file_compression.pl)
        * [Mygzip file compression](./Compression/High-level/mygzip_file_compression.pl)
        * [Mygzipf file compression](./Compression/High-level/mygzipf_file_compression.pl)
        * [Mylz4 file compression](./Compression/High-level/mylz4_file_compression.pl)
        * [Mylz4f file compression](./Compression/High-level/mylz4f_file_compression.pl)
        * [Myzlib file compression](./Compression/High-level/myzlib_file_compression.pl)
        * [Rablz file compression](./Compression/High-level/rablz_file_compression.pl)
        * [Rlzss file compression](./Compression/High-level/rlzss_file_compression.pl)
        * [Sbwt file compression](./Compression/High-level/sbwt_file_compression.pl)
        * [Xz file compression](./Compression/High-level/xz_file_compression.pl)
        * [Zlib file compression](./Compression/High-level/zlib_file_compression.pl)
        * [Zstd file compression](./Compression/High-level/zstd_file_compression.pl)
    * [Lz4 compressor](./Compression/lz4_compressor.pl)
    * [Lz4 decompressor](./Compression/lz4_decompressor.pl)
    * [Lz4 file compression](./Compression/lz4_file_compression.pl)
    * [Lz77 file compression](./Compression/lz77_file_compression.pl)
    * [Lza file compression](./Compression/lza_file_compression.pl)
    * [Lzac file compression](./Compression/lzac_file_compression.pl)
    * [Lzaz file compression](./Compression/lzaz_file_compression.pl)
    * [Lzb2 file compression](./Compression/lzb2_file_compression.pl)
    * [Lzb file compression](./Compression/lzb_file_compression.pl)
    * [Lzbf2 file compression](./Compression/lzbf2_file_compression.pl)
    * [Lzbf file compression](./Compression/lzbf_file_compression.pl)
    * [Lzbh file compression](./Compression/lzbh_file_compression.pl)
    * [Lzbw file compression](./Compression/lzbw_file_compression.pl)
    * [Lzbwa file compression](./Compression/lzbwa_file_compression.pl)
    * [Lzbwad file compression](./Compression/lzbwad_file_compression.pl)
    * [Lzbwd file compression](./Compression/lzbwd_file_compression.pl)
    * [Lzbwh file compression](./Compression/lzbwh_file_compression.pl)
    * [Lzh file compression](./Compression/lzh_file_compression.pl)
    * [Lzhc file compression](./Compression/lzhc_file_compression.pl)
    * [Lzhd file compression](./Compression/lzhd_file_compression.pl)
    * [Lzih file compression](./Compression/lzih_file_compression.pl)
    * [Lzsa file compression](./Compression/lzsa_file_compression.pl)
    * [Lzsad file compression](./Compression/lzsad_file_compression.pl)
    * [Lzsbw file compression](./Compression/lzsbw_file_compression.pl)
    * [Lzss2 file compression](./Compression/lzss2_file_compression.pl)
    * [Lzss file compression](./Compression/lzss_file_compression.pl)
    * [Lzssf file compression](./Compression/lzssf_file_compression.pl)
    * [Lzsst2 file compression](./Compression/lzsst2_file_compression.pl)
    * [Lzsst file compression](./Compression/lzsst_file_compression.pl)
    * [Lzt2 file compression](./Compression/lzt2_file_compression.pl)
    * [Lzt file compression](./Compression/lzt_file_compression.pl)
    * [Lzw file compression](./Compression/lzw_file_compression.pl)
    * [Mbwr file compression](./Compression/mbwr_file_compression.pl)
    * [Mra file compression](./Compression/mra_file_compression.pl)
    * [Mrh file compression](./Compression/mrh_file_compression.pl)
    * [Mrlz file compression](./Compression/mrlz_file_compression.pl)
    * [Ppmh file compression](./Compression/ppmh_file_compression.pl)
    * [Qof file compression](./Compression/qof_file_compression.pl)
    * [Rans file compression](./Compression/rans_file_compression.pl)
    * [Rlac file compression](./Compression/rlac_file_compression.pl)
    * [Rlh file compression](./Compression/rlh_file_compression.pl)
    * [Tac file compression](./Compression/tac_file_compression.pl)
    * [Tacc file compression](./Compression/tacc_file_compression.pl)
    * [Test compressors](./Compression/test_compressors.pl)
    * [Tzip2 file compression](./Compression/tzip2_file_compression.pl)
    * [Tzip file compression](./Compression/tzip_file_compression.pl)
    * [Unzip](./Compression/unzip.pl)
    * [Zip](./Compression/zip.pl)
    * [Zlib compressor](./Compression/zlib_compressor.pl)
    * [Zlib decompressor](./Compression/zlib_decompressor.pl)
    * [Zlib file compression](./Compression/zlib_file_compression.pl)
* Converters
    * [Another notes to markdown](./Converters/another_notes_to_markdown.pl)
    * [Another notes to material notes](./Converters/another_notes_to_material_notes.pl)
    * [Any to 3gp](./Converters/any_to_3gp.pl)
    * [Ass2srt](./Converters/ass2srt.pl)
    * [Code2pdf](./Converters/code2pdf.pl)
    * [Euler2pdf](./Converters/euler2pdf.pl)
    * [From hex](./Converters/from_hex.pl)
    * [Gdbm to berkeley](./Converters/gdbm_to_berkeley.pl)
    * [Gitbook2pdf](./Converters/gitbook2pdf.pl)
    * [Gz2xz](./Converters/gz2xz.pl)
    * [Html2pdf](./Converters/html2pdf.pl)
    * [Html2pdf chromium](./Converters/html2pdf_chromium.pl)
    * [Html2text](./Converters/html2text.pl)
    * [Json2csv](./Converters/json2csv.pl)
    * [Markdown2pdf](./Converters/markdown2pdf.pl)
    * [Markdown2pdf chromium](./Converters/markdown2pdf_chromium.pl)
    * [Markdown2text](./Converters/markdown2text.pl)
    * [Notepadfree to txt](./Converters/notepadfree_to_txt.pl)
    * [Pod2pdf](./Converters/pod2pdf.pl)
    * [Pod2text](./Converters/pod2text.pl)
    * [Recompress](./Converters/recompress.pl)
    * [Unicode2ascii](./Converters/unicode2ascii.pl)
    * [Vnt2txt simple](./Converters/vnt2txt_simple.pl)
    * [Xml2hash](./Converters/xml2hash.pl)
    * [Xpm c to perl](./Converters/xpm_c_to_perl.pl)
    * [Xz2gz](./Converters/xz2gz.pl)
    * [Zip2tar](./Converters/zip2tar.pl)
    * [Zip2tar fast](./Converters/zip2tar_fast.pl)
* Decoders
    * [Base64 decoding-tutorial](./Decoders/base64_decoding-tutorial.pl)
    * [Cnp info](./Decoders/cnp_info.pl)
    * [Named parameters](./Decoders/named_parameters.pl)
* Digest
    * [Brute-force resistant hashing](./Digest/brute-force_resistant_hashing.pl)
    * [Crc32](./Digest/crc32.pl)
* Encoding
    * [Adaptive huffman coding](./Encoding/adaptive_huffman_coding.pl)
    * [Arithmetic coding](./Encoding/arithmetic_coding.pl)
    * [Arithmetic coding adaptive contexts in fixed bits](./Encoding/arithmetic_coding_adaptive_contexts_in_fixed_bits.pl)
    * [Arithmetic coding adaptive in fixed bits](./Encoding/arithmetic_coding_adaptive_in_fixed_bits.pl)
    * [Arithmetic coding anynum](./Encoding/arithmetic_coding_anynum.pl)
    * [Arithmetic coding in fixed bits](./Encoding/arithmetic_coding_in_fixed_bits.pl)
    * [Arithmetic coding mpz](./Encoding/arithmetic_coding_mpz.pl)
    * [Ascii encode decode](./Encoding/ascii_encode_decode.pl)
    * [Binary arithmetic coding](./Encoding/binary_arithmetic_coding.pl)
    * [Binary arithmetic coding anynum](./Encoding/binary_arithmetic_coding_anynum.pl)
    * [Binary variable length run encoding](./Encoding/binary_variable_length_run_encoding.pl)
    * [Binradix arithmetic coding](./Encoding/binradix_arithmetic_coding.pl)
    * [Binradix arithmetic coding anynum](./Encoding/binradix_arithmetic_coding_anynum.pl)
    * [Burrows-wheeler file transform](./Encoding/burrows-wheeler_file_transform.pl)
    * [Burrows-wheeler transform](./Encoding/burrows-wheeler_transform.pl)
    * [Burrows-wheeler transform-n-char generalization](./Encoding/burrows-wheeler_transform-n-char_generalization.pl)
    * [Burrows-wheeler transform symbolic](./Encoding/burrows-wheeler_transform_symbolic.pl)
    * [Delta encoding with double-elias coding](./Encoding/delta_encoding_with_double-elias_coding.pl)
    * [Delta encoding with elias coding](./Encoding/delta_encoding_with_elias_coding.pl)
    * [Delta encoding with unary coding](./Encoding/delta_encoding_with_unary_coding.pl)
    * [Delta rle elias encoding](./Encoding/delta_rle_elias_encoding.pl)
    * [Double-elias gamma encoding](./Encoding/double-elias_gamma_encoding.pl)
    * [Elias gamma encoding](./Encoding/elias_gamma_encoding.pl)
    * [Eyes dropper](./Encoding/eyes_dropper.pl)
    * [Fibonacci coding](./Encoding/fibonacci_coding.pl)
    * [Huffman coding](./Encoding/huffman_coding.pl)
    * [Int2bytes](./Encoding/int2bytes.pl)
    * [Integers binary encoding](./Encoding/integers_binary_encoding.pl)
    * [Integers binary encoding with delta coding](./Encoding/integers_binary_encoding_with_delta_coding.pl)
    * [Integers binary encoding with huffman coding](./Encoding/integers_binary_encoding_with_huffman_coding.pl)
    * [Jpeg transform](./Encoding/jpeg_transform.pl)
    * [Length encoder](./Encoding/length_encoder.pl)
    * [Lz77 encoding](./Encoding/lz77_encoding.pl)
    * [Lz77 encoding symbolic](./Encoding/lz77_encoding_symbolic.pl)
    * [Lzss encoding](./Encoding/lzss_encoding.pl)
    * [Lzss encoding hash table](./Encoding/lzss_encoding_hash_table.pl)
    * [Lzss encoding hash table fast](./Encoding/lzss_encoding_hash_table_fast.pl)
    * [Lzss encoding symbolic](./Encoding/lzss_encoding_symbolic.pl)
    * [Lzt-fast](./Encoding/lzt-fast.pl)
    * [Lzw encoding](./Encoding/lzw_encoding.pl)
    * [Math expr encoder](./Encoding/math_expr_encoder.pl)
    * [Move-to-front transform](./Encoding/move-to-front_transform.pl)
    * [Mtf-delta encoding](./Encoding/mtf-delta_encoding.pl)
    * [Png transform](./Encoding/png_transform.pl)
    * [Ppm encoding](./Encoding/ppm_encoding.pl)
    * [Ppm encoding dynamic](./Encoding/ppm_encoding_dynamic.pl)
    * [RANS encoding](./Encoding/rANS_encoding.pl)
    * [RANS encoding mpz](./Encoding/rANS_encoding_mpz.pl)
    * [Run length with elias coding](./Encoding/run_length_with_elias_coding.pl)
    * [String to integer encoding based on primes](./Encoding/string_to_integer_encoding_based_on_primes.pl)
    * [Swap transform](./Encoding/swap_transform.pl)
    * [Tlen encoding](./Encoding/tlen_encoding.pl)
    * [Variable length run encoding](./Encoding/variable_length_run_encoding.pl)
* Encryption
    * [Age-lf](./Encryption/age-lf.pl)
    * [Backdoored rsa with x25519](./Encryption/backdoored_rsa_with_x25519.pl)
    * [Cbc+xor file encrypter](./Encryption/cbc+xor_file_encrypter.pl)
    * [Crypt rsa](./Encryption/crypt_rsa.pl)
    * [One-time pad](./Encryption/one-time_pad.pl)
    * [Plage](./Encryption/plage.pl)
    * [RSA encryption](./Encryption/RSA_encryption.pl)
    * [Simple XOR cipher](./Encryption/simple_XOR_cipher.pl)
* File Readers
    * [Ldump](./File%20Readers/ldump)
    * [Multi-file-line-reader](./File%20Readers/multi-file-line-reader.pl)
    * [N repeated lines](./File%20Readers/n_repeated_lines.pl)
    * [Tailz](./File%20Readers/tailz)
* File Workers
    * [Arxiv pdf renamer](./File%20Workers/arxiv_pdf_renamer.pl)
    * [Auto extensions](./File%20Workers/auto_extensions.pl)
    * [Collect gifs](./File%20Workers/collect_gifs.pl)
    * [Collect videos](./File%20Workers/collect_videos.pl)
    * [Delete if exists](./File%20Workers/delete_if_exists.pl)
    * [Dir file updater](./File%20Workers/dir_file_updater.pl)
    * [File-mover](./File%20Workers/file-mover.pl)
    * [File updater](./File%20Workers/file_updater.pl)
    * [Filename cmp del](./File%20Workers/filename_cmp_del.pl)
    * [Keep this formats](./File%20Workers/keep_this_formats.pl)
    * [Make filenames portable](./File%20Workers/make_filenames_portable.pl)
    * [Md5 rename](./File%20Workers/md5_rename.pl)
    * [Multiple backups](./File%20Workers/multiple_backups.pl)
    * [Remove eof newlines](./File%20Workers/remove_eof_newlines.pl)
    * [Split to n lines](./File%20Workers/split_to_n_lines.pl)
    * [Sub renamer](./File%20Workers/sub_renamer.pl)
    * [Timestamp rename](./File%20Workers/timestamp_rename.pl)
    * [Undir](./File%20Workers/undir.pl)
    * [Unidec renamer](./File%20Workers/unidec_renamer.pl)
* Finders
    * [Ampath](./Finders/ampath)
    * [Dup subtr finder](./Finders/dup_subtr_finder.pl)
    * [Fcheck](./Finders/fcheck.pl)
    * [Fdf](./Finders/fdf)
    * [Fdf-attr](./Finders/fdf-attr)
    * [Fdf-filename](./Finders/fdf-filename)
    * [File binsearch](./Finders/file_binsearch.pl)
    * [Find perl scripts](./Finders/find_perl_scripts.pl)
    * [Find similar filenames](./Finders/find_similar_filenames.pl)
    * [Find similar filenames unidec](./Finders/find_similar_filenames_unidec.pl)
    * [Fsf](./Finders/fsf.pl)
    * [Fsfn](./Finders/fsfn.pl)
    * [Human-like finder](./Finders/human-like_finder.pl)
    * [Large file search](./Finders/large_file_search.pl)
    * [Locatepm](./Finders/locatepm)
    * [Longest substring](./Finders/longest_substring.pl)
    * [Mimefind](./Finders/mimefind.pl)
    * [Model matching system](./Finders/model_matching_system.pl)
    * [Path diff](./Finders/path_diff.pl)
    * [Plocate](./Finders/plocate.pl)
    * [Similar files levenshtein](./Finders/similar_files_levenshtein.pl)
* Formatters
    * [Ascii table csv](./Formatters/ascii_table_csv.pl)
    * [File columner](./Formatters/file_columner.pl)
    * [Fstab beautifier](./Formatters/fstab_beautifier.pl)
    * [Js beautify](./Formatters/js_beautify)
    * [Reformat literal perl strings](./Formatters/reformat_literal_perl_strings.pl)
    * [Replace html links](./Formatters/replace_html_links.pl)
    * [Sort perl subroutines](./Formatters/sort_perl_subroutines.pl)
    * [Word columner](./Formatters/word_columner.pl)
* Game solvers
    * [Asciiplanes-player](./Game%20solvers/asciiplanes-player.pl)
    * [Asciiplanes-player-v2](./Game%20solvers/asciiplanes-player-v2.pl)
    * [Dice game solver](./Game%20solvers/dice_game_solver.pl)
    * [Peg-solitaire-solver](./Game%20solvers/peg-solitaire-solver)
    * [Reaction time test](./Game%20solvers/reaction_time_test.pl)
    * [Reflex sheep game](./Game%20solvers/reflex_sheep_game.pl)
    * [Sudoku dice game solver](./Game%20solvers/sudoku_dice_game_solver.pl)
    * [Sudoku generator](./Game%20solvers/sudoku_generator.pl)
    * [Sudoku solver](./Game%20solvers/sudoku_solver.pl)
    * [Sudoku solver backtracking](./Game%20solvers/sudoku_solver_backtracking.pl)
    * [Sudoku solver iterative](./Game%20solvers/sudoku_solver_iterative.pl)
    * [Sudoku solver stack](./Game%20solvers/sudoku_solver_stack.pl)
    * [Visual memory test](./Game%20solvers/visual_memory_test.pl)
* Games
    * [Arrow-key drawer](./Games/arrow-key_drawer.pl)
    * [Asciiplanes](./Games/asciiplanes)
    * [Snake game](./Games/snake_game.pl)
* GD
    * [Abstract map](./GD/abstract_map.pl)
    * [AND sierpinski triangle](./GD/AND_sierpinski_triangle.pl)
    * [Barnsley fern fractal](./GD/barnsley_fern_fractal.pl)
    * [Binary triangle](./GD/binary_triangle.pl)
    * [Black star turtle](./GD/black_star_turtle.pl)
    * [Black yellow number triangles](./GD/black_yellow_number_triangles.pl)
    * [Box pattern](./GD/box_pattern.pl)
    * [Chaos game pentagon](./GD/chaos_game_pentagon.pl)
    * [Chaos game tetrahedron](./GD/chaos_game_tetrahedron.pl)
    * [Chaos game triangle](./GD/chaos_game_triangle.pl)
    * [Circular prime triangle](./GD/circular_prime_triangle.pl)
    * [Circular triangle](./GD/circular_triangle.pl)
    * [Collatz triangle](./GD/collatz_triangle.pl)
    * [Color wheel](./GD/color_wheel.pl)
    * [Complex square](./GD/complex_square.pl)
    * [Congruence of squares triangle](./GD/congruence_of_squares_triangle.pl)
    * [Cuboid turtle](./GD/cuboid_turtle.pl)
    * [Cuboid turtle3](./GD/cuboid_turtle3.pl)
    * [Cuboid turtle 2](./GD/cuboid_turtle_2.pl)
    * [Dancing shapes](./GD/dancing_shapes.pl)
    * [Divisor circles](./GD/divisor_circles.pl)
    * [Divisor triangle](./GD/divisor_triangle.pl)
    * [Elementary cellular automaton generalized](./GD/elementary_cellular_automaton_generalized.pl)
    * [Fact exp primorial growing](./GD/fact_exp_primorial_growing.pl)
    * [Factor circles](./GD/factor_circles.pl)
    * [Factor triangle](./GD/factor_triangle.pl)
    * [Factorial turtles](./GD/factorial_turtles.pl)
    * [Factors of two triangle](./GD/factors_of_two_triangle.pl)
    * [Farey turnings plot](./GD/farey_turnings_plot.pl)
    * [Fgraph](./GD/fgraph.pl)
    * [Fgraph precision](./GD/fgraph_precision.pl)
    * [Fibonacci gd](./GD/fibonacci_gd.pl)
    * [Fibonacci spirals](./GD/fibonacci_spirals.pl)
    * [Generator turtle](./GD/generator_turtle.pl)
    * [Geometric shapes](./GD/geometric_shapes.pl)
    * [Goldbach conjecture possibilities](./GD/goldbach_conjecture_possibilities.pl)
    * [Horsie art](./GD/horsie_art.pl)
    * [Julia set](./GD/julia_set.pl)
    * [Julia set complex](./GD/julia_set_complex.pl)
    * [Julia set random](./GD/julia_set_random.pl)
    * [Julia set rperl](./GD/julia_set_rperl.pl)
    * [Koch snowflakes](./GD/koch_snowflakes.pl)
    * [Langton's ant gd](./GD/langton_s_ant_gd.pl)
    * [Line pattern triangles](./GD/line_pattern_triangles.pl)
    * LSystem
        * [Honeycomb](./GD/LSystem/honeycomb.pl)
        * [Honeycomb 2](./GD/LSystem/honeycomb_2.pl)
        * [LSystem.pm](./GD/LSystem/LSystem.pm)
        * [Plant](./GD/LSystem/plant.pl)
        * [Plant 2](./GD/LSystem/plant_2.pl)
        * [Plant 3](./GD/LSystem/plant_3.pl)
        * [Sierpinski triangle](./GD/LSystem/sierpinski_triangle.pl)
        * [Tree](./GD/LSystem/tree.pl)
        * [Turtle.pm](./GD/LSystem/Turtle.pm)
    * [Magic triangle](./GD/magic_triangle.pl)
    * [Mandelbrot like set](./GD/mandelbrot_like_set.pl)
    * [Mandelbrot like set gcomplex](./GD/mandelbrot_like_set_gcomplex.pl)
    * [Mathematical butt](./GD/mathematical_butt.pl)
    * [Mathematical shapes](./GD/mathematical_shapes.pl)
    * [Mirror shells](./GD/mirror_shells.pl)
    * [Moebius walking line](./GD/moebius_walking_line.pl)
    * [Number triangles](./GD/number_triangles.pl)
    * [Numeric circles](./GD/numeric_circles.pl)
    * [Pascal-fibonacci triangle](./GD/pascal-fibonacci_triangle.pl)
    * [Pascal powers of two triangle](./GD/pascal_powers_of_two_triangle.pl)
    * [Pascal's triangle multiples](./GD/pascal_s_triangle_multiples.pl)
    * [Pascal special triangle](./GD/pascal_special_triangle.pl)
    * [Pattern triangle](./GD/pattern_triangle.pl)
    * [Peacock triangles](./GD/peacock_triangles.pl)
    * [Pi abstract art](./GD/pi_abstract_art.pl)
    * [Pi turtle](./GD/pi_turtle.pl)
    * [Prime consecutive sums](./GD/prime_consecutive_sums.pl)
    * [Prime gaps](./GD/prime_gaps.pl)
    * [Prime rectangles](./GD/prime_rectangles.pl)
    * [Prime stripe triangle](./GD/prime_stripe_triangle.pl)
    * [Prime triangle 90deg](./GD/prime_triangle_90deg.pl)
    * [Pythagoras tree](./GD/pythagoras_tree.pl)
    * [Random abstract art](./GD/random_abstract_art.pl)
    * [Random abstract art 2](./GD/random_abstract_art_2.pl)
    * [Random langton's ant](./GD/random_langton_s_ant.pl)
    * [Random looking pattern triangle](./GD/random_looking_pattern_triangle.pl)
    * [Random machinery art](./GD/random_machinery_art.pl)
    * [Random noise triangle](./GD/random_noise_triangle.pl)
    * [Random turtles](./GD/random_turtles.pl)
    * [Real shell](./GD/real_shell.pl)
    * [Recursive squares](./GD/recursive_squares.pl)
    * [Regular poligons](./GD/regular_poligons.pl)
    * [Reversed prime triangles](./GD/reversed_prime_triangles.pl)
    * [Right triangle primes](./GD/right_triangle_primes.pl)
    * [Sandpiles](./GD/sandpiles.pl)
    * [Sierpinski fibonacci triangle](./GD/sierpinski_fibonacci_triangle.pl)
    * [Sierpinski triangle](./GD/sierpinski_triangle.pl)
    * [Spinning shapes](./GD/spinning_shapes.pl)
    * [Spiral matrix primes](./GD/spiral_matrix_primes.pl)
    * [Spiral tree](./GD/spiral_tree.pl)
    * [Square of circles](./GD/square_of_circles.pl)
    * [Star turtle](./GD/star_turtle.pl)
    * [Stern brocot shapes](./GD/stern_brocot_shapes.pl)
    * [Triangle factors](./GD/triangle_factors.pl)
    * [Triangle primes](./GD/triangle_primes.pl)
    * [Triangle primes 2](./GD/triangle_primes_2.pl)
    * [Triangle primes irregular](./GD/triangle_primes_irregular.pl)
    * [Trizen fan turtle](./GD/trizen_fan_turtle.pl)
    * [Trizen flat logo](./GD/trizen_flat_logo.pl)
    * [Trizen new logo](./GD/trizen_new_logo.pl)
    * [Trizen old logo](./GD/trizen_old_logo.pl)
    * [Trizen text art](./GD/trizen_text_art.pl)
    * [Tupper's self-referential formula](./GD/tupper_s_self-referential_formula.pl)
    * [Wavy triangle](./GD/wavy_triangle.pl)
    * [XOR pattern](./GD/XOR_pattern.pl)
    * [Zeta real half terms](./GD/zeta_real_half_terms.pl)
    * [Zig-zag primes](./GD/zig-zag_primes.pl)
* Generators
    * [Bernoulli numbers formulas](./Generators/bernoulli_numbers_formulas.pl)
    * [Faulhaber's formula symbolic](./Generators/faulhaber_s_formula_symbolic.pl)
    * [Faulhaber's formulas expanded](./Generators/faulhaber_s_formulas_expanded.pl)
    * [Faulhaber's formulas expanded 2](./Generators/faulhaber_s_formulas_expanded_2.pl)
    * [Faulhaber's formulas generator](./Generators/faulhaber_s_formulas_generator.pl)
    * [Parsing and code gen](./Generators/parsing_and_code_gen.pl)
    * [Powers of factorial](./Generators/powers_of_factorial.pl)
    * [Random lsystem generator](./Generators/random_lsystem_generator.pl)
    * [Semiprime equationization C generator](./Generators/semiprime_equationization_C_generator.pl)
    * [Semiprime equationization Perl generator](./Generators/semiprime_equationization_Perl_generator.pl)
    * [Zeta 2n generator](./Generators/zeta_2n_generator.pl)
* Greppers
    * [Marif](./Greppers/marif)
    * [Mime types](./Greppers/mime_types.pl)
    * [Mp3grep](./Greppers/mp3grep.pl)
    * [Scgrep](./Greppers/scgrep)
    * [Unigrep](./Greppers/unigrep.pl)
* GTK+
    * [Mouse position](./GTK+/mouse_position.pl)
    * [Tray-file-browser](./GTK+/tray-file-browser.pl)
* HAL
    * HAL3736
        * [HAL3736.memory](./HAL/HAL3736/HAL3736.memory)
        * [HAL3736](./HAL/HAL3736/HAL3736.pl)
    * HAL8212
        * [HAL8212.memory](./HAL/HAL8212/HAL8212.memory)
        * [HAL8212](./HAL/HAL8212/HAL8212.pl)
    * HAL9000
        * [HAL9000.memory](./HAL/HAL9000/HAL9000.memory)
        * [HAL9000](./HAL/HAL9000/HAL9000.pl)
* Image
    * [2x zoom](./Image/2x_zoom.pl)
    * [Add exif info](./Image/add_exif_info.pl)
    * [Bitmap monochrome encoding decoding](./Image/bitmap_monochrome_encoding_decoding.pl)
    * [Bwt horizontal transform](./Image/bwt_horizontal_transform.pl)
    * [Bwt rgb horizontal transform](./Image/bwt_rgb_horizontal_transform.pl)
    * [Bwt rgb vertical transform](./Image/bwt_rgb_vertical_transform.pl)
    * [Bwt vertical transform](./Image/bwt_vertical_transform.pl)
    * [Collage](./Image/collage.pl)
    * [Complex transform](./Image/complex_transform.pl)
    * [Cyan vision](./Image/cyan_vision.pl)
    * [Darken image](./Image/darken_image.pl)
    * [Diff negative](./Image/diff_negative.pl)
    * [Edge detector](./Image/edge_detector.pl)
    * [Extract jpegs](./Image/extract_jpegs.pl)
    * [Fractal frame](./Image/fractal_frame.pl)
    * [Fractal frame transparent](./Image/fractal_frame_transparent.pl)
    * [Gd png2jpg](./Image/gd_png2jpg.pl)
    * [Gd similar images](./Image/gd_similar_images.pl)
    * [Gd star trails](./Image/gd_star_trails.pl)
    * [Gif2webp](./Image/gif2webp.pl)
    * [Horizontal scrambler](./Image/horizontal_scrambler.pl)
    * [Image-hard-rotate](./Image/image-hard-rotate.pl)
    * [Image-unpack](./Image/image-unpack.pl)
    * [Image2ascii](./Image/image2ascii.pl)
    * [Image2audio](./Image/image2audio.pl)
    * [Image2digits](./Image/image2digits.pl)
    * [Image2html](./Image/image2html.pl)
    * [Image2matrix](./Image/image2matrix.pl)
    * [Image2mozaic](./Image/image2mozaic.pl)
    * [Image2png](./Image/image2png.pl)
    * [Image2prime](./Image/image2prime.pl)
    * [Image metadata clone](./Image/image_metadata_clone.pl)
    * [Imager similar images](./Image/imager_similar_images.pl)
    * [Img-autocrop](./Image/img-autocrop.pl)
    * [Img-autocrop-avg](./Image/img-autocrop-avg.pl)
    * [Img-autocrop-whitebg](./Image/img-autocrop-whitebg.pl)
    * [Img composition](./Image/img_composition.pl)
    * [Img rewrite](./Image/img_rewrite.pl)
    * [Julia transform](./Image/julia_transform.pl)
    * [Lookalike images](./Image/lookalike_images.pl)
    * [Magick png2jpg](./Image/magick_png2jpg.pl)
    * [Magick similar images](./Image/magick_similar_images.pl)
    * [Magick star trails](./Image/magick_star_trails.pl)
    * [Matrix visual](./Image/matrix_visual.pl)
    * [Mirror images](./Image/mirror_images.pl)
    * [Mtf horizontal transform](./Image/mtf_horizontal_transform.pl)
    * [Mtf vertical transform](./Image/mtf_vertical_transform.pl)
    * [Nearest neighbor interpolation](./Image/nearest_neighbor_interpolation.pl)
    * [Optimize images](./Image/optimize_images.pl)
    * [Optimize images littleutils](./Image/optimize_images_littleutils.pl)
    * [Outguess-png](./Image/outguess-png.pl)
    * [Outguess-png-imager](./Image/outguess-png-imager.pl)
    * [Photo mosaic from images](./Image/photo_mosaic_from_images.pl)
    * [Qhi decoder](./Image/qhi_decoder.pl)
    * [Qhi encoder](./Image/qhi_encoder.pl)
    * [Qoi decoder](./Image/qoi_decoder.pl)
    * [Qoi encoder](./Image/qoi_encoder.pl)
    * [Qzst decoder](./Image/qzst_decoder.pl)
    * [Qzst encoder](./Image/qzst_encoder.pl)
    * [Recompress images](./Image/recompress_images.pl)
    * [Remove sensitive exif tags](./Image/remove_sensitive_exif_tags.pl)
    * [Resize images](./Image/resize_images.pl)
    * [Rgb dump](./Image/rgb_dump.pl)
    * [Sharp 2x zoom](./Image/sharp_2x_zoom.pl)
    * [Slideshow](./Image/slideshow.pl)
    * [Vertical scrambler](./Image/vertical_scrambler.pl)
    * [Visualize binary](./Image/visualize_binary.pl)
    * [Webp2png](./Image/webp2png.pl)
    * [Zuper image decoder](./Image/zuper_image_decoder.pl)
    * [Zuper image encoder](./Image/zuper_image_encoder.pl)
* JAPH
    * [Alien japh](./JAPH/alien_japh.pl)
    * [Alpha ascii japh](./JAPH/alpha_ascii_japh.pl)
    * [Alpha japh](./JAPH/alpha_japh.pl)
    * [Alpha japh 2](./JAPH/alpha_japh_2.pl)
    * [Alpha japh 3](./JAPH/alpha_japh_3.pl)
    * [Arrow japh](./JAPH/arrow_japh.pl)
    * [Barewords japh](./JAPH/barewords_japh.pl)
    * [Cubic japh](./JAPH/cubic_japh.pl)
    * [Invisible japh](./JAPH/invisible_japh.pl)
    * [Japh from ambiguity](./JAPH/japh_from_ambiguity.pl)
    * [Japh from auto-quoted keywords](./JAPH/japh_from_auto-quoted_keywords.pl)
    * [Japh from escapes](./JAPH/japh_from_escapes.pl)
    * [Japh from escapes 2](./JAPH/japh_from_escapes_2.pl)
    * [Japh from eval subst](./JAPH/japh_from_eval_subst.pl)
    * [Japh from keywords](./JAPH/japh_from_keywords.pl)
    * [Japh from pod](./JAPH/japh_from_pod.pl)
    * [Japh from poetry](./JAPH/japh_from_poetry.pl)
    * [Japh from punctuation chars](./JAPH/japh_from_punctuation_chars.pl)
    * [Japh from subs](./JAPH/japh_from_subs.pl)
    * [Japh from the deep](./JAPH/japh_from_the_deep.pl)
    * [Japh variable](./JAPH/japh_variable.pl)
    * [Japh variables](./JAPH/japh_variables.pl)
    * [Japh variables 2](./JAPH/japh_variables_2.pl)
    * [Leet japh](./JAPH/leet_japh.pl)
    * [Length obfuscation](./JAPH/length_obfuscation.pl)
    * [Log japh](./JAPH/log_japh.pl)
    * [Log japh 2](./JAPH/log_japh_2.pl)
    * [Non-alphanumeric japh](./JAPH/non-alphanumeric_japh.pl)
    * [Re eval japh](./JAPH/re_eval_japh.pl)
    * [Slash r japh](./JAPH/slash_r_japh.pl)
    * [Ternary japh](./JAPH/ternary_japh.pl)
    * [Up and down](./JAPH/up_and_down.pl)
    * [Vec japh](./JAPH/vec_japh.pl)
    * [Vec japh 2](./JAPH/vec_japh_2.pl)
* Lingua
    * [En phoneme](./Lingua/en_phoneme.pl)
    * [Lingua ro numbers](./Lingua/lingua_ro_numbers.pl)
    * [Poetry from poetry](./Lingua/poetry_from_poetry.pl)
    * [Poetry from poetry with variations](./Lingua/poetry_from_poetry_with_variations.pl)
    * [Random poetry generator](./Lingua/random_poetry_generator.pl)
    * [Rus translit](./Lingua/rus_translit.pl)
* Math
    * [1 over n is finite](./Math/1_over_n_is_finite.pl)
    * [1 over n period length](./Math/1_over_n_period_length.pl)
    * [Additive binomial](./Math/additive_binomial.pl)
    * [Additive partitions](./Math/additive_partitions.pl)
    * [Alexandrian integers](./Math/alexandrian_integers.pl)
    * [Almost prime divisors](./Math/almost_prime_divisors.pl)
    * [Almost prime divisors recursive](./Math/almost_prime_divisors_recursive.pl)
    * [Almost prime numbers](./Math/almost_prime_numbers.pl)
    * [Almost prime numbers in range](./Math/almost_prime_numbers_in_range.pl)
    * [Almost prime numbers in range mpz](./Math/almost_prime_numbers_in_range_mpz.pl)
    * [Almost prime numbers in range v2](./Math/almost_prime_numbers_in_range_v2.pl)
    * [Almost primes from factor list](./Math/almost_primes_from_factor_list.pl)
    * [Almost primes in range from factor list](./Math/almost_primes_in_range_from_factor_list.pl)
    * [Area of triangle](./Math/area_of_triangle.pl)
    * [Arithmetic derivative](./Math/arithmetic_derivative.pl)
    * [Arithmetic expressions](./Math/arithmetic_expressions.pl)
    * [Arithmetic geometric mean complex](./Math/arithmetic_geometric_mean_complex.pl)
    * [Arithmetic sum closed form](./Math/arithmetic_sum_closed_form.pl)
    * [Ascii cuboid](./Math/ascii_cuboid.pl)
    * [Ascii julia set](./Math/ascii_julia_set.pl)
    * [Ascii mandelbrot set](./Math/ascii_mandelbrot_set.pl)
    * [Batir factorial asymptotic formula mpfr](./Math/batir_factorial_asymptotic_formula_mpfr.pl)
    * [Bell numbers](./Math/bell_numbers.pl)
    * [Bell numbers mpz](./Math/bell_numbers_mpz.pl)
    * [Bernoulli denominators](./Math/bernoulli_denominators.pl)
    * [Bernoulli denominators records](./Math/bernoulli_denominators_records.pl)
    * [Bernoulli numbers](./Math/bernoulli_numbers.pl)
    * [Bernoulli numbers from factorials](./Math/bernoulli_numbers_from_factorials.pl)
    * [Bernoulli numbers from factorials mpq](./Math/bernoulli_numbers_from_factorials_mpq.pl)
    * [Bernoulli numbers from factorials mpz](./Math/bernoulli_numbers_from_factorials_mpz.pl)
    * [Bernoulli numbers from factorials visual](./Math/bernoulli_numbers_from_factorials_visual.pl)
    * [Bernoulli numbers from primes](./Math/bernoulli_numbers_from_primes.pl)
    * [Bernoulli numbers from primes gmpf](./Math/bernoulli_numbers_from_primes_gmpf.pl)
    * [Bernoulli numbers from primes mpfr](./Math/bernoulli_numbers_from_primes_mpfr.pl)
    * [Bernoulli numbers from primes ntheory](./Math/bernoulli_numbers_from_primes_ntheory.pl)
    * [Bernoulli numbers from tangent numbers](./Math/bernoulli_numbers_from_tangent_numbers.pl)
    * [Bernoulli numbers from zeta](./Math/bernoulli_numbers_from_zeta.pl)
    * [Bernoulli numbers ramanujan congruences](./Math/bernoulli_numbers_ramanujan_congruences.pl)
    * [Bernoulli numbers ramanujan congruences unreduced](./Math/bernoulli_numbers_ramanujan_congruences_unreduced.pl)
    * [Bernoulli numbers recursive](./Math/bernoulli_numbers_recursive.pl)
    * [Bernoulli numbers recursive 2](./Math/bernoulli_numbers_recursive_2.pl)
    * [Bernoulli numbers seidel](./Math/bernoulli_numbers_seidel.pl)
    * [Bi-unitary divisors](./Math/bi-unitary_divisors.pl)
    * [Binary gcd algorithm](./Math/binary_gcd_algorithm.pl)
    * [Binary gcd algorithm mpz](./Math/binary_gcd_algorithm_mpz.pl)
    * [Binary multiplier](./Math/binary_multiplier.pl)
    * [Binary prime encoder](./Math/binary_prime_encoder.pl)
    * [Binary prime encoder fast](./Math/binary_prime_encoder_fast.pl)
    * [Binary prime sieve mpz](./Math/binary_prime_sieve_mpz.pl)
    * [Binary splitting product](./Math/binary_splitting_product.pl)
    * [Binomial sum with imaginary term](./Math/binomial_sum_with_imaginary_term.pl)
    * [Binomial theorem](./Math/binomial_theorem.pl)
    * [Bitstring prime sieve mpz](./Math/bitstring_prime_sieve_mpz.pl)
    * [Bitstring prime sieve vec](./Math/bitstring_prime_sieve_vec.pl)
    * [Both truncatable primes in base](./Math/both_truncatable_primes_in_base.pl)
    * [BPSW primality test](./Math/BPSW_primality_test.pl)
    * [BPSW primality test mpz](./Math/BPSW_primality_test_mpz.pl)
    * [Brazilian primes constant](./Math/brazilian_primes_constant.pl)
    * [Brown numbers](./Math/brown_numbers.pl)
    * [Carmichael factorization method](./Math/carmichael_factorization_method.pl)
    * [Carmichael factorization method generalized](./Math/carmichael_factorization_method_generalized.pl)
    * [Carmichael numbers from multiple](./Math/carmichael_numbers_from_multiple.pl)
    * [Carmichael numbers from multiple mpz](./Math/carmichael_numbers_from_multiple_mpz.pl)
    * [Carmichael numbers from multiple recursive mpz](./Math/carmichael_numbers_from_multiple_recursive_mpz.pl)
    * [Carmichael numbers generation erdos method](./Math/carmichael_numbers_generation_erdos_method.pl)
    * [Carmichael numbers generation erdos method dynamic programming](./Math/carmichael_numbers_generation_erdos_method_dynamic_programming.pl)
    * [Carmichael numbers in range](./Math/carmichael_numbers_in_range.pl)
    * [Carmichael numbers in range from prime factors](./Math/carmichael_numbers_in_range_from_prime_factors.pl)
    * [Carmichael numbers in range mpz](./Math/carmichael_numbers_in_range_mpz.pl)
    * [Carmichael numbers random](./Math/carmichael_numbers_random.pl)
    * [Carmichael strong fermat pseudoprimes in range](./Math/carmichael_strong_fermat_pseudoprimes_in_range.pl)
    * [Carmichael strong fermat pseudoprimes in range mpz](./Math/carmichael_strong_fermat_pseudoprimes_in_range_mpz.pl)
    * [Cartesian product iter](./Math/cartesian_product_iter.pl)
    * [Cartesian product rec](./Math/cartesian_product_rec.pl)
    * [Cauchy numbers of first type](./Math/cauchy_numbers_of_first_type.pl)
    * [Chebyshev factorization method](./Math/chebyshev_factorization_method.pl)
    * [Chebyshev factorization method mpz](./Math/chebyshev_factorization_method_mpz.pl)
    * [Chernick-carmichael numbers](./Math/chernick-carmichael_numbers.pl)
    * [Chernick-carmichael numbers below limit](./Math/chernick-carmichael_numbers_below_limit.pl)
    * [Chernick-carmichael polynomials](./Math/chernick-carmichael_polynomials.pl)
    * [Chernick-carmichael with n factors sieve](./Math/chernick-carmichael_with_n_factors_sieve.pl)
    * [Chinese factorization method](./Math/chinese_factorization_method.pl)
    * [Coin change](./Math/coin_change.pl)
    * [Collatz function](./Math/collatz_function.pl)
    * [Complex exponentiation in real numbers](./Math/complex_exponentiation_in_real_numbers.pl)
    * [Complex logarithm in real numbers](./Math/complex_logarithm_in_real_numbers.pl)
    * [Complex modular multiplicative inverse](./Math/complex_modular_multiplicative_inverse.pl)
    * [Complex zeta in real numbers](./Math/complex_zeta_in_real_numbers.pl)
    * [Congruence of powers factorization method](./Math/congruence_of_powers_factorization_method.pl)
    * [Consecutive partitions](./Math/consecutive_partitions.pl)
    * [Continued fraction expansion of sqrt of n](./Math/continued_fraction_expansion_of_sqrt_of_n.pl)
    * [Continued fraction expansion of sqrt of n mpz](./Math/continued_fraction_expansion_of_sqrt_of_n_mpz.pl)
    * [Continued fraction factorization method](./Math/continued_fraction_factorization_method.pl)
    * [Continued fractions](./Math/continued_fractions.pl)
    * [Continued fractions for e](./Math/continued_fractions_for_e.pl)
    * [Continued fractions for nth roots](./Math/continued_fractions_for_nth_roots.pl)
    * [Continued fractions for pi](./Math/continued_fractions_for_pi.pl)
    * [Continued fractions for square roots](./Math/continued_fractions_for_square_roots.pl)
    * [Continued fractions prime constant](./Math/continued_fractions_prime_constant.pl)
    * [Convergent series](./Math/convergent_series.pl)
    * [Cosmic calendar](./Math/cosmic_calendar.pl)
    * [Count of brilliant numbers](./Math/count_of_brilliant_numbers.pl)
    * [Count of cube-full numbers](./Math/count_of_cube-full_numbers.pl)
    * [Count of integers with gpf of n equals p](./Math/count_of_integers_with_gpf_of_n_equals_p.pl)
    * [Count of integers with lpf of n equals p](./Math/count_of_integers_with_lpf_of_n_equals_p.pl)
    * [Count of inverse tau in range](./Math/count_of_inverse_tau_in_range.pl)
    * [Count of k-almost primes](./Math/count_of_k-almost_primes.pl)
    * [Count of k-omega primes](./Math/count_of_k-omega_primes.pl)
    * [Count of k-powerfree numbers](./Math/count_of_k-powerfree_numbers.pl)
    * [Count of k-powerful numbers](./Math/count_of_k-powerful_numbers.pl)
    * [Count of k-powerful numbers in range](./Math/count_of_k-powerful_numbers_in_range.pl)
    * [Count of perfect powers](./Math/count_of_perfect_powers.pl)
    * [Count of prime power](./Math/count_of_prime_power.pl)
    * [Count of prime signature numbers](./Math/count_of_prime_signature_numbers.pl)
    * [Count of rough numbers](./Math/count_of_rough_numbers.pl)
    * [Count of rough numbers recursive](./Math/count_of_rough_numbers_recursive.pl)
    * [Count of smooth numbers](./Math/count_of_smooth_numbers.pl)
    * [Count of smooth numbers memoized](./Math/count_of_smooth_numbers_memoized.pl)
    * [Count of smooth numbers mpz](./Math/count_of_smooth_numbers_mpz.pl)
    * [Count of smooth numbers mpz 2](./Math/count_of_smooth_numbers_mpz_2.pl)
    * [Count of smooth numbers with k factors](./Math/count_of_smooth_numbers_with_k_factors.pl)
    * [Count of squarefree k-almost primes](./Math/count_of_squarefree_k-almost_primes.pl)
    * [Count of squarefree numbers](./Math/count_of_squarefree_numbers.pl)
    * [Count subtriangles](./Math/count_subtriangles.pl)
    * [Cube-full numbers](./Math/cube-full_numbers.pl)
    * [Cuboid](./Math/cuboid.pl)
    * [Cyclotomic factorization method](./Math/cyclotomic_factorization_method.pl)
    * [Cyclotomic factorization method 2](./Math/cyclotomic_factorization_method_2.pl)
    * [Cyclotomic polynomial](./Math/cyclotomic_polynomial.pl)
    * [Definite integral numerical approximation](./Math/definite_integral_numerical_approximation.pl)
    * [Dickson linear forms prime sieve](./Math/dickson_linear_forms_prime_sieve.pl)
    * [Dickson linear forms prime sieve in range](./Math/dickson_linear_forms_prime_sieve_in_range.pl)
    * [Dickson linear forms prime sieve in range 2](./Math/dickson_linear_forms_prime_sieve_in_range_2.pl)
    * [Difference of k powers](./Math/difference_of_k_powers.pl)
    * [Difference of powers factorization method](./Math/difference_of_powers_factorization_method.pl)
    * [Difference of three squares solutions](./Math/difference_of_three_squares_solutions.pl)
    * [Difference of two squares solutions](./Math/difference_of_two_squares_solutions.pl)
    * [Digits to number subquadratic algorithm](./Math/digits_to_number_subquadratic_algorithm.pl)
    * [Digits to number subquadratic algorithm mpz](./Math/digits_to_number_subquadratic_algorithm_mpz.pl)
    * [Dirichlet hyperbola method](./Math/dirichlet_hyperbola_method.pl)
    * [Discrete logarithm pollard rho](./Math/discrete_logarithm_pollard_rho.pl)
    * [Discrete logarithm pollard rho mpz](./Math/discrete_logarithm_pollard_rho_mpz.pl)
    * [Discrete root](./Math/discrete_root.pl)
    * [Divisors descending lazy](./Math/divisors_descending_lazy.pl)
    * [Divisors lazy](./Math/divisors_lazy.pl)
    * [Divisors lazy fast](./Math/divisors_lazy_fast.pl)
    * [Divisors less than k](./Math/divisors_less_than_k.pl)
    * [Divisors of factorial below limit](./Math/divisors_of_factorial_below_limit.pl)
    * [Divisors of factorial in range iterator](./Math/divisors_of_factorial_in_range_iterator.pl)
    * [Dixon factorization method](./Math/dixon_factorization_method.pl)
    * [E from binomial](./Math/e_from_binomial.pl)
    * [E primorial](./Math/e_primorial.pl)
    * [Ecm factorization method](./Math/ecm_factorization_method.pl)
    * [Elementary cellular automaton generalized](./Math/elementary_cellular_automaton_generalized.pl)
    * [Elliptic-curve factorization method](./Math/elliptic-curve_factorization_method.pl)
    * [Elliptic-curve factorization method with B2 stage](./Math/elliptic-curve_factorization_method_with_B2_stage.pl)
    * [Elliptic-curve factorization method with B2 stage mpz](./Math/elliptic-curve_factorization_method_with_B2_stage_mpz.pl)
    * [Equally spaced squares solutions](./Math/equally_spaced_squares_solutions.pl)
    * [Esthetic numbers](./Math/esthetic_numbers.pl)
    * [Ethiopian multiplication](./Math/ethiopian_multiplication.pl)
    * [Ethiopian multiplication binary](./Math/ethiopian_multiplication_binary.pl)
    * [Even fermat pseudoprimes in range](./Math/even_fermat_pseudoprimes_in_range.pl)
    * [Even squarefree fermat pseudoprimes in range](./Math/even_squarefree_fermat_pseudoprimes_in_range.pl)
    * [Exponential divisors](./Math/exponential_divisors.pl)
    * [Factorial difference of prime squares](./Math/factorial_difference_of_prime_squares.pl)
    * [Factorial dsc algorithm](./Math/factorial_dsc_algorithm.pl)
    * [Factorial expansion of reciprocals](./Math/factorial_expansion_of_reciprocals.pl)
    * [Factorial from primes](./Math/factorial_from_primes.pl)
    * [Factorial from primes simple](./Math/factorial_from_primes_simple.pl)
    * [Factorial from primorials](./Math/factorial_from_primorials.pl)
    * [Factorial from trinomial coefficients](./Math/factorial_from_trinomial_coefficients.pl)
    * [Factorial in half steps](./Math/factorial_in_half_steps.pl)
    * [Factorions in base n](./Math/factorions_in_base_n.pl)
    * [Factorization with difference of prime factors](./Math/factorization_with_difference_of_prime_factors.pl)
    * [Farey rational approximation](./Math/farey_rational_approximation.pl)
    * [Faulhaber's formula](./Math/faulhaber_s_formula.pl)
    * [Fermat factorization method](./Math/fermat_factorization_method.pl)
    * [Fermat factorization method 2](./Math/fermat_factorization_method_2.pl)
    * [Fermat frobenius quadratic primality test](./Math/fermat_frobenius_quadratic_primality_test.pl)
    * [Fermat overpseudoprimes generation](./Math/fermat_overpseudoprimes_generation.pl)
    * [Fermat overpseudoprimes in range](./Math/fermat_overpseudoprimes_in_range.pl)
    * [Fermat pseudoprimes from multiple](./Math/fermat_pseudoprimes_from_multiple.pl)
    * [Fermat pseudoprimes from multiple mpz](./Math/fermat_pseudoprimes_from_multiple_mpz.pl)
    * [Fermat pseudoprimes generation](./Math/fermat_pseudoprimes_generation.pl)
    * [Fermat pseudoprimes generation 2](./Math/fermat_pseudoprimes_generation_2.pl)
    * [Fermat pseudoprimes generation 3](./Math/fermat_pseudoprimes_generation_3.pl)
    * [Fermat pseudoprimes in range](./Math/fermat_pseudoprimes_in_range.pl)
    * [Fermat pseudoprimes in range mpz](./Math/fermat_pseudoprimes_in_range_mpz.pl)
    * [Fermat superpseudoprimes generation](./Math/fermat_superpseudoprimes_generation.pl)
    * [Fibonacci closed form](./Math/fibonacci_closed_form.pl)
    * [Fibonacci closed form 2](./Math/fibonacci_closed_form_2.pl)
    * [Fibonacci encoding](./Math/fibonacci_encoding.pl)
    * [Fibonacci factorization method](./Math/fibonacci_factorization_method.pl)
    * [Fibonacci k-th order](./Math/fibonacci_k-th_order.pl)
    * [Fibonacci k-th order efficient algorithm](./Math/fibonacci_k-th_order_efficient_algorithm.pl)
    * [Fibonacci k-th order fast](./Math/fibonacci_k-th_order_fast.pl)
    * [Fibonacci k-th order odd primes indices](./Math/fibonacci_k-th_order_odd_primes_indices.pl)
    * [Fibonacci number fast](./Math/fibonacci_number_fast.pl)
    * [Fibonacci polynomials closed form](./Math/fibonacci_polynomials_closed_form.pl)
    * [Fibonacci pseudoprimes generation](./Math/fibonacci_pseudoprimes_generation.pl)
    * [Find least common denominator](./Math/find_least_common_denominator.pl)
    * [Floor and ceil functions fourier series](./Math/floor_and_ceil_functions_fourier_series.pl)
    * [Flt factorization method](./Math/flt_factorization_method.pl)
    * [Fraction approximation](./Math/fraction_approximation.pl)
    * [Fraction to decimal expansion](./Math/fraction_to_decimal_expansion.pl)
    * [Fractional pi](./Math/fractional_pi.pl)
    * [Frobenius pseudoprimes generation](./Math/frobenius_pseudoprimes_generation.pl)
    * [Fubini numbers](./Math/fubini_numbers.pl)
    * [Fubini numbers 2](./Math/fubini_numbers_2.pl)
    * [Fubini numbers recursive](./Math/fubini_numbers_recursive.pl)
    * [Function graph](./Math/function_graph.pl)
    * [Function inverse binary search](./Math/function_inverse_binary_search.pl)
    * [Gamma function](./Math/gamma_function.pl)
    * [Gaussian divisors](./Math/gaussian_divisors.pl)
    * [Gaussian factors](./Math/gaussian_factors.pl)
    * [Gaussian integers sum](./Math/gaussian_integers_sum.pl)
    * [General binary multiplier](./Math/general_binary_multiplier.pl)
    * [Goldbach conjecture 2n prime](./Math/goldbach_conjecture_2n_prime.pl)
    * [Goldbach conjecture increasing primes](./Math/goldbach_conjecture_increasing_primes.pl)
    * [Goldbach conjecture possibilities](./Math/goldbach_conjecture_possibilities.pl)
    * [Goldbach conjecture random primes](./Math/goldbach_conjecture_random_primes.pl)
    * [Golomb's sequence](./Math/golomb_s_sequence.pl)
    * [Greatest common unitary divisor](./Math/greatest_common_unitary_divisor.pl)
    * [Hamming numbers](./Math/hamming_numbers.pl)
    * [Harmonic numbers](./Math/harmonic_numbers.pl)
    * [Harmonic numbers from digamma](./Math/harmonic_numbers_from_digamma.pl)
    * [Harmonic numbers from powers](./Math/harmonic_numbers_from_powers.pl)
    * [Harmonic numbers from powers mpz](./Math/harmonic_numbers_from_powers_mpz.pl)
    * [Harmonic prime powers](./Math/harmonic_prime_powers.pl)
    * [Hybrid prime factorization](./Math/hybrid_prime_factorization.pl)
    * [Infinitary divisors](./Math/infinitary_divisors.pl)
    * [Inverse of bernoulli numbers](./Math/inverse_of_bernoulli_numbers.pl)
    * [Inverse of euler totient](./Math/inverse_of_euler_totient.pl)
    * [Inverse of factorial](./Math/inverse_of_factorial.pl)
    * [Inverse of factorial stirling](./Math/inverse_of_factorial_stirling.pl)
    * [Inverse of fibonacci](./Math/inverse_of_fibonacci.pl)
    * [Inverse of multiplicative functions](./Math/inverse_of_multiplicative_functions.pl)
    * [Inverse of p adic valuation](./Math/inverse_of_p_adic_valuation.pl)
    * [Inverse of sigma function](./Math/inverse_of_sigma_function.pl)
    * [Inverse of sigma function fast](./Math/inverse_of_sigma_function_fast.pl)
    * [Inverse of sigma function generalized](./Math/inverse_of_sigma_function_generalized.pl)
    * [Inverse of usigma function](./Math/inverse_of_usigma_function.pl)
    * [Inverse tau in range](./Math/inverse_tau_in_range.pl)
    * [Invert transform of factorials](./Math/invert_transform_of_factorials.pl)
    * [Is absolute euler pseudoprime](./Math/is_absolute_euler_pseudoprime.pl)
    * [Is almost prime](./Math/is_almost_prime.pl)
    * [Is bfsw pseudoprime](./Math/is_bfsw_pseudoprime.pl)
    * [Is chernick carmichael number](./Math/is_chernick_carmichael_number.pl)
    * [Is even perfect](./Math/is_even_perfect.pl)
    * [Is even perfect 2](./Math/is_even_perfect_2.pl)
    * [Is even perfect 3](./Math/is_even_perfect_3.pl)
    * [Is extra bfsw pseudoprime](./Math/is_extra_bfsw_pseudoprime.pl)
    * [Is omega prime](./Math/is_omega_prime.pl)
    * [Is perfect power](./Math/is_perfect_power.pl)
    * [Is smooth over product](./Math/is_smooth_over_product.pl)
    * [Is squarefree over product](./Math/is_squarefree_over_product.pl)
    * [Is sum of two cubes](./Math/is_sum_of_two_cubes.pl)
    * [Is sum of two squares](./Math/is_sum_of_two_squares.pl)
    * [Iterative difference of central divisors to reach zero](./Math/iterative_difference_of_central_divisors_to_reach_zero.pl)
    * [K-imperfect numbers](./Math/k-imperfect_numbers.pl)
    * [K-odd-powerful numbers](./Math/k-odd-powerful_numbers.pl)
    * [K-powerful numbers](./Math/k-powerful_numbers.pl)
    * [K-powerful numbers in range](./Math/k-powerful_numbers_in_range.pl)
    * [Karatsuba multiplication](./Math/karatsuba_multiplication.pl)
    * [Kempner binomial numbers](./Math/kempner_binomial_numbers.pl)
    * [Klein J invariant and modular lambda](./Math/klein_J_invariant_and_modular_lambda.pl)
    * [Lambert W function](./Math/lambert_W_function.pl)
    * [Lambert W function complex](./Math/lambert_W_function_complex.pl)
    * [Lanczos approximation](./Math/lanczos_approximation.pl)
    * [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)
    * [Least nonresidue](./Math/least_nonresidue.pl)
    * [Legendary question six](./Math/legendary_question_six.pl)
    * [Length of shortest addition chain](./Math/length_of_shortest_addition_chain.pl)
    * [Lerch zeta function](./Math/lerch_zeta_function.pl)
    * [Logarithmic integral asymptotic formula](./Math/logarithmic_integral_asymptotic_formula.pl)
    * [Logarithmic root](./Math/logarithmic_root.pl)
    * [Logarithmic root complex](./Math/logarithmic_root_complex.pl)
    * [Logarithmic root in two variables](./Math/logarithmic_root_in_two_variables.pl)
    * [Logarithmic root mpfr](./Math/logarithmic_root_mpfr.pl)
    * [Long division](./Math/long_division.pl)
    * [Long multiplication](./Math/long_multiplication.pl)
    * [Lucas-carmichael numbers from multiple](./Math/lucas-carmichael_numbers_from_multiple.pl)
    * [Lucas-carmichael numbers from multiple mpz](./Math/lucas-carmichael_numbers_from_multiple_mpz.pl)
    * [Lucas-carmichael numbers in range](./Math/lucas-carmichael_numbers_in_range.pl)
    * [Lucas-carmichael numbers in range from prime factors](./Math/lucas-carmichael_numbers_in_range_from_prime_factors.pl)
    * [Lucas-carmichael numbers in range mpz](./Math/lucas-carmichael_numbers_in_range_mpz.pl)
    * [Lucas-miller factorization method](./Math/lucas-miller_factorization_method.pl)
    * [Lucas-pocklington primality proving](./Math/lucas-pocklington_primality_proving.pl)
    * [Lucas-pratt primality proving](./Math/lucas-pratt_primality_proving.pl)
    * [Lucas-pratt prime records](./Math/lucas-pratt_prime_records.pl)
    * [Lucas factorization method](./Math/lucas_factorization_method.pl)
    * [Lucas factorization method generalized](./Math/lucas_factorization_method_generalized.pl)
    * [Lucas pseudoprimes generation](./Math/lucas_pseudoprimes_generation.pl)
    * [Lucas pseudoprimes generation erdos method](./Math/lucas_pseudoprimes_generation_erdos_method.pl)
    * [Lucas sequences U V](./Math/lucas_sequences_U_V.pl)
    * [Lucas sequences U V mpz](./Math/lucas_sequences_U_V_mpz.pl)
    * [Lucas theorem](./Math/lucas_theorem.pl)
    * [LUP decomposition](./Math/LUP_decomposition.pl)
    * [Magic 3-gon ring](./Math/magic_3-gon_ring.pl)
    * [Magic 5-gon ring](./Math/magic_5-gon_ring.pl)
    * [Map num](./Math/map_num.pl)
    * [Matrix determinant bareiss](./Math/matrix_determinant_bareiss.pl)
    * [Matrix path 2-ways best](./Math/matrix_path_2-ways_best.pl)
    * [Matrix path 2-ways greedy](./Math/matrix_path_2-ways_greedy.pl)
    * [Matrix path 3-ways best](./Math/matrix_path_3-ways_best.pl)
    * [Matrix path 3-ways diagonal best](./Math/matrix_path_3-ways_diagonal_best.pl)
    * [Matrix path 3-ways greedy](./Math/matrix_path_3-ways_greedy.pl)
    * [Matrix path 4-ways best](./Math/matrix_path_4-ways_best.pl)
    * [Matrix path 4-ways best 2](./Math/matrix_path_4-ways_best_2.pl)
    * [Matrix path 4-ways best 3](./Math/matrix_path_4-ways_best_3.pl)
    * [Matrix path 4-ways greedy](./Math/matrix_path_4-ways_greedy.pl)
    * [Maximum product of parts bisection](./Math/maximum_product_of_parts_bisection.pl)
    * [Maximum square remainder](./Math/maximum_square_remainder.pl)
    * [MBE factorization method](./Math/MBE_factorization_method.pl)
    * [Meissel lehmer prime count](./Math/meissel_lehmer_prime_count.pl)
    * [Mertens function](./Math/mertens_function.pl)
    * [Mertens function fast](./Math/mertens_function_fast.pl)
    * [Miller-rabin deterministic primality test](./Math/miller-rabin_deterministic_primality_test.pl)
    * [Miller-rabin deterministic primality test mpz](./Math/miller-rabin_deterministic_primality_test_mpz.pl)
    * [Miller-rabin factorization method](./Math/miller-rabin_factorization_method.pl)
    * [Modular bell numbers](./Math/modular_bell_numbers.pl)
    * [Modular bell numbers mpz](./Math/modular_bell_numbers_mpz.pl)
    * [Modular binomial](./Math/modular_binomial.pl)
    * [Modular binomial fast](./Math/modular_binomial_fast.pl)
    * [Modular binomial faster](./Math/modular_binomial_faster.pl)
    * [Modular binomial faster mpz](./Math/modular_binomial_faster_mpz.pl)
    * [Modular binomial faster mpz 2](./Math/modular_binomial_faster_mpz_2.pl)
    * [Modular binomial ntheory](./Math/modular_binomial_ntheory.pl)
    * [Modular binomial small k](./Math/modular_binomial_small_k.pl)
    * [Modular binomial small k faster](./Math/modular_binomial_small_k_faster.pl)
    * [Modular cyclotomic polynomial](./Math/modular_cyclotomic_polynomial.pl)
    * [Modular factorial](./Math/modular_factorial.pl)
    * [Modular factorial crt](./Math/modular_factorial_crt.pl)
    * [Modular factorial crt mpz](./Math/modular_factorial_crt_mpz.pl)
    * [Modular fibonacci](./Math/modular_fibonacci.pl)
    * [Modular fibonacci anynum](./Math/modular_fibonacci_anynum.pl)
    * [Modular fibonacci cassini](./Math/modular_fibonacci_cassini.pl)
    * [Modular fibonacci cassini fast](./Math/modular_fibonacci_cassini_fast.pl)
    * [Modular fibonacci fast mpz](./Math/modular_fibonacci_fast_mpz.pl)
    * [Modular fibonacci mpz](./Math/modular_fibonacci_mpz.pl)
    * [Modular fibonacci polynomial](./Math/modular_fibonacci_polynomial.pl)
    * [Modular fibonacci polynomial 2](./Math/modular_fibonacci_polynomial_2.pl)
    * [Modular hyperoperation](./Math/modular_hyperoperation.pl)
    * [Modular inverse](./Math/modular_inverse.pl)
    * [Modular k-th root all solutions](./Math/modular_k-th_root_all_solutions.pl)
    * [Modular k-th root all solutions fast](./Math/modular_k-th_root_all_solutions_fast.pl)
    * [Modular k-th root all solutions fast mpz](./Math/modular_k-th_root_all_solutions_fast_mpz.pl)
    * [Modular k-th root all solutions mpz](./Math/modular_k-th_root_all_solutions_mpz.pl)
    * [Modular lucas numbers](./Math/modular_lucas_numbers.pl)
    * [Modular lucas sequence V](./Math/modular_lucas_sequence_V.pl)
    * [Modular lucas sequences U V](./Math/modular_lucas_sequences_U_V.pl)
    * [Modular pseudo square root](./Math/modular_pseudo_square_root.pl)
    * [Modular pseudo square root 2](./Math/modular_pseudo_square_root_2.pl)
    * [Modular sigma of unitary divisors of factorial](./Math/modular_sigma_of_unitary_divisors_of_factorial.pl)
    * [Modular square root](./Math/modular_square_root.pl)
    * [Modular square root 2](./Math/modular_square_root_2.pl)
    * [Modular square root 3](./Math/modular_square_root_3.pl)
    * [Modular square root all solutions](./Math/modular_square_root_all_solutions.pl)
    * [Modular square root all solutions cipolla](./Math/modular_square_root_all_solutions_cipolla.pl)
    * [Multi sqrt nums](./Math/multi_sqrt_nums.pl)
    * [Multinomial coefficient](./Math/multinomial_coefficient.pl)
    * [Multinomial coefficient from binomial](./Math/multinomial_coefficient_from_binomial.pl)
    * [Multiplicative partitions](./Math/multiplicative_partitions.pl)
    * [Multisets](./Math/multisets.pl)
    * [Multivariate gamma function](./Math/multivariate_gamma_function.pl)
    * [Mysterious sum-pentagonal numbers](./Math/mysterious_sum-pentagonal_numbers.pl)
    * [Mysterious sum-pentagonal numbers 2](./Math/mysterious_sum-pentagonal_numbers_2.pl)
    * [N dimensional circles](./Math/n_dimensional_circles.pl)
    * [Near-power factorization method](./Math/near-power_factorization_method.pl)
    * [Newton's method](./Math/newton_s_method.pl)
    * [Newton's method recursive](./Math/newton_s_method_recursive.pl)
    * [Next palindrome](./Math/next_palindrome.pl)
    * [Next palindrome from non-palindrome](./Math/next_palindrome_from_non-palindrome.pl)
    * [Next palindrome in base](./Math/next_palindrome_in_base.pl)
    * [Next power of two](./Math/next_power_of_two.pl)
    * [Nth composite](./Math/nth_composite.pl)
    * [Nth digit of fraction](./Math/nth_digit_of_fraction.pl)
    * [Nth prime approx](./Math/nth_prime_approx.pl)
    * [Nth root good rational approximations](./Math/nth_root_good_rational_approximations.pl)
    * [Nth root recurrence constant](./Math/nth_root_recurrence_constant.pl)
    * [Nth smooth number](./Math/nth_smooth_number.pl)
    * [Number2expression](./Math/number2expression.pl)
    * [Number of conditional GCDs](./Math/number_of_conditional_GCDs.pl)
    * [Number of connected permutations](./Math/number_of_connected_permutations.pl)
    * [Number of partitions into 2 distinct positive cubes](./Math/number_of_partitions_into_2_distinct_positive_cubes.pl)
    * [Number of partitions into 2 distinct positive squares](./Math/number_of_partitions_into_2_distinct_positive_squares.pl)
    * [Number of partitions into 2 nonnegative cubes](./Math/number_of_partitions_into_2_nonnegative_cubes.pl)
    * [Number of partitions into 2 positive squares](./Math/number_of_partitions_into_2_positive_squares.pl)
    * [Number of representations as sum of 3 triangles](./Math/number_of_representations_as_sum_of_3_triangles.pl)
    * [Number of representations as sum of four squares](./Math/number_of_representations_as_sum_of_four_squares.pl)
    * [Number of representations as sum of two squares](./Math/number_of_representations_as_sum_of_two_squares.pl)
    * [Number to digits subquadratic algorithm](./Math/number_to_digits_subquadratic_algorithm.pl)
    * [Number to digits subquadratic algorithm mpz](./Math/number_to_digits_subquadratic_algorithm_mpz.pl)
    * [Numbers with pow 2 divisors](./Math/numbers_with_pow_2_divisors.pl)
    * [Omega prime divisors](./Math/omega_prime_divisors.pl)
    * [Omega prime numbers in range](./Math/omega_prime_numbers_in_range.pl)
    * [Omega prime numbers in range mpz](./Math/omega_prime_numbers_in_range_mpz.pl)
    * [Omega prime numbers in range simple](./Math/omega_prime_numbers_in_range_simple.pl)
    * [Order factorization method](./Math/order_factorization_method.pl)
    * [Palindrome iteration](./Math/palindrome_iteration.pl)
    * [Partial sums of dedekind psi function](./Math/partial_sums_of_dedekind_psi_function.pl)
    * [Partial sums of euler totient function](./Math/partial_sums_of_euler_totient_function.pl)
    * [Partial sums of euler totient function fast](./Math/partial_sums_of_euler_totient_function_fast.pl)
    * [Partial sums of euler totient function fast 2](./Math/partial_sums_of_euler_totient_function_fast_2.pl)
    * [Partial sums of euler totient function times k](./Math/partial_sums_of_euler_totient_function_times_k.pl)
    * [Partial sums of euler totient function times k to the m](./Math/partial_sums_of_euler_totient_function_times_k_to_the_m.pl)
    * [Partial sums of exponential prime omega functions](./Math/partial_sums_of_exponential_prime_omega_functions.pl)
    * [Partial sums of gcd-sum function](./Math/partial_sums_of_gcd-sum_function.pl)
    * [Partial sums of gcd-sum function fast](./Math/partial_sums_of_gcd-sum_function_fast.pl)
    * [Partial sums of gcd-sum function faster](./Math/partial_sums_of_gcd-sum_function_faster.pl)
    * [Partial sums of generalized gcd-sum function](./Math/partial_sums_of_generalized_gcd-sum_function.pl)
    * [Partial sums of gpf](./Math/partial_sums_of_gpf.pl)
    * [Partial sums of inverse moebius transform of dedekind function](./Math/partial_sums_of_inverse_moebius_transform_of_dedekind_function.pl)
    * [Partial sums of jordan totient function](./Math/partial_sums_of_jordan_totient_function.pl)
    * [Partial sums of jordan totient function fast](./Math/partial_sums_of_jordan_totient_function_fast.pl)
    * [Partial sums of jordan totient function times k to the m](./Math/partial_sums_of_jordan_totient_function_times_k_to_the_m.pl)
    * [Partial sums of lcm count function](./Math/partial_sums_of_lcm_count_function.pl)
    * [Partial sums of liouville function](./Math/partial_sums_of_liouville_function.pl)
    * [Partial sums of lpf](./Math/partial_sums_of_lpf.pl)
    * [Partial sums of n over k-almost prime divisors](./Math/partial_sums_of_n_over_k-almost_prime_divisors.pl)
    * [Partial sums of powerfree numbers](./Math/partial_sums_of_powerfree_numbers.pl)
    * [Partial sums of powerfree part](./Math/partial_sums_of_powerfree_part.pl)
    * [Partial sums of prime bigomega function](./Math/partial_sums_of_prime_bigomega_function.pl)
    * [Partial sums of prime omega function](./Math/partial_sums_of_prime_omega_function.pl)
    * [Partial sums of sigma0 function](./Math/partial_sums_of_sigma0_function.pl)
    * [Partial sums of sigma function](./Math/partial_sums_of_sigma_function.pl)
    * [Partial sums of sigma function times k](./Math/partial_sums_of_sigma_function_times_k.pl)
    * [Partial sums of sigma function times k to the m](./Math/partial_sums_of_sigma_function_times_k_to_the_m.pl)
    * [Partitions count](./Math/partitions_count.pl)
    * [Partitions count abs](./Math/partitions_count_abs.pl)
    * [Partitions count simple](./Math/partitions_count_simple.pl)
    * [Pascal-fibonacci triangle](./Math/pascal-fibonacci_triangle.pl)
    * [Pascal's triangle multiples](./Math/pascal_s_triangle_multiples.pl)
    * [Pattern mixing](./Math/pattern_mixing.pl)
    * [Pell cfrac factorization](./Math/pell_cfrac_factorization.pl)
    * [Pell factorization](./Math/pell_factorization.pl)
    * [Pell factorization anynum](./Math/pell_factorization_anynum.pl)
    * [Perfect numbers](./Math/perfect_numbers.pl)
    * [Period of continued fraction for square roots](./Math/period_of_continued_fraction_for_square_roots.pl)
    * [Period of continued fraction for square roots mpz](./Math/period_of_continued_fraction_for_square_roots_mpz.pl)
    * [Period of continued fraction for square roots ntheory](./Math/period_of_continued_fraction_for_square_roots_ntheory.pl)
    * [Phi-finder factorization method](./Math/phi-finder_factorization_method.pl)
    * [Pi from infinity](./Math/pi_from_infinity.pl)
    * [Pisano periods](./Math/pisano_periods.pl)
    * [Pisano periods efficient algorithm](./Math/pisano_periods_efficient_algorithm.pl)
    * [Pocklington-pratt primality proving](./Math/pocklington-pratt_primality_proving.pl)
    * [Pollard-strassen factorization method](./Math/pollard-strassen_factorization_method.pl)
    * [Pollard p-1 factorization](./Math/pollard_p-1_factorization.pl)
    * [Pollard rho exp factorization](./Math/pollard_rho_exp_factorization.pl)
    * [Pollard rho factorization](./Math/pollard_rho_factorization.pl)
    * [Polygonal numbers](./Math/polygonal_numbers.pl)
    * [Polygonal representations](./Math/polygonal_representations.pl)
    * [Polynomial interpolation](./Math/polynomial_interpolation.pl)
    * [Power divisors](./Math/power_divisors.pl)
    * [Power of factorial ramanujan](./Math/power_of_factorial_ramanujan.pl)
    * [Power unitary divisors](./Math/power_unitary_divisors.pl)
    * [Powerfree divisors](./Math/powerfree_divisors.pl)
    * [Powers of primes in factorial](./Math/powers_of_primes_in_factorial.pl)
    * [Powers of primes modulus in factorial](./Math/powers_of_primes_modulus_in_factorial.pl)
    * [Prime 41](./Math/prime_41.pl)
    * [Prime abundant sequences](./Math/prime_abundant_sequences.pl)
    * [Prime count smooth sum](./Math/prime_count_smooth_sum.pl)
    * [Prime counting from almost primes](./Math/prime_counting_from_almost_primes.pl)
    * [Prime counting from squarefree almost primes](./Math/prime_counting_from_squarefree_almost_primes.pl)
    * [Prime counting liouville formula](./Math/prime_counting_liouville_formula.pl)
    * [Prime counting mertens formula](./Math/prime_counting_mertens_formula.pl)
    * [Prime factorization concept](./Math/prime_factorization_concept.pl)
    * [Prime factors of binomial coefficients](./Math/prime_factors_of_binomial_coefficients.pl)
    * [Prime factors of binomial product](./Math/prime_factors_of_binomial_product.pl)
    * [Prime factors of factorial](./Math/prime_factors_of_factorial.pl)
    * [Prime factors of superfactorial and hyperfactorial](./Math/prime_factors_of_superfactorial_and_hyperfactorial.pl)
    * [Prime formulas](./Math/prime_formulas.pl)
    * [Prime functions in terms of zeros of zeta](./Math/prime_functions_in_terms_of_zeros_of_zeta.pl)
    * [Prime numbers generator](./Math/prime_numbers_generator.pl)
    * [Prime omega function generalized](./Math/prime_omega_function_generalized.pl)
    * [Prime quadratic polynomial analyzer](./Math/prime_quadratic_polynomial_analyzer.pl)
    * [Prime quadratic polynomials](./Math/prime_quadratic_polynomials.pl)
    * [Prime signature numbers in range](./Math/prime_signature_numbers_in_range.pl)
    * [Prime summation](./Math/prime_summation.pl)
    * [Prime zeta](./Math/prime_zeta.pl)
    * [Primes diff](./Math/primes_diff.pl)
    * [Primes sum of pair product](./Math/primes_sum_of_pair_product.pl)
    * [Primitive sum of two squares](./Math/primitive_sum_of_two_squares.pl)
    * [Primorial deflation](./Math/primorial_deflation.pl)
    * [Pseudo square root](./Math/pseudo_square_root.pl)
    * [PSW primality test](./Math/PSW_primality_test.pl)
    * [PSW primality test mpz](./Math/PSW_primality_test_mpz.pl)
    * [Pythagorean triples](./Math/pythagorean_triples.pl)
    * [Quadratic-integer factorization method](./Math/quadratic-integer_factorization_method.pl)
    * [Quadratic-integer factorization method mpz](./Math/quadratic-integer_factorization_method_mpz.pl)
    * [Quadratic frobenius primality test](./Math/quadratic_frobenius_primality_test.pl)
    * [Quadratic frobenius pseudoprimes generation](./Math/quadratic_frobenius_pseudoprimes_generation.pl)
    * [Quadratic polynomial in terms of its zeros](./Math/quadratic_polynomial_in_terms_of_its_zeros.pl)
    * [Ramanujan sum](./Math/ramanujan_sum.pl)
    * [Ramanujan sum fast](./Math/ramanujan_sum_fast.pl)
    * [Random carmichael fibonacci pseudoprimes](./Math/random_carmichael_fibonacci_pseudoprimes.pl)
    * [Random integer factorization](./Math/random_integer_factorization.pl)
    * [Random miller-rabin pseudoprimes](./Math/random_miller-rabin_pseudoprimes.pl)
    * [Range map](./Math/range_map.pl)
    * [Rational approximations](./Math/rational_approximations.pl)
    * [Rational continued fractions](./Math/rational_continued_fractions.pl)
    * [Rational prime product](./Math/rational_prime_product.pl)
    * [Rational summation of fractions](./Math/rational_summation_of_fractions.pl)
    * [Reciprocal cycle length](./Math/reciprocal_cycle_length.pl)
    * [Rectangle sides from area and diagonal](./Math/rectangle_sides_from_area_and_diagonal.pl)
    * [Rectangle sides from diagonal angles](./Math/rectangle_sides_from_diagonal_angles.pl)
    * [Rectangle sides from one diagonal angle](./Math/rectangle_sides_from_one_diagonal_angle.pl)
    * [Recursive matrix multiplication](./Math/recursive_matrix_multiplication.pl)
    * [Rest calc](./Math/rest_calc.pl)
    * [Reversed number triangle](./Math/reversed_number_triangle.pl)
    * [Reversed number triangles](./Math/reversed_number_triangles.pl)
    * [Riemann prime-counting function](./Math/riemann_prime-counting_function.pl)
    * [Riemann's J function](./Math/riemann_s_J_function.pl)
    * [Roots on the rise](./Math/roots_on_the_rise.pl)
    * [RSA example](./Math/RSA_example.pl)
    * [RSA PRNG](./Math/RSA_PRNG.pl)
    * [Secant numbers](./Math/secant_numbers.pl)
    * [Semiprime equationization](./Math/semiprime_equationization.pl)
    * [Semiprime equationization uncached](./Math/semiprime_equationization_uncached.pl)
    * [Sequence analyzer](./Math/sequence_analyzer.pl)
    * [Sequence closed form](./Math/sequence_closed_form.pl)
    * [Sequence polynomial closed form](./Math/sequence_polynomial_closed_form.pl)
    * [Sieve of eratosthenes](./Math/sieve_of_eratosthenes.pl)
    * [Sigma0 of factorial](./Math/sigma0_of_factorial.pl)
    * [Sigma function](./Math/sigma_function.pl)
    * [Sigma of factorial](./Math/sigma_of_factorial.pl)
    * [Sigma of product of binomials](./Math/sigma_of_product_of_binomials.pl)
    * [Sigma p adic](./Math/sigma_p_adic.pl)
    * [Siqs factorization](./Math/siqs_factorization.pl)
    * [Smallest carmichael divisible by n](./Math/smallest_carmichael_divisible_by_n.pl)
    * [Smallest k-gonal inverse](./Math/smallest_k-gonal_inverse.pl)
    * [Smallest k-gonal inverse brute force](./Math/smallest_k-gonal_inverse_brute_force.pl)
    * [Smallest lucas-carmichael divisible by n](./Math/smallest_lucas-carmichael_divisible_by_n.pl)
    * [Smallest number with at least n divisors](./Math/smallest_number_with_at_least_n_divisors.pl)
    * [Smallest number with n divisors](./Math/smallest_number_with_n_divisors.pl)
    * [Smarandache function](./Math/smarandache_function.pl)
    * [Smooth numbers generalized](./Math/smooth_numbers_generalized.pl)
    * [Solutions to x squared equals -1 mod n](./Math/solutions_to_x_squared_equals_-1_mod_n.pl)
    * [Solutions to x squared equals 1 mod n](./Math/solutions_to_x_squared_equals_1_mod_n.pl)
    * [Solutions to x squared equals a mod n](./Math/solutions_to_x_squared_equals_a_mod_n.pl)
    * [Solve congruence equation example](./Math/solve_congruence_equation_example.pl)
    * [Solve cubic equation](./Math/solve_cubic_equation.pl)
    * [Solve cubic equation real](./Math/solve_cubic_equation_real.pl)
    * [Solve modular cubic equation](./Math/solve_modular_cubic_equation.pl)
    * [Solve modular quadratic equation](./Math/solve_modular_quadratic_equation.pl)
    * [Solve pell equation](./Math/solve_pell_equation.pl)
    * [Solve pell equation fast](./Math/solve_pell_equation_fast.pl)
    * [Solve pell equation generalized](./Math/solve_pell_equation_generalized.pl)
    * [Solve pell equation simple](./Math/solve_pell_equation_simple.pl)
    * [Solve quadratic diophantine reciprocals](./Math/solve_quadratic_diophantine_reciprocals.pl)
    * [Solve reciprocal pythagorean equation](./Math/solve_reciprocal_pythagorean_equation.pl)
    * [Solve sequence](./Math/solve_sequence.pl)
    * [Sophie germain factorization method](./Math/sophie_germain_factorization_method.pl)
    * [Sorting algorithms](./Math/sorting_algorithms.pl)
    * [Sphere volume](./Math/sphere_volume.pl)
    * [Sqrt mod p tonelli-shanks mpz](./Math/sqrt_mod_p_tonelli-shanks_mpz.pl)
    * [Square divisors](./Math/square_divisors.pl)
    * [Square product subsets](./Math/square_product_subsets.pl)
    * [Square root convergents](./Math/square_root_convergents.pl)
    * [Square root method](./Math/square_root_method.pl)
    * [Square root modulo n tonelli-shanks](./Math/square_root_modulo_n_tonelli-shanks.pl)
    * [Squarefree almost prime divisors](./Math/squarefree_almost_prime_divisors.pl)
    * [Squarefree almost primes from factor list](./Math/squarefree_almost_primes_from_factor_list.pl)
    * [Squarefree almost primes in range](./Math/squarefree_almost_primes_in_range.pl)
    * [Squarefree almost primes in range from factor list](./Math/squarefree_almost_primes_in_range_from_factor_list.pl)
    * [Squarefree almost primes in range mpz](./Math/squarefree_almost_primes_in_range_mpz.pl)
    * [Squarefree divisors](./Math/squarefree_divisors.pl)
    * [Squarefree fermat overpseudoprimes in range](./Math/squarefree_fermat_overpseudoprimes_in_range.pl)
    * [Squarefree fermat pseudoprimes in range](./Math/squarefree_fermat_pseudoprimes_in_range.pl)
    * [Squarefree fermat pseudoprimes in range mpz](./Math/squarefree_fermat_pseudoprimes_in_range_mpz.pl)
    * [Squarefree lucas U pseudoprimes in range](./Math/squarefree_lucas_U_pseudoprimes_in_range.pl)
    * [Squarefree strong fermat pseudoprimes in range](./Math/squarefree_strong_fermat_pseudoprimes_in_range.pl)
    * [Squarefree strong fermat pseudoprimes in range mpz](./Math/squarefree_strong_fermat_pseudoprimes_in_range_mpz.pl)
    * [Squarefree strong fermat pseudoprimes to multiple bases in range](./Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range.pl)
    * [Squarefree strong fermat pseudoprimes to multiple bases in range mpz](./Math/squarefree_strong_fermat_pseudoprimes_to_multiple_bases_in_range_mpz.pl)
    * [Stern brocot encoding](./Math/stern_brocot_encoding.pl)
    * [Stern brocot sequence](./Math/stern_brocot_sequence.pl)
    * [Strong fermat pseudoprimes in range](./Math/strong_fermat_pseudoprimes_in_range.pl)
    * [Strong fermat pseudoprimes in range mpz](./Math/strong_fermat_pseudoprimes_in_range_mpz.pl)
    * [Sub-unit squares](./Math/sub-unit_squares.pl)
    * [Sum factorial](./Math/sum_factorial.pl)
    * [Sum of an even number of positive squares](./Math/sum_of_an_even_number_of_positive_squares.pl)
    * [Sum of digits](./Math/sum_of_digits.pl)
    * [Sum of digits subquadratic algorithm](./Math/sum_of_digits_subquadratic_algorithm.pl)
    * [Sum of digits subquadratic algorithm mpz](./Math/sum_of_digits_subquadratic_algorithm_mpz.pl)
    * [Sum of k-powerful numbers in range](./Math/sum_of_k-powerful_numbers_in_range.pl)
    * [Sum of natural powers in constant base](./Math/sum_of_natural_powers_in_constant_base.pl)
    * [Sum of perfect powers](./Math/sum_of_perfect_powers.pl)
    * [Sum of prime-power exponents of factorial](./Math/sum_of_prime-power_exponents_of_factorial.pl)
    * [Sum of prime-power exponents of product of binomials](./Math/sum_of_prime-power_exponents_of_product_of_binomials.pl)
    * [Sum of prime powers](./Math/sum_of_prime_powers.pl)
    * [Sum of primes generalized](./Math/sum_of_primes_generalized.pl)
    * [Sum of sigma](./Math/sum_of_sigma.pl)
    * [Sum of sigma 2](./Math/sum_of_sigma_2.pl)
    * [Sum of the number of divisors](./Math/sum_of_the_number_of_divisors.pl)
    * [Sum of the number of divisors of gcd x y](./Math/sum_of_the_number_of_divisors_of_gcd_x_y.pl)
    * [Sum of the number of unitary divisors](./Math/sum_of_the_number_of_unitary_divisors.pl)
    * [Sum of the sum of divisors](./Math/sum_of_the_sum_of_divisors.pl)
    * [Sum of three cubes problem](./Math/sum_of_three_cubes_problem.pl)
    * [Sum of triangular numbers solutions](./Math/sum_of_triangular_numbers_solutions.pl)
    * [Sum of two primes](./Math/sum_of_two_primes.pl)
    * [Sum of two squares all solutions](./Math/sum_of_two_squares_all_solutions.pl)
    * [Sum of two squares all solutions 2](./Math/sum_of_two_squares_all_solutions_2.pl)
    * [Sum of two squares all solutions tonelli-shanks](./Math/sum_of_two_squares_all_solutions_tonelli-shanks.pl)
    * [Sum of two squares multiple solutions](./Math/sum_of_two_squares_multiple_solutions.pl)
    * [Sum of two squares solution](./Math/sum_of_two_squares_solution.pl)
    * [Sum remainders](./Math/sum_remainders.pl)
    * [Super pandigital numbers](./Math/super_pandigital_numbers.pl)
    * [Tangent numbers](./Math/tangent_numbers.pl)
    * [Trial division fast](./Math/trial_division_fast.pl)
    * [Triangle hyperoperation](./Math/triangle_hyperoperation.pl)
    * [Triangle interior angles](./Math/triangle_interior_angles.pl)
    * [Tribonacci primality test](./Math/tribonacci_primality_test.pl)
    * [Trip2mars](./Math/trip2mars.pl)
    * [Unique permutations](./Math/unique_permutations.pl)
    * [Unitary divisors](./Math/unitary_divisors.pl)
    * [Unitary divisors fast](./Math/unitary_divisors_fast.pl)
    * [Unitary squarefree divisors](./Math/unitary_squarefree_divisors.pl)
    * [Wilson prime formula](./Math/wilson_prime_formula.pl)
    * [Yahtzee](./Math/yahtzee.pl)
    * [Zequals](./Math/zequals.pl)
    * [Zeta 2n](./Math/zeta_2n.pl)
    * [Zeta for primes](./Math/zeta_for_primes.pl)
    * [Zeta function](./Math/zeta_function.pl)
    * [Zeta prime count approx](./Math/zeta_prime_count_approx.pl)
* Media
    * [Wimp-viewer](./Media/wimp-viewer)
* Microphone
    * Alsa
        * [Raw from microphone](./Microphone/Alsa/raw_from_microphone.pl)
    * Julius
        * [Julius voice control concept](./Microphone/Julius/julius_voice_control_concept.pl)
        * [Voice control](./Microphone/Julius/voice_control.pl)
* Monitoring
    * [File-monitor](./Monitoring/file-monitor)
* Other
    * [Concatenation weirdness](./Other/concatenation_weirdness.pl)
    * [Lexical subs recursion bug](./Other/lexical_subs_recursion_bug.pl)
    * [Tail recursion](./Other/tail_recursion.pl)
    * [Yafu factorization](./Other/yafu_factorization.pl)
* Regex
    * [Positive-negative matching](./Regex/positive-negative_matching.pl)
    * [Prime regexp](./Regex/prime_regexp.pl)
    * [Regex optimizer in source](./Regex/regex_optimizer_in_source.pl)
    * [Regex pair factors](./Regex/regex_pair_factors.pl)
    * [Regexp to strings](./Regex/regexp_to_strings.pl)
* Search
    * [Binary search](./Search/binary_search.pl)
    * [Binary search ge](./Search/binary_search_ge.pl)
    * [Binary search le](./Search/binary_search_le.pl)
* Shell
    * [Execute perl scripts](./Shell/execute_perl_scripts.pl)
* Simulation
    * [100 prisoners riddle](./Simulation/100_prisoners_riddle.pl)
* Socket
    * [Chat server](./Socket/chat_server.pl)
* Sort
    * [Binsertion sorting algorithm](./Sort/binsertion_sorting_algorithm.pl)
    * [Dream sort](./Sort/dream_sort.pl)
* Subtitle
    * [Srt-delay](./Subtitle/srt-delay)
    * [Srt assembler](./Subtitle/srt_assembler.pl)
    * [Srt fix](./Subtitle/srt_fix.pl)
* Text
    * [Abs string](./Text/abs_string.pl)
    * [All substrings](./Text/all_substrings.pl)
    * [Change-encoding](./Text/change-encoding.pl)
    * [Group alike words](./Text/group_alike_words.pl)
    * [Jaro-winkler distance](./Text/jaro-winkler_distance.pl)
    * [Levenshtein distance iter](./Text/levenshtein_distance_iter.pl)
    * [Levenshtein distance rec](./Text/levenshtein_distance_rec.pl)
    * [Markov chain text generator](./Text/markov_chain_text_generator.pl)
    * [Orthogonal text scrambling](./Text/orthogonal_text_scrambling.pl)
    * [Orthogonal text scrambling double](./Text/orthogonal_text_scrambling_double.pl)
    * [Repeated substrings](./Text/repeated_substrings.pl)
    * [Search by prefix](./Text/search_by_prefix.pl)
    * [Sim end words](./Text/sim_end_words.pl)
    * [SmartWordWrap](./Text/smartWordWrap.pl)
    * [SmartWordWrap lazy](./Text/smartWordWrap_lazy.pl)
    * [SmartWordWrap simple](./Text/smartWordWrap_simple.pl)
    * [Unique prefixes](./Text/unique_prefixes.pl)
    * [Word roots](./Text/word_roots.pl)
    * [Word unscrambler](./Text/word_unscrambler.pl)
* Time
    * [Calendar](./Time/calendar.pl)
    * [Contdown](./Time/contdown.pl)
* Video
    * [Sponsor-free](./Video/sponsor-free.pl)
    * [Video concat ffmpeg](./Video/video_concat_ffmpeg.pl)
    * [Video split ffmpeg](./Video/video_split_ffmpeg.pl)
* Visualisators
    * [Binview](./Visualisators/binview.pl)
    * [Disk-stats](./Visualisators/disk-stats.pl)
    * [Dnscrypt stats](./Visualisators/dnscrypt_stats.pl)
    * [Greycmd](./Visualisators/greycmd.pl)
    * [Human-finder-visual](./Visualisators/human-finder-visual.pl)
    * [Lz visual](./Visualisators/lz_visual.pl)
    * [Matrix path 2-ways best](./Visualisators/matrix_path_2-ways_best.pl)
    * [Matrix path 3-ways best](./Visualisators/matrix_path_3-ways_best.pl)
    * [Matrix path 3-ways greedy](./Visualisators/matrix_path_3-ways_greedy.pl)
    * [Pview](./Visualisators/pview)
    * [Random finder visual](./Visualisators/random_finder_visual.pl)
    * [Triangle sub-string finder](./Visualisators/triangle_sub-string_finder.pl)
    * [Visual lz77 compression](./Visualisators/visual_lz77_compression.pl)
    * [Visual sudoku dice solver](./Visualisators/visual_sudoku_dice_solver.pl)


================================================
FILE: Regex/positive-negative_matching.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 30 May 2013
# https://github.com/trizen

# Returns true in a positive check
# if a string doesn't matches a regex.

my $string = 'This is a TOP 10 string.';

if ($string =~ m{^(?(?{/top/i})(?!))}) {
    print "Doesn't contains the 'top' word.\n";
}
else {
    print "Contains the 'top' word.\n";
}


================================================
FILE: Regex/prime_regexp.pl
================================================
#!/usr/bin/perl

$\ = "\n";
my $prime = 0;
my $limit = shift() || 100;

while ($prime++ < $limit) {
    $_ .= 0;

    print $prime if $prime > 1 and not /^(00+?)\1+$/;

    # How it works?
    # When length(${^MATCH}) is not equal to length($_), then is a prime number
    # Uncomment the following lines to see how it actually works...

#    if(/^(00+?)\1+$/p){
#        print "number = $prime\ndolar1 = $1 (",length($1),")\n\$& = $& (",length(${^MATCH}),")\n\$_ = $_ (",length($_),")\n\n";
#    }elsif(!/^(00+?)\1+$/p){
#        print "number = $prime\ndolar1 = $1 (",length($1),")\n\$& = $& (",length(${^MATCH}),")\n\$_ = $_ (",length($_),")\n\n";
#    }

}


================================================
FILE: Regex/regex_optimizer_in_source.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 12 November 2017
# https://github.com/trizen

# Optimize regular expressions in a given Perl source code, using Perl::Tokenizer and Regexp::Optimizer.

# Example:
#   qr/foobar|fooxar|foozap$/im  -> qr/foo(?:[bx]ar|zap$)/im
#    m/foobar|fooxar|foozap$/gci ->   /foo(?:[bx]ar|zap$)/cgi

# Regexes which (potentially) include variable interpolation, are ignored.

# The input source code must be UTF-8 encoded.

use utf8;
use 5.018;
use warnings;

use open IO => ':encoding(UTF-8)', ':std';

use Regexp::Optimizer;
use Data::Dump qw(pp);
use Perl::Tokenizer qw(perl_tokens);
use Encode qw(decode_utf8 encode_utf8);

# usage: perl script.pl < source.pl
my $code = join('', <>);

my $regexp_optimizer = Regexp::Optimizer->new;

perl_tokens {
    my ($name, $i, $j) = @_;

    if (   $name eq 'match_regex'
        or $name eq 'compiled_regex') {

        my $str = substr($code, $i, $j - $i);

        my @flags;

        if ($name eq 'match_regex') {

            $str =~ s/^m//;
            $str = 'qr' . $str;

            if ($str =~ s/^.*\Kg([a-z]*)\z/$1/s) {
                push @flags, 'g';
            }

            if ($str =~ s/^.*\Kc([a-z]*)\z/$1/s) {
                push @flags, 'c';
            }
        }

        my $eval_code = join(
                             ';',
                             'my $str = qq{' . quotemeta(encode_utf8($str)) . '}',    # quoted string
                             'die if $str =~ /[\$\@][{\\w]/',                         # skip regexes with interpolation
                             '$str = eval $str',                                      # evaluate string
                             'die if $@',                                             # check the status of eval()
                             '$str',                                                  # regex ref
                            );

        my $raw_str = eval($eval_code);

        if (defined($raw_str) and !$@) {

            my $regex_str = eval { decode_utf8(pp($regexp_optimizer->optimize($raw_str))) };

            if (defined($regex_str)) {

                my ($delim_beg, $delim_end);

                if ($regex_str =~ /^qr(.)\(\?\^([a-z]+):(.*)\)(.)\z/s) {
                    ($delim_beg, $regex_str, $delim_end) = ($1, $3, $4);
                    push @flags, split(//, $2);
                }

#<<<
                $regex_str = join('',
                    $delim_beg, $regex_str, $delim_end,
                        (sort { $a cmp $b } grep { $_ ne 'u' } @flags)
                );
#>>>

                if ($name eq 'match_regex') {
                    $regex_str = 'm' . $regex_str if ($regex_str !~ m{^/});
                }
                else {
                    $regex_str = 'qr' . $regex_str;
                }

                print $regex_str;
                return;
            }
        }
    }

    print substr($code, $i, $j - $i);
} $code;


================================================
FILE: Regex/regex_pair_factors.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 April 2014
# Website: https://github.com/trizen

# Get the pair factors for a number (using a regex)

use 5.010;
use strict;
use warnings;

my $prod = $ARGV[0] // 36;
my $msg  = 'a' x $prod;

for my $i (2 .. $prod / 2) {
    for my $j ($i .. $prod / $i) {
        if ($msg =~ /^(?:a{$i}){$j}\z/) {
            say "$j * $i == $prod";
        }
    }
}


================================================
FILE: Regex/regexp_to_strings.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 21 December 2014
# Website: https://github.com/trizen

# Find the minimum sentence(s) that satisfies a regular expression
# See also: https://www.perlmonks.org/?node_id=284513

# WARNING: this script is just an idea in development

# usage: perl regex_to_strings.pl [regexp]

use utf8;
use 5.010;
use strict;
use warnings;

use Regexp::Parser;
use Data::Dump qw(pp);

binmode(STDOUT, ':utf8');

{
    no warnings 'redefine';
    *Regexp::Parser::anyof_class::new = sub {
        my ($class, $rx, $type, $neg, $how) = @_;
        my $self = bless {
                          rx     => $rx,
                          flags  => $rx->{flags}[-1],
                          family => 'anyof_class',
                         }, $class;

        if (ref $type) {
            $self->{data} = $type;
        }
        else {
            $self->{type} = $type;
            $self->{data} = 'POSIX';
            $self->{neg}  = $neg;
            $self->{how}  = ${$how};    # bug-fix
        }

        return $self;
    };
}

my $regex = shift() // 'ab(c[12]|d(n|p)o)\w{3}[.?!]{4}';
my $parser = Regexp::Parser->new($regex);

my %conv = (
            alnum  => 'a',
            nalnum => '#',
            digit  => '1',
            ndigit => '+',
            space  => ' ',
            nspace => '.',
           );

my @stack;
my @strings = [];
my $ref     = \@strings;

my $iter = $parser->walker;

my $min        = 1;
my $last_depth = 0;
while (my ($node, $depth) = $iter->()) {

    my $family = $node->family;
    my $type   = $node->type;

    if ($depth < $last_depth) {
        $min = 1;
        say "MIN CHANGED";
    }

    if ($family eq 'quant') {
        $min = $node->min;
        say "MIN == $min";
    }

    pp $family, $type, $node->qr;    # for debug

    if ($type =~ /^(?:close\d|tail)/) {
        $ref = pop @stack;
    }
    elsif (exists $conv{$type}) {
        push @{$ref->[-1]}, $conv{$type} x $min;
    }
    elsif ($family eq 'open' or $type eq 'group' or $type eq 'suspend') {
        push @stack, $ref;
        push @{$ref->[-1]}, [];
        $ref = $ref->[-1][-1];
        push @{$ref}, [];
    }
    elsif ($type eq 'branch') {
        $#{$ref->[-1]} == -1 or push @{$ref}, [];
    }
    elsif ($type eq 'exact' or $type eq 'exactf') {
        push @{$ref->[-1]}, $node->data x $min;
    }
    elsif ($type eq 'anyof' and $min > 0) {
        my $regex = $node->qr;
        foreach my $c (0 .. 1000000) {
            if (chr($c) =~ /$regex/) {
                push @{$ref->[-1]}, chr($c) x $min;
                last;
            }
        }
    }

    $last_depth = $depth;
}

use Data::Dump qw(pp);
pp @strings;

# TODO: join the @strings into real $strings


================================================
FILE: Search/binary_search.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 July 2019
# https://github.com/trizen

# The binary search algorithm.

# See also:
#   https://en.wikipedia.org/wiki/Binary_search_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub bsearch ($left, $right, $callback) {

    while ($left <= $right) {

        my $mid = int(($left + $right) / 2);
        my $cmp = $callback->($mid) || return $mid;

        if ($cmp > 0) {
            $right = $mid - 1;
        }
        else {
            $left = $mid + 1;
        }
    }

    return undef;
}

say bsearch(0, 202,  sub ($x) { $x * $x <=> 49 });     #=> 7   (7*7  = 49)
say bsearch(3, 1000, sub ($x) { $x**$x <=> 3125 });    #=> 5   (5**5 = 3125)


================================================
FILE: Search/binary_search_ge.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 July 2019
# https://github.com/trizen

# The binary search algorithm: "greater than or equal to" variation.

# See also:
#   https://en.wikipedia.org/wiki/Binary_search_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub bsearch_ge ($left, $right, $callback) {

    my ($mid, $cmp);

    for (; ;) {

        $mid = int(($left + $right) / 2);
        $cmp = $callback->($mid) || return $mid;

        if ($cmp < 0) {
            $left = $mid + 1;

            if ($left > $right) {
                $mid += 1;
                last;
            }
        }
        else {
            $right = $mid - 1;
            $left > $right and last;
        }
    }

    return $mid;
}

say bsearch_ge(0, 202,  sub ($x) { $x * $x <=> 49 });     #=> 7   (7*7  = 49)
say bsearch_ge(3, 1000, sub ($x) { $x**$x <=> 3125 });    #=> 5   (5**5 = 3125)

say bsearch_ge(1,    1e6, sub ($x) { exp($x) <=> 1e+9 }); #=>  21   (exp( 21) >= 1e+9)
say bsearch_ge(-1e6, 1e6, sub ($x) { exp($x) <=> 1e-9 }); #=> -20   (exp(-20) >= 1e-9)


================================================
FILE: Search/binary_search_le.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 10 July 2019
# https://github.com/trizen

# The binary search algorithm: "less than or equal to" variation.

# See also:
#   https://en.wikipedia.org/wiki/Binary_search_algorithm

use 5.020;
use strict;
use warnings;

use experimental qw(signatures);

sub bsearch_le ($left, $right, $callback) {

    my ($mid, $cmp);

    for (; ;) {

        $mid = int(($left + $right) / 2);
        $cmp = $callback->($mid) || return $mid;

        if ($cmp < 0) {
            $left = $mid + 1;
            $left > $right and last;
        }
        else {
            $right = $mid - 1;

            if ($left > $right) {
                $mid -= 1;
                last;
            }
        }
    }

    return $mid;
}

say bsearch_le(0, 202,  sub ($x) { $x * $x <=> 49 });     #=> 7   (7*7  = 49)
say bsearch_le(3, 1000, sub ($x) { $x**$x <=> 3125 });    #=> 5   (5**5 = 3125)

say bsearch_le(1,    1e6, sub ($x) { exp($x) <=> 1e+9 }); #=>  20   (exp( 20) <= 1e+9)
say bsearch_le(-1e6, 1e6, sub ($x) { exp($x) <=> 1e-9 }); #=> -21   (exp(-21) <= 1e-9)


================================================
FILE: Shell/execute_perl_scripts.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 25 June 2024
# https://github.com/trizen

# Execute a given list of Perl scripts given as command-line arguments.

use 5.036;

use File::Basename qw(basename);
use Getopt::Long   qw(GetOptions);

my $arg   = undef;
my $regex = undef;

sub usage($exit_code = 0) {
    print <<"EOT";
usage: $0 [options] [Perl scripts]

options:

    --regex=s : execute scripts matching a given regex (default: None)
    --arg=s   : an argument to be passed to each script (default: None)
    --help    : print this message and exit

examples:

    perl $0 --arg=42 *.pl
    perl $0 --arg=42 --regex='^\\w+\.pl\\z'

EOT

    exit($exit_code);
}

GetOptions(
           'arg=s'   => \$arg,
           'regex=s' => \$regex,
           'h|help'  => sub { usage(0) },
          )
  or die("Error in command line arguments\n");

my @files = @ARGV;

if (defined($regex)) {
    my $re = qr{$regex};
    foreach my $file (glob("*")) {
        if (basename($file) =~ $re) {
            push @files, $file;
        }
    }
}

@files || usage(2);

foreach my $script (@files) {

    if (not -f $script) {
        warn "[!] Not a file: $script\n. Skipping...";
    }

    warn ":: Executing: $script\n";
    system($^X, $script, (defined($arg) ? $arg : ()));
    $? == 0 or die "[!] Stopping... Exit code: $?\n";
}


================================================
FILE: Simulation/100_prisoners_riddle.pl
================================================
#!/usr/bin/perl

# Simulation of the 100 Prisoners Riddle.

# See also the Veritasium video on this problem:
#   https://yewtu.be/watch?v=iSNsgj1OCLA

use 5.014;
use strict;
use warnings;

use List::Util qw(shuffle);

my $ok        = 0;
my $runs      = 10000;
my $prisoners = 100;

for my $n (1 .. $runs) {

    my @boxes = shuffle(0 .. $prisoners - 1);

    my $success = 1;

    foreach my $k (0 .. $prisoners - 1) {

        my $found = 0;
        my $pick  = $boxes[$k];

        for (my $tries = $prisoners >> 1 ; $tries > 0 ; --$tries) {
            if ($pick == $k) {
                $found = 1;
                last;
            }
            $pick = $boxes[$pick];
        }

        if (not $found) {
            $success = 0;
            last;
        }
    }

    if ($success) {
        ++$ok;
    }
}

say "Probability of success: ", ($ok / $runs * 100), '%';

__END__
Probability of success: 31.52%


================================================
FILE: Socket/chat_server.pl
================================================
#!/usr/bin/perl

#
## Translation of: https://rosettacode.org/wiki/Chat_server#Python
#

# Create server:
#     perl chat_server.pl

# Connect to the chat via telnet:
#     telnet localhost 4004

use 5.010;
use strict;
use warnings;

use threads;
use threads::shared;

use IO::Socket::INET;
use Time::HiRes qw(sleep ualarm);

my $HOST = "localhost";
my $PORT = 4004;

my @open;
my %users : shared;

sub broadcast {
    my ($id, $message) = @_;
    print "$message\n";
    foreach my $i (keys %users) {
        if ($i != $id) {
            $open[$i]->send("$message\n");
        }
    }
}

sub sign_in {
    my ($conn) = @_;

    state $id = 0;

    threads->new(
        sub {
            while (1) {
                $conn->send("Please enter your name: ");
                $conn->recv(my $name, 1024, 0);

                if (defined $name) {
                    $name = unpack('A*', $name);

                    if (exists $users{$name}) {
                        $conn->send("Name entered is already in use.\n");
                    }
                    elsif ($name ne '') {
                        $users{$id} = $name;
                        broadcast($id, "+++ $name arrived +++");
                        last;
                    }
                }
            }
        }
    );

    ++$id;
    push @open, $conn;
}

my $server = IO::Socket::INET->new(
                                   Timeout   => 0,
                                   LocalPort => $PORT,
                                   Proto     => "tcp",
                                   LocalAddr => $HOST,
                                   Blocking  => 0,
                                   Listen    => 1,
                                   Reuse     => 1,
                                  );

local $| = 1;
print "Listening on $HOST:$PORT\n";

while (1) {
    my ($conn) = $server->accept;

    if (defined($conn)) {
        sign_in($conn);
    }

    foreach my $i (keys %users) {

        my $conn = $open[$i];
        my $message;

        eval {
            local $SIG{ALRM} = sub { die "alarm\n" };
            ualarm(500);
            $conn->recv($message, 1024, 0);
            ualarm(0);
        };

        if ($@ eq "alarm\n") {
            next;
        }

        if (defined($message)) {
            if ($message ne '') {
                $message = unpack('A*', $message);
                broadcast($i, "$users{$i}> $message");
            }
            else {
                broadcast($i, "--- $users{$i} leaves ---");
                delete $users{$i};
                undef $open[$i];
            }
        }
    }

    sleep(0.1);
}


================================================
FILE: Sort/binsertion_sorting_algorithm.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 16 December 2013
# Edit: 06 December 2023
# https://github.com/trizen

# Sorting algorithm: insertion sort + binary search = binsertion sort

use 5.036;
use strict;
use warnings;

sub bsearch_ge ($left, $right, $callback) {

    my ($mid, $cmp);

    for (; ;) {

        $mid = ($left + $right) >> 1;
        $cmp = $callback->($mid) || return $mid;

        if ($cmp < 0) {
            $left = $mid + 1;

            if ($left > $right) {
                $mid += 1;
                last;
            }
        }
        else {
            $right = $mid - 1;
            $left > $right and last;
        }
    }

    return $mid;
}

sub binsertion_sort {
    my (@list) = @_;

    foreach my $i (1 .. $#list) {
        if ((my $k = $list[$i]) < $list[$i - 1]) {
            splice(@list, $i, 1);
            splice(@list, bsearch_ge(0, $i - 1, sub ($j) { $list[$j] <=> $k }), 0, $k);
        }
    }

    return @list;
}

#
## MAIN
#

use List::Util qw(shuffle);

my @list = (shuffle((1 .. 100) x 2))[0 .. 50];

say "Before: ", join(' ', @list);
say "After:  ", join(' ', binsertion_sort(@list));

my @sorted = sort { $a <=> $b } @list;

join(' ', binsertion_sort(@list)) eq join(' ', @sorted)           or die "error";
join(' ', binsertion_sort(@sorted)) eq join(' ', @sorted)         or die "error";
join(' ', binsertion_sort(reverse @sorted)) eq join(' ', @sorted) or die "error";


================================================
FILE: Sort/dream_sort.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 19 August 2025
# https://github.com/trizen

# A recursive sorting algorithm for strings, based on a dream that I had, similar to Radix sort.

# The running time of the algorithm is:
#   O(n * len(s))
# where `n` is the number of strings being sorted and `s` is the longest string in the array.

# See also:
#   https://en.wikipedia.org/wiki/Radix_sort

use 5.036;
use List::Util qw(shuffle);
use Test::More tests => 20;

sub dream_sort($arr, $i = 0) {

    my @buckets;

    foreach my $item (@$arr) {
        my $byte = substr($item, $i, 1) // '';
        if ($byte eq '') {
            $byte = 0;
        }
        else {
            $byte = ord($byte) + 1;
        }
        push @{$buckets[$byte]}, $item;
    }

    my @sorted;

    if (defined($buckets[0])) {
        push @sorted, @{$buckets[0]};
    }

    foreach my $k (1 .. $#buckets) {
        my $entry = $buckets[$k];
        if (defined($entry)) {
            if (scalar(@$entry) == 1) {
                push @sorted, $entry->[0];
            }
            else {
                push @sorted, @{__SUB__->($entry, $i + 1)};
            }
        }
    }

    return \@sorted;
}

sub sort_test($arr) {
    my @sorted = sort @$arr;
    is_deeply(dream_sort($arr),             \@sorted);
    is_deeply(dream_sort([reverse @$arr]),  \@sorted);
    is_deeply(dream_sort(\@sorted),         \@sorted);
    is_deeply(dream_sort([shuffle(@$arr)]), \@sorted);
}

sort_test(["abc",  "abd"]);
sort_test(["abc",  "abc"]);
sort_test(["abcd", "abc"]);
sort_test(["John", "Kate", "Zerg", "Alice", "Joe", "Jane"]);

sort_test(
    do {
        open my $fh, '<:raw', __FILE__;
        local $/;
        [split(' ', scalar <$fh>)];
    }
);


================================================
FILE: Subtitle/srt-delay
================================================
#!/usr/bin/perl

# Copyright (C) 2011-2017 Daniel "Trizen" Șuteu
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .
#
#-------------------------------------------------------
#  Appname: srt-delay
#  Version: 0.0.6
#  Created: 26 December 2011
#  Edit on: 19 October 2020
#  https://github.com/trizen
#-------------------------------------------------------

use 5.014;
use strict;
use warnings;

use Getopt::Long qw(GetOptions);

sub usage {
    my ($exit_code) = @_;
    print <<"USAGE";
usage: $0 [options] [seconds] [file.srt]

Options:
    -b  --backup    : backup original to .bak
    -d  --delay=f   : number of seconds of delay
    -s  --scale=f   : scale the timestamps by a multiple

Examples: $0 -b -d=1.439 file.srt
          $0 -b -d=0.321 file.srt
          $0 -b -d=-3.14 file.srt
USAGE
    exit($exit_code // 0);
}

sub time2sec {
    my @out;
    foreach my $time (@_) {
        my ($hours, $min, $sec, $milisec) = split(/[:,]/, $time, 4);
        push @out, $hours * 3600 + $min * 60 + $sec + $milisec / 1000;
    }
    return @out;
}

sub sec2time {
    my @out;
    foreach my $sec (map { sprintf '%.3f', $_ } @_) {
        push @out,
          sprintf('%02d:%02d:%02d,%03d', ($sec / 3600 % 24, $sec / 60 % 60, $sec % 60, substr($sec, index($sec, '.') + 1)));
    }
    return @out;
}

my $delay  = 0;
my $backup = 0;
my $scale  = 1;

GetOptions(
           "b|backup!" => \$backup,
           "s|scale=f" => \$scale,
           "d|delay=f" => \$delay,
           "h|help"    => sub { usage(0) },
          )
  or die("Error in command line arguments");

my @files = grep { -f $_ } @ARGV;

@files || usage(2);

foreach my $file (@files) {
    my @output;
    open my $fh, '<', $file or die "Unable to open for read ${file}: $!\n";
    while (defined(my $line = <$fh>)) {
        if ($line =~ /^\d+:\d+:\d+(?:,\d+)?\s*-->\s*\d+:\d+:\d+(?:,\d+)?(\s*)\z/) {
            push @output, join(
                ' --> ',
                sec2time(
                    map {
                        my $sec = $scale * $_ + $delay;
                        ($sec >= 0)
                          ? $sec
                          : !warn "[!] Time cannot be lower than zero at line $.\n";
                    } time2sec(split(/\s*-->\s*/, $line, 2))
                )
              )
              . $1;
        }
        else { push @output, $line }
    }

    close $fh;
    rename $file, "$file.bak" if $backup;

    open $fh, '>', $file or die "Unable to open for write ${file}: $!\n";
    print {$fh} @output;
    close $fh;
}


================================================
FILE: Subtitle/srt_assembler.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 14 December 2014
# Edit: 14 December 2016
# License: GPLv3
# https://github.com/trizen

# Extract the text and the skeleton from a SRT file.

# The text can be translated into another language, then
# joined back with the SRT skeleton into a new SRT file.

use utf8;
use 5.010;
use strict;
use autodie;
use warnings;

use experimental qw(signatures);

use Getopt::Std qw(getopts);
use File::BOM qw(get_encoding_from_filehandle);

sub usage {
    my ($code) = @_;
    require File::Basename;
    my $main = File::Basename::basename($0);
    print <<"EOF";
usage: $main [options] [input file]

options:
    -j  : join text with template
    -t  : name of the template file

example:
    $main -t file.t file.srt > file.text
    $main -t file.t file.text > new_file.srt
EOF

    exit($code // 0);
}

sub prepare_words ($words, $width, $callback, $depth = 0) {

    my @root;
    my $len = 0;
    my $i   = -1;

    my $limit = $#{$words};
    while (++$i <= $limit) {
        $len += (my $word_len = length($words->[$i]));

        if ($len > $width) {
            if ($word_len > $width) {
                $len -= $word_len;
                splice(@$words, $i, 1, unpack("(A$width)*", $words->[$i]));
                $limit = $#{$words};
                --$i;
                next;
            }
            last;
        }

#<<<
        push @root, [
            join(' ', @{$words}[0 .. $i]),
            prepare_words([@{$words}[$i + 1 .. $limit]], $width, $callback, $depth + 1),
        ];
#>>>

        if ($depth == 0) {
            $callback->($root[0]);
            @root = ();
        }

        last if (++$len > $width);
    }

    \@root;
}

sub combine ($path, $callback, $root = []) {
    my $key = shift(@$path);
    foreach my $value (@$path) {
        push @$root, $key;
        if (@$value) {
            foreach my $item (@$value) {
                combine($item, $callback, $root);
            }
        }
        else {
            $callback->($root);
        }
        pop @$root;
    }
}

sub smart_wrap ($text, $width) {

    my @words = (
                 ref($text) eq 'ARRAY'
                 ? @{$text}
                 : split(' ', $text)
                );

    my %best = (
                score => 'inf',
                value => [],
               );

    prepare_words(
        \@words,
        $width,
        sub ($path) {
            combine(
                $path,
                sub ($combination) {
                    my $score = 0;
                    foreach my $line (@$combination) {
                        $score += ($width - length($line))**2;
                        return if $score >= $best{score};
                    }
                    $best{score} = $score;
                    $best{value} = [@$combination];
                }
            );
        }
    );

    join("\n", @{$best{value}});
}

sub disassemble ($srt_file, $template_file) {

    open(my $srt_fh,  '<:crlf', $srt_file);
    open(my $tmpl_fh, '>',      $template_file);

    my $enc = get_encoding_from_filehandle($srt_fh);

    if (defined($enc) and $enc ne '') {
        binmode($srt_fh, ":encoding($enc)");
        binmode(STDOUT,  ":encoding($enc)");
    }

    local $/ = "";    # paragraph mode
    while (defined(my $para = <$srt_fh>)) {
        if (
            $para =~ /^
        (?[0-9]+)\h*\R

        (?[0-9]{2}:[0-9]{2}:[0-9]{2},[0-9]{3})
                     \h*-->\h*
        (?[0-9]{2}:[0-9]{2}:[0-9]{2},[0-9]{3})\h*\R

        (?.+)/sx
          ) {
            print {$tmpl_fh} "$+{i}\n$+{from} --> $+{to}\n%s\n\n";

            my $text = $+{text};
            $text =~ s/<.*?>//gs;    # remove HTML tags
                                     # (consider this a bug)

            print join(' ', split(' ', $text)), "\n\n";
        }
        else {
            die "[ERROR] Invalid paragraph:
{{->>BEGIN<<-}}
$para
{{->>END<<-}}\n";
        }
    }

    close $srt_fh;
    close $tmpl_fh;
}

sub assemble ($text_file, $template_file) {

    open my $txt_fh,  '<:crlf', $text_file;
    open my $tmpl_fh, '<:crlf', $template_file;

    my $enc = get_encoding_from_filehandle($txt_fh)
      || get_encoding_from_filehandle($tmpl_fh);

    if (defined($enc) and $enc ne '') {
        binmode($txt_fh,  ":encoding($enc)");
        binmode($tmpl_fh, ":encoding($enc)");
        binmode(STDOUT,   ":encoding($enc)");
    }

    local $/ = "";
    while (defined(my $text = <$txt_fh>)) {
        my $format = <$tmpl_fh> // die "Unexpected error: template file is shorter than text!";

        $text =~ s/[?!.)\]"']\K\h+([-‒―—]+)(?=\h)/\n$1/g;
        $text = join("\n", map { length($_) <= 45 ? $_ : smart_wrap($_, 45) } split(/\R/, $text));

        printf($format, $text);
    }

    close $txt_fh;
    close $tmpl_fh;
}

my %opt;
getopts('jt:h', \%opt);

my $input_file    = shift(@ARGV) // usage(1);
my $template_file = $opt{t}      // ($input_file =~ s/\.\w{1,5}\z//r . '.template');

$opt{j} || ($input_file !~ /\.srt\z/)
  ? assemble($input_file, $template_file)
  : disassemble($input_file, $template_file);


================================================
FILE: Subtitle/srt_fix.pl
================================================
#!/usr/bin/perl

# Fix subtitles translated with Google Translate

use strict;
use warnings;

use Tie::File;

my $filename = shift(@ARGV);

tie my @lines, 'Tie::File', $filename
  or die "Can't tie into file `$filename': $!";

for (@lines) {
    s/(?/-->/g;
    /\h-->\h/
      ? do {
        s/[0-9]{2}\K:\h+(?=[0-9]{2})/:/g;
      }
      : do {
        s{(@cache);
    }

    return;
}

all_substrings("abcdefg", sub { say for @_ });


================================================
FILE: Text/change-encoding.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 17 December 2023
# https://github.com/trizen

# Change the encoding of a text file.

use 5.010;
use strict;
use warnings;

use Encode       qw(encode decode);
use Getopt::Long qw(GetOptions);

my $input_encoding  = 'iso-8859-2';
my $output_encoding = 'utf-8';

sub help {
    my ($exit_code) = @_;
    $exit_code //= 0;
    print <<"EOT";
usage: $0 [options] [input.txt] [output.txt]

    --from=s  : input encoding (default: $input_encoding)
    --to=s    : output encoding (default: $output_encoding)
EOT

    exit($exit_code);
}

GetOptions(
           "from=s" => \$input_encoding,
           "to=s"   => \$output_encoding,
           "h|help" => sub { help(0) }
          )
  or do {
    warn("Error in command line arguments\n");
    help(1);
  };

my $input  = $ARGV[0] // help(1);
my $output = $ARGV[1] // $input;

my $raw = do {
    open my $fh, '<:raw', $input or die "Can't open <<$input>> for reading: $!";
    local $/;
    <$fh>;
};

my $dec = decode($input_encoding, $raw, Encode::FB_CROAK);
my $enc = encode($output_encoding, $dec, Encode::FB_CROAK);

open my $fh, '>:raw', $output or die "Can't open <<$output>> for writing: $!";
print $fh $enc;
close $fh;


================================================
FILE: Text/group_alike_words.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 July 2014
# Website: https://github.com/trizen

# Group in distinct paragraphs all the words that look pretty much the same to one another

use 5.010;
use strict;
use warnings;

use open IO => ':utf8', ':std';

use POSIX qw(ceil);
use Getopt::Std qw(getopts);
use List::Util qw(first min);

my %opt = (d => 2);

sub usage {
    my ($code) = @_;

    print <<"USAGE";
usage: $0 [options] [input file]

options:
        -d int  : the maximum distance between two words (default: $opt{d})
        -m      : merge similar groups into one larger group
        -k      : allow a word to exist in more than one group

        -h      : print this message and exit

example:
        $0 -d 1 input.txt > output.txt
USAGE

    exit($code // 0);
}

getopts('d:kmh', \%opt);
$opt{h} && usage();

# Levenshtein's distance function (optimized for speed)
sub leven {
    my ($s, $t) = @_;

    my @d = ([0 .. @$t], map { [$_] } 1 .. @$s);

    foreach my $i (0 .. $#{$s}) {
        foreach my $j (0 .. $#{$t}) {
            $d[$i + 1][$j + 1] =
              $s->[$i] eq $t->[$j]
                ? $d[$i][$j]
                : 1 + min($d[$i][$j + 1], $d[$i + 1][$j], $d[$i][$j]);
        }
    }

    $d[-1][-1];
}

# When no file has been provided, throw an error
@ARGV || usage(2);

# Iterate over the argument-files
foreach my $file (@ARGV) {

    my @words = do {
        my %w;
        open my $fh, '<', $file or do {
            warn "Can't open file '$file': $!";
            next;
        };
        @w{map { unpack('A*') } <$fh>} = ();
        map { [split //] } sort keys %w;
    };

    my %table;
    for (my $i = 0 ; $i <= $#words - 1 ; $i++) {

        printf STDERR "[%*d of %d] Processing...\r", ceil(log(scalar @words) / log(10)), $i, scalar(@words);

        my %h1;
        @h1{@{$words[$i]}} = ();

        for (my $j = $i + 1 ; $j <= $#words ; $j++) {

            # If the lengths of the words differ by more than $opt{d}
            if (abs(@{$words[$i]} - @{$words[$j]}) > $opt{d}) {
                next;    # then there is no need to compute the distance
            }

            my %h2;
            @h2{@{$words[$j]}} = ();

            # One more check before calling the very
            # expensive Levenshtein's distance function
            my $diff = 0;
            foreach my $key (keys %h1) {
                exists $h2{$key} or do {
                    last if ++$diff > $opt{d};
                };
            }

            next if $diff > $opt{d};

            # Compute the Levenshtein distance
            if (leven($words[$i], $words[$j]) <= $opt{d}) {
                if (not exists $table{$i}) {
                    $table{$i} = [join('', @{$words[$i]})];
                }
                push @{$table{$i}}, join('', @{$words[$j]});
                splice(@words, $j--, 1) if (not $opt{k} and not $opt{m});
            }
        }
    }

    # Clear the process line
    print STDERR "                             \r";

    # Output the results
    if ($opt{m}) {    # merge the groups
        my @values = values %table;
        for (my $i = 0 ; $i <= $#values ; $i++) {
            foreach my $val (@{$values[$i]}) {
                for (my $j = $i + 1 ; $j <= $#values ; $j++) {
                    if (defined(first { $val eq $_ } @{$values[$j]})) {
                        push @{$values[$i]}, @{$values[$j]};
                        splice(@values, $j--, 1);
                        last;
                    }
                }
            }

            my %w;
            @w{@{$values[$i]}} = ();
            say for sort keys %w;
            print "\n";
        }
    }
    else {    # simple output
        foreach my $value (values %table) {
            say for @{$value};
            print "\n";
        }
    }
}


================================================
FILE: Text/jaro-winkler_distance.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 October 2015
# Website: https://github.com/trizen

# Implementation of the Jaro-Winkler distance algorithm
# See: https://en.wikipedia.org/wiki/Jaro%E2%80%93Winkler_distance

use 5.010;
use strict;
use warnings;

use List::Util qw(min max);

sub jaro {
    my ($s, $t) = @_;

    my $s_len = length($s);
    my $t_len = length($t);

    return 1 if ($s_len == 0 and $t_len == 0);

    my $match_distance = int(max($s_len, $t_len) / 2) - 1;

    my @s_matches;
    my @t_matches;

    my @s = split(//, $s);
    my @t = split(//, $t);

    my $matches = 0;
    foreach my $i (0 .. $s_len - 1) {

        my $start = max(0, $i - $match_distance);
        my $end = min($i + $match_distance + 1, $t_len);

        foreach my $j ($start .. $end - 1) {
            $t_matches[$j] and next;
            $s[$i] eq $t[$j] or next;
            $s_matches[$i] = 1;
            $t_matches[$j] = 1;
            $matches++;
            last;
        }
    }

    return 0 if $matches == 0;

    my $k     = 0;
    my $trans = 0;

    foreach my $i (0 .. $s_len - 1) {
        $s_matches[$i] or next;
        until ($t_matches[$k]) { ++$k }
        $s[$i] eq $t[$k] or ++$trans;
        ++$k;
    }

#<<<
    (($matches / $s_len) + ($matches / $t_len)
        + (($matches - $trans / 2) / $matches)) / 3;
#>>>
}

sub jaro_winkler {
    my ($s, $t) = @_;

    my $distance = jaro($s, $t);

    my $prefix = 0;
    foreach my $i (0 .. min(3, length($s), length($t))) {
        substr($s, $i, 1) eq substr($t, $i, 1) ? ++$prefix : last;
    }

    $distance + $prefix * 0.1 * (1 - $distance);
}

printf("%f\n", jaro_winkler("MARTHA",      "MARHTA"));
printf("%f\n", jaro_winkler("DWAYNE",      "DUANE"));
printf("%f\n", jaro_winkler("DIXON",       "DICKSONX"));
printf("%f\n", jaro_winkler("ROSETTACODE", "ROSETTASTONE"));


================================================
FILE: Text/levenshtein_distance_iter.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 12 December 2016
# https://github.com/trizen

# Levenshtein distance (iterative implementation).

# See also:
#   https://en.wikipedia.org/wiki/Levenshtein_distance

use 5.010;
use strict;
use warnings;

use List::Util qw(min);

sub leven {
    my ($s, $t) = @_;

    my $tl = length($t);
    my $sl = length($s);

    my @d = ([0 .. $tl], map { [$_] } 1 .. $sl);

    foreach my $i (0 .. $sl - 1) {
        foreach my $j (0 .. $tl - 1) {
            $d[$i + 1][$j + 1] =
              substr($s, $i, 1) eq substr($t, $j, 1)
              ? $d[$i][$j]
              : 1 + min($d[$i][$j + 1], $d[$i + 1][$j], $d[$i][$j]);
        }
    }

    $d[-1][-1];
}

say leven('rosettacode', 'raisethysword');


================================================
FILE: Text/levenshtein_distance_rec.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 12 December 2016
# https://github.com/trizen

# Levenshtein distance (recursive implementation).

# See also:
#   https://en.wikipedia.org/wiki/Levenshtein_distance

use 5.010;
use strict;
use warnings;

use List::Util qw(min);
use Memoize qw(memoize);

memoize('leven');

sub leven {
    my ($s, $t) = @_;

    return length($t) if $s eq '';
    return length($s) if $t eq '';

    my ($s1, $t1) = (substr($s, 1), substr($t, 1));

    (substr($s, 0, 1) eq substr($t, 0, 1))
      ? leven($s1, $t1)
      : min(
            leven($s1, $t1),
            leven($s,  $t1),
            leven($s1, $t ),
        ) + 1;
}

say leven('rosettacode', 'raisethysword');


================================================
FILE: Text/markov_chain_text_generator.pl
================================================
#!/usr/bin/perl

# A very simple text generator, using Markov chains.

# This version uses prefixes of variable lengths, between `n_min` and `n_max`.

# See also:
#   https://en.wikipedia.org/wiki/Markov_chain
#   https://rosettacode.org/wiki/Markov_chain_text_generator

use 5.014;
use strict;
use warnings;

use Encode qw(decode_utf8);
use Text::Unidecode qw(unidecode);
use List::Util qw(uniq);

my $n_min = 2;
my $n_max = 4;
my $max   = 200 - $n_max;

sub build_dict {
    my (@orig_words) = @_;

    my %dict;

    foreach my $n ($n_min .. $n_max) {

        my @words = (@orig_words, @orig_words[0 .. $n - 1]);

        for my $i (0 .. $#words - $n) {
            my @prefix = @words[$i .. $i + $n - 1];
            push @{$dict{join ' ', @prefix}}, $words[$i + $n];
        }
    }

    foreach my $key(keys %dict) {
        $dict{$key} = [uniq(@{$dict{$key}})];
    }

    return %dict;
}

my $text = do {
    if (-t STDIN) {
        my $content = '';
        foreach my $file (@ARGV) {
            open my $fh, '<', $file;
            local $/;
            $content .= <$fh>;
            $content .= "\n";
        }
        $content;
    }
    else {
        local $/;
        <>;
    }
};

$text = decode_utf8($text);
$text = unidecode($text);
$text = lc($text);

$text =~ s/[^\w'-]+/ /g;

my @words = grep { /^[a-z]/ } split ' ', $text;

my %dict  = build_dict(@words);
my $idx   = int(rand(@words - $n_max));
my @rotor = @words[$idx .. $idx + $n_min - 1];
my @chain = @rotor;

sub pick_next {
    my (@prefix) = @_;

    my $key = join(' ', @prefix);
    my @arr = @{$dict{$key}};

    $arr[rand @arr];
}

for (1 .. $max) {

    my $new = pick_next(@rotor);
    my $idx = int(rand($n_max - $n_min + 1) + $n_min - 1);

    if ($idx > $#rotor) {
        #shift(@rotor) if rand(1) < 0.5;
    }
    else {
        @rotor = @rotor[$#rotor - $idx + 1 .. $#rotor];
    }

    push @rotor, $new;
    push @chain, $new;
}

while (@chain) {
    say join(' ', splice(@chain, 0, 8));
}


================================================
FILE: Text/orthogonal_text_scrambling.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 July 2017
# https://github.com/trizen

# An interesting text scrambling algorithm, invented by the author in ~2008.

use utf8;
use 5.010;
use strict;
use warnings;

sub scramble {
    my ($str) = @_;

    my $i = length($str);
    $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0);
    return $str;
}

sub unscramble {
    my ($str) = @_;

    my $i = 0;
    my $l = length($str);
    $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l);
    return $str;
}

my $abc = "abcdefghijklmnopqrstuvwxyz";

say scramble($abc);                #=> "fvjnabdsgrpzxqeholmictyuwk"
say unscramble(scramble($abc));    #=> "abcdefghijklmnopqrstuvwxyz"


================================================
FILE: Text/orthogonal_text_scrambling_double.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 July 2017
# https://github.com/trizen

# An interesting text scrambling algorithm, invented by the author in ~2008.

use utf8;
use 5.010;
use strict;
use warnings;

sub scramble {
    my ($str) = @_;

    my $i = my $l = length($str);

    $str =~ s/(.{$i})(.)/$2$1/sg while (--$i > 0);
    $str =~ s/(.{$i})(.)/$2$1/sg while (++$i < $l);

    return $str;
}

sub unscramble {
    my ($str) = @_;

    my $i = my $l = length($str);

    $str =~ s/(.)(.{$i})/$2$1/sg while (--$i > 0);
    $str =~ s/(.)(.{$i})/$2$1/sg while (++$i < $l);

    return $str;
}

my $abc = "abcdefghijklmnopqrstuvwxyz";

say scramble($abc);                #=> "ckytmliqzrbjwuexhogpdsanvf"
say unscramble(scramble($abc));    #=> "abcdefghijklmnopqrstuvwxyz"


================================================
FILE: Text/repeated_substrings.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 27 April 2015
# website: https://github.com/trizen

# Find repeated substrings of a string. (fast solution)

# usage: perl repeated_substrings.pl < file.txt

use 5.010;
use strict;
use warnings;

sub rep_substrings {
    my ($str, $min, $max) = @_;

    my $limit = length($str);

    $min //= 4;
    $max //= int($limit) / 2;

    my @reps;
    my $cur_pos = $min;
    my $old_pos = 0;
    my $old_n   = 0;

    while ($cur_pos < $limit) {

        my $n   = 2;
        my $pos = 0;
        my $matched;

        while (   $pos != $old_pos + 1
               && $cur_pos + $n <= $limit
               && $n <= $max
               && (my $p = index(substr($str, 0, $cur_pos), substr($str, $cur_pos, $n), $pos)) >= 0) {
            ++$n;
            $pos = $p;
            !$matched && $n > $min && ($matched = 1);
        }

        if ($pos == $old_pos + 1) {
            $cur_pos += $old_n - 1;
        }
        else {
            push @reps, [$cur_pos, $pos, $n - 1, substr($str, $cur_pos, $n - 1)] if $matched;
            $cur_pos += 1;
        }

        $old_pos = $pos;
        $old_n   = $n - 1;
    }

    return \@reps;
}

my $text = @ARGV ? do { local $/; <> } : 'TOBEORNOTTOBEORTOBEORNOT#';
my $positions = rep_substrings($text);

my $total_len = 0;
foreach my $group (@{$positions}) {
    $total_len += length($group->[-1]);
}

eval {
    require Data::Dump;
    say Data::Dump::pp($positions);
};

say "\n** A total of $total_len characters!\n";


================================================
FILE: Text/search_by_prefix.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 29 July 2016
# Website: https://github.com/trizen

# Analyzes a list of strings and returns those that have a certain prefix

package Search::ByPrefix;

use 5.014;
use strict;
use warnings;

sub new {
    my ($class, %opt) = @_;
    bless {table => $opt{table} // {}}, $class;
}

sub add {
    my ($self, $key, $value) = @_;

    my $ref = $self->{table};
    foreach my $item (@$key) {
        $ref = $ref->{$item} //= {};
        push @{$ref->{values}}, \$value;
    }

    $self;
}

sub search {
    my ($self, $pattern) = @_;

    my $ref = $self->{table};

    foreach my $item (@$pattern) {
        if (exists $ref->{$item}) {
            $ref = $ref->{$item};
        }
        else {
            return;
        }
    }

    map { $$_ } @{$ref->{values}};
}

package main;

use File::Spec::Unix;
my $obj = Search::ByPrefix->new;

sub make_key {
    [File::Spec::Unix->splitdir($_[0])];
}

foreach my $dir (
                 qw(
                 /home/user1/tmp/coverage/test
                 /home/user1/tmp/covert/operator
                 /home/user1/tmp/coven/members
                 /home/user1/tmp2/coven/members
                 /home/user2/tmp2/coven/members
                 )
  ) {
    $obj->add(make_key($dir), $dir);
}

# Finds the common directories
say for $obj->search(make_key('/home/user1/tmp'));


================================================
FILE: Text/sim_end_words.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 17 April 2012
# https://github.com/trizen

# Group and list words from a wordlist that have similar ending chars

use strict;
use warnings;

use open IO => ':utf8', ':std';
use Getopt::Long qw(GetOptions);

my $min = 4;
my $max = 15;

my $min_words = 2;
my $max_words = 'inf';

my $unique = 0;

GetOptions(
           'end-min|end_min=i'     => \$min,
           'end-max|end_max=i'     => \$max,
           'group-min|group_min=i' => \$min_words,
           'group-max|group_max=i' => \$max_words,
           'unique!'               => \$unique,
          )
  or die "Error in command-line arguments!";

@ARGV or die <<"HELP";
usage: $0 [options] wordlists

options:
       --end-min=i   : minimum number of similar characters (default: $min)
       --end-max=i   : maximum number of similar characters (default: $max)
       --group-min=i : minimum number of words per group (default: $min_words)
       --group-max=i : maximum number of words per group (default: $max_words)
       --unique!     : don't use the same word in different groups (default: $unique)
HELP

--$min;    # starting with zero

foreach my $file (grep { -f } @ARGV) {
    my %table;
    open my $fh, '<', $file or do { warn "$0: can't open file $file: $!"; next };
    while (defined(my $line = <$fh>)) {
        chomp $line;

        next if (my $length = length($line)) <= $min;
        --$length;    # same as $#chars

        my @chars = split //, $line;
        for (my $i = $length - $min ; $i >= 0 ; --$i) {
            push @{$table{join q{}, @chars[$i .. $length]}}, $line;
        }
    }
    close $fh;

    my %data;
    my %seen;
    {
        local $, = "\n";
        local $\ = "\n";
        foreach my $key (
                         map  { $_->[1] }
                         sort { $b->[0] <=> $a->[0] }
                         map  { [scalar @{$table{$_}} => $_] } keys %table
          ) {
            next if length($key) > $max;
            @{$table{$key}} = do {
                my %s;
                grep { !$s{$_}++ } @{$table{$key}};
            };
            my $items = @{$table{$key}};
            next if $items < $min_words;
            next if $items > $max_words;

            if ($unique) {
                @{$table{$key}} = grep { not exists $seen{$_} } @{$table{$key}};
                @{$table{$key}} or next;
                @seen{@{$table{$key}}} = ();
            }

            #print "\e[1;46m$key\e[0m";
            print "\t\t\t==$key==";
            print @{$table{$key}};
        }
    }
}


================================================
FILE: Text/smartWordWrap.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 15th October 2013
# https://trizenx.blogspot.com

# Smart word wrap algorithm
# See: https://en.wikipedia.org/wiki/Word_wrap#Minimum_raggedness

use 5.016;
use strict;
use warnings;

package Smart::Word::Wrap {

    sub new {
        my (undef, %args) = @_;

        my %opt = (
                   width => 6,
                   text  => '',
                  );

        foreach my $key (keys %args) {
            if (exists $opt{$key}) {
                $opt{$key} = delete $args{$key};
            }
            else {
                local $" = ', ';
                die "ERROR: invalid key-option '$key' (expected one of {@{[keys %opt]}})";
            }
        }

        bless \%opt, __PACKAGE__;
    }

    # This is the ugliest function! It, recursively,
    # prepares the words for the make_paths() function.
    sub prepare_words {
        my ($self, @array) = @_;

        my @root;
        my $len = 0;

        for (my $i = 0 ; $i <= $#array ; $i++) {
            $len += (my $wordLen = length($array[$i]));

            if ($len > $self->{width}) {
                if ($wordLen > $self->{width}) {
                    $len -= $wordLen;
                    splice(@array, $i, 1, unpack "(A$self->{width})*", $array[$i]);
                    $i--, next;
                }
                last;
            }

            push @root, [@array[0 .. $i], __SUB__->($self, @array[$i + 1 .. $#{array}])];
            last if ++$len >= $self->{width};
        }

        @root ? @root : @array ? \@array : ();
    }

    # This function creates all the
    # available paths, for further processing.
    sub make_paths {
        my (@array) = @_;

        my @head;
        while (@array) {
            last if ref($array[0]) eq 'ARRAY';
            push @head, shift @array;
        }

        my @row;
        foreach my $path (@array) {
            push @row, {"@head" => __SUB__->(@{$path})};
        }

        @row ? \@row : "@head";
    }

    # This function combines the
    # the parents with the children.
    sub combine {
        my ($root, $hash) = @_;

        my @row;
        while (my ($key, $value) = each %{$hash}) {
            push @{$root}, $key;

            if (ref $value eq 'ARRAY') {
                foreach my $item (@{$value}) {
                    push @row, __SUB__->($root, $item);
                }
            }
            else {
                push @row, @{$root}, $value;
            }

            pop @{$root};
        }

        \@row;
    }

    # This function normalize the combinations.
    # Example: [[["abc"]]] is normalized to ["abc"];
    sub normalize {
        my ($array_ref) = @_;

        my @strings;
        foreach my $item (@{$array_ref}) {

            if (ref $item eq 'ARRAY') {
                push @strings, __SUB__->($item);
            }
            else {
                push @strings, $array_ref;
                last;
            }
        }

        @strings;
    }

    # This function finds the best
    # combination available and returns it.
    sub find_best {
        my ($self, @arrays) = @_;

        my %best = (score => 'inf');

        foreach my $array_ref (@arrays) {

            my $score = 0;
            foreach my $string (@{$array_ref}) {
                $score += ($self->{width} - length($string))**2;
            }

            if ($score < $best{score}) {
                $best{score} = $score;
                $best{value} = $array_ref;
            }
        }

        exists($best{value}) ? @{$best{value}} : ();
    }

    # This is the main function of the algorithm
    # which calls all the other functions and
    # returns the best possible wrapped string.
    sub smart_wrap {
        my ($self, %opt) = @_;

        if (%opt) {
            $self = $self->new(%{$self}, %opt);
        }

        my @words =
          ref($self->{text}) eq 'ARRAY'
          ? @{$self->{text}}
          : split(' ', $self->{text});

        my @paths;
        foreach my $group ($self->prepare_words(@words)) {
            push @paths, make_paths(@{$group});
        }

        my @combinations;
        while (@paths) {

            if (ref($paths[0]) eq 'ARRAY') {
                push @paths, @{shift @paths};
                next;
            }

            my $path = shift @paths;
            push @combinations, ref($path) eq 'HASH' ? [combine([], $path)] : [$path];
        }

        join("\n", $self->find_best(normalize(\@combinations)));
    }

}

#
## Usage example
#

my $text = 'aaa bb cc ddddd';

my $obj = Smart::Word::Wrap->new(width => 7);

say "=>>> SMART WRAP:";
say $obj->smart_wrap(text => $text);

say "\n=>>> GREEDY WRAP (Text::Wrap):";
require Text::Wrap;
$Text::Wrap::columns = $obj->{width};
$Text::Wrap::columns += 1;
say Text::Wrap::wrap('', '', $text);


================================================
FILE: Text/smartWordWrap_lazy.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 15th October 2013
# https://trizenx.blogspot.com
# https://trizenx.blogspot.com/2013/11/smart-word-wrap.html

# Smart word wrap algorithm
# See: https://en.wikipedia.org/wiki/Word_wrap#Minimum_raggedness

use 5.010;
use strict;
use warnings;

use experimental qw(signatures);

# This is the ugliest method! It, recursively,
# prepares the words for the combine() function.
sub prepare_words ($words, $width, $callback, $depth = 0) {

    my @root;
    my $len = 0;
    my $i   = -1;

    my $limit = $#{$words};
    while (++$i <= $limit) {
        $len += (my $word_len = length($words->[$i]));

        if ($len > $width) {
            if ($word_len > $width) {
                $len -= $word_len;
                splice(@$words, $i, 1, unpack("(A$width)*", $words->[$i]));
                $limit = $#{$words};
                --$i;
                next;
            }
            last;
        }

#<<<
        push @root, [
            join(' ', @{$words}[0 .. $i]),
            prepare_words([@{$words}[$i + 1 .. $limit]], $width, $callback, $depth + 1),
        ];
#>>>

        if ($depth == 0) {
            $callback->($root[0]);
            @root = ();
        }

        last if (++$len > $width);
    }

    \@root;
}

# This function combines the
# the parents with the children.
sub combine ($path, $callback, $root = []) {
    my $key = shift(@$path);
    foreach my $value (@$path) {
        push @$root, $key;
        if (@$value) {
            foreach my $item (@$value) {
                combine($item, $callback, $root);
            }
        }
        else {
            $callback->($root);
        }
        pop @$root;
    }
}

# This is the main function of the algorithm
# which calls all the other functions and
# returns the best possible wrapped string.
sub smart_wrap ($text, $width) {

    my @words = (
                 ref($text) eq 'ARRAY'
                 ? @{$text}
                 : split(' ', $text)
                );

    my %best = (
                score => 'inf',
                value => [],
               );

    prepare_words(
        \@words,
        $width,
        sub ($path) {
            combine(
                $path,
                sub ($combination) {
                    my $score = 0;
                    foreach my $line (@{$combination}[0 .. $#{$combination} - 1]) {
                        $score += ($width - length($line))**2;
                    }
                    if ($score < $best{score}) {
                        $best{score} = $score;
                        $best{value} = [@$combination];
                    }
                }
            );
        }
    );

    join("\n", @{$best{value}});
}

#
## Usage examples
#

my $text = 'aaa bb cc ddddd';
say smart_wrap($text, 6);

say '-' x 80;

$text = 'Lorem ipsum dolor sit amet, consectetur adipiscing elit.';
say smart_wrap($text, 20);

say '-' x 80;

$text = "Lorem ipsum dolor ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ amet, consectetur adipiscing elit.";
say smart_wrap($text, 20);

say '-' x 80;

$text = 'As shown in the above phases (or steps), the algorithm does many useless transformations';
say smart_wrap($text, 20);

say '-' x 80;

$text = 'Will Perl6 also be pre-installed on future Mac/Linux operating systems? ... I can\'t predict the success of the project';
say smart_wrap($text, 20);

say '-' x 80;

say smart_wrap(['a' .. 'n'], 5);


================================================
FILE: Text/smartWordWrap_simple.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 15th October 2013
# https://trizenx.blogspot.com

# Smart word wrap algorithm
# See: https://en.wikipedia.org/wiki/Word_wrap#Minimum_raggedness

use 5.016;
use strict;
use warnings;

package Smart::Word::Wrap {

    sub new {
        my (undef, %args) = @_;

        my %opt = (
                   width => 6,
                   text  => '',
                  );

        foreach my $key (keys %args) {
            if (exists $opt{$key}) {
                $opt{$key} = delete $args{$key};
            }
            else {
                local $" = ', ';
                die "ERROR: invalid key-option '$key' (expected one of {@{[keys %opt]}})";
            }
        }

        bless \%opt, __PACKAGE__;
    }

    # This is the ugliest function! It, recursively,
    # prepares the words for the combine() function.
    sub prepare_words {
        my ($self, @array) = @_;

        my @root;
        my $len = 0;

        for (my $i = 0 ; $i <= $#array ; $i++) {
            $len += (my $wordLen = length($array[$i]));

            if ($len > $self->{width}) {
                if ($wordLen > $self->{width}) {
                    $len -= $wordLen;
                    splice(@array, $i, 1, unpack "(A$self->{width})*", $array[$i]);
                    $i--, next;
                }
                last;
            }

            push @root, {"@array[0 .. $i]" => __SUB__->($self, @array[$i + 1 .. $#{array}])};
            last if ++$len >= $self->{width};
        }

        @root ? \@root : undef;
    }

    # This function combines the
    # the parents with the children.
    sub combine {
        my ($root, $hash) = @_;

        my @row;
        while (my ($key, $value) = each %{$hash}) {
            push @{$root}, $key;

            if (ref $value eq 'ARRAY') {
                foreach my $item (@{$value}) {
                    push @row, __SUB__->($root, $item);
                }
            }
            else {
                @row = [@{$root}];
            }

            pop @{$root};
        }

        @row;
    }

    # This function finds the best
    # combination available and returns it.
    sub find_best {
        my ($self, @arrays) = @_;

        my %best = (
                    score => 'inf',
                    value => [],
                   );

        foreach my $array_ref (@arrays) {

            my $score = 0;
            foreach my $string (@{$array_ref}) {
                $score += ($self->{width} - length($string))**2;
            }

            if ($score < $best{score}) {
                $best{score} = $score;
                $best{value} = $array_ref;
            }
        }

        @{$best{value}};
    }

    # This is the main function of the algorithm
    # which calls all the other functions and
    # returns the best possible wrapped string.
    sub smart_wrap {
        my ($self, %opt) = @_;

        if (%opt) {
            $self = $self->new(%{$self}, %opt);
        }

        my @words =
          ref($self->{text}) eq 'ARRAY'
          ? @{$self->{text}}
          : split(' ', $self->{text});

        join "\n", $self->find_best(map { combine([], $_) } @{$self->prepare_words(@words)});
    }

}

#
## Usage example
#

my $text = 'As shown in the above phases (or steps), the algorithm does many useless transformations';

my $obj = Smart::Word::Wrap->new(width => 20);

say "=>>> SMART WRAP:";
say $obj->smart_wrap(text => $text);

say "\n=>>> GREEDY WRAP (Text::Wrap):";
require Text::Wrap;
$Text::Wrap::columns = $obj->{width};
$Text::Wrap::columns += 1;
say Text::Wrap::wrap('', '', $text);

say "\n", '-' x 80, "\n";

say "=>>> SMART WRAP:";
$text = 'Lorem ipsum dolor sit amet, consectetur adipiscing elit.';
say $obj->smart_wrap(text => $text);

say "\n=>>> GREEDY WRAP (Text::Wrap):";
say Text::Wrap::wrap('', '', $text);


================================================
FILE: Text/unique_prefixes.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 28 September 2014
# Website: https://github.com/trizen

# Find the unique prefixes for an array of arrays of strings

use 5.016;
use strict;
use warnings;

sub abbrev {
    my ($array, $code) = @_;

    my $__END__  = {};                     # some unique value
    my $__CALL__ = ref($code) eq 'CODE';

    my %table;
    foreach my $sub_array (@{$array}) {
        my $ref = \%table;
        foreach my $item (@{$sub_array}) {
            $ref = $ref->{$item} //= {};
        }
        $ref->{$__END__} = $sub_array;
    }

    my @abbrevs;
    sub {
        my ($hash) = @_;

        foreach my $key (my @keys = sort keys %{$hash}) {
            next if $key eq $__END__;
            __SUB__->($hash->{$key});

            if ($#keys > 0) {
                my $count = 0;
                my $ref   = $hash->{$key};
                while (my ($key) = each %{$ref}) {
                    if ($key eq $__END__) {
                        my $arr = [@{$ref->{$key}}[0 .. $#{$ref->{$key}} - $count]];
                        $__CALL__ ? $code->($arr) : push(@abbrevs, $arr);
                        last;
                    }
                    $ref = $ref->{$key};
                    $count++;
                }
            }
        }
      }
      ->(\%table);

    return \@abbrevs;
}

#
## Example: find the common directory from a list of dirs
#

my @dirs = qw(
  /home/user1/tmp/coverage/test
  /home/user1/tmp/covert/operator
  /home/user1/tmp/coven/members
  );

require List::Util;
my $unique_prefixes = abbrev([map { [split('/')] } @dirs]);
my %table = map { $#{$_} => $_ } @{$unique_prefixes};
my $min = List::Util::min(keys %table);

say "=>> Common directory:";
say join('/', splice(@{$table{$min}}, 0, -1));

my @words = qw(
  deodorant
  decor
  decorat
  decadere
  plecare
  placere
  plecat
  jaguar
  );

say "\n=>> Unique prefixes:";
abbrev([map { [split //] } @words], sub { say @{$_[0]} });


================================================
FILE: Text/word_roots.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 11th September 2014
# https://github.com/trizen

# Find the minimum word derivations for a list of words

use 5.016;
use strict;
use warnings;

no warnings 'recursion';

sub make_tree {
    my ($fh) = @_;

    my %table;
    while (defined(my $word = unpack('A*', scalar(<$fh>) // last))) {
        my $ref = \%table;
        foreach my $char (split //, $word) {
            $ref = $ref->{$char} //= {};
        }
        undef $ref->{$word};
    }

    return \%table;
}

sub traverse(&$) {
    my ($code, $hash) = @_;

    foreach my $key (my @keys = sort keys %{$hash}) {
        __SUB__->($code, $hash->{$key});

        if ($#keys > 0) {

            my $count = 0;
            my $ref = my $val = delete $hash->{$key};

            while (my ($key) = each %{$ref}) {
                $ref = $val = $ref->{$key // last} // ($code->(substr($key, 0, length($key) - $count)), last);
                ++$count;
            }
        }
    }
}

traverse { say shift } make_tree(@ARGV ? \*ARGV : \*DATA);

__END__
deodorant
decor
decadere
plecare
placere
plecat
jaguar


================================================
FILE: Text/word_unscrambler.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# Date: 05 September 2020
# https://github.com/trizen

# Find words in a given scrambled word, using a dictionary.

use 5.020;
use strict;
use warnings;

use open IO => ':utf8', ':std';

use Term::ReadLine;
use List::Util qw(min uniq);
use Algorithm::Combinatorics qw(combinations);
use experimental qw(signatures);
use Encode qw(decode_utf8);

my $dict_file = '/usr/share/dict/words';

my $unidecode        = 0;    # plain ASCII transliterations of Unicode text
my $group_by_length  = 1;    # group words by length
my $case_insensitive = 0;    # case-insensitive mode

my $min_length = 3;          # minimum number of letters a word must have
my $max_length = 0;          # maximum number of letters a word must have (0 for no limit)

sub normalize_word ($word) {

    if ($unidecode) {        # Unicode to ASCII
        require Text::Unidecode;
        $word = Text::Unidecode::unidecode($word);
    }

    if ($case_insensitive) {
        $word = CORE::fc($word);
    }

    return $word;
}

sub create_optimized_dictionary ($file) {

    open my $fh, '<:utf8', $file
      or die "Can't open file <<$file>> for reading: $!";

    my %dict;

    while (defined(my $line = <$fh>)) {

        $line =~ s{/\w+}{};

        my @words = split(' ', $line);

        foreach my $word (@words) {

            # Ignore too short words
            if ($min_length > 0 and length($word) < $min_length) {
                next;
            }

            # Ignore too long words
            if ($max_length > 0 and length($word) > $max_length) {
                next;
            }

            $word = normalize_word($word);

            # Add the word into the hash table
            push(@{$dict{join('', sort split(//, $word))}}, $word);
        }
    }

    close $fh;
    return \%dict;    # return dictionary
}

sub find_unscrambled_words ($word, $dict) {

    $word = normalize_word($word);

    my @found;
    my @chars = sort split(//, $word);    # split word into characters

    foreach my $k (($min_length || 1) .. min($max_length || scalar(@chars), scalar(@chars))) {

        # Create combination of words of k characters
        my $iter = combinations(\@chars, $k);

        while (my $arr = $iter->next) {

            my $unscrambled = join('', @$arr);

            # Check each combination if it exists inside the dictionary
            if (exists $dict->{$unscrambled}) {

                # Store the words made from this combination of letters
                push @found, @{$dict->{$unscrambled}};
            }
        }
    }

    return uniq(@found);
}

my $dict = create_optimized_dictionary($dict_file);
my $term = Term::ReadLine->new("Word Unscrambler");

while (1) {

    chomp(my $word = decode_utf8($term->readline("Word: ") // last));

    my @unscrambled = find_unscrambled_words($word, $dict);

    my %groups;
    foreach my $word (@unscrambled) {
        push @{$groups{length($word)}}, $word;
    }

    say '';
    foreach my $len (sort { $b <=> $a } keys %groups) {

        if ($group_by_length) {
            say join(" ", sort @{$groups{$len}});
        }
        else {
            say for sort @{$groups{$len}};
        }
    }
    say '';
}


================================================
FILE: Time/calendar.pl
================================================
#!/usr/bin/perl

# cal.pl - Display the calendar of a given month.
# Fedon Kadifeli, 1998 - April 2003.
# Improved by Trizen - February 2012

my (%months) = (
                '1'  => {LENGTH => 31, NAME => 'January'},
                '2'  => {LENGTH => 28, NAME => 'February'},
                '3'  => {LENGTH => 31, NAME => 'March'},
                '4'  => {LENGTH => 30, NAME => 'April'},
                '5'  => {LENGTH => 31, NAME => 'May'},
                '6'  => {LENGTH => 30, NAME => 'June'},
                '7'  => {LENGTH => 31, NAME => 'July'},
                '8'  => {LENGTH => 31, NAME => 'August'},
                '9'  => {LENGTH => 30, NAME => 'September'},
                '10' => {LENGTH => 31, NAME => 'October'},
                '11' => {LENGTH => 30, NAME => 'November'},
                '12' => {LENGTH => 31, NAME => 'December'},
               );

my ($day, $real_month, $real_year) = (localtime time)[3 .. 5];
my ($month, $year) = ($real_month += 1, $real_year += 1900);

if (@ARGV and $ARGV[0] =~ /^(?:\d\d?|\w{3,})$/) {
    $month = shift @ARGV;
    if ($month =~ /^ *\d\d? *$/) {
        unless ($month >= 1 and $month <= 12) {
            die "Month must be between 1 and 12!\n";
        }
        $month = int $month;
    }
    else {
        while (my ($k, $v) = each %months) {
            if ($$v{'NAME'} =~ /^\Q$month\E/io) {
                $month = $k;
                last;
            }
        }
        $month = $real_month unless $month =~ /^\d\d?$/;
    }
}

if (@ARGV and $ARGV[0] =~ /^\d\d\d\d$/) {
    $year = int shift @ARGV;
}

printf "%*s\n%s\n", 11 + (5 + length($months{$month}{'NAME'})) / 2,
  "$months{$month}{'NAME'} $year", 'Su Mo Tu We Th Fr Sa';

if ($year % 400 == 0 or $year % 4 == 0 and $year % 100 != 0) {
    $months{'2'}{'LENGTH'} = 29;
}
--$year;

my $st = 1 + $year * 365 + int($year / 4) - int($year / 100) + int($year / 400);

foreach my $i (1 .. $month - 1) {
    $st += $months{$i}{'LENGTH'};
}

print q{   } x ($st % 7);
++$year;

foreach my $i (1 .. $months{$month}{'LENGTH'}) {
    if ($i == $day and $year == $real_year and $month == $real_month) {
        printf '%s%2d%s ', "\e[7m", $i, "\e[0m";
    }
    else {
        printf '%2d ', $i;
    }

    print "\n" if ($st + $i) % 7 == 0 and $i != $months{$month}{'LENGTH'};
}

print "\n\n";


================================================
FILE: Time/contdown.pl
================================================
#!/usr/bin/perl

use 5.010;
use strict;
use warnings;

use Time::Piece;
use Time::Seconds;

sub _div {
    my $quot = $_[0] / $_[1];
    my $int  = int($quot);
    $int > $quot ? $int - 1 : $int;
}

sub leap_year {
    my ($y) = @_;
    (($y % 4 == 0) and ($y % 400 == 0 or $y % 100 != 0)) || 0;
}

{
    #<<<
    my @days_in_month = (
                         [0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],
                         [0, 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31],
                        );
    #>>>

    sub days_in_month ($$) {
        my ($y, $m) = @_;
        $days_in_month[leap_year($y)][$m];
    }
}

sub ymd_to_days {
    my ($Y, $M, $D) = @_;

    if (   $M < 1
        || $M > 12
        || $D < 1
        || ($D > 28 && $D > days_in_month($Y, $M))) {
        return undef;
    }

    my $x = ($M <= 2 ? $Y - 1 : $Y);
    my $days = $D + (undef, -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333)[$M];

    $days += 365 * ($Y - 1970);
    $days += _div(($x - 1968), 4);
    $days -= _div(($x - 1900), 100);
    $days += _div(($x - 1600), 400);

    $days;
}

{
    my $t = localtime;

    my $now = ymd_to_days($t->year, $t->mon, $t->mday) + $t->sec / (60 * 60 * 24) + $t->min / (60 * 24);
    my $then = ymd_to_days(2014, 7, 29) - (3 / 24);

    local $| = 1;
    while ((my $diff = $then - $now) > 0) {
        printf("* Seconds: %d | Minutes: %.2f | Days: %.2f\r", 86400 * $diff, 86400 * $diff / 60, $diff);
        $now += 1 / 86400;
        sleep 1;
    }
}


================================================
FILE: Video/sponsor-free.pl
================================================
#!/usr/bin/env perl

# SponsorBlock CLI for YouTube Videos
# Marks or removes sponsored segments using FFmpeg.

# Dependencies:
#   ffmpeg
#   URI
#   IO::Socket::SSL

# Inspired by:
#   https://github.com/faissaloo/SponSkrub

use 5.036;

use URI;
use HTTP::Tiny;
use Getopt::Long qw(:config no_ignore_case bundling);
use JSON::PP     qw(decode_json encode_json);
use Digest::SHA  qw(sha256_hex);
use File::Temp   qw(tempfile);

# ==============================================================================
# Configuration & CLI Parsing
# ==============================================================================

my $appname = 'sponsor-free';
my $version = '0.01';

my %cfg = (
           action     => 'cut',                        # 'cut' or 'chapter'
           categories => 'sponsor',                    # comma-separated
           api_url    => 'https://sponsor.ajay.app',
           direct     => 0,                            # Use direct videoID lookup instead of hash
           proxy      => $ENV{HTTP_PROXY} // '',
           keep_date  => 0,
           tolerance  => 1,                            # tolerance in seconds for video duration (local vs server)
          );

my $remove_all = 0;

my @available_categories = qw(
  sponsor intro outro interaction selfpromo music_offtopic
);

GetOptions(
           'h|help'         => sub { show_help(0) },
           'v|version'      => sub { show_version() },
           'a|action=s'     => \$cfg{action},
           'c|categories=s' => \$cfg{categories},
           'all'            => \$remove_all,
           'api-url=s'      => \$cfg{api_url},
           'direct'         => \$cfg{direct},
           'proxy=s'        => \$cfg{proxy},
           'tolerance=f'    => \$cfg{tolerance},
           'keep-date'      => \$cfg{keep_date},
          )
  or show_help(1);

if ($remove_all) {
    $cfg{categories} = join(',', @available_categories);
}

my ($video_id, $input_file, $output_file) = @ARGV;

show_help(1)
  unless ($video_id && $input_file && $output_file);

die "Invalid action: $cfg{action}\n" unless $cfg{action} =~ /^(cut|chapter)$/;

# ==============================================================================
# Main Execution
# ==============================================================================

my $duration = extract_duration($input_file);
my $bitrate  = extract_bitrate($input_file);

die "Could not determine video duration. Is FFmpeg installed?\n" unless $duration;

say "Fetching SponsorBlock data...";
my @categories = split(',', $cfg{categories});
my @sponsors   = fetch_sponsor_data($video_id, \@categories, $duration);

unless (@sponsors) {
    say "No matching segments found. Nothing to do.";
    exit 0;
}

say "Found " . scalar(@sponsors) . " segment(s).";

my @chapters = get_existing_chapters($input_file, $duration);
my @merged   = merge_segments(\@sponsors, \@chapters);

if ($cfg{action} eq 'chapter') {
    say "Injecting chapters...";
    my $meta = build_ffmpeg_metadata(@merged);
    run_ffmpeg_metadata_pass($input_file, $output_file, $meta);
}
else {    # cut
    say "Removing segments...";
    my @keep = grep { $_->{type} eq 'content' } @merged;
    my $meta = build_ffmpeg_metadata(recalculate_kept_chapters(@keep));

    my $streams = extract_streams($input_file);
    my $has_vid = $streams =~ /video/;
    my $has_aud = $streams =~ /audio/;

    run_ffmpeg_cut_pass($input_file, $output_file, \@keep, $has_vid, $has_aud, $meta);
}

if ($cfg{keep_date}) {
    my @s = stat($input_file);
    utime($s[8], $s[9], $output_file);
}

say "Success! Output saved to: $output_file";
exit 0;

# ==============================================================================
# API Client
# ==============================================================================

sub fetch_sponsor_data ($vid, $cats, $duration) {
    my $http      = HTTP::Tiny->new(proxy => $cfg{proxy} || undef, timeout => 30);
    my $cats_json = encode_json($cats);

    my $url = URI->new("$cfg{api_url}/api/skipSegments");

    if ($cfg{direct}) {
        $url->query_form(videoID    => $vid,
                         categories => $cats_json);
    }
    else {
        my $hash = substr(sha256_hex($vid), 0, 4);    # 4-char prefix is standard for privacy API
        $url->path($url->path . '/' . $hash);
        $url->query_form(categories => $cats_json);
    }

    my $res = $http->get($url);
    return () if $res->{status} == 404;               # No segments
    die "API Error $res->{status}: $res->{reason}\n" unless $res->{success};

    my $data = decode_json($res->{content});

    # If using privacy API, filter the returned list by the exact videoID
    $data = [map { $_->{segments}->@* } grep { $_->{videoID} eq $vid } @$data] unless $cfg{direct};

    foreach my $segment (@$data) {
        if (abs($segment->{videoDuration} - $duration) > $cfg{tolerance}) {
            warn "The input does not match the video duration!\n";
            return ();
        }
    }

    return map {
        ;
        {
         start => sprintf('%.6f', $_->{segment}[0]),
         end   => sprintf('%.6f', $_->{segment}[1]),
         title => $_->{category},
         type  => 'sponsor',
        }
    } $data->@*;
}

# ==============================================================================
# Timeline Mathematics
# ==============================================================================

sub get_existing_chapters ($file, $duration) {

    my $json_str = ffprobe($file, qw(-show_chapters -print_format json));
    my $data     = decode_json($json_str // '{}');

    my @chaps =
      map {
        ;
        {
         start => $_->{start_time},
         end   => $_->{end_time},
         title => $_->{tags}{title} // 'Chapter',
         type  => 'content',
        }
      } ($data->{chapters} // [])->@*;

    if (!@chaps) {
        @chaps = (
                  {
                   start => 0,
                   end   => $duration,
                   title => 'Content',
                   type  => 'content',
                  }
                 );
    }

    return @chaps;
}

# Flattens overlapping intervals (sponsors override content)
sub merge_segments ($sponsors, $chapters) {
    my @timeline;

    # Convert all events into start/end points
    for my $c ($chapters->@*) {
        push @timeline, {t => $c->{start}, type => 'content_start', title => $c->{title}};
        push @timeline, {t => $c->{end}, type => 'content_end'};
    }
    for my $s ($sponsors->@*) {
        push @timeline, {t => $s->{start}, type => 'sponsor_start', title => $s->{title}};
        push @timeline, {t => $s->{end}, type => 'sponsor_end'};
    }

    @timeline = sort { $a->{t} <=> $b->{t} || $a->{type} cmp $b->{type} } @timeline;

    my @merged;
    my ($cur_time, $cur_title, $sponsor_depth) = (0, 'Content', 0);

    for my $ev (@timeline) {
        if ($ev->{t} > $cur_time) {
            push @merged,
              {
                start => $cur_time,
                end   => $ev->{t},
                title => $sponsor_depth > 0 ? "[Skip] $cur_title" : $cur_title,
                type  => $sponsor_depth > 0 ? 'sponsor'           : 'content'
              };
        }
        $cur_time = $ev->{t};
        $sponsor_depth++          if $ev->{type} eq 'sponsor_start';
        $sponsor_depth--          if $ev->{type} eq 'sponsor_end';
        $cur_title = $ev->{title} if $ev->{type} =~ /start$/;
    }

    # Filter out zero-length segments
    return grep { $_->{end} > $_->{start} } @merged;
}

sub recalculate_kept_chapters (@kept) {
    my ($cur, @out) = (0);
    for my $seg (@kept) {
        my $len = $seg->{end} - $seg->{start};
        push @out, {start => $cur, end => $cur + $len, title => $seg->{title}};
        $cur += $len;
    }
    return @out;
}

# ==============================================================================
# FFmpeg Wrappers
# ==============================================================================

sub ffprobe ($file, @args) {
    chomp(my $out = `ffprobe -loglevel quiet @args \Q$file\E 2>&1`);
    return $? == 0 ? $out : undef;
}

sub extract_bitrate ($file) {
    ffprobe($file, qw(-show_entries format=bit_rate -of default=noprint_wrappers=1:nokey=1));
}

sub extract_duration ($file) {
    ffprobe($file, qw(-show_entries format=duration -of default=noprint_wrappers=1:nokey=1));
}

sub extract_streams ($file) {
    ffprobe($file, qw(-show_entries stream=codec_type -print_format default=noprint_wrappers=1:nokey=1));
}

sub run_ffmpeg_metadata_pass ($in, $out, $meta) {
    my $meta_file = create_temp_file($meta);
    my @cmd =
      ('ffmpeg', '-y', '-loglevel', 'warning', '-stats', '-i', $in, '-i', $meta_file, '-map_metadata', '1', '-map_chapters', '1', '-codec', 'copy', $out);
    system(@cmd) == 0 or die "FFmpeg failed.\n";
    unlink $meta_file;
}

sub run_ffmpeg_cut_pass ($in, $out, $clips, $has_v, $has_a, $meta) {
    my $n = scalar $clips->@*;

    my @ts  = sort { $a->{start} <=> $b->{start} } @$clips;
    my @idx = 0 .. $n - 1;

    my $vouts  = join '', map { "[vcopy$_]" } @idx;
    my $aouts  = join '', map { "[acopy$_]" } @idx;
    my $vclips = join '', map { "[vcopy$_] trim=$ts[$_]{start}:$ts[$_]{end},setpts=PTS-STARTPTS[v$_]," } @idx;
    my $aclips = join '', map { "[acopy$_] atrim=$ts[$_]{start}:$ts[$_]{end},asetpts=PTS-STARTPTS[a$_]," } @idx;

    my $filter = '';
    if ($has_a && $has_v) {
        $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]";
    }
    elsif ($has_v) {
        $filter = "[0:v]split=$n$vouts,${vclips}" . join(' ', map { "[v$_]" } @idx) . " concat=n=$n:v=1[v]";
    }
    elsif ($has_a) {
        $filter = "[0:a]asplit=$n$aouts,${aclips}" . join(' ', map { "[a$_]" } @idx) . " concat=n=$n:v=0:a=1[a]";
    }

    my $meta_file = create_temp_file($meta);

    my @cmd = ('ffmpeg', '-y', '-loglevel', 'warning', '-stats', '-i', $in, '-i', $meta_file, '-filter_complex', $filter);
    push @cmd, '-map', '[v]' if $has_v;
    push @cmd, '-map', '[a]' if $has_a;

    if ($has_v) {

        # push @cmd, '-b:v', $bitrate;   # for better quality, let ffmpeg decide
    }
    elsif ($has_a) {
        push @cmd, '-b:a', $bitrate;
    }

    push @cmd, '-map_metadata', '1', '-map_chapters', '1', $out;

    system(@cmd) == 0 or die "FFmpeg failed.\n";
    unlink $meta_file;
}

sub build_ffmpeg_metadata (@chapters) {
    my $meta = ";FFMETADATA1\n";
    for my $ch (@chapters) {
        $meta .= "[CHAPTER]\nTIMEBASE=1/1\nSTART=$ch->{start}\nEND=$ch->{end}\ntitle=$ch->{title}\n";
    }
    return $meta;
}

sub create_temp_file ($content) {
    my ($fh, $file) = tempfile(SUFFIX => '.txt');
    print $fh $content;
    close $fh;
    return $file;
}

sub show_version {
    print "$appname $version\n";
    exit 0;
}

sub show_help ($code) {
    local $" = ",";
    print <<"USAGE";
Usage: $0 [options]   

Options:
  -a, --action       Action to perform: 'cut' (default) or 'chapter'.
  -c, --categories   Comma-separated categories to target. (default: $cfg{categories})
                           Available: @available_categories
  --all                    Remove all categories
  --tolerance       Tolerance, in seconds, for the duration of the video (default: $cfg{tolerance})
  --direct                 Bypass privacy hash and query API directly via Video ID.
  --proxy             Route requests through a proxy.
  --api-url           Override SponsorBlock API URL.
  --keep-date              Preserve original file modification timestamp.
  -h, --help               Show this help message.
USAGE
    exit $code;
}


================================================
FILE: Video/video_concat_ffmpeg.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 21 August 2025
# https://github.com/trizen

# Concatenate multiple MP4 video files, given as arguments, into one single file called "CONCATENATED.mp4".

# Requires: ffmpeg

use 5.036;
use File::Temp            qw(tempfile tempdir);
use File::Path            qw(make_path);
use File::Spec::Functions qw(catfile curdir);
use Image::ExifTool       qw(ImageInfo);

my $output_filename = "CONCATENATED.mp4";
my $output_dir      = tempdir(CLEANUP => 1, DIR => curdir());

sub new_tempfile {
    my ($fh, $filename) = tempfile("tmpfileXXXXX", SUFFIX => '.txt', UNLINK => 1);
    return ($fh, $filename);
}

sub make_video_filename($i) {
    catfile($output_dir, sprintf('output_%05d.mp4', $i));
}

sub make_ffmpeg_filename_entry($file) {
    sprintf("file '%s'\n", $file);
}

sub ffmpeg_concat_files ($filename, $output_filename) {
    system('ffmpeg', '-loglevel', 'fatal', '-f', 'concat', '-i', $filename, '-c:v', 'copy', '-c:a', 'aac', '-y', $output_filename);
    $? == 0 or die "Stopped with exit code = $?";
}

my $mp4_version = undef;

my $i = 1;
my ($fh, $filename) = new_tempfile();

foreach my $file (@ARGV) {

    my $info    = ImageInfo($file);
    my $version = $info->{'MajorBrand'};

    $mp4_version //= $version;

    if ($version ne $mp4_version) {
        $mp4_version = undef;
        ffmpeg_concat_files($filename, make_video_filename($i));
        ($fh, $filename) = new_tempfile();
        ++$i;
    }

    print $fh make_ffmpeg_filename_entry($file);
}

ffmpeg_concat_files($filename, make_video_filename($i));

($fh, $filename) = new_tempfile();

foreach my $k (1 .. $i) {
    my $file = make_video_filename($k);
    print $fh make_ffmpeg_filename_entry($file);
}

close $fh;
ffmpeg_concat_files($filename, $output_filename);


================================================
FILE: Video/video_split_ffmpeg.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 24 August 2025
# https://github.com/trizen

# Split a video file into multiple parts of length `n` seconds, or into `n` equal parts.

# Requires: ffmpeg

use 5.036;
use Getopt::Long qw(GetOptions);

my $parts           = undef;
my $duration        = undef;
my $output_template = "PART_%04d.mp4";

sub usage($exit_code = 0) {

    print <<"EOT";
usage: $0 [options] [video.mp4]

options:

    --parts=i     : split into `i` equal parts
    --duration=i  : split into segments of length `i` seconds
    --template=s  : output filename template (default: $output_template)
    --help        : display this message and exit

example:

    # Split video.mp4 into 3 equal parts
    perl $0 --parts=3 video.mp4

    # Split video.mp4 into equal parts of 10 seconds length
    perl $0 --duration=10 video.mp4
EOT

    exit($exit_code);
}

GetOptions(
           "duration=i" => \$duration,
           "parts=i"    => \$parts,
           "template=s" => \$output_template,
           "h|help"     => sub { usage() },
          )
  or die("Error in command line arguments\n");

if (!defined($parts) and !defined($duration)) {
    usage(1);
}

my $input_video = shift(@ARGV) // usage(2);

if (not -f $input_video) {
    die "Not a file <<$input_video>>: $!";
}

if (defined($parts)) {
    $duration = `ffprobe -v error -show_entries format=duration -of csv=p=0 \Q$input_video\E`;
    chomp($duration);
    $duration /= $parts;
}

system(qw(ffmpeg -loglevel fatal -i), $input_video,                                qw(-acodec copy -f segment -segment_time),
       $duration,                     qw(-vcodec copy -reset_timestamps 1 -map 0), $output_template);

if ($? == 0) {
    say ":: Done!";
}
else {
    die "Something went wrong! ffmpeg exit code: $?";
}


================================================
FILE: Visualisators/binview.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# License: GPLv3
# Date: 09 October 2013
# https://trizenx.blogspot.com

# Prints bits and bytes (or byte values) from a binary file.

use 5.010;
use strict;
use autodie;
use warnings;

sub usage {
    print STDERR "usage: $0 file [cols]\n";
    exit 1;
}

my $file = shift() // usage();
my $cols = shift() // 1;

sysopen my $fh, $file, 0;
while (sysread($fh, (my $chars), $cols) > 0) {
    foreach (split //, $chars) {
        printf "%10s%4s", unpack("B*"), /[[:print:]]/ ? $_ : sprintf("%03d", ord);
    }
    print "\n";
}
close $fh;


================================================
FILE: Visualisators/disk-stats.pl
================================================
#!/usr/bin/perl

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 30 January 2013
# https://github.com/trizen

# Show disk and RAM usage.

use 5.010;
use strict;
use warnings;

use List::Util qw(max);
use Term::ANSIColor qw(colored color);
use Number::Bytes::Human qw(format_bytes);

my %CONFIG = (DF_COMMAND => 'df -Th');

sub get_ram {

    # RAM
    my $freeram   = 0;
    my $totalram  = 0;
    my $match_ram = qr/:\s+(\d+)/;

    {
        open my $ram_fh, '<', '/proc/meminfo';
        while (defined(my $ram_line = <$ram_fh>)) {
            $totalram = $1 / 1024 if $. == 1 and $ram_line =~ /$match_ram/o;
            $freeram += $1 / 1024 if $. > 1  and $ram_line =~ /$match_ram/o;
            last if $. == 4;
        }
        close $ram_fh;
    }

    my $usedram      = $totalram - $freeram;
    my $used_percent = $usedram / $totalram * 100;

    return
      scalar {
              name         => "/dev/mem",
              used         => format_bytes($usedram * 1024**2),
              total        => format_bytes($totalram * 1024**2),
              used_percent => $used_percent,
             };
}

sub get_partitions {
    my @partitions;
    open my $df_pipe, '-|', $CONFIG{DF_COMMAND};
    while (defined($df_pipe) and defined(my $line = <$df_pipe>)) {
        chomp($line);

        my (undef, $type, $totalsize, $used, undef, $used_percent, $mountpoint) = split(' ', $line, 7);
        $used_percent =~ s/^\d+\K%\z// or next;

        #$mountpoint =
        #    $mountpoint eq '/' ? 'Root'
        #  : $mountpoint =~ m{^.*/}s ? ucfirst substr($mountpoint, $+[0])
        #  :                           ucfirst $mountpoint;

        push @partitions,
          scalar {
                  name         => $mountpoint,
                  used_percent => $used_percent,
                  total        => $totalsize,
                  used         => $used,
                 };
    }
    close $df_pipe;

    my %seen;
    return grep { !$seen{join $;, %{$_}}++ } @partitions;
}

my @data = (get_ram(), get_partitions());

my %data;
push @{$data{names}}, map { $_->{name} } @data;
push @{$data{usage}}, map { "$_->{used}/$_->{total}" } @data;

my $left_cut  = max(map { length } @{$data{names}});
my $right_cut = max(map { length } @{$data{usage}});

my $width = (split(' ', `stty size`))[1];

foreach my $i (0 .. $#data) {

    my $hash_ref = $data[$i];
    my $barw     = $width - ($left_cut + $right_cut + 2);
    my $used     = sprintf "%.0f", $barw * ($hash_ref->{used_percent} / 100);

    my $bar   = '';
    my $pos   = 0;
    my $bleft = 0;

    my @colors = ([50, 'green'], [80, 'yellow'], [100, 'red']);
    until ($bleft >= $used) {
        my ($size, $color) = @{shift @colors};

        my $barsize = sprintf "%.0f",
          $hash_ref->{used_percent} > $size ? (($size - $pos) / 100 * $barw) : ($used - $bleft);

        $bar .= colored('>' x $barsize, "bold $color");
        $pos   += $size;
        $bleft += $barsize;
    }

    printf "%s%-${left_cut}s%s[%s%s]%s%${right_cut}s%s\n", color('bright_blue'), $data{names}[$i], color('reset'),
      $bar, " " x ($barw - $used), color('green'), $data{usage}[$i], color('reset');
}


================================================
FILE: Visualisators/dnscrypt_stats.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# Date: 04 May 2022
# May the 4th Be With You
# https://github.com/trizen

# Show human-readable stats for the dnscrypt-proxy query log.

use 5.020;
use strict;
use warnings;

use List::Util qw(sum uniq);
use experimental qw(signatures);
use Getopt::Long qw(GetOptions);

binmode(STDOUT, ':utf8');

my $top      = 10;
my $log_file = '/var/log/dnscrypt-proxy/query.log';

sub help {
    print <<"EOT";
usage: $0 [options]

options:

    --top=i   : display the top results (default: $top)
    --file=s  : path to the log file
    --help    : display this message

EOT

    exit;
}

GetOptions(
           "top=i"  => \$top,
           "file=s" => \$log_file,
           "h|help" => \&help,
          )
  or die("Error in command line arguments\n");

my %domains;
my %resolvers;
my %cache_misses;
my %cache_hits;
my @durations;

my @recent_domains;
my @recent_resolvers;

open my $fh, '<:utf8', $log_file
  or die "Can't open <<$log_file>>: $!";

while (<$fh>) {
    if (m{^\[.*?\]\s+\S+\s+(\S+)\s+\S+\s+(\S+)\s+(\S+)\s+(\S+)}) {
        my ($host, $status, $time_ms, $resolver) = ($1, $2, $3, $4);

        $status eq 'PASS' or next;

        $domains{$host}++;

        if ($resolver eq '-') {
            $resolvers{'--cache--'}++;
            $cache_hits{$host}++;
        }
        else {
            $cache_misses{$host}++;
            $resolvers{$resolver}++;
            push @recent_domains,   $host;
            push @recent_resolvers, $resolver;
            push @durations, ($time_ms =~ /^(\d+)/);
        }
    }
}

close $fh;

sub make_top ($header, $data) {

    my @entries = sort { ($data->{$b} <=> $data->{$a}) || ($a cmp $b) } keys %$data;
    my $total   = sum(values %$data);

    if (scalar(@entries) > $top) {
        $#entries = $top - 1;
    }

    my @rows;
    push @rows, sprintf($header, scalar(@entries));

    foreach my $entry (@entries) {
        push @rows, sprintf("%40s  %5d  %2.0f%%", $entry, $data->{$entry}, $data->{$entry} / $total * 100);
    }

    return \@rows;
}

sub make_recent ($msg, $data) {

    my @entries = uniq(reverse @$data);

    if (scalar(@entries) > $top) {
        $#entries = $top - 1;
    }

    my @rows;
    push @rows, sprintf($msg, scalar(@entries));

    foreach my $entry (@entries) {
        push @rows, sprintf("%50s", $entry);
    }

    return \@rows;
}

my @top;

push @top, make_top("Top %s resolved domains", \%domains);
push @top, make_top("Top %s cache misses",     \%cache_misses);
push @top, make_top("Top %s cache hits",       \%cache_hits);
push @top, make_top("Top %s resolvers",        \%resolvers);

push @top, make_recent("Latest %s resolved domains", \@recent_domains);
push @top, make_recent("Latest %s resolvers",        \@recent_resolvers);

while (@top) {
    my ($x, $y) = splice(@top, 0, 2);

    my ($header1, $header2) = (shift(@$x), shift(@$y));
    printf("%50s %60s\n\n", "== $header1 == ", " == $header2 == ");

    while (@$x or @$y) {
        printf("%-60s %s\n", shift(@$x) // '', shift(@$y) // '');
    }

    print "\n";
}

if (@durations) {
    say "\n:: Average resolving time: ",                   sprintf('%.2f', sum(@durations) / scalar(@durations)),   "ms.";
    say ":: Overall resolving time (including caching): ", sprintf('%.2f', sum(@durations) / sum(values %domains)), "ms.";
}


================================================
FILE: Visualisators/greycmd.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 05 October 2015
# Website: https://github.com/trizen

# Colorize the output of a given command in nuances of grey.

# Example: perl greycmd.pl ls -l

use 5.010;
use strict;
use warnings;

use Encode qw(decode_utf8);
use Text::Tabs qw(expand);
use List::Util qw(shuffle max);
use Term::ANSIColor qw(colored colorstrip);

@ARGV || die "usage: $0 [cmd]\n";

my $text = expand(colorstrip(decode_utf8(scalar(`@{[map{quotemeta}@ARGV]}`) // exit 2)));

my @lines = split(/\R/, $text);

@lines || exit;    # no output -- exit

my @colors = (map { "grey$_" } 0 .. 23);

my $max = max(map { length($_) } @lines);
my @chars = map { split //, sprintf("%-*s", $max, $_) } @lines;

my $r = 1 + int($max / @colors);

my $j = 0;
my $k = 0;

foreach my $i (0 .. $#chars) {

    if ($i % $max == 0) {
        $j = 0;
    }

    if ($k++ % $r == 0) {
        ++$j;
    }

    $chars[$i] eq ' ' and next;             # ignore spaces
    $chars[$i] =~ /[[:print:]]/ or next;    # ignore non-printable characters

    $chars[$i] = colored($chars[$i], $colors[$j % @colors]);
}

binmode(STDOUT, ':utf8');

my $str = '';
foreach my $i (0 .. $#chars) {
    $str .= $chars[$i];
    if (($i + 1) % $max == 0) {
        $str = unpack('A*', $str) . "\n";
    }
}
print $str;


================================================
FILE: Visualisators/human-finder-visual.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 20 April 2014
# Website: https://github.com/trizen

# A smart human-like substring finder
# Steps:
#  1. loop from i=2 and count up to int(sqrt(len(text)))
#  2. loop from pos=(i-2)*len(substr)*2 and add int(len(text)/i) to pos while pos <= len(text)
#  3. jump to position pos and scan back and forward and stop if the string is found somewhere nearby
#  4. loop #2 end
#  5. loop #1 end
#  6. return -1

use 5.010;
use strict;
use warnings;

use Term::ANSIColor;

my $TOTAL = 0;    # count performance
sub DEBUG () { 1 }    # verbose mode

sub random_find {
    my ($text, $substr) = @_;

    my $tlen = length($text);
    my $slen = length($substr);

    my $tmax = $tlen - $slen;
    my $smax = int($slen / 2);    # this value influences the performance

    my $counter = 0;
    my $locate  = sub {
        my ($pos, $guess) = @_;

        for my $i (0 .. $smax) {

            ++$counter if DEBUG;    # measure performance

            if (    $pos + $i <= $tmax
                and substr($guess, $i) eq substr($substr, 0, $slen - $i)
                and substr($text,  $pos + $i,             $slen) eq $substr) {
                printf("RIGHT (i: %d; counter: %d):\n>  %*s\n>  %s\n", $i, $counter, $i + $slen, $substr, $guess) if DEBUG;
                $TOTAL += $counter if DEBUG;
                return $pos + $i;
            }
            elsif (    $pos - $i >= 0
                   and substr($substr, $i) eq substr($guess, 0, $slen - $i)
                   and substr($text,   $pos - $i,            $slen) eq $substr) {
                printf("LEFT (i: %d; counter: %d):\n>  %s\n>  %*s\n", $i, $counter, $substr, $i + $slen, $guess) if DEBUG;
                $TOTAL += $counter if DEBUG;
                return $pos - $i;
            }
        }

        return;
    };

    my %seen;
    foreach my $i (1 .. int(sqrt($tlen))) {
        #my $delta = int($tlen / $i)-$slen;

        #my $delta = int(($tlen - $slen));
        my $delta = int($tlen/$i);
        #say $delta;

        #for (my $pos = ($i - 1) * $slen ; $pos <= $tmax ; $pos += $delta) {
        for (my $pos = int($tlen/$i)-$slen ; $pos <= int(sqrt($tlen))*$i; $pos += $delta) {

            #next if $seen{$pos}++;

            #$pos -= $slen;
            #$delta -= $slen;

            say "POS: $pos" if DEBUG;
            if ($pos + $slen <= $tlen) {

                system 'clear';
                say substr($text, 0, $pos), color('bold red'), substr($text, $pos, $slen), color('reset'), substr($text, $pos+$slen);

                if (defined(my $i = $locate->($pos, substr($text, $pos, $slen)))) {
                    say "** FORWARD MATCH!" if DEBUG;
                    return $i;
                }

                sleep 1;
            }
            else {
                die "ERROR!";
            }




=cut
            if ($pos >= $slen) {

                system 'clear';
                say substr($text, 0, $pos-$slen), color('bold red'), substr($text, $pos-$slen, $slen), color('reset'), substr($text, $pos);

                if (defined(my $i = $locate->($pos - $slen, substr($text, $pos - $slen, $slen)))) {
                    say "** BACKWARD MATCH!" if DEBUG;
                    return $i;
                }

                sleep 2;
            }
=cut
        }
    }

    return -1;
}

my $text = join('', );
my $split = 30;

random_find($text, q{the blue arcs to});

say "TOTAL: ", $TOTAL if DEBUG;

__END__
The data structure has one node for every prefix of every
string in the dictionary. So if (bca) is in the dictionar
then there will be nodes for (bca), (bc), (b), and (). If
is in the dictionary then it is blue node. Otherwise it i
There is a black directed "child" arc from each node to a
is found by appending one character. So there is a black
There is a blue directed "suffix" arc from each node to t
possible strict suffix of it in the graph. For example, f
are (aa) and (a) and (). The longest of these that exists
graph is (a). So there is a blue arc from (caa) to (a). T
a green "dictionary suffix" arc from each node to the nex
in the dictionary that can be reached by following blue a
example, there is a green arc from (bca) to (a) because (
node in the dictionary (i.e. a blue node) that is reached
the blue arcs to (ca) and then on to (a).


================================================
FILE: Visualisators/lz_visual.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 21 May 2014
# License: GPLv3
# Website: https://github.com/trizen

# A visual variant of the LZ compression.

use 5.010;
use strict;
use autodie;
use warnings;

use open IO => ':utf8', ':std';
use Getopt::Long qw(GetOptions);
use Term::ANSIColor qw(colored);

my $min    = 4;
my $buffer = 1024;

sub usage {
    my ($code) = @_;
    print <<"USAGE";
usage: $0 [options] [files]

options:
        --min=i     : minimum length of a dictionary key (default: $min)
        --buffer=i  : buffer size of the input stream, in bytes (default: $buffer)
        --help      : print this message and exit

example: $0 --min=2 --buffer=512 file.txt
USAGE
    exit($code // 0);
}

GetOptions(
           'buffer=i' => \$buffer,
           'min=i'    => \$min,
           'help'     => \&usage,
          )
  or die("Error in command line arguments\n");

@ARGV || usage(1);

foreach my $file (@ARGV) {
    open my $fh, '<', $file;
    while ((my $len = read($fh, (my $block), $buffer)) > 0) {

        my %dict;
        my $limit = int($len / 2);

        foreach my $i (reverse($min .. $limit)) {
            foreach my $j (0 .. $len - $i * 2) {
                if ((my $pos = index($block, substr($block, $j, $i), $j + $i)) != -1) {
                    if (not exists $dict{$pos} or $i > $dict{$pos}[1]) {
                        $dict{$pos} = [$j, $i];
                    }
                }
            }
        }

        for (my $i = 0 ; $i < $len ; $i++) {
            if (exists($dict{$i})) {
                my ($key, $vlen) = @{$dict{$i}};
                print colored("[$key,$vlen]", 'red');    # this line prints the pointer values
                print colored(substr($block, $key, $vlen), 'blue');    # this line fetches and prints the real data
                $i += $vlen - 1;
            }
            else {
                print substr($block, $i, 1);
            }
        }
    }
    close $fh;
}


================================================
FILE: Visualisators/matrix_path_2-ways_best.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 08 August 2016
# Website: https://github.com/trizen

# Visualization for the best minimum path-sum in a matrix.
# Inspired by: https://projecteuler.net/problem=81

# The path moves only right and down.

use 5.010;
use strict;
use warnings;

use List::Util qw(min);
use Time::HiRes qw(sleep);
use Term::ANSIColor qw(colored);

my @matrix = (
              [131, 673, 234, 103, 18],
              [201, 96,  342, 965, 150],
              [630, 803, 746, 422, 111],
              [537, 699, 497, 121, 956],
              [805, 732, 524, 37,  331],
             );

my $end = $#matrix;

my @path;

sub draw {
    print "\e[H\e[J\e[H";
    my @screen = map {
        [map { sprintf "%3s", $_ } @{$_}]
    } @matrix;

    foreach my $path (@path) {
        my ($i, $j) = @$path;
        $screen[$i][$j] = colored($screen[$i][$j], 'red');
    }

    foreach my $row (@screen) {
        say join(' ', @{$row});
    }

    sleep(0.05);
}

sub path {
    my ($i, $j) = @_;

    push @path, [$i, $j];
    draw();
    pop @path;

    if ($i < $end and $j < $end) {
        push @path, [$i, $j];
        my $sum = $matrix[$i][$j] + min(path($i + 1, $j), path($i, $j + 1));
        pop @path;
        return $sum;
    }

    if ($i < $end) {
        push @path, [$i, $j];
        my $sum = $matrix[$i][$j] + path($i + 1, $j);
        pop @path;
        return $sum;
    }

    if ($j < $end) {
        push @path, [$i, $j];
        my $sum = $matrix[$i][$j] + path($i, $j + 1);
        pop @path;
        return $sum;
    }

    $matrix[$i][$j];
}

my $min_pathsum = path(0, 0);
say "\nMinimum path sum is: $min_pathsum\n";


================================================
FILE: Visualisators/matrix_path_3-ways_best.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# The minimal path sum in the 5 by 5 matrix below, by starting in any cell
# in the left column and finishing in any cell in the right column, and only
# moving up, down, and right; the sum is equal to 994.

# This algorithm finds the best possible path. (visual version)
# The problem was taken from: https://projecteuler.net/problem=82

use 5.010;
use strict;
use warnings;

no warnings 'recursion';

use List::Util qw(min);
use Time::HiRes qw(sleep);
use Term::ANSIColor qw(colored);

my @matrix = (
    map {
        [map { int(rand(1000)) } 1 .. 6]
      } 1 .. 6
);

sub draw {
    my ($path) = @_;

    print "\e[H\e[J\e[H";
    my @screen = map {
        [map { sprintf "%3s", $_ } @{$_}]
    } @matrix;

    foreach my $p (@$path) {
        my ($i, $j) = @$p;
        $screen[$i][$j] = colored($screen[$i][$j], 'red');
    }

    foreach my $row (@screen) {
        say join(' ', @{$row});
    }
}

my $end = $#matrix;

sub path {
    my ($i, $j, $prev, $path) = @_;

    push @$path, [$i, $j];

    $j >= $end && do {
        return [$matrix[$i][$j], [@$path]];
    };

    my @paths;
    if ($i > 0 and $prev ne 'down') {
        push @paths, path($i - 1, $j, 'up', [@$path]);
    }

    push @paths, path($i, $j + 1, 'ok', [@$path]);

    if ($i < $end and $prev ne 'up') {
        push @paths, path($i + 1, $j, 'down', [@$path]);
    }

    my $min = ['inf', []];

    foreach my $sum (@paths) {
        $min = $sum if $sum->[0] < $min->[0];
    }

    pop @$path;
    [$min->[0] + $matrix[$i][$j], $min->[1]];
}

my @sums;
foreach my $i (0 .. $end) {
    push @sums, path($i, 0, 'ok', []);
}

my $min = (map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, $_->[0]] } @sums)[0];

draw($min->[1]);
say "Minimum path-sum is: $min->[0]";


================================================
FILE: Visualisators/matrix_path_3-ways_greedy.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 August 2016
# Website: https://github.com/trizen

# The minimal path sum in the 5 by 5 matrix below, by starting in any cell
# in the left column and finishing in any cell in the right column, and only
# moving up, down, and right; the sum is equal to 994.

# This is a greedy algorithm (visual version).
# The problem was taken from: https://projecteuler.net/problem=82

use 5.010;
use strict;
use warnings;

use Time::HiRes qw(sleep);
use Term::ANSIColor qw(colored);

my @matrix = (
    map {
        [map { int(rand(1000)) } 1 .. 6]
      } 1 .. 6
);

sub draw {
    my ($path) = @_;

    print "\e[H\e[J\e[H";
    my @screen = map {
        [map { sprintf "%3s", $_ } @{$_}]
    } @matrix;

    foreach my $p (@$path) {
        my ($i, $j) = @$p;
        $screen[$i][$j] = colored($screen[$i][$j], 'red');
    }

    foreach my $row (@screen) {
        say join(' ', @{$row});
    }

    sleep(0.2);
}

my $end = $#matrix;
my $min = ['inf', []];

foreach my $i (0 .. $#matrix) {
    my $sum = $matrix[$i][0];

    my $j    = 0;
    my $last = 'ok';
    my @path = [$i, 0];

    while (1) {
        my @ways;

        if ($i > 0 and $last ne 'down') {
            push @ways, [-1, 0, $matrix[$i - 1][$j], 'up'];
        }

        if ($j < $end) {
            push @ways, [0, 1, $matrix[$i][$j + 1], 'ok'];
        }

        if ($i < $end and $last ne 'up') {
            push @ways, [1, 0, $matrix[$i + 1][$j], 'down'];
        }

        my $m = [0, 0, 'inf', 'ok'];

        foreach my $way (@ways) {
            $m = $way if $way->[2] < $m->[2];
        }

        $i   += $m->[0];
        $j   += $m->[1];
        $sum += $m->[2];
        $last = $m->[3];

        push @path, [$i, $j];
        draw(\@path);
        last if $j >= $end;
    }

    $min = [$sum, \@path] if $sum < $min->[0];
}

draw($min->[1]);
say "Minimum path-sum: $min->[0]";


================================================
FILE: Visualisators/pview
================================================
#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 14 January 2013
# Latest edit on: 16 July 2015
# https://github.com/trizen

# Perl source code highlighter.

use 5.018;
use strict;
use warnings;

use open IO => ':utf8', ':std';

#use lib qw(../lib);
use Perl::Tokenizer qw(perl_tokens);
use Term::ANSIColor qw(color);

my %scheme = (
              dereference_operator => color('bright_blue'),
              fat_comma            => color('bright_blue'),
              comma                => color('bright_blue'),
              assignment_operator  => color('bright_blue'),
              operator             => color('bright_blue'),
              comment              => color('bright_black'),
              number               => color('bright_red'),
              binary_number        => color('bright_red'),
              hex_number           => color('bright_red'),
              special_keyword      => color('bold blue'),
              keyword              => color('bold blue'),
              file_test            => color('bold blue'),
              substitution         => color('yellow'),
              transliteration      => color('bright_yellow'),
              match_regex          => color('bold yellow'),
              glob_readline        => color('bold white on_black'),
              curly_bracket_open   => color('bold'),
              curly_bracket_close  => color('bold'),
              right_bracket_open   => color('bold green'),
              right_bracket_close  => color('bold green'),
              array_sigil          => color('bright_cyan'),
              scalar_sigil         => color('bright_green'),
              hash_sigil           => color('bright_yellow'),
              glob_sigil           => color('bold cyan'),
              ampersand_sigil      => color('bold red'),
              heredoc_beg          => color('bold magenta on_black'),
              heredoc              => color('bold magenta on_black'),
              semicolon            => color('red'),
              qq_string            => color('bright_yellow on_black'),
              q_string             => color('bright_yellow on_black'),
              compiled_regex       => color('bold blue on_black'),
              qx_string            => color('bright_magenta on_black'),
              backtick             => color('bright_magenta on_black'),
              double_quoted_string => color('bold bright_green on_black'),
              single_quoted_string => color('green on_black'),
              qw_string            => color('bright_yellow on_black'),
              var_name             => color('bold magenta'),
              special_var_name     => color('bold magenta'),
              special_fh           => color('bold cyan'),
              sub_name             => color('bold white'),
              sub_proto            => color('bright_green on_black'),
              bare_word            => color('green'),
              data                 => color('blue on_black'),
              pod                  => color('bright_blue on_black'),
              format               => color('magenta on_black'),
              v_string             => color('green on_black'),
             );

my $code = (
    do { local $/; <> }
      // die "usage: $0 [file]\n"
);

my $reset_color = color('reset');

perl_tokens {
    my ($token, $from, $to) = @_;
    print +(exists($scheme{$token}) ? $scheme{$token} : ''), substr($code, $from, $to - $from), $reset_color;
}
$code;

=encoding utf8

=head1 NAME

pl2term - highlights Perl code in terminal

=head1 SYNOPSIS

    pl2term < [script.pl]

=head1 DESCRIPTION

pl2term reads a Perl script and outputs an highlighted terminal version of it.

I a compatible terminal is required.

=head1 AUTHOR

Daniel "Trizen" Șuteu, Etrizenx@gmail.comE

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.22.0 or,
at your option, any later version of Perl 5 you may have available.

=cut


================================================
FILE: Visualisators/random_finder_visual.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 13 April 2015
# Website: https://github.com/trizen

#
## A recursive-random text finder with potential support for parallelization
#

# It tries to find a substring inside a given text, starting at random positions, by
# splitting (recursively) the text into halves, stopping when the window is too narrow.
# If the substring exists inside the text, it returns "true". "false" otherwise.

# This is the visual version of the algorithm.

use 5.016;
use strict;
use warnings;

use List::Util qw(shuffle);
use Term::ANSIColor qw(colored);

sub rec_find {
    my ($text, $substr) = @_;

    my $limit = length($substr);

    my $find = sub {
        my ($min, $max) = @_;

        my $middle = int(($max + $min) / 2);
        my $pos_l  = int(($middle + $min) / 2);
        my $pos_r  = int(($middle + $max) / 2);

        if (($middle - $pos_l) > $limit * 2) {
#<<<
            __SUB__->(@{$_}) for shuffle(
                [$pos_l, $middle],
                [$pos_r,    $max],
                [$min,    $pos_l],
                [$middle, $pos_r],
            );
#>>>
        }
        else {
            my $t = $text;
            substr($t, $min, $max - $min,
                colored(substr($t, $min, $max - $min), 'bold red'));
            system 'clear';
            print $t;
            sleep 1;
        }
    };

    my $min = 0;
    my $max = length($text);
    $find->($min, $max);
}

my $text = do { local $/;  };
rec_find($text, 'following blue');

__END__
The data structure has one node for every prefix of every
string in the dictionary. So if (bca) is in the dictionar
then there will be nodes for (bca), (bc), (b), and (). If
is in the dictionary then it is blue node. Otherwise it i
There is a black directed "child" arc from each node to a
is found by appending one character. So there is a black
There is a blue directed "suffix" arc from each node to t
possible strict suffix of it in the graph. For example, f
are (aa) and (a) and (). The longest of these that exists
graph is (a). So there is a blue arc from (caa) to (a). T
a green "dictionary suffix" arc from each node to the nex
in the dictionary that can be reached by following blue a
example, there is a green arc from (bca) to (a) because (
node in the dictionary (i.e. a blue node) that is reached
the blue arcs to (ca) and then on to (a).


================================================
FILE: Visualisators/triangle_sub-string_finder.pl
================================================
#!/usr/bin/perl

# Author: Trizen
# License: GPLv3
# Date: 07 June 2014
# Website: https://github.com/trizen

# Triangle sub-string finder (concept only)
# - search a substring using a triangle like pattern,
#   starting in the middle of the string, continuing
#   going towards the string edges after each fail-match.

use 5.014;
use strict;
use warnings;

use Term::ANSIColor qw(colored);

sub triangle_finder {
    my ($s, $c) = @_;

    my $left  = 0;
    my $right = @{$c};

    my $min = length($s);
    my $mid = int($left + $right) / 2;

    my $acc = 0;
    for (my $m1 = $mid - $acc, my $m2 = $mid + $acc ;
         $m1 > $left && $m2 < $right ;
         $acc += $min, $m1 = $mid - $acc, $m2 = $mid + $acc) {

        #
        ## some code here that will perform the search in the left
        #

        say join('', @{$c}[0 .. $m1 - 1], colored($c->[$m1], 'red'), @{$c}[$m1 + 1 .. $#{$c}]);

        #
        ## some code here that will perform the search on the right
        #

        say join('', @{$c}[0 .. $m2 - 1], colored($c->[$m2], 'red'), @{$c}[$m2 + 1 .. $#{$c}]);
    }
}

my @chars = 'a' .. 'z';
triangle_finder('i', \@chars);


================================================
FILE: Visualisators/visual_lz77_compression.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# Date: 14 May 2014
# License: GPLv3
# Website: https://github.com/trizen

# A variant of LZ77 compression, with minimum and maximum boundaries control.

use 5.010;
use strict;
use autodie;
use warnings;

use open IO => ':utf8', ':std';
use Getopt::Long qw(GetOptions);
use Term::ANSIColor qw(colored);

my $min    = 4;
my $max    = 32766;
my $buffer = 1024;

sub usage {
    my ($code) = @_;
    print <<"USAGE";
usage: $0 [options] [files]

options:
        --min=i     : minimum length of a dictionary key (default: $min)
        --max=i     : maximum length of a dictionary key (default: $max)
        --buffer=i  : buffer size of the input stream, in bytes (default: $buffer)
        --help      : print this message and exit

example: $0 --min=4 --max=32 --buffer=512 file.txt
USAGE
    exit($code // 0);
}

GetOptions(
           'buffer=i' => \$buffer,
           'min=i'    => \$min,
           'max=i'    => \$max,
           'help'     => \&usage,
          )
  or die("Error in command line arguments\n");

@ARGV || usage(1);

foreach my $file (@ARGV) {
    open my $fh, '<', $file;
    while ((my $size = read($fh, (my $block), $buffer)) > 0) {

        my %dict;
        $block =~ /(.{$min,$max}?)(?(?=.*?(\1))(?{$dict{$-[2]}{$-[0]} = length($1)}))(?!)/s;

        my $len = length($block);
        for (my $i = 0 ; $i < $len ; $i++) {
            if (exists($dict{$i})) {
                my ($key) = sort { $dict{$i}{$b} <=> $dict{$i}{$a} } keys %{$dict{$i}};
                my $vlen = $dict{$i}{$key};
                print colored("[$key,$vlen]", 'red');                  # this line prints the pointer values
                print colored(substr($block, $key, $vlen), 'blue');    # this line fetches and prints the real data
                $i += $vlen - 1;
            }
            else {
                print substr($block, $i, 1);
            }
        }
    }
    close $fh;
}


================================================
FILE: Visualisators/visual_sudoku_dice_solver.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 30 June 2013
# Edit: 30 April 2014
# Website: https://github.com/trizen

# Sudoku dice game solver

use 5.010;
use strict;
use warnings;

use Time::HiRes qw(sleep);
use Term::ANSIColor qw(colored);
use List::Util qw(first shuffle);

sub valid_move {
    my ($row, $col, $table) = @_;

    if (($row < 0 or not exists $table->[$row]) || ($col < 0 or not exists $table->[$row][$col])) {
        return;
    }

    return 1;
}

{
    my @moves = (
                 {dir => 'left',  pos => [+0, -1]},
                 {dir => 'right', pos => [+0, +1]},
                 {dir => 'up',    pos => [-1, +0]},
                 {dir => 'down',  pos => [+1, +0]},
                );

    sub get_moves {
        my ($table, $row, $col, $number) = @_;

        my @next_pos;
        foreach my $move (@moves) {
            if (valid_move($row + $move->{pos}[0], $col + $move->{pos}[1], $table)) {
                if (    $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] != 0
                    and $table->[$row + $move->{pos}[0]][$col + $move->{pos}[1]] == $number + 1) {
                    push @next_pos, $move;
                }
            }
        }

        return \@next_pos;
    }
}

my @steps;

sub init_universe {    # recursion at its best
    my ($table, $pos) = @_;
    my ($row,   $col) = @{$pos};

    my $number = $table->[$row][$col];
    $table->[$row][$col] = 1337;

    print "\e[H\e[J\e[H";
    foreach my $row (@{$table}) {
        say map {
                $_ == 1337 ? colored('[ ]', 'bold blue')
              : $_ == 0    ? colored(' * ', 'bold red')
              : colored(" $_ ", 'bold black')
        } @{$row};
    }
    sleep 0.05;

    $table->[$row][$col] = 0;

    if ($number == 0) {
        pop @steps;
        return $table;
    }

    $number = 0 if $number == 3;
    my $moves = get_moves($table, $row, $col, $number);

    if (@{$moves}) {
        foreach my $move (@{$moves}) {
            push @steps, $move;

            my $universe = init_universe([map { [@{$_}] } @{$table}], [$row + $move->{pos}[0], $col + $move->{pos}[1]]);

            if (
                not first {
                    first { $_ != 0 } @{$_};
                }
                @{$universe}
              ) {
                die "solved\n";
            }
        }

        return init_universe($table, [$row, $col]);
    }
    else {
        pop @steps;
        return $table;
    }
}

#
## MAIN
#

{
    my @rows = qw(
      321321313
      123312222
      321213131
      312231123
      213112321
      231323123
      132231231
      123113322
      321322113
      );

    my @table;
    foreach my $row (@rows) {
        push @table, [split //, $row];
    }

    my @positions;
    foreach my $i (0 .. $#table) {
        foreach my $j (0 .. $#{$table[$i]}) {
            if ($table[$i][$j] == 1) {
                push @positions, [$i, $j];
            }
        }
    }

    foreach my $pos (shuffle @positions) {    # tested solution from position[6]

        eval {
            init_universe([map { [@{$_}] } @table], $pos);
        };

        if ($@ eq "solved\n") {

            printf "** Locate row %d, column %d, click on it and follow the steps:\n", ($pos->[0] + 1, $pos->[1] + 1);

            my $i         = 1;
            my $count     = 1;
            my $prev_step = (shift @steps)->{dir};

            foreach my $step (@steps) {
                if ($step->{dir} eq $prev_step) {
                    ++$count;
                }
                else {
                    printf "%2d. Go %-8s%s", $i++, $prev_step, ($count == 1 ? "\n" : "($count times)\n");
                    $count     = 1;
                    $prev_step = $step->{dir};
                }
            }

            sleep 2;
            print "\n";
            @steps = ();
        }
    }
}


================================================
FILE: update_readme.pl
================================================
#!/usr/bin/perl

# Author: Daniel "Trizen" Șuteu
# License: GPLv3
# Date: 24 April 2015
# Website: https://github.com/trizen

# Updated the README.md file by adding new scripts to the summary.

use 5.016;
use strict;
use autodie;
use warnings;

use Cwd                   qw(getcwd);
use File::Spec::Functions qw(rel2abs curdir);
use File::Basename        qw(basename dirname);
use URI::Escape           qw(uri_escape);

my %ignore;
if (open my $fh, '<:utf8', '.gitignore') {

    while (<$fh>) {
        next if /^#/;
        chomp;
        if (-e $_) {
            $ignore{rel2abs($_)} = 1;
        }
    }

    close $fh;
}

sub add_section {
    my ($section, $file) = @_;

    my ($before, $middle);
    open my $fh, '<', $file;
    while (defined(my $line = <$fh>)) {
        if ($line =~ /^(#+\h*Summary\s*)$/) {
            $middle = "$1\n";
            last;
        }
        else {
            $before .= $line;
        }
    }
    close $fh;

    open my $out_fh, '>', $file;
    print {$out_fh} $before . $middle . $section;
    close $out_fh;
}

my $summary_file = 'README.md';
my $main_dir     = curdir();

{
    my @root;

    sub make_section {
        my ($dir, $spaces) = @_;

        my $cwd = getcwd();

        chdir $dir;
        my @files = sort { $a->{key} cmp $b->{key} }
          map { {key => fc(s/\.\w+\z//r), name => $_, path => File::Spec->rel2abs($_)} } glob('*');
        chdir $cwd;

        my $make_section_url = sub {
            my ($name) = @_;
            join('/', basename($main_dir), @root, $name);
        };

        my $section = '';
        foreach my $file (@files) {
            my $title = $file->{name} =~ tr/_/ /r =~ s/ s /'s /gr;

            if ($file->{name} =~ /\.(\w{2,3})\z/) {
                next if $1 !~ /^(?:p[lm])\z/i;
            }

            next if exists $ignore{$file->{path}};

            if (-d $file->{path}) {
                $section .= (' ' x $spaces) . "* $title\n";
                push @root, $file->{name};
                $section .= make_section($file->{path}, $spaces + 4);
            }
            else {
                next if $dir eq $main_dir;
                my $naked_title = $title =~ s/\.pl\z//ri;
                my $url_path    = uri_escape($make_section_url->($file->{name}), ' ?');
                $section .= (' ' x $spaces) . "* [\u$naked_title]($url_path)\n";
            }
        }

        pop @root;
        return $section;
    }
}

my $section         = make_section($main_dir, 0);
my $section_content = add_section($section, $summary_file);

say "** All done!";