here's a class thats quite usefull. it lets u read each pixel from a 24bit and a monochrome bitmap file directly
the 24bit mode works well.. drawing the colors onto the screen may not be so though. but thats a turing RGB.AddColour problem
the monochrome mode is giving me problems.. if u guys figure out whats wrong do post.
| code: |
class RGBQUAD export var rgbBlue, var rgbGreen, var rgbRed, var rgbReserved var rgbBlue : nat1 var rgbGreen : nat1 var rgbRed : nat1 var rgbReserved : nat1 end RGBQUAD class MONOCHROMESET export var color1, var color2, getColor, setBit var color1, color2 : int color1 := black color2 := white var bit : boolean := false fcn getColor : int if bit = true then result color1 else result color2 end if end getColor proc setBit bit := true end setBit end MONOCHROMESET class Rectangle export x, y, w, h, setDimensions, setLocation var ix, iy : int var width, height : int proc setLocation (x, y : int) ix := x iy := y end setLocation proc setDimensions (w, h : int) width := w height := h end setDimensions fcn x : int result ix end x fcn y : int result iy end y fcn w : int result width end w fcn h : int result height end h end Rectangle class Image import Rectangle export Destruct, draw, getBounds var bounds : ^Rectangle new bounds var file : string new bounds fcn getBounds : ^Rectangle result bounds end getBounds deferred proc draw proc Destruct free bounds end Destruct end Image class BitmapFile inherit Image import RGBQUAD, MONOCHROMESET export Construct, BITMAPFILEHEADER, BITMAPINFOHEADER, MONOCHROME, COLOR_16, COLOR_256, COLOR_16M, getInfoAt % --constants-- const MONOCHROME := 1 const COLOR_16 := 4 const COLOR_256 := 8 const COLOR_16M := 24 type BITMAPFILEHEADER : % defaults % location in file record bfType : nat2 %:= 19778 % 1 bfSize : nat4 %:= ?? % 3 bfReserved1 : nat2 %:= 0 % 7 bfReserved2 : nat2 %:= 0 % 9 bfOffBits : nat4 %:= 1078 % 11 end record type BITMAPINFOHEADER : record biSize : nat4 %:= 40 % 15 biWidth : int4 %:= 100 % 19 biHeight : int4 %:= 100 % 23 biPlanes : nat2 %:= 1 % 27 biBitCount : nat2 %:= COLOR_256 % 29 biCompression : nat4 %:= 0 % 31 biSizeImage : nat4 %:= 0 % 35 biXPelsPerMeter : int4 %:= 0 % 39 biYPelsPerMeter : int4 %:= 0 % 43 biClrUsed : nat4 %:= 0 % 47 biClrImportant : nat4 %:= 0 % 51 end record % --variables-- var bitmapBits : flexible array 0 .. 0 of ^anyclass bounds -> setLocation (0, maxy) var fileName : string var bitmapFileHeader : BITMAPFILEHEADER var bitmapInfoHeader : BITMAPINFOHEADER var bit : array 1 .. 32 of nat4 bit (1) := 2#00000000000000000000000000000001 bit (2) := 2#00000000000000000000000000000010 bit (3) := 2#00000000000000000000000000000100 bit (4) := 2#00000000000000000000000000001000 bit (5) := 2#00000000000000000000000000010000 bit (6) := 2#00000000000000000000000000100000 bit (7) := 2#00000000000000000000000001000000 bit (8) := 2#00000000000000000000000010000000 bit (9) := 2#00000000000000000000000100000000 bit (10) := 2#00000000000000000000001000000000 bit (11) := 2#00000000000000000000010000000000 bit (12) := 2#00000000000000000000100000000000 bit (13) := 2#00000000000000000001000000000000 bit (14) := 2#00000000000000000010000000000000 bit (15) := 2#00000000000000000100000000000000 bit (16) := 2#00000000000000001000000000000000 bit (17) := 2#00000000000000010000000000000000 bit (18) := 2#00000000000000100000000000000000 bit (19) := 2#00000000000001000000000000000000 bit (20) := 2#00000000000010000000000000000000 bit (21) := 2#00000000000100000000000000000000 bit (22) := 2#00000000001000000000000000000000 bit (23) := 2#00000000010000000000000000000000 bit (24) := 2#00000000100000000000000000000000 bit (25) := 2#00000001000000000000000000000000 bit (26) := 2#00000010000000000000000000000000 bit (27) := 2#00000100000000000000000000000000 bit (28) := 2#00001000000000000000000000000000 bit (29) := 2#00010000000000000000000000000000 bit (30) := 2#00100000000000000000000000000000 bit (31) := 2#01000000000000000000000000000000 bit (32) := 2#10000000000000000000000000000000 proc _readBitmapFileHeader (sn : int) read : sn, bitmapFileHeader.bfType read : sn, bitmapFileHeader.bfSize read : sn, bitmapFileHeader.bfReserved1 read : sn, bitmapFileHeader.bfReserved2 read : sn, bitmapFileHeader.bfOffBits end _readBitmapFileHeader proc _readBitmapInfoHeader (sn : int) read : sn, bitmapInfoHeader.biSize read : sn, bitmapInfoHeader.biWidth read : sn, bitmapInfoHeader.biHeight read : sn, bitmapInfoHeader.biPlanes read : sn, bitmapInfoHeader.biBitCount read : sn, bitmapInfoHeader.biCompression read : sn, bitmapInfoHeader.biSizeImage read : sn, bitmapInfoHeader.biXPelsPerMeter read : sn, bitmapInfoHeader.biYPelsPerMeter read : sn, bitmapInfoHeader.biClrUsed read : sn, bitmapInfoHeader.biClrImportant end _readBitmapInfoHeader fcn _getPos (sn : int) : int var pos : int tell : sn, pos result pos end _getPos fcn _readRGBBytes (sn : int) : ^RGBQUAD var r, g, b : nat1 seek : sn, _getPos (sn) read : sn, b read : sn, g read : sn, r var rgbQuad : ^RGBQUAD new rgbQuad rgbQuad -> rgbRed := r rgbQuad -> rgbGreen := g rgbQuad -> rgbBlue := b result rgbQuad end _readRGBBytes proc _read24BitData (sn : int) for i : 0 .. bounds -> w * bounds -> h bitmapBits (i) := _readRGBBytes (sn) end for end _read24BitData proc _readMonochromeData (sn : int) var cbit32 : nat4 := 0 var tmp : ^MONOCHROMESET := nil for k : 0 .. bounds -> w * bounds -> h by 32 read : sn, cbit32 for decreasing i : 32 .. 1 if k + (32 - i) > bounds -> w * bounds -> h then exit end if new tmp if (cbit32 and bit (i)) = bit (i) then tmp -> setBit end if bitmapBits (k + (32 - i)) := tmp end for end for end _readMonochromeData proc Construct (name : string) fileName := name var sn : int open : sn, fileName, read, seek seek : sn, 0 _readBitmapFileHeader (sn) _readBitmapInfoHeader (sn) bounds -> setDimensions (bitmapInfoHeader.biWidth, bitmapInfoHeader.biHeight) new bitmapBits, bounds -> w * bounds -> h case bitmapInfoHeader.biBitCount of label COLOR_16M : _read24BitData (sn) label MONOCHROME : _readMonochromeData (sn) label : assert false % if u've reached here, it's probably cuz ur using a colour % resolution that is not implemented yet end case close : sn end Construct fcn getInfoAt (x, y : int) : ^anyclass var tmp : ^anyclass := nil tmp := bitmapBits (((bounds -> h - y) * bounds -> w) - (bounds -> w - x)) result tmp end getInfoAt body proc draw var tmp : ^anyclass var colr : int := 0 case bitmapInfoHeader.biBitCount of label COLOR_16M : for y : 0 .. bounds -> h - 1 by 1 for x : 0 .. bounds -> w - 1 by 1 tmp := getInfoAt (x, y) colr := RGB.AddColour (RGBQUAD (tmp).rgbRed / 255, RGBQUAD (tmp).rgbGreen / 255, RGBQUAD (tmp).rgbBlue / 255) drawdot (bounds -> x + x, bounds -> y - y, colr) end for end for label MONOCHROME : for y : 0 .. bounds -> h - 1 by 1 for x : 0 .. bounds -> w - 1 by 1 tmp := getInfoAt (x, y) colr := MONOCHROMESET (tmp).getColor drawdot (bounds -> x + x, bounds -> y - y, colr) end for end for label : assert false % if u've reached here, it's probably cuz ur using a colour % resolution that is not implemented yet end case end draw body proc Destruct for i : 0 .. bounds -> h * bounds -> w if bitmapBits (i) not= nil then free bitmapBits (i) end if end for free bitmapBits Image.Destruct end Destruct end BitmapFile |
here's how u can use this class. do make sure u call the destructor before freeing the object
var img : ^BitmapFile
new img
img -> Construct ("pic.bmp")
img -> draw
img -> Destruct
free img