I am writing a graphics lib entirely written in Perl! Here is what it can do so far: Read any bmp photo. Change saturation. Save As: BMP in any truecolor format. It will work on any computer that has Perl, because it does not use ImageMagick or any kind of magic.
You're welcome.
#!/usr/bin/perl
use 5.004;
use strict;
use warnings;
$| = 1; # Stop buffering stdout.
my $CANVAS = ReadBMP('photo.bmp');
Saturation($CANVAS, 50); # Reduce saturation to 50% of original
SaveBMP($CANVAS, 'photo2.bmp', 1);
exit;
# This function adjusts the saturation of an image
# by a percentage:
# 0 = Grayscale
# 50 = 50% less saturation
# 100 = ORIGINAL IMAGE
# 150 = 50% greater saturation
# 200 = 100% greater saturation
# Usage: Saturation(CANVASREF, PERCENT)
sub Saturation
{
defined $_[1] or return 0;
my ($CANVAS, $W, $H, $D, $PTR) = UseCanvas($_[0]) or return 0;
my $PERCENT = $_[1];
if ($PERCENT == 100) { return 0; }
my $S = "\nSaturation():";
unless ($D == 1 || $D == 3 || $D == 4) {
GPRINT("$S Cannot work on ", ($D << 3), '-bit image!',
"$S 8-bit, 24-bit, or 32-bit image required!\n"); return 0; }
my $RES = $W * $H;
GPRINT("$S Adjusting $W x $H image saturation by ",
int($PERCENT * 1000) / 10, " % ...");
my ($R, $G, $B);
$PERCENT /= 100;
while ($RES--)
{
# Read pixel:
if ($D == 1) { $R = $G = $B = vec($$CANVAS, $PTR, 8); }
else { if ($D == 4) { $PTR++; }
$R = vec($$CANVAS, $PTR, 8);
$G = vec($$CANVAS, $PTR + 1, 8);
$B = vec($$CANVAS, $PTR + 2, 8); }
# Here we calculate the grayscale equivalent of each pixel.
# Then we compare the grayscale value to the original and
# multiply the difference by a percentage. This will either
# reduce or amplify the difference in saturation:
my $GRAY = int(($R + $G + $B) / 3 + 0.5);
$R = int($GRAY + ($R - $GRAY) * $PERCENT);
$G = int($GRAY + ($G - $GRAY) * $PERCENT);
$B = int($GRAY + ($B - $GRAY) * $PERCENT);
# Check for overflow.
$R >= 0 or $R = 0; $R <= 255 or $R = 255;
$G >= 0 or $G = 0; $G <= 255 or $G = 255;
$B >= 0 or $B = 0; $B <= 255 or $B = 255;
# Write pixel
if ($D == 1)
{ vec($$CANVAS, $PTR++, 8) = int(($R + $G + $B) / 3 + 0.5); }
else {
vec($$CANVAS, $PTR, 8) = $R;
vec($$CANVAS, $PTR + 1, 8) = $G;
vec($$CANVAS, $PTR + 2, 8) = $B;
$PTR += 3;
}
}
GPRINT("DONE.\n");
return 1;
}
# This function returns a reference to a canvas object
# along with its width, height and depth...
# Returns an empty list if the canvas object is
# missing or corrupt or if it has a different
# format than what's requested.
#
# Usage: ARRAY = UseCanvas(CANVASREF, [REQUESTS])
#
# The following values are returned on success:
# ARRAY[0] = Reference to the canvas object
# ARRAY[1] = Image width in pixels
# ARRAY[2] = Image height in pixels
# ARRAY[3] = Image depth (bytes per pixel)
# ARRAY[4] = Byte Pointer to where pixel data begins
#
sub UseCanvas
{
my $REF = GetCanvasRef($_[0]) or return ();
my $D = DepthOf($REF);
shift;
foreach (@_)
{
if (($_ == 32 || $_ == 4) && $D == 4) { $D = 4; last; }
if (($_ == 24 || $_ == 3) && $D == 3) { $D = 3; last; }
if (($D == 8) && ($_ == 8 || $_ == 1))
{ $D = 1; last; } else { $D = 0; }
}
$D or return ();
# Check canvas size.
FixCanvas($REF);
my $W = WidthOf($REF);
my $H = HeightOf($REF);
return ($REF, $W, $H, $D, 16);
}
#
# Canvas | Graphics | v2022.12.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 or
# the number of colors. This function always returns
# the value in bytes per pixel.
# This function returns the DEFAULT value if an
# invalid depth is given. If a DEFAULT value is
# not specified, then zero is the default value.
#
# Usage: BYTES_PER_PIXEL = GetBPP(DEPTH, [DEFAULT])
#
sub GetBPP
{
my $D = IntRange($_[0], 0, 9999999999);
if ($D == 1 || $D == 8 || $D == 256) { return 1; }
if ($D == 2 || $D == 16 || $D == 65536) { return 2; }
if ($D == 3 || $D == 24 || $D == 16777216) { return 3; }
if ($D == 4 || $D == 32 || $D == 4294967296) { return 4; }
return defined $_[1] ? $_[1] : 0;
}
#
# Canvas | Graphics | v2022.12.13
# This function overwrites the first 16 bytes of a
# string with a new canvas header. The first
# argument must be a string reference!
#
# Usage: FixCanvasHeader(CANVASREF, Width, Height, [Depth])
#
sub FixCanvasHeader
{
defined $_[0] && ref($_[0]) eq 'SCALAR' or return 0;
my $REF = shift;
defined $$REF or $$REF = '';
substr($$REF, 0, 16) = CreateCanvasHeader(@_);
return 1;
}
# This function returns a new 16-byte canvas header
# string which starts with the word 'CANVAS' and
# contains the canvas width, height, and depth.
#
# This function will always return a valid canvas
# header even if you provide invalid arguments.
#
# Usage: HEADER = CreateCanvasHeader(Width, Height, Depth)
#
sub CreateCanvasHeader
{
my $D = GetBPP($_[2], 3); # Convert image depth to bytes per pixel
my $HEADER = sprintf('CANVAS%0.2d', $D << 3);
vec($HEADER, 2, 32) = IntRange($_[0], 0, 4294967295); # Save width
vec($HEADER, 3, 32) = IntRange($_[1], 0, 4294967295); # Save height
return $HEADER;
}
# 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); }
# 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); }
# 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;
no warnings;
my $D = substr($$REF, 6, 2) >> 3;
use warnings;
return $D;
}
# This function returns a canvas reference if the
# first argument holds a valid canvas reference.
# Otherwise this function returns zero!
#
# Usage: CANVASREF = GetCanvasRef(CANVAS OR CANVASREF)
#
sub GetCanvasRef
{
defined $_[0] && ref($_[0]) eq 'SCALAR' or return 0;
my $REF = $_[0];
defined $$REF && length($$REF) > 15 or return 0;
substr($$REF, 0, 6) eq 'CANVAS' or return 0;
return (index('08162432', substr($$REF, 6, 2)) & 1) ? 0 : $REF;
}
# This function makes sure that the canvas string is
# not too short. If parts of the image are missing,
# they are filled in 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 = GetBPP($_[3]) || DepthOf($REF);
FixCanvasHeader($REF, $W, $H, $D);
my $SIZE = $W * $H * $D + 16;
if (length($$REF) < $SIZE) { vec($$REF, $SIZE - 1, 8) = 0; }
if (length($$REF) > $SIZE) { $$REF = substr($$REF, 0, $SIZE); }
return 1;
}
#
# Canvas | Graphics | v2022.12.13
# Returns a reference to a 0 x 0 blank canvas.
# Usage: CANVASREF = BlankCanvas([DEPTH])
sub BlankCanvas { return NewCanvas(0, 0, $_[0]); }
# 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 $NUM = defined $_[0] ? int($_[0]) : $MIN;
my $MAX = defined $_[2] ? int($_[2]) : 4294967295;
use warnings;
$NUM > $MIN or return $MIN;
$NUM < $MAX or return $MAX;
return int($NUM);
}
#
# 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!22C2CCT2CCTCTTe2CCTCTTe
+CTTeTeev!22C2CCT2CCTCTTe2CCTCTTeCTTeTeev2CCTCTTeCTTeTeevCTTeTeevTeeve
+vv\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);
}
#
# 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; }
#
# Math | v2022.10.23
# Like the name suggests, this function takes any
# number as input and returns an integer that
# is rounded up to the next higher value.
#
# Usage: INTEGER = CEIL(NUMBER)
#
sub CEIL { return int($_[0]) + ($_[0] - int($_[0]) > 0); }
#
# Debugging | v2022.12.11
# This function is called whenever information or
# error messages are printed by any of the graphics
# routines in this library. This function can be
# modified to print everything to stderr or to save
# the messages to a file or suppress everything.
# Usage: GPRINT(MSG)
#
sub GPRINT { print @_; }
#
# 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.
#
# A BMP file can have a number of different formats
# and can use 1 bit, 4 bits, 8 bits, 16 bits, 24 bits,
# or 32 bits to represent one pixel. However, at
# the time when the image is decoded and stored in
# memory, the image can be upscaled or downscaled.
#
# 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], 3);
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.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;
}
#
# 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]) > 1150 or return ();
my @L = unpack('C5V24d3', $_[0]);
push(@L, substr($_[0], 125, 1024));
push(@L, substr($_[0], 1151));
return @L;
}
#
# 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 ($BPP > 8) { $CC = $PALWIDTH = $PALPTR = 0; }
my $PALETTE = ReadBMPPalette($HEADER, $PALPTR, $PALWIDTH, $CC);
# Perform some calculations...
my $ROWLEN = CEIL(($W * $BPP) / 8); # Bytes per row
my $PADDING = (4 - ($ROWLEN & 3)) & 3; # Padding bytes per row
my ($DIR, $START, $STOP) = (1, 0, $H);
if ($VFLIP) { ($DIR, $START, $STOP) = (-1, $H - 1, -1); }
$ROWLEN += $PADDING;
# Everything seems to be OK.
$BMPINFO = pack('C5V24d3', $FMT, $E, $BGRS, $PALWIDTH, $VFLIP,
$W, $H, $COMPR, $BMPVER, $COLORS, $XRES, $YRES, $MAXCOLORS,
$FILESIZE, $DATASIZE, $DATAPTR, $RESERVED, $IC, $CC, $SIG,
$RMASK, $GMASK, $BMASK, $AMASK, $BPP, $PLANES, $ROWLEN,
$PALPTR, $PADDING, $START, $STOP, $DIR) . $PALETTE;
}
vec($BMPINFO, 1, 8) = $E; # Save error code
vec($BMPINFO, 1150, 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, $BGRS, $PALWIDTH, $VFLIP, $W, $H, $COMPR, $BMPVER,
$COLORS, $XRES, $YRES, $MAXCOLORS, $FILESIZE, $DATASIZE,
$DATAPTR, $RESERVED, $IC, $CC, $SIG, $RMASK, $GMASK, $BMASK,
$AMASK, $BPP, $PLANES, $ROWLEN, $PALPTR, $PADDING, $START,
$STOP, $DIR, $PALETTE, $F) = UnpackBMPINFO($_[0]);
my $D = GetBPP(defined $_[1] ? $_[1] : $BPP, 3);
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 = CreateCanvasHeader($W, $H, $D);
vec($CANVAS, $W * $H * $D + 15, 8) = 0; # Fill canvas.
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
#print "\nW=$W H=$H START=$START STOP=$STOP VFLIP=$VFLIP Y=$Y ROWL
+EN=$ROWLEN";
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;
}
#
# 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], 3); # Convert depth to bytes per pixel
my $C = Int32bit($_[3]); # Background color
my $CANVAS = CreateCanvasHeader($W, $H, $D);
my $RES = $W * $H;
$RES or return \$CANVAS;
# Use zero (black) as the background?
if ($C == 0)
{ vec($CANVAS, ($RES * $D + 15), 8) = 0; return \$CANVAS; }
# Convert color to a string.
$C = toColorStr($C, $D);
$CANVAS .= $C x $RES; # Fill canvas
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.
#
# WHAT DOES THIS FUNCTION REALLY DO AND WHY ?
#
# We take each color component and stretch its normal
# range of values so its new range will be 0 to 255.
# For example, if a red value is stored in 4 bits,
# then we have a possible range of 0000 to 1111 in
# binary. That's 0 to 15. Now, we could put 4
# zero bits behind this, but our range would still be
# from 00000000 to 11110000 (0-240). This means that
# the brightest white in the picture would still look
# a bit greyish. This is what happens when you chop
# off the least significant bits of the R G B values.
# So, to fix this, we multiply each R G B color component
# by a certain amount, so when they are at maximum, the
# intensity will be 255 instead of 240. But instead of
# multiplying, we use a lookup table, which is a whole
# lot faster. This function builds the lookup table.
#
# EXAMPLE. How to use the lookup table:
#
# $RX = CountBits32($RMASK); # 0000f000 => 4
# $GX = CountBits32($GMASK); # 00000f00 => 4
# $BX = CountBits32($BMASK); # 000000f0 => 4
# $RLT = BuildColorStretchTable($RX);
# $GLT = BuildColorStretchTable($GX);
# $BLT = BuildColorStretchTable($BX);
# ...
# $RED = vec($RLT, $RED, 8); # Input: 240 Output: 255
# $GRN = vec($GLT, $GRN, 8); # Input: 16 Output: 17
# $BLU = vec($BLT, $BLU, 8); # Input: 0 Output: 0
#
# 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;
}
#
# 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, $BGRS, $PALWIDTH, $VFLIP, $W, $H, $COMPR, $BMPVER,
$COLORS, $XRES, $YRES, $MAXCOLORS, $FILESIZE, $DATASIZE,
$DATAPTR, $RESERVED, $IC, $CC, $SIG, $RMASK, $GMASK, $BMASK,
$AMASK, $BPP, $PLANES, $ROWLEN, $PALPTR, $PADDING, $START,
$STOP, $DIR, $PALETTE, $F) = UnpackBMPINFO($_[0]);
my $D = GetBPP(defined $_[1] ? $_[1] : $BPP, 3);
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 = CreateCanvasHeader($W, $H, $D);
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;
}
# 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;
}
#
# 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;
}
#
# 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;
}
#
# 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, $BGRS, $PALWIDTH, $VFLIP, $W, $H, $COMPR, $BMPVER,
$COLORS, $XRES, $YRES, $MAXCOLORS, $FILESIZE, $DATASIZE,
$DATAPTR, $RESERVED, $IC, $CC, $SIG, $RMASK, $GMASK, $BMASK,
$AMASK, $BPP, $PLANES, $ROWLEN, $PALPTR, $PADDING, $START,
$STOP, $DIR, $PALETTE, $F) = UnpackBMPINFO($_[0]);
my $D = GetBPP(defined $_[1] ? $_[1] : $BPP, 3);
my $DEBUG = 0;
print "\nExpanding $W x $H RLE compressed BMP image ",
"($BPP bpp => ", ($D << 3), ' bpp) ';
# Create canvas right here.
my $CANVAS = CreateCanvasHeader($W, $H, $D);
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 8;
# 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;
}
#
# 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;
}
#
# 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;
}
#
# BMP | Graphics | v2022.11.26
# This function saves a canvas image as a BMP file.
# You may use the 3rd and 4th arguments to specify
# the exact output format. If you omit these,
# we will automatically pick the best format.
#
# Usage: SaveBMP(CANVASREF, FILENAME, [FMT, [BMPVER]])
#
# The 4th argument allows you to request that a particular
# BMP header version be used, however this request may be
# overridden by the 3rd argument. Also, if you specify an
# invalid value, it will be replaced with the correct one.
# Also note that BMP v40 is the standard format, and using
# anything other than v40 means that some photo editors
# and viewers will not be able to decode your BMP file.
#
# Recommended: Choose a format that has a * in front of it.
# This means that all programs will be able to open your BMP file.
#
# FMT v12 v40 v56 BITS FORMAT COLORS
# -------------------------------------------------------------
# 0 .......... *X X 32 A8 R8 G8 B8 16777216 truecolor
# 1 ..... *X *X X 24 R8 G8 B8 16777216 truecolor
# 2 ................ X 32 X8 R8 G8 B8 16777216 truecolor
# 3 ................ X 16 R5 G6 B5 65536 truecolor
# 4 ................ X 16 A1 R5 G5 B5 32768 truecolor
# 5 ................ X 16 X1 R5 G5 B5 32768 truecolor
# 6 ................ X 16 A4 R4 G4 B4 4096 truecolor
# 7 ................ X 16 X4 R4 G4 B4 4096 truecolor
# 8 ................ X 16 A8 C8 256 grayscale
# -------------------------------------------------------------
#
# Usage: SaveBMP(CANVASREF, FILENAME, [FMT, [BMPVER]])
#
sub SaveBMP
{
my ($REF, $W, $H, $D, $START) = UseCanvas($_[0]) or return 0;
my @FORMAT_DETAILS = (
##################
# BYTES PER PIXEL Minimum Header Version
# Red Green Blue Alpha \ | Compression Value
# Mask Mask Mask Mask \ | / Encoding MaxColors
'00ff0000 0000ff00 000000ff ff000000 4 40 0 A8 R8 G8 B8 16777216',
'00ff0000 0000ff00 000000ff 00000000 3 12 0 R8 G8 B8 16777216',
'00ff0000 0000ff00 000000ff 00000000 4 56 3 X8 R8 G8 B8 16777216',
'0000f800 000007e0 0000001f 00000000 2 56 3 R5 G6 B5 65536',
'00007c00 000003e0 0000001f 00008000 2 56 3 A1 R5 G5 B5 32768',
'00007c00 000003e0 0000001f 00000000 2 56 3 X1 R5 G5 B5 32768',
'00000f00 000000f0 0000000f 0000f000 2 56 3 A4 R4 G4 B4 4096',
'00000f00 000000f0 0000000f 00000000 2 56 3 X4 R4 G4 B4 4096',
'000000ff 000000ff 000000ff 0000ff00 2 56 3 A8 L8 gray 256',
'00000000 00000000 00000000 00000000 1 12 0 L8 gray 256',
'00000000 00000000 00000000 00000000 1 40 1 L8 gray RLE8 256',
'00000000 00000000 00000000 00000000 1 12 0 8-bit 256',
'00000000 00000000 00000000 00000000 1 40 1 8-bit RLE8 256',
'00000000 00000000 00000000 00000000 1 12 0 4-bit 16',
'00000000 00000000 00000000 00000000 1 40 2 4-bit RLE4 16',
'00000000 00000000 00000000 00000000 1 12 0 1-bit 2',
'00000000 00000000 00000000 00000000 1 12 0 B/W dithered 2');
##################
# Get BMP Version
my $BMPVER = defined $_[3] ? $_[3] : 40;
if ($BMPVER <= 12) { $BMPVER = 12; }
elsif ($BMPVER >= 56) { $BMPVER = 56; }
else { $BMPVER = 40; }
# Look up format details.
my $FMT = defined $_[2] ? $_[2] : -1;
if ($FMT < 0 || $FMT >= @FORMAT_DETAILS) # Autodetect format
{
$BMPVER = 40; $FMT = 1;
if ($D == 1) { $FMT = 14; }
elsif ($D == 4) { $FMT = 0; }
}
my $DETAILS = $FORMAT_DETAILS[$FMT];
my $COMPRESS = index($DETAILS, 'RLE') > 0;
# Images whose width or height exceeds
# 65535 pixels must use at least v40 header.
# Update BMP Version.
my $MINVER = substr($DETAILS, 38, 2);
if ($BMPVER < $MINVER) { $BMPVER = $MINVER; }
if ($BMPVER < 40 && ($W > 65535 || $H > 65535)) { $BMPVER = 40; }
substr($DETAILS, 38, 2) = $BMPVER;
vec($DETAILS, 66, 8) = 32;
$DETAILS .= FilterFileName($_[1]);
if ($FMT < 9) { return SaveTruecolorBMP($REF, $DETAILS); }
if ($COMPRESS) { return CompressBMP($REF, $DETAILS); }
return SaveBMPwithPalette($REF, $DETAILS);
}
#
# BMP | Graphics | v2022.11.26
# This function unpacks the format details provided
# by the SaveBMP() function for its private functions.
# Usage: ARRAY = UnpackBMPFormatDetails(STRING)
#
sub UnpackBMPFormatDetails
{
my $F = defined $_[0] ? $_[0] : '';
if (length($F) < 55) { return (0) x 9; }
my $BYTES_PER_PIXEL = substr($F, 36, 1);
my $RMASK = hex(substr($F, 0, 8));
my $GMASK = hex(substr($F, 9, 8));
my $BMASK = hex(substr($F, 18, 8));
my $AMASK = hex(substr($F, 27, 8));
my $BMPVER = substr($F, 38, 2);
my $COMPR = substr($F, 41, 1);
my $ENCODING = Trim(substr($F, 43, 12));
my $MAXCOLORS = Trim(substr($F, 56, 8));
my $FILENAME = Trim(substr($F, 66));
return ($BYTES_PER_PIXEL, $RMASK, $GMASK, $BMASK, $AMASK,
$BMPVER, $COMPR, $ENCODING, $MAXCOLORS, $FILENAME);
}
#
# BMP | Graphics | v2022.11.26
# This is a private function that is called by the
# SaveBMP() function to save a canvas image as a
# BMP file in truecolor format.
#
# The second argument is special string that contains
# all the necessary details about the encoding such as
# bit masks, BPP, BMP version, compression, etc.
#
# Usage: SaveTruecolorBMP(CANVASREF, FORMAT_DETAILS)
#
sub SaveTruecolorBMP
{
my ($CANVAS, $W, $H, $DIN, $START) = UseCanvas($_[0]) or return 0;
# $DIN contains the input image depth (bytes per pixel)
# $DOUT contains the output image depth (bytes per pixel)
my $PALETTE = '';
my ($DOUT, $RMASK, $GMASK, $BMASK, $AMASK, $BMPVER, $COMPR,
$ENCODING, $MAXCOLORS, $F) = UnpackBMPFormatDetails($_[1]);
my $RES = $W * $H;
my $DATASIZE = $RES * $DOUT;
# Adobe PhotoShop prefers when FILESIZE is divisible by 4.
# (We'll add some zero padding at the end of the file.)
my $FILESIZE = $DATASIZE + $BMPVER + 14;
my $EOFPAD = (4 - (($FILESIZE) & 3)) & 3;
$DATASIZE += $EOFPAD;
my $HEADER = MakeBMPHeader($W, $H, $DOUT << 3, $COMPR, $BMPVER,
$DATASIZE, 0, 0, '', 720, $AMASK, $RMASK, $GMASK, $BMASK)
or return 0;
# This is an explanation of the arguments for MakeBMPHeader():
# First, we pass the image width and image height, followed by the
# Bits Per Pixel ($DOUT << 3), Compression value, BMP Version,
# Size of the entire image in bytes ($DATASIZE), Number of colors
# and important colors are zero (these values have no significance
# when truecolor images are saved), the palette is an empty string,
# because truecolor images do not use a palette). We use 720 DPI
# as the recommended print resolution. Finally, we include the bit
# masks ($AMASK, $RMASK, $GMASK, $BMASK) which specify how the
# R G B A channels are stored inside each pixel.
# Make some calculations...
my $INPUT_ROWLEN = $W * $DIN;
my $OUTPUT_ROWLEN = $W * $DOUT;
my $PADLEN = (4 - ($OUTPUT_ROWLEN & 3)) & 3;
my $PADDING = "\0" x $PADLEN;
my $PTR = ($H - 1) * $INPUT_ROWLEN + $START; # Pointer to last row
my $STEP = -($INPUT_ROWLEN * 2); # to jump to prev row
# Enumerate each format so we can later identify them quickly.
my $AX = CountBits32($AMASK);
my $RX = CountBits32($RMASK);
my $GX = CountBits32($GMASK);
my $BX = CountBits32($BMASK);
my $f = $AX << 16 | $RX << 12 | $GX << 8 | $BX << 4 | $DOUT;
my ($PX, $A, $R, $G, $B, $PIXEL) = (0) x 6;
# Print some stuff...
$| = 1;
print "\n\nSaving BMP file: $F ( $W x $H )",
"\nUsing ", ($DOUT << 3), "-bit $ENCODING encoding.\n";
printf("\n AMASK = %0.8x\tPADDING = $PADLEN\t ORIENTATION = UPSIDE
+DOWN", $AMASK);
printf("\n RMASK = %0.8x\tBMPVER = $BMPVER\t PTR = $PTR", $RMASK);
printf("\n GMASK = %0.8x\tCOMPRESSION = $COMPR\t STEP = $STEP", $GM
+ASK);
printf("\n BMASK = %0.8x\tHEADERLEN = ", $BMASK);
print length($HEADER), "\t MAXCOLORS = $MAXCOLORS\n...";
# Create BMP file...
local *FILE;
open(FILE, ">$F") or return 0;
binmode FILE;
print FILE $HEADER;
undef $HEADER;
# And now, let's encode the pixels.
while ($H--)
{
for (my $X = 0; $X < $W; $X++)
{
# Read pixels from canvas
if ($DIN == 1) # Use 8-bit input source
{
my $CX = vec($$CANVAS, $PTR++, 8) << 2;
$A = vec($PALETTE, $CX++, 8);
$R = vec($PALETTE, $CX++, 8);
$G = vec($PALETTE, $CX++, 8);
$B = vec($PALETTE, $CX++, 8);
}
else # Use 24-bit or 32-bit input source
{
$A = vec($$CANVAS, $PTR++, 8) if ($DIN == 4);
$R = vec($$CANVAS, $PTR++, 8);
$G = vec($$CANVAS, $PTR++, 8);
$B = vec($$CANVAS, $PTR++, 8);
}
# Convert pixel to appropriate output format:
if ($f == 0x88884) { $PIXEL = pack('CCCC', # A8 R8 G8 B8
$B, $G, $R, $A); }
elsif ($f == 0x08884) { $PIXEL = pack('CCCC', # X8 R8 G8 B8
$B, $G, $R, 0); }
elsif ($f == 0x08883) { $PIXEL = pack('CCC', # R8 G8 B8
$B, $G, $R); }
elsif ($f == 0x05652) { $PIXEL = pack('CC', # R5 G6 B5
(($B >> 3) & 0x1F) | (($G << 3) & 0xE0),
($R & 0xF8) | (($G & 0xE0) >> 5)); }
elsif ($f == 0x15552) { $PIXEL = pack('CC', # A1 R5 G5 B5
(($G << 2) & 0xE0) | ($B >> 3),
(($R >> 1) & 0x7C) | ($G >> 6) | ($A & 0x80)); }
elsif ($f == 0x05552) { $PIXEL = pack('CC', # X1 R5 G5 B5
(($G << 2) & 0xE0) | ($B >> 3),
(($R >> 1) & 0x7C) | ($G >> 6)); }
elsif ($f == 0x44442) { $PIXEL = pack('CC', # A4 R4 G4 B4
($G & 0xF0) | ($B >> 4),
($A & 0xF0) | ($R >> 4)); }
elsif ($f == 0x04442) { $PIXEL = pack('CC', # X4 R4 G4 B4
($G & 0xF0) | ($B >> 4), ($R >> 4)); }
elsif ($f == 0x88882) { $PIXEL = pack('CC', # Grayscale A8 L8
int(($R + $G + $B) / 3 + 0.5), $A); }
print FILE $PIXEL; # Write pixel
# After writing 3000 pixels, we print one dot to stdout.
$PX++ < 3000 or $PX = print '.';
}
$PTR += $STEP; # Move to beginning of next line
if ($PADLEN) { print FILE $PADDING; } # Add padding if needed
}
print FILE "\0" x $EOFPAD; # Make Adobe Photoshop happy.
close FILE;
print "\nDONE.\n";
return 1;
}
#
# BMP | Graphics | v2022.11.24
# This function reads a BMP file's header and returns
# a short list of values. The first value is the image
# width, followed by the image height, depth, a format
# string, and an error code. If the error code is
# non-zero, then the file either doesn't exist or
# is not a BMP file or has some other serious
# issue which will prevent it from being displayed.
#
# Usage: (W, H, D, FMT, ERR) = QuickReadBMPHeader(FILENAME)
#
sub QuickReadBMPHeader
{
# Read the first 70 bytes from the file.
my $HEADER = '';
my $F = FilterFileName($_[0]);
my $ERR = ReadFile($_[0], $HEADER, 0, 70);
if ($ERR) { return (0, 0, 0, '', $ERR); }
vec($HEADER, 70, 8) = 0; # Expand header if it's too short.
# Unpack header values. 54
my ($SIG, $VER, $W, $H, $BPP, $COMPR, $RX, $GX, $BX, $AX) =
unpack('v x12 V3 xx vV x20 V4', $HEADER);
if ($VER < 16)
{ ($W, $H, $BPP) = unpack('x18 vvxxv', $HEADER); $COMPR = 0; }
# Check BMP Version number.
index('12|16|40|52|56|58|64|108|124|', "$VER|") >= 0 or $ERR |= 4;
# Check bits per pixel value.
index('1|4|8|16|24|32|', "$BPP|") >= 0 or $ERR |= 8;
# Check compression value.
index('0|1|2|3|', "$COMPR|") >= 0 or $ERR |= 16;
# Check file signature.
$SIG == 0x4D42 or $ERR |= 32;
if ($ERR) { return (0, 0, 0, '', $ERR); }
# Fix image height.
if ($H & 0x80000000) { $H = NEG32($H); }
# Check image width and height.
$W && $H or $ERR |= 64;
# Color indexed BMP file? Exit here:
if ($BPP <= 8) { return ($W, $H, $BPP, '', $ERR); }
# Build format string.
if ($COMPR == 3 && $VER >= 56)
{
$AX = CountBits32($AX);
$RX = CountBits32($RX);
$GX = CountBits32($GX);
$BX = CountBits32($BX);
}
else
{
$AX = ($BPP < 32) ? 0 : 8;
$RX = $GX = $BX = 8;
}
my $UX = $BPP - $AX - $RX - $GX - $BX;
$UX = ($UX) ? "X$UX-" : '';
$AX = ($AX) ? "A$AX-" : '';
my $FMT = $UX . $AX . "R$RX-G$GX-B$BX";
return ($W, $H, $BPP, $FMT, 0);
}
# 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) == 1024)
{
if ($BMPVER < 16)
{ ReorderStr(\$PALETTE, 4, '432'); }
else
{ ReorderStr(\$PALETTE, 4, '4321'); }
}
if (length($PALETTE) > $PALMAX)
{ $PALETTE = substr($PALETTE, 0, $PALMAX); }
if ($BPP >= 16 && $BMPVER >= 56) { $COMPR = 3; }
# 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.)
# We add 14, because that's the primary header size.
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.9365);
my $YRES = int($DPI * 3.9365);
# 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) { $HEADER .= $PALETTE; }
if (length($HEADER) < $HDRSIZE) { $HEADER .= "\0" x
($HDRSIZE - length($HEADER)); } # Fill the rest with zeros.
return $HEADER;
}
# This function converts a color from integer to string.
#
# Usage: STRING = toColorStr(COLOR, DEPTH)
#
sub toColorStr
{
my $C = Int32bit($_[0]);
my $D = GetBPP($_[1]);
if ($D == 1) { return chr($C & 255); }
if ($D == 2) { return pack('n', $C & 0xffff); }
if ($D == 4) { return pack('N', $C & 0xffffffff); }
if ($D == 3) { return substr(pack('N', $C & 0xffffff), 1, 3); }
return '';
}
# This function splits up a 24-bit integer and returns
# the individual R-G-B color values as integers.
# Example: (0xff, 0xbb, 0x99) = Int2RGB(0xffbb99);
# Usage: (R, G, B) = Int2RGB(INTEGER)
#
sub Int2RGB
{
defined $_[0] or return (0, 0, 0);
my $R = ($_[0] >> 16) & 255;
my $G = ($_[0] >> 8) & 255;
my $B = $_[0] & 255;
return ($R, $G, $B);
}
# Converts a 24-bit integer to a 3-byte string.
# Usage: STRING = ColorStr(INTEGER)
#
sub ColorStr
{
my $C = "\0\0\0";
defined $_[0] or return $C;
vec($C, 0, 8) = ($_[0] >> 16) & 255; # Write RED
vec($C, 1, 8) = ($_[0] >> 8) & 255; # Write GRN
vec($C, 2, 8) = $_[0] & 255; # Write BLU
return $C;
}
#
# Math | v2022.12.21
# This function converts a number to a 32-bit integer.
# If the number is undefined to begin with, then
# it returns the default value which is provided
# in the second argument. If the default value
# is undefined, then returns zero.
#
# Usage: INTEGER = Int32bit(NUMBER, [DEFAULT])
#
sub Int32bit
{
no warnings;
my $DEF = defined $_[1] ? $_[1] & 0xffffffff : 0;
my $INT = defined $_[0] ? $_[0] & 0xffffffff : $DEF;
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;
}
#
# String | v2022.10.18
# This function removes whitespace from before and
# after STRING. Whitespace is here defined as any
# character whose ASCII value is less than 33.
# This includes spaces, tabs, esc, null, new lines, etc.
# Usage: STRING = Trim(STRING)
#
sub Trim
{
defined $_[0] or return '';
(my $L = length($_[0])) or return '';
my $P = 0;
while ($P <= $L && ord(substr($_[0], $P++, 1)) < 33) {} $P--; # Fin
+d first non-whitespace
while ($P <= $L && ord(substr($_[0], $L--, 1)) < 33) {} # Fin
+d last non-whitespace
return substr($_[0], $P, $L - $P + 2);
}
#
# 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\x88uxwxvxwxdhghfhghehghfhg
+hSXWXVXWXUXWXVXWXTXWXVXWXUXWXVXWXBHGHFHGHEHGHFHGHDHGHFHGHEHGHFHGHCHGH
+FHGHEHGHFHGHDHGHFHGHEHGHFHGH18786878587868784878687858786878387868785
+878687848786878587868782878687858786878487868785878687838786878587868
+784878687858786878", $_[0] & 255, 8);
my $BEFORE = ($N >> 4) + (defined $_[1] ? $_[1] : 0) - 3;
my $AFTER = (8 - ($N & 15)) + (defined $_[2] ? $_[2] : 0);
return ($BEFORE, $AFTER);
}
#
# 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;
}
| 