Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

Re^2: Convert BMP to HTML

by harangzsolt33 (Chaplain)
on Oct 31, 2022 at 02:25 UTC ( [id://11147850]=note: print w/replies, xml ) Need Help??


in reply to Re: Convert BMP to HTML
in thread Convert BMP to HTML

Where is the script? Good question! I could not insert it into my first post, because each post can only be 64K long, and the picture took up all the space. lol But here it is! This is actually part of a much larger project I am working on. This is an updated version. (Last Update: 11/22/2022) Now the ReadBMP() function works perfectly. It can read any kind of BMP file including old OS/2 BMPs, modern Windows BMPs, 32-bit, 24-bit, 16-bit, 8-bit, 4-bit, 1-bit, RLE4 and RLE8 compressed bitmaps, A4 R4 G4 B4, X4 R4 G4 B4, A1 R5 G5 B5, X1 R5 G5 B5, R5 G6 B5, etc...

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

Replies are listed 'Best First'.
Re^3: Convert BMP to HTML
by pryrt (Abbot) on Oct 31, 2022 at 14:10 UTC
    Have you compared yours to what cavac published as Re^3: Shameless plug and QR japh in April, in the second code block? Since GD::Image can handle multiple image types, cavac's has more input options. But looking at yours, I see that it might have color reduction/compression (like changing the default color on the table to the most prevalent color in the image). I also see "canvas" mentioned in your code, but I'm not sure if that's just there because it isn't using GD::Image, or whether it was doing something unique with a real HTML5 <canvas> , or whether you just borrowed that term from HTML5 (since Perl Monks Approved HTML tags doesn't list <canvas> among our assets).
      Yes! It seems that does exactly the same things. Except I noticed that he uses "</TD>" and "</TR>" closing elements also. Mine doesn't do that, because it's unnecessary. All web browsers know that a "</TD>" block ends when another one begins or when TABLE object ends. Every byte counts. In my code, I also compress colors. For example, FC0102 becomes "RED" because it looks like red. Then black becomes a single zero, because web browsers accept it. Of course, it might not be standard or official, but if I can get away with it, then that's fine. So instead of saying BGCOLOR=BLACK, I just do BGCOLOR=0. Green would be BGCOLOR=00FF00 but I just write it as BGCOLOR=00F# because web browsers correctly interpret it as green.

      I have thought about using ROWSPAN as well, but I would have to significantly rewrite the code to detect not just long repeating lines of same color but box shaped areas which are all made up of the same color.

      I use the word "CANVAS" in my code simply because ReadBMP converts the BMP file to an intermediary format that my script can work with. This image format is a single string that always starts with the word "CANVAS." That's how the program recognizes that the string is an image. The next 2 bytes hold the image format, which is then followed by 4-byte width and 4-byte height of the image. Then 3 bytes for the red, green, blue values for the first pixel starting in the upper left hand corner. This format is pretty straightforward (to me), because I designed it. And I also wrote ReadRAS() ReadRGB() and ReadPXR() subs, which are obsolete formats that are not supported by Imager. I don't understand why, because, for example, SUN Raster image format is a very clean and easy to understand format, and many times RAS files are smaller than BMP files. Writing a script to read and write RAS images is a whole lot simpler than writing a script that reads and writes BMP files. BMP files contain so much unnecessary complexity! Anyway, once the image is read and decoded, it is stored as a string whose first few bytes start with the word "CANVAS" and then the functions that I write simply act on that string. I can read a pixel using either substr() and vec() or unpack(). Those are my tools. I found that calling a SetPixel() or GetPixel() function slows down the code, because if you have to call a function millions of times, it adds significant delay. And when you're writing it in pure perl, it's better not to put that into separate subs. So, my getpixel and putpixel methods look like single substr() calls.

      my ($R, $G, $B) = unpack('CCC', substr($$CANVAS, $PTR, 3)); # Reads a single pixel.

      substr($$CANVAS, $PTR, 3) = "\0\0\xFF"; # Writes a single blue pixel somewhere.

        Making assumptions about error correcting heuristics of some current browsers just to save some bytes is not a good strategy.

        For instance: The markup of the monastery is basic enough to be interpreted by a new reader, like a Tk or mobile app. Those will not show the same intelligence.

        Furthermore, we do parse and filter the markup here. Unbalanced tags might lead to unwanted effects.

        Cheers Rolf
        (addicted to the 𐍀𐌴𐍂𐌻 Programming Language :)
        Wikisyntax for the Monastery

        Mine doesn't do that, because it's unnecessary. All web browsers know that a "</TD>" block ends when another one begins or when TABLE object ends

        Just because all most browsers will deal with erroneous HTML code is hardly an excuse to deliberately produce it.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://11147850]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others about the Monastery: (7)
As of 2024-04-18 12:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found