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
setscreen ("graphics:800;600")
% Pic.ScreenLoad("wr.bmp",0 ,0, picCopy)
var img : ^BitmapFile
new img
img -> Construct ("mono.bmp")
img -> Construct ("wr.bmp")
img -> draw
img -> Destruct
free img
|