Computer Science Canada

Bitmap file

Author:  rizzix [ Fri Nov 14, 2003 6:31 pm ]
Post subject:  Bitmap file

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



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


: