FunctionImagingInPascal/BMPImage.pas

unit BMPImage;

interface

uses classes;

type
  TColor = object
    r: byte;
    g: byte;
    b: byte;

    procedure set_color(tr: byte; tg: byte; tb: byte);
    procedure reset();
  end;

  TPxData = array of array of TColor;

  TBMPImage = object
    private
      width, height: integer;

      function get_padding(): integer;
    public
      pixel_data: array of array of TColor;

      constructor init();
      constructor init(w: integer; h: integer; c: TColor);
      constructor init(px_data: TPxData);
      destructor done();

      procedure set_pixel_data(px_data: TPxData);
      procedure set_width(w: integer);
      procedure set_height(h: integer);

      function get_width(): integer;
      function get_height(): integer;

      procedure open(path: string);
      procedure save(path: string; monochrome: boolean);
  end;

implementation

procedure TColor.reset();
begin
  r := 0;
  g := 0;
  b := 0;
end;

procedure TColor.set_color(tr: byte; tg: byte; tb: byte);
begin
  r := tr;
  g := tg;
  b := tb;
end;

procedure TBMPImage.set_pixel_data(px_data: TPxData);
var
  i, j: longint;
begin
  width := length(px_data);
  height := length(px_data[0]);
  setLength(pixel_data, width, height);

  for i := 0 to width - 1 do begin
    for j := 0 to height - 1 do begin
      pixel_data[i][j] := px_data[i][j];
    end;
  end;
end;

constructor TBMPImage.init();
begin
  setLength(pixel_data, 0, 0);
  width := 0;
  height := 0;
end;

constructor TBMPImage.init(w: integer; h: integer; c: TColor);
var
  i, j: integer;
begin
  setLength(pixel_data, w, h);
  width := w;
  height := h;

  for i := 0 to width - 1 do begin
    for j := 0 to height - 1 do begin
      pixel_data[i][j] := c;
    end;
  end;
end;

constructor TBMPImage.init(px_data: TPxData);
begin
  set_pixel_data(px_data);
end;


destructor TBMPImage.done();
begin
  setLength(pixel_data, 0, 0); // not neccesary
  width := 0;
  height := 0;
end;

function TBMPImage.get_padding(): integer;
var
  bytes_per_row, padding: integer;
begin
  bytes_per_row := width * 3;
  padding := 4 - bytes_per_row mod 4;
  if padding = 4 then padding := 0;
  get_padding := padding;
end;

procedure TBMPImage.set_width(w: integer);
var
  color: TColor;
  i, j: integer;
begin
  setLength(pixel_data, w, height);
  if (w > width) then begin
    for i := width to w - 1 do begin
      for j := 0 to height - 1 do begin
        color.set_color(255, 255, 255);
        pixel_data[i][j] := color;
      end;
    end;
  end;
  width := w;
end;

procedure TBMPImage.set_height(h: integer);
var
  color: TColor;
  i, j: integer;
begin
  setLength(pixel_data, width, h);
  if (h > height) then begin
    for i := 0 to width - 1 do begin
      for j := height to h - 1 do begin
        color.set_color(255, 255, 255);
        pixel_data[i][j] := color;
      end;
    end;
  end;
  height := h;
end;

function TBMPImage.get_width(): integer;
begin
  get_width := width;
end;

function TBMPImage.get_height(): integer;
begin
  get_height := height;
end;

procedure TBMPImage.open(path: string);
var
  instream: TFileStream;
  px_data_offset, i, j, k, padding: integer;
  color: TColor;
begin
  instream := TFileStream.Create(path, fmOpenRead);

  instream.position := 10;
  px_data_offset := instream.readword();

  instream.position := 18;
  width := instream.readword();
  instream.position := 22;
  height := instream.readword();

  setLength(pixel_data, width, height); // indexes begins with zero

  padding := get_padding();

  instream.position := px_data_offset;
  k := 1;
  for i := height - 1 downto 0 do begin
    for j := 0 to width - 1 do begin
      color.b := instream.readbyte();
      color.g := instream.readbyte();
      color.r := instream.readbyte();

      pixel_data[j][i] := color;

      inc(k);
    end;
    instream.position := instream.position + padding;
  end;
end;

procedure TBMPImage.save(path: string; monochrome: boolean);
var
  ostream: TFileStream;
  padding, i, j, cs: integer;
  color: TColor;
  buf: array[1..1000000] of byte;
  k, size: longint;
begin
  ostream := TFileStream.Create(path, fmCreate + fmOpenWrite);

  ostream.writeword(19778); // "BM" - format specifier

  ostream.position := 10;
  ostream.WriteDWord(54); // pixel data offset is bytes (54)
  ostream.WriteDWord(40); // second header size in bytes (40, 14 - first header)
  ostream.WriteDWord(width);
  ostream.WriteDWord(height);
  ostream.position := 26;
  ostream.writeword(1); // must be one
  // bits per pixel
  if (monochrome) then ostream.writeword(1) else ostream.writeword(24);

  padding := get_padding();
  ostream.position := 54;

  size := width * 3 + padding;
  for k := 1 to size do begin // we need zero bytes to fill padding
    buf[k] := 0;
  end;

  if (monochrome) then begin
    {color := pixel_data[j][i];
    cs := color.r + color.g + color.b;
    if (cs > 425) then begin
      cs := 255;
    end else begin
      cs := 0;
    end;
    ostream.writebyte(cs);
    ostream.writebyte(cs);
    ostream.writebyte(cs);}
  end else begin
    for i := height - 1 downto 0 do begin
      k := 1;
      for j := 0 to width - 1 do begin
        color := pixel_data[j][i];

        buf[k + 0] := color.b;
        buf[k + 1] := color.g;
        buf[k + 2] := color.r;

        k := k + 3;
      end;
      ostream.writebuffer(buf, size);
    end;
  end;
end;

begin
end.