#!/usr/bin/perl
#####################################################################
#
# BMP2HTML v1.0 Last Update: 2022.11.23
#
# BMP2HTML is a tool that converts a BMP file to simple HTML code.
#
# Written by Zsolt N Perry (also known as Zsolt Nagy Perge).
# For questions, comments, feature requests, or bug reports,
# write to zsnp@juno.com.
# This Perl script was tested with TinyPerl 5.8 under Windows XP.
# This file was downloaded from http://www.wzsn.net/perl
#
# THIS ENTIRE SOURCE CODE IS FREEWARE.
# If you want to incorporate it or parts of it into your program,
# just copy and paste whatever you need! There is no need to ask
# for permission. This software is distributed "AS IS." There is
# no warranty of any kind. The author will not be held liable for
# any loss resulting from the use or misuse of this software.
#
#####################################################################
use 5.004;
use strict;
use warnings;
$| = 1;
my $BMPFILE = "C:\\BMPTOOLS\\test.bmp";
my $HTMFILE = "C:\\BMPTOOLS\\test.htm";
my $CANVAS = ReadBMP($BMPFILE, 24);
#ConvertToWebColors($CANVAS);
my $HTML = Canvas2HTML($CANVAS);
CreateFile($HTMFILE, $HTML);
exit;
##################################################
# BMP | Graphics | v2022.11.15
# Use this function to read and decode any kind of
# BMP file. Returns a canvas object. Returns a
# 0 x 0 blank canvas if something goes wrong.
#
# The first argument is the BMP file name.
# The second argument tells this function how many
# bytes to use to store each pixel. There are only
# three valid values: 1, 3, 4.
#
# This function supports all types of BMP formats.
# It can read old OS/2 BMP images, RLE compressed
# BMP images, standard BMP images (no compression),
# and custom format BMP images with or without
# palette and transparency.
#
# Usage: CANVASREF = ReadBMP(FILENAME, [DEPTH])
#
sub ReadBMP
{
my $D = GetBPP($_[1]);
my $BMPINFO = ReadBMPHeader($_[0]);
my $FMT = vec($BMPINFO, 0, 16);
if ($FMT == 0x100) { return ReadStandardBMP($BMPINFO, $D); }
if ($FMT == 0x200) { return ReadCustomBMP($BMPINFO, $D); }
if ($FMT == 0x300) { return ExpandRLE($BMPINFO, $D); }
return BlankCanvas($D);
}
##################################################
# BMP | Graphics | v2022.11.21
# This function reads a BMP file's header and
# returns a bunch of values encapsulated in a
# string using the pack() function.
#
# Usage: BMPINFO = ReadBMPHeader(FILENAME)
#
sub ReadBMPHeader
{
my $F = FilterFileName($_[0]);
my ($BMPINFO, $HEADER, $FMT, $E) = ('', '', 0, 0);
# The following foreach() loop allows us to exit the function
# conveniently using a common exit route. Everything inside the
# loop will run only once. If there is an error, we skip to the
# end quickly using the "last" statement. If there are no
# errors, we go through all the steps and exit at the bottom
# at the same place. $E will hold the error code.
# If no errors occurred, then $E will be zero.
foreach (0)
{
# Read the first 1200 bytes from the file.
($E = ReadFile($_[0], $HEADER, 0, 1200)) and last;
vec($HEADER, 1200, 8) = 0; # Expand header if it was shorter.
# Unpack header values.
my ($SIG, $FILESIZE, $RESERVED, $DATAPTR, $BMPVER)
= unpack('vV4', $HEADER);
my ($W, $H, $PLANES, $BPP) = unpack($BMPVER < 16 ?
'v4' : 'VVvv', substr($HEADER, 18, 12));
my ($COMPR, $DATASIZE, $XRES, $YRES, $COLORS, $IC) = $BMPVER > 16
? unpack('V6', substr($HEADER, 30, 24)) : (0) x 6;
my $BGRS = ($BPP <= 8 && substr($HEADER, 54, 4) eq 'BGRs') & 1;
# Check file signature.
if ($SIG != 0x4D42) { $E = 4; last; } # Not a BMP file
# Figure out what kind of encoding is used.
if ($COMPR == 0) { $FMT = 1; } # Standard (raw)
elsif ($BMPVER >= 56 && $DATAPTR >= 70
&& $BPP >= 16 && $COMPR == 3) { $FMT = 2; } # Custom format
elsif (($BPP == 4 || $BPP == 8) &&
($COMPR == 1 || $COMPR == 2)) { $FMT = 3; } # RLE Compressed
else { $E = 5; print last; } # Corrupt file
# Read bit masks for custom format.
my ($RMASK, $GMASK, $BMASK, $AMASK) = ($FMT == 2) ?
unpack('V4', substr($HEADER, 54, 16)) : (0) x 4;
# Calculate image height.
my $VFLIP = 1; # VFLIP=1 means the image is stored upside down
if ($H & 0x80000000) { $VFLIP = 0; $H = NEG32($H); }
if ($W == 0 || $H == 0) { $E = 6; last; }
# Copy palette from BMP header.
my $MAXCOLORS = 16777216;
if ($FMT == 2) { $MAXCOLORS =
POWER(2, CountBits32($RMASK | $GMASK | $BMASK)); }
elsif ($BPP < 24) { $MAXCOLORS = 1 << $BPP; }
my $PALPTR = $BMPVER + 14;
my $PALWIDTH = $BMPVER < 16 ? 3 : 4; # $CC is the COLOR COUNT.
my $CC = $COLORS && $COLORS < $MAXCOLORS ? $COLORS : $MAXCOLORS;
if ($FMT >= 3 || $BPP > 8) { $CC = $PALWIDTH = $PALPTR = 0; }
my $PALETTE = ReadBMPPalette($HEADER, $PALPTR, $PALWIDTH, $CC);
# Perform some calculations...
my $ROWLEN = int(($W * $BPP + 7) / 8); # Bytes per row
my $PADDING = (4 - ($ROWLEN & 3)) & 3; # Padding bytes per row
my ($DIR, $START, $STOP) = $VFLIP ? (-1, $H, -1) : (1, 1, $H);
$ROWLEN += $PADDING;
$START--;
# Everything seems to be OK.
$BMPINFO = pack('C6V20v5c', $FMT, $E, $VFLIP, $PADDING, $BGRS,
$PALWIDTH, $W, $H, $COMPR, $BMPVER, $COLORS, $XRES, $YRES,
$MAXCOLORS, $FILESIZE, $DATASIZE, $DATAPTR, $RESERVED, $IC,
$ROWLEN, $START, $STOP, $RMASK, $GMASK, $BMASK, $AMASK,
$BPP, $SIG, $PLANES, $PALPTR, $CC, $DIR) . $PALETTE;
}
vec($BMPINFO, 1, 8) = $E; # Save error code
vec($BMPINFO, 1122, 8) = 0; # Expand BMPINFO
undef $HEADER;
return $BMPINFO . $F;
}
##################################################
# BMP | Graphics | v2022.11.16
# This function reads a BMP file that uses the simplest
# form of encoding. Returns a reference to a canvas object.
#
# Usage: CANVASREF = ReadStandardBMP(BMPINFO, [DEPTH])
#
sub ReadStandardBMP
{
my ($FMT, $E, $VFLIP, $PADDING, $BGRS, $PALWIDTH, $W, $H, $COMPR,
$BMPVER, $COLORS, $XRES, $YRES, $MAXCOLORS, $FILESIZE,
$DATASIZE, $DATAPTR, $RESERVED, $IC, $ROWLEN, $START, $STOP,
$RMASK, $GMASK, $BMASK, $AMASK, $BPP, $SIG, $PLANES, $PALPTR,
$CC, $DIR, $PALETTE, $F) = UnpackBMPINFO($_[0]);
print "$FMT $E $VFLIP $PADDING $BGRS\n";
my $D = GetBPP(defined $_[1] ? $_[1] : $BPP);
print "\nReading BMP file: $F (", Commify(-s $F), ' bytes)',
"\nDecoding $W x $H x $BPP uncompressed BMP image...";
my ($BYTE, $COLOR, $PX, $A, $R, $G, $B) = (0) x 7;
my $SHIFT = 7; # The $SHIFT variable is only used when reading
# monochrome bitmaps where each bit represents one pixel, so we
# have to shift the bits left to extract them. The first pixel is
# always stored in the highest bit, so we start with $SHIFT = 7.
# Create canvas right here.
my $CANVAS = sprintf('CANVAS%0.2d', $D << 3) . pack('NN', $W, $H);
vec($CANVAS, $W * $H * $D + 15, 8) = 0; # Fill canvas.
if ($D == 1 && $BPP > 8) {
$PALWIDTH = 4;
$PALETTE = Build256CPalette();
$CANVAS .= $PALETTE;
}
elsif ($D == 1) { $CANVAS .= $PALETTE; }
my $P = 16; # Canvas byte pointer to first pixel
# Open file for read only.
local *FILE;
sysopen(FILE, $F, 0) or return \$CANVAS;
binmode FILE;
for (my $Y = $START; $Y != $STOP; $Y += $DIR)
{
# Move the file pointer to the beginning of row $Y
seek(FILE, $Y * $ROWLEN + $DATAPTR, 0);
for (my $X = 0; $X < $W; $X++)
{
if ($BPP <= 8)
{
# Read 8-bit pixel:
if ($BPP == 8) { $COLOR = ord(getc(FILE)); }
# Read 4-bit pixel:
elsif ($BPP == 4) { $COLOR = ($X & 1) ?
$BYTE & 15 : ($BYTE = ord(getc(FILE))) >> 4; }
# Read 1-bit pixel:
elsif ($BPP == 1) { $COLOR = ($X & 7) ?
($BYTE >> --$SHIFT) & 1 :
($BYTE = ord(getc(FILE))) >> ($SHIFT = 7); }
# Look up R G B values in palette if we have to upscale
# the image from 8bpp to 24bpp or 32bpp.
if ($D >= 3 && $BPP <= 8)
{
$COLOR <<= 2;
$A = vec($PALETTE, $COLOR, 8);
$R = vec($PALETTE, $COLOR+1, 8);
$G = vec($PALETTE, $COLOR+2, 8);
$B = vec($PALETTE, $COLOR+3, 8);
}
}
elsif ($BPP >= 24) # Read 24-bit or 32-bit pixel
{
$B = ord(getc(FILE));
$G = ord(getc(FILE));
$R = ord(getc(FILE));
$A = ord(getc(FILE)) if ($BPP == 32);
if ($D == 1)
{
$COLOR = Match_Palette_Color($PALETTE, $R, $G, $B);
}
}
# Save pixel to canvas as 8-bit, 24-bit, or 32-bit:
if ($D == 1) { vec($CANVAS, $P++, 8) = $COLOR; }
else { if ($D > 3) { vec($CANVAS, $P++, 8) = $A; }
substr($CANVAS, $P, 3) = pack('CCC', $R, $G, $B); $P += 3; }
$PX++ < 10000 or $PX = print '.';
}
}
close FILE;
print "\nDONE.\n";
return \$CANVAS;
}
##################################################
# BMP | Graphics | v2022.11.19
# This function reads a custom format BMP file.
# Returns a reference to a canvas object.
#
# Usage: CANVASREF = ReadCustomBMP(BMPINFO, DEPTH)
#
# BMPINFO: The first argument must be a special string
# that is generated by the ReadBMPHeader() function.
#
# DEPTH: The second argument is the requested image depth
# for the canvas. This value may be provided in bytes per pixel
# or bits per pixel. Valid values are: 1, 3, 4, 8, 24, 32.
#
# CANVASREF: The return value of this function is a reference
# that points to a string which contains the image data.
# The first 8 bytes of this string will contain the word
# "CANVAS24" or "CANVAS32" depending on the encoding, followed
# by the width and height of the image which are encoded as
# two 32-bit unsigned integers stored in big-endian format.
# After this 16-byte header, the pixels are stored in raw
# format starting with the first pixel in the upper left corner.
# When "CANVAS24" is used, the pixels are in RGB order.
# When "CANVAS32" is used, the pixels are in ARGB order.
# The canvas contains no padding at all, just raw data.
#
# WHAT IS CUSTOM FORMAT ?
#
# Custom format means that the BMP header includes
# four 32-bit integers which are used as bit masks
# that tell us where the bits are stored for red,
# green, blue and alpha values. Here is an example:
# AMASK=0000000f This tells us that the alpha value
# RMASK=000000f0 is stored in the lowest 4 bits,
# GMASK=00000f00 followed by red, which is stored
# BMASK=0000f000 in the next 4 bits, then 4-bits
# for green, and 4 bits for blue. We would represent
# this encoding as A4 R4 G4 B4. As you can see, this
# adds up to 16 bits. So, that's 16 bits per pixel.
#
# You will find this representation in Adobe PhotoShop.
# When you save a picture in BMP format, it gives you a
# number of options such as A1 R5 G5 B5, A8 R8 G8 B8,
# R5 G6 B5, and others. There are many possibilities.
#
# Unfortunately, most of these special formats result in
# a loss of quality. For example, if the picture includes
# a purple color such as R=204 G=83 B=255 and we wanted to
# store it in 16 bits in the format specified above, we
# would start out like this: R=11001100 G=01010011 B=11111111
# Then we will keep only the high 4 bits R=1100 G=0101 B=1111
# and then join them together to form one 16-bit number:
# 1111 + 0101 + 1100 + 0000 => 1111010111000000
# So, that's how we store one pixel in custom format.
#
# For decoding, we do the same steps in reverse.
# We use the bit masks to extract the values from one
# 16-bit pixel: 1111010111000000
# RED MASK : 0000000011110000
# RED VALUE : --------1100----
# RED VALUE : 1100
# RED VALUE : 11000000
#
# 16-bit pixel: 1111010111000000
# GREEN MASK : 0000111100000000
# GREEN VALUE : ----0101--------
# GREEN VALUE : 0101
# GREEN VALUE : 01010000
#
# So, we will have R=1100 G=0101 B=1111 which becomes
# R=11000000 G=01010000 B=11110000 (R=192 G=80 B=240).
# So, the original color was R=204 G=83 B=255, and you
# can see that we ended up with a slightly different
# color. It's still a purple, but it's a little bit off.
# To try to correct this problem, we use a color stretch
# lookup table. See BuildColorStretchTable() for more info.
#
# When using custom format, the Compression value must
# be set to 3, and the Bits Per Pixel value can be 16,
# 24 or 32. The header must use BMP version 56 or above.
#
# Usage: CANVASREF = ReadCustomBMP(BMPINFO, DEPTH)
#
sub ReadCustomBMP
{
my ($FMT, $E, $VFLIP, $PADDING, $BGRS, $PALWIDTH, $W, $H, $COMPR,
$BMPVER, $COLORS, $XRES, $YRES, $MAXCOLORS, $FILESIZE,
$DATASIZE, $DATAPTR, $RESERVED, $IC, $ROWLEN, $START, $STOP,
$RMASK, $GMASK, $BMASK, $AMASK, $BPP, $SIG, $PLANES, $PALPTR,
$CC, $DIR, $PALETTE, $F) = UnpackBMPINFO($_[0]);
my $D = GetBPP(defined $_[1] ? $_[1] : $BPP);
print "\nReading BMP file: $F (", Commify(-s $F), ' bytes)',
"\nDecoding $W x $H custom format BMP image ",
"($BPP bpp => ", ($D << 3), ' bpp) ';
my ($PX, $PIXEL, $A, $R, $G, $B) = (0) x 7;
# Okay. This is just preparation work.
# Here we figure out how many bits are set in each mask.
my $RX = CountBits32($RMASK);
my $GX = CountBits32($GMASK);
my $BX = CountBits32($BMASK);
my $AX = CountBits32($AMASK);
# Here we figure out how much we have to shift a pixel's value
# to the right in order to extract the individual R G B A values.
my $RSHIFT = ZeroCountR32($RMASK) + ($RX > 8 ? $RX - 8 : 0);
my $GSHIFT = ZeroCountR32($GMASK) + ($GX > 8 ? $GX - 8 : 0);
my $BSHIFT = ZeroCountR32($BMASK) + ($BX > 8 ? $BX - 8 : 0);
my $ASHIFT = ZeroCountR32($AMASK) + ($AX > 8 ? $AX - 8 : 0);
# Here we build two separate lookup tables for
# enhancing the R G B values and alpha:
my $RLT = BuildColorStretchTable($RX);
my $GLT = BuildColorStretchTable($GX);
my $BLT = BuildColorStretchTable($BX);
my $ALT = BuildColorStretchTable($AX);
# Create canvas right here.
my $CANVAS = sprintf('CANVAS%0.2d', $D << 3) . pack('NN', $W, $H);
vec($CANVAS, $W * $H * $D + 15, 8) = 0; # Fill canvas.
my $P = 16; # Canvas byte pointer to first pixel
# Create 256 color palette if we have to downscale
# the image to 8-bit from 16-bit, 24-bit, or 32-bit.
if ($D == 1) {
$PALWIDTH = 4;
$PALETTE = Build256CPalette();
$CANVAS .= $PALETTE;
}
# Open file for read only.
local *FILE;
sysopen(FILE, $F, 0) or return \$CANVAS;
binmode FILE;
for (my $Y = $START; $Y != $STOP; $Y += $DIR)
{
# Move the file pointer to the beginning of row $Y
seek(FILE, $Y * $ROWLEN + $DATAPTR, 0);
for (my $X = 0; $X < $W; $X++)
{
# Read one pixel:
$PIXEL = ord(getc(FILE));
$PIXEL |= ord(getc(FILE)) << 8;
$BPP <= 16 or $PIXEL |= ord(getc(FILE)) << 16;
$BPP <= 24 or $PIXEL |= ord(getc(FILE)) << 24;
# Extract R G B A values and do some color enhancement:
$R = vec($RLT, ($RMASK & $PIXEL) >> $RSHIFT, 8);
$G = vec($GLT, ($GMASK & $PIXEL) >> $GSHIFT, 8);
$B = vec($BLT, ($BMASK & $PIXEL) >> $BSHIFT, 8);
$A = vec($ALT, ($AMASK & $PIXEL) >> $ASHIFT, 8);
# Write pixel to canvas:
# If we have to save a 16-bit, 24-bit or 32-bit
# pixel as 8-bit, then we convert it first.
if ($D == 1) { vec($CANVAS, $P++, 8) =
Match_Palette_Color($PALETTE, $R, $G, $B); }
else # 24-bit or 32-bit:
{ $D < 4 or vec($CANVAS, $P++, 8) = $A;
if ($D >= 3) { substr($CANVAS, $P, 3) =
pack('CCC', $R, $G, $B); $P += 3; } }
$PX++ < 10000 or $PX = print '.';
}
}
close FILE;
print "\nDONE.\n";
return \$CANVAS;
}
##################################################
# BMP | Graphics | v2022.11.17
# This function expands RLE4 and RLE8 compressed BMP
# files and returns a reference to a canvas object.
# If an error occurs, then returns a reference
# to a blank (0x0) canvas.
#
# BMPINFO: The first argument must be a special string
# that is generated by the ReadBMPHeader() function.
#
# DEPTH: The second argument is the requested image depth
# for the canvas. This can be provided in bits per pixel or
# bytes per pixel. Valid values are: 1, 3, 4, 8, 24, 32.
# By default, all RLE compressed BMP images are 32-bit which
# includes transparency, but you may request 8-bit or 24-bit
# in which case the image will be downscaled automatically.
#
# Usage: CANVASREF = ExpandRLE(BMPINFO, DEPTH)
#
sub ExpandRLE
{
my ($FMT, $E, $VFLIP, $PADDING, $BGRS, $PALWIDTH, $W, $H, $COMPR,
$BMPVER, $COLORS, $XRES, $YRES, $MAXCOLORS, $FILESIZE,
$DATASIZE, $DATAPTR, $RESERVED, $IC, $ROWLEN, $START, $STOP,
$RMASK, $GMASK, $BMASK, $AMASK, $BPP, $SIG, $PLANES, $PALPTR,
$CC, $DIR, $PALETTE, $F) = UnpackBMPINFO($_[0]);
my $D = GetBPP(defined $_[1] ? $_[1] : $BPP);
my $DEBUG = 0;
print "\nExpanding $W x $H RLE compressed BMP image ",
"($BPP bpp => ", ($D << 3), ' bpp) ';
# Create canvas right here.
my $CANVAS = sprintf('CANVAS%0.2d', $D << 3) . pack('NN', $W, $H);
vec($CANVAS, $W * $H * $D + 15, 8) = 0; # Fill canvas.
if ($D == 1) { $CANVAS .= $PALETTE; }
my $P = 16; # Canvas byte pointer to first pixel
my $PX = 0;
$ROWLEN = $W * $D; # Output bytes per row
my ($X, $Y, $MODE, $COUNT, $REPEAT, $SKIP, $PIX1, $PIX2) = (0) x 9;
# Initialize some variables.
sysopen(FILE, $F, 0) or return \$CANVAS;
binmode FILE;
sysseek(FILE, $DATAPTR, 0);
my $RUN = 1;
while ($RUN)
{
$PX++ < 1000 or $PX = print '.';
# Read file one byte at a time. Convert the byte to ASCII code.
# After we reach the end of file, we read zeros.
my $c = getc(FILE);
$RUN = defined $c;
$c = ($RUN) ? ord($c) : 0;
if ($MODE < 0) { $MODE++; next; } # Skip padding character.
if ($MODE == 0) # First byte
{
# If the first byte is zero: the next byte is going to be
# a control character, which tells us what to do next...
# If the first byte is non-zero: then we're looking at
# a compressed chunk.
$MODE = $c + 1; # Remember this and read next byte.
next;
}
if ($MODE == 1) # 2nd byte: Control character!
{
if ($c == 0) # END OF LINE.
{
$X = 0;
$Y = IntRange($Y + 1, 0, $H);
$P = $Y * $W * $D + 16;
$MODE = 0;
next;
}
elsif ($c == 1) # END OF BITMAP.
{ last; }
elsif ($c == 2) # MOVE PEN.
{ $MODE = 300; next; }
else # Uncompressed block comes next
{
$COUNT = $c;
$MODE = 500;
# Uncompressed blocks in RLE mode must end on a word boundary, so
# sometimes the block will be followed by a zero byte. We control
# this by setting the $SKIP value, which later sets $MODE to -1,
# which then causes the one byte to be read and discarded.
#
# Adobe PhotoShop and others include a padding byte when required,
# but XnView leaves the padding off in RLE4 mode. This means
# the resulting file will be smaller, but this is non-standard
# practice which prevents certain programs from decoding the
# file correctly. For example, Windows Paint will not open
# 16-color BMP files compressed with XnView. This discrepancy is
# hard to detect, but apparently, when $DATASIZE is zero, then
# no padding is added. So, in the next few lines we try to
# figure out when we need to skip a byte and when we don't:
if ($BPP == 8) { $SKIP = $COUNT & 1; } else # RLE8 padding
{ $SKIP = ($DATASIZE) ? ($COUNT & 2) : 0; } # RLE4 padding
next;
}
}
elsif ($MODE <= 256) # 2nd byte: Compressed data comes next
{ $COUNT = $MODE - 1; $MODE = 600; }
elsif ($MODE == 300) # Move pen. STEP 1.
{
$X += ($c < 128) ? $c : $c - 256; # Update X coordinate
$X = IntRange($X, 0, $W);
$MODE = 330; # Goto step 2 now.
$DEBUG and print "\n\tMOVE PEN: X = $X";
next;
}
elsif ($MODE == 330) # Move pen. STEP 2.
{
$Y += ($c < 128) ? $c : $c - 256; # Update Y coordinate
$Y = IntRange($Y, 0, $H);
$P = ($Y * $ROWLEN) + ($X * $D) + 16; # Move pointer
$MODE = 0; # We're done.
$DEBUG and print "\n\tMOVE PEN: Y = $Y";
next;
}
if ($MODE > 400) # Write pixel(s)
{
if ($MODE == 500) # Prepare for writing uncompressed bytes.
{
$REPEAT = ($COUNT == 1 || $BPP == 8) ? 1 : 2;
$COUNT -= ($BPP == 8) ? 1 : 2;
if ($COUNT <= 0) { $MODE = ($SKIP) ? -1 : 0; $SKIP = 0; }
}
elsif ($MODE == 600) # Prepare for repeating pixels
{ $REPEAT = $COUNT; $MODE = 0; }
# In RLE8 mode, each byte ($c) holds the color of one pixel.
# In RLE4 mode, each byte ($c) holds two pixels. First pixel
# is in the upper 4 bits; the second is in the lower 4 bits.
# We break this down into $PIX1 and $PIX2. Then in the
# for loop below, we alternate between PIX1 and PIX2 as we
# write the pixels one by one.
if ($BPP == 4) { $PIX1 = ($c >> 4) & 15; $PIX2 = $c & 15; }
for (my $i = 0; $i < $REPEAT; $i++)
{
if ($BPP == 4) { $c = ($i & 1) ? $PIX2 : $PIX1; }
if ($Y < 0 || $Y >= $H) { last; }
if ($X++ < 0 || $X > $W) { next; }
if ($D == 1) { # Write pixel to 8bpp canvas:
vec($CANVAS, $P++, 8) = $c; }
else { # Write pixel to 24bpp canvas:
my $A = vec($PALETTE, $c, 32); # Lookup RGB values
my $R = ($A >> 16) & 255;
my $G = ($A >> 8) & 255;
my $B = $A & 255;
$A = ($A >> 24) & 255;
if ($D == 4) { vec($CANVAS, $P++, 8) = $A; } # 32bpp
vec($CANVAS, $P++, 8) = $R;
vec($CANVAS, $P++, 8) = $G;
vec($CANVAS, $P++, 8) = $B;
} #### End of write pixel
} ###### End of repeat pixel
} ######## End of $MODE select
} ########## End of main loop
close FILE;
if ($VFLIP) { FlipVertical(\$CANVAS); }
print "\nDONE.\n";
return \$CANVAS;
}
##################################################
# Canvas | Graphics | v2022.11.21
# This function creates a new canvas object in
# memory and returns its reference.
#
# Usage: CANVASREF = NewCanvas(Width, Height, Depth, [BgColor])
#
sub NewCanvas
{
my $W = IntRange($_[0], 0, 4294967295); # Width
my $H = IntRange($_[1], 0, 4294967295); # Height
my $D = GetBPP($_[2]); # Depth
my $C = Int32bit($_[3]); # BgColor
my $CANVAS = sprintf('CANVAS%0.2d', $D << 3) . pack('NN', $W, $H);
my $LAST = $W * $H * $D + 15;
vec($CANVAS, $LAST, 8) = 0; # Reserve memory.
if ($D == 3) { $C &= 0xffffff; }
elsif ($D == 1) { $C &= 255; }
$C or return \$CANVAS; # Canvas is already painted black.
if ($D == 1) { $C = chr($C); }
else { $C = pack('N', $C);
if ($D == 3) { $C = substr($C, 1, 3); } }
for (my $P = 16; $P <= $LAST; $P += $D) # Paint canvas.
{ substr($CANVAS, $P, $D) = $C; }
return \$CANVAS;
}
##################################################
# Graphics | v2022.11.20
# This function creates a lookup table for color
# enhancement. The function expects one integer
# that tells it how many bits are used to
# represent a particular RGB channel.
#
# Usage: STRING = BuildColorStretchTable(BITCOUNT)
#
sub BuildColorStretchTable
{
my $N = $_[0];
$N > 0 or return '';
# What's the biggest number we can arrange using $N number of bits?
my $MAX = (1 << $N) - 1;
my $LUT = '';
vec($LUT, $MAX, 8) = 0; # Reserve memory for the lookup table.
# If colors are represented with 8 bits, then we don't
# need to stretch anything at all. In other words,
# the output is going to be the same as the input.
# So, here we build a lookup table that does that:
if ($N >= 8)
{
for (my $i = 1; $i < 256; $i++)
{ vec($LUT, $i, 8) = $i; }
return $LUT;
}
# Calculate multiplier.
my $MULTIPLIER = 255 / $MAX;
# Here, we will build the lookup table:
for (my $i = 1; $i <= $MAX; $i++)
{ vec($LUT, $i, 8) = ($i * $MULTIPLIER) & 255; }
return $LUT;
}
##################################################
# Palette | v2022.9.27
# This function returns a color index that points
# to a palette color that is the closest match to
# the original R G B values provided. This function
# is used when downscaling a truecolor bitmap from
# 16 million colors to 16 colors or 256 colors, and for
# each RGB pixel, we must find a color in the palette
# that most closely resembles the original color.
#
# NOTE: No error checking is done, so make sure you
# pass the right arguments every time!
#
# Usage: COLOR_INDEX = Match_Palette_Color(PALETTE, R, G, B)
#
sub Match_Palette_Color
{
my ($i, $C, $PREV, $DIFF, $PALPTR) = (0) x 5;
my $L = length($_[0]);
my $LEAST_DIFF = 777;
for (; $PALPTR < $L; $PALPTR += 4, $i++)
{
$DIFF = abs(vec($_[0], $PALPTR + 1, 8) - $_[1])
+ abs(vec($_[0], $PALPTR + 2, 8) - $_[2])
+ abs(vec($_[0], $PALPTR + 3, 8) - $_[3]);
if ($DIFF == 0) { return $i; }
if ($DIFF < $LEAST_DIFF) {
$LEAST_DIFF = $DIFF;
$PREV = $C;
$C = $i;
}
}
return $C;
}
##################################################
# BMP | Graphics | v2022.11.21
# This function returns all the values that are
# stored in the BMPINFO string.
# Usage: ARRAY = UnpackBMPINFO(BMPINFO)
#
sub UnpackBMPINFO
{
defined $_[0] && length($_[0]) > 1122 or return ();
my @L = unpack('C6V20v5c', $_[0]);
push(@L, substr($_[0], 98, 1024));
push(@L, substr($_[0], 1123));
return @L;
}
##################################################
# Graphics | v2022.11.5
# This function returns a complete BMP file header
# which is usually between 50 and 1100 bytes long.
# Returns an empty string if something goes wrong.
#
# Usage: HEADER = MakeBMPHeader(WIDTH, HEIGHT, BPP,
# COMPR, BMPVER, DATASIZE, COLORS, IC, PALETTE,
# DPI, AMASK, RMASK, GMASK, BMASK)
#
sub MakeBMPHeader
{
@_ >= 5 or return '';
my ($W, $H, $BPP, $COMPR, $BMPVER, $DATASIZE, $COLORS, $IC,
$PALETTE, $DPI, $AMASK, $RMASK, $GMASK, $BMASK) = @_;
# Fix some errors.
$BMPVER = NearestNum($BMPVER, 12, 16, 40, 52, 56, 64, 108, 124);
my $PALMAX = ($BMPVER < 16) ? 768 : 1024;
if (length($PALETTE) > $PALMAX)
{ $PALETTE = substr($PALETTE, 0, $PALMAX); }
# Check limitations.
if ($BMPVER < 40 && ($W > 65535 || $H > 65535)) { $BMPVER = 40; }
if ($W > 4294967295) {
print "\nBMP image width cannot exceed 4,294,967,295 pixels!\n";
return ''; }
if ($H > 2147483647) {
print "\nBMP image height cannot exceed 2,147,483,647 pixels!\n";
return ''; }
# Colors and Important Colors (IC) have significance when we're
# working with color-indexed images. A zero value means
# that all colors are used and all colors are important.
# In most BMP files, both COLORS and IC are zero.
my $MAXCOLORS = GetMaxColors($BPP);
FixOverflow($COLORS, $MAXCOLORS, 0);
FixOverflow($IC, $MAXCOLORS, 0);
# It is okay for DATASIZE and FILESIZE to be zero,
# because most programs ignore these values anyway.
# (When DATASIZE is zero, it has a special meaning, but
# that only comes into play when using RLE compression.)
my $HDRSIZE = 14 + $BMPVER + length($PALETTE);
my $FILESIZE = $HDRSIZE + $DATASIZE;
FixOverflow($DATASIZE, 4294967295, 0);
FixOverflow($FILESIZE, 4294967295, 0);
# XRES and YRES hold the recommended print resolution.
# (It's perfectly fine to leave these values zero.)
my $XRES = int($DPI * 3.934);
my $YRES = int($DPI * 3.934);
# Assemble BMP Header.
my $HEADER = 'BM' . pack(($BMPVER < 16 ? 'V4v4' : 'V6vv'),
$FILESIZE, 0, $HDRSIZE, $BMPVER, $W, $H, 1, $BPP);
if ($BMPVER > 16) { $HEADER .= pack('V6', $COMPR,
$DATASIZE, $XRES, $YRES, $COLORS, $IC); }
if ($BPP >= 16 && $COMPR == 3 && $BMPVER >= 56 && $HDRSIZE >= 70)
{ $HEADER .= pack('V4', $RMASK, $GMASK, $BMASK, $AMASK); }
elsif ($BPP <= 8) { if ($BMPVER >= 108) { $HEADER .= 'BGRs'; }
$HEADER .= $PALETTE; }
if (length($HEADER) < $HDRSIZE) { $HEADER .= "\0" x
($HDRSIZE - length($HEADER)); } # Fill the rest with zeros.
return $HEADER;
}
##################################################
# BMP | Graphics | v2022.11.5
# This function converts canvas image data to
# standard 24-bit truecolor BMP format and saves
# it to a file. This is the most popular BMP format.
# It is recognized by most photo viewers and editors.
#
# Usage: STATUS = SaveBMP24(CANVASREF, FILENAME)
#
sub SaveBMP24
{
my ($CANVAS, $W, $H, $INPUT, $PTR) = UseCanvas($_[0]) or return 0;
my $FILENAME = FilterFileName($_[1]);
print
"\nSaving BMP file: $FILENAME",
"\nin standard truecolor format: $W x $H (", ($INPUT << 3), " bpp => 24 bpp) ...";
# Padding is used to make EACH LINE'S LENGTH divisible by 4.
# So, we extend the lines (when we have to) by adding zero bytes
# at the end of every line. Note: The fastest way to divide the
# image width by 4 and get the remainder is to do: ($W & 3)
my $ROWLEN = $W * 3;
my $PADLEN = (4 - ($ROWLEN & 3)) & 3;
my $PADDING = "\0" x $PADLEN;
my $DATASIZE = ($ROWLEN + $PADLEN) * $H;
my $HEADER =
MakeBMPHeader($W, $H, 24, 0, 40, $DATASIZE, 0, 0, '', 720)
or return 0;
my $PALETTE = GetCanvasPalette($CANVAS);
if (length($PALETTE) == 0) { $PALETTE = Build256CPalette(); }
local *FILE;
open(FILE, ">$FILENAME") or return 0; # Create a BMP file.
binmode FILE;
print FILE $HEADER; # Write BMP header.
undef $HEADER; # Erase header from memory.
my ($PX, $R, $G, $B) = (0) x 4;
my $CANVAS_ROWLEN = $W * $INPUT; # Canvas bytes per row
my $P = $CANVAS_ROWLEN * $H + $PTR; # Canvas byte pointer
# $P is now pointing to the last pixel in the canvas (bottom right)
# BMP files usually contain images upside down,
# so we start from the bottom and go up.
for (my $Y = $H - 1; $Y >= 0; $Y--)
{
$P -= $CANVAS_ROWLEN; # Jump to the beginning of the line.
for (my $X = 0; $X < $W; $X++)
{
if ($INPUT == 1)
# If we're getting only 1 byte per pixel, then we have to
# use a palette to look up the R G B values:
{
my $CX = vec($$CANVAS, $P++, 8) << 2;
$R = vec($PALETTE, $CX + 1, 8);
$G = vec($PALETTE, $CX + 2, 8);
$B = vec($PALETTE, $CX + 3, 8);
}
# If we're getting 4 bytes per pixel, we discard the alpha:
else { $INPUT == 4 and $P++;
# We're getting 3 byte-per-pixel signal:
$R = vec($$CANVAS, $P++, 8);
$G = vec($$CANVAS, $P++, 8);
$B = vec($$CANVAS, $P++, 8);
}
print FILE pack('CCC', $B, $G, $R); # Write pixel
$PX++ < 10000 or $PX = print '.';
}
if ($PADLEN) { print FILE $PADDING; } # Insert padding
$P -= $CANVAS_ROWLEN; # Go one line up.
}
close FILE;
print "\nDONE.\n";
return 1;
}
##################################################
# String | v2022.11.9
# This function can be used to test if a scalar is
# a reference to a string that holds some value.
# If this condition is true, returns the reference,
# otherwise returns zero.
# Usage: REF = GetRef(REF)
#
sub GetRef
{
defined $_[0] or return 0;
ref($_[0]) eq 'SCALAR' or return 0;
my $REF = $_[0];
return (defined $$REF && length($$REF)) ? $REF : 0;
}
##################################################
# Graphics : Palette | v2022.11.9
# This function adds a color palette to the canvas.
# Usage: SetCanvasPalette(CANVASREF, PALETTE)
#
sub SetCanvasPalette
{
defined $_[1] && length($_[1]) > 4 or return 0;
SetCanvasTail($_[0], $_[1]);
}
##################################################
# Graphics : Palette | v2022.11.9
# Returns the color palette from the canvas string.
# Usage: PALETTE = GetCanvasPalette(CANVASREF)
#
sub GetCanvasPalette
{
my $T = GetCanvasTail($_[0]);
length($T) >= 1024 or return '';
return substr($T, 0, 1024);
}
##################################################
# Graphics | v2022.11.7
# Returns 1 if the first argument holds a reference
# to a valid canvas string; returns zero otherwise.
# Usage: INTEGER = IsCanvasRef(CANVASREF)
#
sub IsCanvasRef
{
my $REF = GetRef($_[0]) or return 0;
length($$REF) > 15 or return 0;
my $S = substr($$REF, 0, 8);
return ($S eq 'CANVAS32' | $S eq 'CANVAS24' | $S eq 'CANVAS08');
}
##################################################
# Canvas | Graphics | v2022.11.22
# This function returns whatever additional data is
# stored at the end of the canvas string that is not
# part of the pixel data.
# Usage: STRING = GetCanvasTail(CANVASREF)
#
sub GetCanvasTail
{
my ($CANVAS, $W, $H, $D, $START) = UseCanvas($_[0]) or return '';
my $IMAGESIZE = $W * $H * $D + $START;
return (length($$CANVAS) > $IMAGESIZE) ?
substr($$CANVAS, $IMAGESIZE) : '';
}
##################################################
# Canvas | Graphics | v2022.11.22
# This function adds additional data to the end
# of a canvas string. This can be a color palette or
# some plain text description about the image.
# Usage: SetCanvasTail(CANVASREF, STRING)
#
sub SetCanvasTail
{
my ($CANVAS, $W, $H, $D, $START) = UseCanvas($_[0]) or return 0;
my $T = defined $_[1] ? $_[1] : '';
my $LT = length($T);
my $IMAGESIZE = $W * $H * $D + $START;
# Expand canvas size if it's too small.
if (length($$CANVAS) < $IMAGESIZE)
{ vec($$CANVAS, $IMAGESIZE - 1, 8) = 0; }
# Write tail data.
substr($$CANVAS, $IMAGESIZE, $LT) = $T;
# Reduce canvas size if it's too big.
if (length($$CANVAS) > $IMAGESIZE + $LT)
{ $$CANVAS = substr($$CANVAS, 0, $IMAGESIZE + $LT); }
return 1;
}
##################################################
# Canvas | Graphics | v2022.11.13
# This function converts the image depth to
# bytes per pixel. It doesn't matter if you provide
# the depth in bits per pixel or bytes per pixel.
# This function always returns it in bytes per pixel.
# Returns 3 if an invalid value is provided!
#
# Usage: BYTES_PER_PIXEL = GetBPP(DEPTH)
#
sub GetBPP
{
my $D = IntRange($_[0], 0, 999);
if ($D == 1 || $D == 8) { return 1; }
elsif ($D == 4 || $D == 32) { return 4; }
return 3;
}
##################################################
# Canvas | Graphics | v2022.11.7
# This function erases the canvas and fills it with
# one solid color.
#
# The COLOR must be specified as an integer which
# holds an 8-bit, 24-bit, or 32-bit value. If it's
# a 32-bit value, it must be given as 0xAARRGGBB.
# If it's a 24-bit value, it must be given as 0xRRGGBB.
#
# Usage: FillCanvas(CANVASREF, COLOR)
#
sub FillCanvas
{
my $REF = GetCanvasRef($_[0]) or return 0; # Check reference
my $COLOR = Int32bit($_[1]); # Color is a 32-bit integer
my $TAIL = GetCanvasTail($REF); # Save palette and plain text.
my $W = WidthOf($REF); # Get image width in pixels
my $H = HeightOf($REF); # Get image height in pixels
my $D = DepthOf($REF);
my $SIZE = $W * $H * $D + 16;
$$REF = substr($$REF, 0, 16); # Erase canvas.
vec($$REF, $SIZE - 1, 8) = 0; # Fill with black.
if ($COLOR)
{
if ($D == 1)
{
$COLOR &= 255;
for (my $i = 16; $i < $SIZE; $i++)
{ vec($$REF, $i, 8) = $COLOR; }
}
if ($D == 3)
{
$COLOR = substr(pack('N', $COLOR & 0xffffff), 1, 3);
for (my $i = 16; $i < $SIZE; $i += 3)
{ substr($$REF, $i, 3) = $COLOR; }
}
if ($D == 4)
{
$SIZE = $W * $H + 4;
for (my $i = 4; $i < $SIZE; $i++)
{ vec($$REF, $i, 32) = $COLOR; }
}
}
length($TAIL) and SetCanvasTail($REF, $TAIL);
return 1;
}
##################################################
# BMP | Graphics | v2022.11.17
# This function reads the color palette from a
# BMP file's header and returns it as a 1024-byte
# string in which each color takes up 4 bytes,
# starting with alpha (transparency) value, which
# is followed by the red, green, and blue values.
# Missing colors are filled with zero bytes.
#
# The 1st argument (HEADER) must be a string that
# contains the first 1200 bytes of a BMP file.
# The 2nd argument (PALPTR) is a pointer to where
# the palette begins within the header.
# The 3rd argument (PALWIDTH) tells the function
# whether the palette is 3 or 4 bytes per color.
# The 4th argument (CC) is the number of colors
# in the palette.
#
# Usage: PALETTE = ReadBMPPalette(HEADER, PALPTR, PALWIDTH, CC)
#
sub ReadBMPPalette
{
@_ == 4 or return '';
foreach (@_) { defined $_ or return ''; }
my $PALPTR = $_[1];
my $PALWIDTH = $_[2];
my $CC = $_[3];
$PALPTR > 12 or return '';
# Initialize palette.
my $PALETTE = '';
vec($PALETTE, 1023, 8) = 0; # Fill with zero bytes.
my ($R, $G, $B, $A) = (0) x 4;
# In the BMP header, each color is stored usually in 4 bytes,
# sometimes 3 bytes. And they are stored first starting with
# the blue value, then green, red, and finally the alpha.
for (my $i = 0; $i < $CC; $i++)
{
$B = vec($_[0], $PALPTR++, 8);
$G = vec($_[0], $PALPTR++, 8);
$R = vec($_[0], $PALPTR++, 8);
$A = vec($_[0], $PALPTR++, 8) if ($PALWIDTH == 4);
vec($PALETTE, $i, 32) = $A << 24 | $R << 16 | $G << 8 | $B;
}
return $PALETTE;
}
##################################################
# Graphics | v2022.10.29
# This function converts an RGB color to the SHORTEST
# string representation of that color for use in a
# HTML document.
#
# Example: Color2HTML('ffffff') => 'white'
#
# A THRESHOLD value tells this function that if a color
# is close enough to a nearby color that can be expressed
# in fewer bytes, then go with that color instead. For
# example, if THRESHOLD is 5, then the color 0xfe0103
# is close enough to 0xff0000 which can be expressed
# simply as 'RED' in a HTML document. ""
# is a valid expression, and so is ""
# but the first one is 3 bytes shorter.
#
# It's easier to tell the difference between two bright
# colors than two dark colors, so there are two different
# values for threshold-- one is for dark colors,
# and the other is for light colors.
#
# Default value: Color2HTML($HEXCOLOR, 80, 8);
#
# Usage: STRING = Color2HTML(HEXCOLOR, [DARK_THRESHOLD, LIGHT_THRESHOLD])
#
sub Color2HTML
{
my $C = defined $_[0] ? $_[0] : '000000';
my $R = hex(substr($C, 0, 2));
my $G = hex(substr($C, 2, 2));
my $B = hex(substr($C, 4, 2));
my $LO = defined $_[1] ? $_[1] : 25;
my $HI = defined $_[2] ? 255 - $_[2] : 247;
if ($R < $LO && $G < $LO && $B < $LO) { return '0'; }
if ($R > $HI && $G > $HI && $B > $HI) { return 'WHITE'; }
if ($R > $HI && $G < $LO && $B < $LO) { return 'F#'; }
if ($R < $LO && $G < $LO && $B > $HI) { return 'BLUE'; }
if ($R < $LO && $G > $HI && $B < $LO) { return '00F#'; }
if ($R < $LO && $G > $HI && $B > $HI) { return 'CYAN'; }
if ($R > $LO && $G < $LO && $B < $LO) { return substr($C, 0, 1) . '#'; }
if ($B < $LO)
{
$G = ($G & 0xF0) + (($G & 15) < 9 ? 0 : 16);
$G < 255 or $G = 255;
return sprintf('%0.2X%X#', $R, $G >> 4);
}
if ($R > $LO && $G > $LO && $B < $LO) { return substr($C, 0, 3) . '#'; }
if ($B < $LO) { return substr($C, 0, 4) . '#'; }
return $C;
}
##################################################
# Graphics | v2022.10.29
# This function writes tags that appear as one
# or more pixels when displayed in a web browser.
#
# Usage: STRING = HTMLWritePixel(BGCOLOR, COLOR, REPEAT)
#
sub HTMLWritePixel
{
my ($BGCOLOR, $COLOR, $REPEAT) = @_;
return (($REPEAT == 1) ? '';
}
##################################################
# Graphics | v2022.10.29
# This function exports a canvas image to a HTML
# object where each pixel becomes an
# individual element...
#
# Usage: HTMLCODE = Canvas2HTML(CANVASREF)
#
sub Canvas2HTML
{
my ($REF, $W, $H, $INPUT, $PTR) = UseCanvas($_[0], 24) or return '';
my $BGCOLOR = sprintf('%0.6X', FindDominantColor($REF));
my $HTML = " 0xffffffff) { $STOP = 0xffffffff; }
my $TOPCOUNT = 0;
my $DOMINANT = 0;
for (my $i = 0; $i < $RES; $i++, $PTR += 3)
{
# Read pixel:
my $RGB = vec(substr($$CANVAS, $PTR, 3), 0, 32) >> 8;
# Increment count:
my $COUNT = vec($C, $RGB, 32) = vec($C, $RGB, 32) + 1;
if ($COUNT > $TOPCOUNT)
{
$DOMINANT = $RGB; # Keep track of the most dominant color
$TOPCOUNT = $COUNT; # Remember how many times it was used
# If at least half of the image is made up of one single color
# or we reach 0xffffffff, then we stop counting.
if ($TOPCOUNT >= $STOP) { last; }
}
if (($i & 0xfffff) == 0) { print '.'; }
}
printf("\n The dominant color is: %0.6X\n", $DOMINANT);
return $DOMINANT;
}
##################################################
# v2022.9.5
# This function removes illegal characters from
# a file name such as: $ % ? * < > | " \t \r \n \0
# and any character whose ASCII value is 0-31.
#
# Usage: FILENAME = FilterFileName(FILENAME)
#
sub FilterFileName
{
my $F = defined $_[0] ? $_[0] : '';
$F =~ tr`<>*%$?\x00-\x1F\"\|``d;
return $F;
}
##################################################
# Math | v2022.11.19
# This function converts a 32-bit integer to a
# binary number that consists of 1s and 0s, and
# counts the number of zeroes that are at the end
# of the number. (Actually, we use a lookup table
# to speed things up a bit...)
#
# Example: ZeroCountR32(1500000) => 5
#
# 1500000 = 00000000000101101110001101100000
# ^^^^^
# 5
# Usage: COUNT = ZeroCountR32(INTEGER)
#
sub ZeroCountR32
{
my $N = $_[0] & 0xffffffff;
$N or return 32;
my $HI = ZeroCountR16($N >> 16);
my $LO = ZeroCountR16($N);
return ($LO < 16) ? $LO : $HI + 16;
}
##################################################
# Math | v2022.11.19
# This function converts an integer (0-65535) to a
# 16-digit number that consists of 1s and 0s, and
# counts the number of zeroes that are on the right
# side of that number. (Actually, we use a lookup
# table to speed things up a bit.)
#
# Example: ZeroCountR16(696) => 3
#
# 696 = 0000001010111000
# ^^^
# 3
#
# Usage: COUNT = ZeroCountR16(INTEGER)
#
sub ZeroCountR16
{
defined $_[0] or return 16;
my $N = $_[0] & 0xffff;
$N or return 16; # Let me guess...it's zero?
my @HI = ZeroCount8($N >> 8);
my @LO = ZeroCount8($N);
return ($LO[1] < 8) ? $LO[1] : $HI[1] + 8;
}
##################################################
# Math | v2022.11.19
# This function converts an integer (0-255) to an
# 8-digit number that consists of 1s and 0s, and
# counts the number of zeroes that come before
# and after the number. (Actually, we use a
# lookup table to speed things up a bit.)
#
# Example: ZeroCount8(40) => (2, 3)
#
# 40 = 00101000
# ^^ ^^^
# 2 3
#
# The second and third arguments are optional:
# The second argument will be added to BEFORE's value.
# The third argument will be added to AFTER's value.
#
# Usage: (BEFORE, AFTER) = ZeroCount8(INTEGER, [ADD1, [ADD2]])
#
sub ZeroCount8
{
# DO NOT MODIFY LOOKUP TABLE:
my $N = vec("\xB0\xA8\x97\x98\x86\x88\x87\x88uxwxvxwxdhghfhghehghfhghSXWXVXWXUXWXVXWXTXWXVXWXUXWXVXWXBHGHFHGHEHGHFHGHDHGHFHGHEHGHFHGHCHGHFHGHEHGHFHGHDHGHFHGHEHGHFHGH18786878587868784878687858786878387868785878687848786878587868782878687858786878487868785878687838786878587868784878687858786878", $_[0] & 255, 8);
my $BEFORE = ($N >> 4) + (defined $_[1] ? $_[1] : 0) - 3;
my $AFTER = (8 - ($N & 15)) + (defined $_[2] ? $_[2] : 0);
return ($BEFORE, $AFTER);
}
##################################################
# Math | v2022.10.21
# This function counts how many 1s occur in a
# 32-bit integer when converted to binary format.
# (This function actually doesn't do any counting;
# it uses a lookup table to get the answer.)
#
# Usage: INTEGER = CountBits32(INTEGER)
#
sub CountBits32
{
my $V = $_[0] & 0xffffffff;
my $T = "\x10!!2!22C!22C2CCT!22C2CCT2CCTCTTe!22C2CCT2CCTCTTe2CCTCTTeCTTeTeev!22C2CCT2CCTCTTe2CCTCTTeCTTeTeev2CCTCTTeCTTeTeevCTTeTeevTeevevv\x87";
# According to the order of precedence, the shift >> operator is evaluated first,
# then the bitwise & operator is second, which is quite convenient for us here.
return vec($T, $V & 255, 4) + vec($T, $V >> 8 & 255, 4) + vec($T, $V >> 16 & 255, 4) + vec($T, $V >> 24 & 255, 4);
}
##################################################
# Graphics | v2022.11.14
# This function flips an image vertically.
# Supports 8-bit, 24-bit and 32-bit images.
#
# Usage: STATUS = FlipVertical(CANVASREF)
#
sub FlipVertical
{
my ($REF, $W, $H, $D, $START) = UseCanvas($_[0]) or return 0;
# If the entire image is just one line, there is nothing to do.
$W > 0 && $H > 1 or return 1;
my $COUNT = $H >> 1;
my $ROWLEN = $W * $D;
my $FROM = $START;
my $TO = $ROWLEN * $H + $START;
while ($COUNT--)
{
$TO -= $ROWLEN;
my $LINE = substr($$REF, $FROM, $ROWLEN); # Copy entire line
substr($$REF, $FROM, $ROWLEN) = substr($$REF, $TO, $ROWLEN);
substr($$REF, $TO, $ROWLEN) = $LINE;
$FROM += $ROWLEN;
}
return 1;
}
##################################################
# Palette | Graphics | v2022.11.19
# This function builds a 256-color palette
# that somewhat resembles web colors.
# Returns a string that contains 256 x 4 bytes.
# The 4-byte chunks correspond to A R G B values.
# The alpha value is always zero.
#
# Usage: STRING = Build256CPalette()
#
sub Build256CPalette
{
my $PALETTE = '';
foreach (0, 0x33, 0x66, 0x99, 0xCC, 0xE8, 0xFF)
{
my $RED = chr($_);
foreach (0, 0x33, 0x66, 0x99, 0xCC, 0xFF)
{
my $GREEN = chr($_);
foreach (0, 0x33, 0x66, 0x99, 0xCC, 0xFF)
{ $PALETTE .= "\0" . $RED . $GREEN . chr($_); }
}
}
$PALETTE .= "\0" . ("\xE5" x 3);
$PALETTE .= "\0" . ("\xB5" x 3);
$PALETTE .= "\0" . ("\x80" x 3);
$PALETTE .= "\0" . ("\x4C" x 3);
return $PALETTE;
}
##################################################
# Canvas | Graphics | v2022.11.13
# This function makes sure that the canvas string is
# not too short. If parts of the image are missing,
# they are filled with black pixels.
#
# Usage: FixCanvas(CANVASREF, [Width, [Height, [Depth]]])
#
sub FixCanvas
{
my $REF = GetCanvasRef($_[0]) or return 0;
my $W = defined $_[1] ? $_[1] : WidthOf($REF);
my $H = defined $_[2] ? $_[2] : HeightOf($REF);
my $D = defined $_[3] ? GetBPP($_[3]) : DepthOf($REF);
substr($$REF, 0, 16) = 'CANVAS' .
sprintf('%0.2d', $D << 3) . pack('NN', $W, $H);
my $MINSIZE = $W * $H * $D + 16;
if (length($$REF) < $MINSIZE)
{ vec($$REF, $MINSIZE - 1, 8) = 0; }
return 1;
}
##################################################
# Graphics | v2022.11.8
# Returns the pixel width of the canvas.
# No error checking is done, so make sure to provide
# the correct argument everytime.
# Usage: ImageWidth = WidthOf(CANVASREF)
#
sub WidthOf
{
my $REF = $_[0];
return vec($$REF, 2, 32);
}
##################################################
# Graphics | v2022.11.8
# Returns the pixel height of the canvas.
# No error checking is done, so make sure to provide
# the correct argument everytime.
# Usage: ImageHeight = HeightOf(CANVASREF)
#
sub HeightOf
{
my $REF = $_[0];
return vec($$REF, 3, 32);
}
##################################################
# Canvas | Graphics | v2022.11.13
# Returns the image depth (bytes per pixel) of a canvas.
# No error checking is done, so make sure to provide
# the correct argument everytime!
# Usage: BytesPerPixel = DepthOf(CANVASREF)
#
sub DepthOf
{
my $REF = $_[0];
defined $$REF && length($$REF) > 7 or return 0;
my $D = substr($$REF, 6, 2);
if ($D eq '32') { return 4; }
if ($D eq '08') { return 1; }
return 3;
}
##################################################
# Math | v2022.10.11
# This function forces the INPUT_NUMBER to become
# and integer between MIN and MAX values.
# If INPUT_NUMBER is smaller than MIN, then return MIN.
# If INPUT_NUMBER is greater than MAX, then return MAX.
#
# Usage: INTEGER = IntRange(INPUT_NUMBER, MIN, MAX)
#
sub IntRange
{
no warnings;
my $MIN = defined $_[1] ? int($_[1]) : 0;
my $MAX = defined $_[2] ? int($_[2]) : 4294967295;
my $NUM = defined $_[0] ? int($_[0]) : $MIN;
use warnings;
$NUM > $MIN or return $MIN;
$NUM < $MAX or return $MAX;
return int($NUM);
}
##################################################
# Math | v2022.10.12
# This function converts a number to a 32-bit integer.
#
# Usage: INTEGER = Int32bit(NUMBER)
#
sub Int32bit
{
no warnings;
my $INT = defined $_[0] ? $_[0] & 0xffffffff : 0;
use warnings;
return $INT;
}
##################################################
# Math | v2022.11.5
# This function checks if a value is above and
# beyond a certain limit, and if it is, then it
# overwrites the first argument's value with the
# third argument's value. Returns the final new value.
#
# Also, if the first argument is undefined,
# it overwrites it with zero!
#
# Usage: NUMBER = FixOverflow(VARIABLE, LIMIT, NEWVALUE)
#
sub FixOverflow
{
defined $_[0] or return $_[0] = 0;
no warnings;
my $NEW = defined $_[2] ? $_[2] : 0;
if (defined $_[1] && $_[0] > $_[1]) { $_[0] = $NEW; }
use warnings;
return $_[0];
}
##################################################
# Math | v2022.11.5
# This function expects a list of numbers and decides
# which one is closest to the first one and returns that number.
# Returns the number itself if the list is empty.
#
# Example: NearestNum(25, 55, 35, 99) => 35
# NearestNum(88, 90, 88, 77, 14) => 88
# NearestNum(103) => 103
#
# Usage: NUMBER = NearestNum(FIRST_NUMBER, LIST OF NUMBERS...)
#
sub NearestNum
{
my $FIRST = shift;
my $NEAREST = $FIRST;
my $LEASTDIFF = 999999999999999;
foreach (@_)
{
my $DIFF = abs($FIRST - $_);
$DIFF or return $FIRST;
if ($LEASTDIFF > $DIFF)
{
$LEASTDIFF = $DIFF;
$NEAREST = $_;
}
}
return $NEAREST;
}
##################################################
# Graphics | v2022.11.5
# This function calculates the maximum possible
# colors based on the bit per pixel value.
#
# Usage: INTEGER = GetMaxColors(BPP)
#
sub GetMaxColors
{
my $BPP = defined $_[0] ? $_[0] : 0;
$BPP > 0 or return 0;
$BPP > 24 or return 1 << 8;
return 16777216;
}
##################################################
# Math | v2022.8.28
# This function raises X to the Nth power.
# Usage: INTEGER = POWER(X, N)
#
sub POWER
{
my $X = defined $_[0] ? $_[0] : 0;
my $N = defined $_[1] ? $_[1] : 0;
$N > 0 or return 1;
my $PWR = 1;
while ($N-- > 0) { $PWR *= $X; }
return $PWR;
}
##################################################
# Math | v2022.10.23
# This function forces a number to become a 32-bit
# integer and returns the negated value of that integer.
#
# Usage: INTEGER = NEG32(NUMBER)
#
sub NEG32 { return defined $_[0] && $_[0] ? ~$_[0] + 1 & 0xffffffff : 0; }
##################################################
# String | v2018.6.5
# This function inserts commas into a number at
# every 3 digits and returns a string.
# Usage: STRING = Commify(INTEGER)
# Copied from www.PerlMonks.org/?node_id=157725
#
sub Commify
{
my $N = reverse $_[0];
$N =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
return scalar reverse $N;
}
##################################################
# File | v2022.11.17
# Reads an entire binary file or part of a file.
# This function uses sysopen(), sysseek(), and
# sysread() functions. Unlike many other perl subs,
# this function returns 0 on success or an error code:
# 1=File Not Found, 2=Not Plain File, 3=Cannot Open For Reading
# If an error occurs then the buffer will hold an empty string.
#
# The first argument is the file name.
# The second argument is a string buffer. (The buffer doesn't
# have to be initialized. It may contain an undefined value.)
# An optional 3rd argument (integer) will move
# the file pointer before reading, and an optional
# 4th argument (integer) can limit the number of
# bytes to read. These numbers cannot be negative.
# If the number of bytes to read is set to zero,
# then it will read the entire file. (default)
#
# Usage: STATUS = ReadFile(FILENAME, BUFFER, [START, [LENGTH]])
#
sub ReadFile
{
my $F = defined $_[0] ? $_[0] : ''; # Get file name.
$F =~ tr/\x00-\x1F\"\|*%$?<>//d; # Remove illegal characters.
my $FP = defined $_[2] ? $_[2] : 0; # File Pointer
my $N = defined $_[3] ? $_[3] : 0; # Number of bytes to read
$_[1] = ''; # Initialize read buffer.
-e $F or return 1; # File exists?
-f $F or return 2; # Is it a plain file?
my $SIZE = -s $F; # Get file size.
# Make sure all parameters are valid.
if ($N < 0 || $FP < 0 || $FP >= $SIZE) { return 0; }
$SIZE -= $FP;
if ($N == 0 || $N > $SIZE) { $N = $SIZE; }
local *FILE;
sysopen(FILE, $F, 0) or return 3; # Open file for read only.
$FP && sysseek(FILE, $FP, 0); # Move file pointer
sysread(FILE, $_[1], $N); # Read N bytes
close FILE;
return 0;
}
##################################################
# File | v2022.11.8
# Creates and overwrites a file in binary mode.
# If the file has already existed, it erases the
# old content and replaces it with the new content.
# Returns 1 on success or 0 if something went wrong.
#
# Usage: STATUS = CreateFile(FILENAME, CONTENT)
#
sub CreateFile
{
my $F = defined $_[0] ? $_[0] : '';
$F =~ tr/\x00-\x1F\"\|*%$?<>//d; # Remove illegal characters.
my $L = defined $_[1] ? length($_[1]) : 0;
local *FILE;
open(FILE, ">$F") or return 0;
binmode FILE;
$L and print FILE $_[1];
close FILE;
-e $F or return 0; # File exists?
-f $F or return 0; # It's a plain file?
$L -= -s($F); # Check file size.
return !$L;
}
##################################################
| |