in reply to Cannot Set Image Pixel to a Random Colour using GD
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; }
|
|---|