DBR Delphi-Ecke

// Farbige Bitmaps werden grau bzw. schwarz/weiß angezeigt.

// Getestet mit D4 unter WinME

1. Graustufen-Bilder


Original	256 Graustufen	16 Graustufen

1.1. 256 Graustufen aber 24 BpP
1.2. 256 Graustufen und 8 BpP mit Streams
1.3. 256 Graustufen und 8 BpP mit Palette
1.4 256 Graustufen und 16 BpP
1.5. 16 Graustufen und 4 BpP

2. Monochrom-Bilder


Original	Monochrom	Monochrom3	Monochrom4

Monochrom5	Pattern	Diffusion	Dithering

2.1. Monochrom aber 24 BpP
2.2. Monochrom und 1 BpP
2.3. Monochrom3
2.4. Monochrom4
2.5. Monochrom5
2.6. Pattern
2.7. Error-Diffusion "F&S"
2.8. Ordered Dither

// 256 Graustufen aber 24 BpP
// Es sind zwar 256 Graustufen zu sehen, die Farbtiefe beträgt aber
// 24 Bit.

procedure grau_256_24(Source, Dest: TBitmap); 
var 
  x, y, br: integer; 
  pd: PBytearray; 
begin 
  Dest.pixelformat := pf24bit; 
  br := Source.width * 3 - 1; 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.canvas.draw(0, 0, Source); 
  for y := 0 to Dest.height - 1 do begin 
    pd := Dest.ScanLine[y]; 
    x := 0; 
    while x < br do begin 
      pd[x] := (pd[x + 2] * 77 + pd[x + 1] * 151 + pd[x] * 28) shr 8; 
      pd[x + 1] := pd[x]; 
      pd[x + 2] := pd[x]; 
      inc(x, 3); 
    end; 
  end; 
end;

// 256 Graustufen und 8 BpP mit Streams
// Mit Einigem an Mehraufwand werden die Bilder umgewandelt und
// haben dann das Pixelformat pf8bit. Allerdings werden nur
// Farbtiefen von 8, 24 und 32 Bit (im Quellbild)akzeptiert.

type 
  RGBQ = array[0..0] of RGBQUAD; 
  PRGBQ = ^RGBQ; 
 
function Weiter(p: Pointer; plus: Integer): PByte; 
begin 
  Result := p; 
  Inc(Result, plus); 
end; 
 
function breit(x: LongInt): LongInt; 
begin 
  Result := ((x + 31) div 32) * 4; 
end; 
 
{$R-} 
 
function grau_256_8_strm(Source, Dest: TBitmap): boolean; 
var 
  SPal, DPal: PRGBQ; 
  Pal: array[Byte] of Byte; 
  SBFH, DBFH: PBitmapFileHeader; 
  SBih, DBih: PBitmapInfoHeader; 
  x, y, DLS, SLS, SrcWidth, SrcHeight, srcpf: LongInt; 
  SStream, DStream: TMemoryStream; 
  SPL, SrcPB, DPL, DstPB: PByte; 
  SP, DP: Pointer; 
 
  function GetSrcHeader: Boolean; 
  var 
    p: PByte; 
    BitsIndex: LongInt; 
  begin 
    Result := False; 
    p := SStream.Memory; 
    SBFH := PBitmapFileHeader(p); 
    if SBFH^.bfType <> $4D42 then Exit; 
    Inc(p, SizeOf(TBitmapFileHeader)); 
    SBih := PBitmapInfoHeader(p); 
    Inc(p, SizeOf(TBitmapInfoHeader)); 
    with SBih^ do begin 
      if biSize <> SizeOf(TBitmapInfoHeader) then Exit; 
      if biCompression <> BI_RGB then Exit; 
      SPal := PRGBQ(p); 
      BitsIndex := SBFH^.bfOffBits; 
      if biBitCount > 8 then Inc(BitsIndex, biClrUsed * SizeOf(RGBQuad)); 
      SP := Weiter(SStream.Memory, BitsIndex); 
      SrcWidth := biWidth; 
      SrcHeight := biHeight; 
      SLS := breit(biWidth * biBitCount); 
      case biBitCount of 
        8, 24, 32: srcpf := biBitCount shr 3; 
      else exit; 
      end; 
      if BitsIndex + biHeight * SLS > SStream.Size then exit; 
    end; 
    Result := True; 
  end; 
 
  function CreateDstHeader: boolean; 
  var 
    p: PByte; 
    NewSize: LongInt; 
    i: LongInt; 
  begin 
    result := false; 
    try 
      NewSize := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) + 
        256 * SizeOf(RGBQuad) + breit(SrcWidth * 8) * SrcHeight; 
      DStream.SetSize(NewSize); 
      p := DStream.Memory; 
      FillChar(p^, NewSize, 0); 
      DBFH := PBitmapFileHeader(p); 
      with DBFH^ do begin 
        bfType := $4D42; 
        bfSize := NewSize; 
        bfOffBits := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) + 
          256 * SizeOf(RGBQuad); 
      end; 
      Inc(p, SizeOf(TBitmapFileHeader)); 
      DBih := PBitmapInfoHeader(p); 
      with DBih^ do begin 
        biSize := SizeOf(TBitmapInfoHeader); 
        biWidth := SrcWidth; 
        biHeight := SrcHeight; 
        biPlanes := 1; 
        biBitCount := 8; 
        biCompression := BI_RGB; 
        biSizeImage := 0; 
        biXPelsPerMeter := 96; 
        biYPelsPerMeter := 96; 
        biClrUsed := 0; 
        biClrImportant := 0; 
        DLS := breit(biWidth * biBitCount); 
      end; 
      Inc(p, SizeOf(TBitmapInfoHeader)); 
      DPal := PRGBQ(p); 
      Inc(p, 256 * SizeOf(RGBQuad)); 
      DP := p; 
      for i := 0 to 255 do begin 
        with DPal^[i] do begin 
          rgbBlue := i; 
          rgbGreen := i; 
          rgbRed := i; 
        end; 
      end; 
      result := true; 
    except 
      exit; 
    end; 
  end; 
begin 
  result := false; 
  SStream := TMemoryStream.Create; 
  DStream := TMemoryStream.Create; 
  if (Source.width = 0) or (Source.height = 0) then exit; 
  try 
    Source.SaveToStream(SStream); 
    if GetSrcHeader then begin 
      if CreateDstHeader then begin 
        if srcpf = 1 then begin 
          for x := 0 to 255 do with SPal^[x] do 
              Pal[x] := Byte((rgbRed * 77 + rgbGreen * 151 + rgbBlue * 28) shr 
                8); 
          SPL := SP; 
          DPL := DP; 
          for y := 0 to SrcHeight - 1 do 
          begin 
            SrcPB := SPL; 
            DstPB := DPL; 
            for x := 0 to SrcWidth - 1 do 
            begin 
              DstPB^ := Pal[SrcPB^]; 
              Inc(SrcPB); 
              Inc(DstPB); 
            end; 
            Inc(SPL, SLS); 
            Inc(DPL, DLS); 
          end; 
        end 
        else begin 
          SPL := SP; 
          DPL := DP; 
          for y := 0 to SrcHeight - 1 do 
          begin 
            SrcPB := SPL; 
            DstPB := DPL; 
            for x := 0 to SrcWidth - 1 do 
            begin 
              with PRGBQuad(SrcPB)^ do 
                DstPB^ := Byte((rgbRed * 77 + rgbGreen * 151 + rgbBlue * 28) shr 
                  8); 
              Inc(SrcPB, srcpf); 
              Inc(DstPB); 
            end; 
            Inc(SPL, SLS); 
            Inc(DPL, DLS); 
          end; 
        end; 
        DStream.Seek(0, soFromBeginning); 
        Dest.LoadFromStream(DStream); 
        result := true; 
      end; 
    end; 
  finally 
    DStream.Free; 
    SStream.Free; 
  end; 
end;

// 256 Graustufen und 8 BpP mit Palette
// Nicht ganz so gut in der Qualität wie die obige Stream-Variante,
// aber mit wesentlich weniger Aufwand werden so die Bilder auch
// umgewandelt.

{$R-}

procedure grau_256_8_pal(Source, Dest: TBitmap); 
var 
  lPal: PLogpalette; 
  i: integer; 
begin 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf8bit; 
  GetMem(lpal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256); 
  lpal.palVersion := $300; 
  lpal.palNumEntries := 256; 
  for i := 0 to 255 do lpal.palPalEntry[i] := 
    Tpaletteentry(i or (i shl 8) or (i shl 16)); 
  Dest.palette := CreatePalette(lpal^); 
  FreeMem(lpal); 
  Dest.canvas.draw(0, 0, Source); 
end;

// 256 Graustufen und 16 BpP

procedure grau_24_16(Source, Dest: TBitmap); 
var 
  pbi: pBitmapInfo; 
  pSrc: pRGBQuad; 
  hbmp: HBitmap; 
  x, y: Integer; 
  pDst: pWord; 
  p: Pointer; 
  b: byte;            
begin 
  Source.pixelformat := pf24bit; 
  pbi := AllocMem(sizeof(BITMAPINFO) + sizeof(DWord) * 3); 
  with pbi^.bmiHeader do 
  begin 
    biSize := sizeof(BITMAPINFOHEADER); 
    biPlanes := 1; 
    biBitCount := 16; 
    biWidth := Source.Width; 
    biHeight := Source.Height; 
    biCompression := BI_BITFIELDS; 
  end; 
  pWordArray(@(pbi^.bmiColors[0]))^[0] := $F800; 
  pWordArray(@(pbi^.bmiColors[0]))^[2] := $07E0; 
  pWordArray(@(pbi^.bmiColors[0]))^[4] := $001F; 
  hbmp := CreateDIBSection(0, pbi^, DIB_RGB_COLORS, p, 0, 0); 
  if hbmp <> HBITMAP(0) then 
    for y := 0 to Source.Height - 1 do 
    begin 
      pSrc := pRGBQuad(Source.ScanLine[y]); 
      pDst := pWord(Integer(p) + 
        ((Source.Width * 2 + 3) and -4) 
        * (Source.Height - 1 - y)); 
      for x := 0 to Source.Width - 1 do 
      begin 
        b := (pSrc^.rgbBlue * 77 + 
          pSrc^.rgbGreen * 151 + pSrc^.rgbRed * 28) shr 8; 
        pDst^ := (b shr 3) or ((b shr 2) shl 5) or (DWord(b shr 3) shl 11); 
        Inc(Integer(pSrc), 3); 
        Inc(pDst); 
      end; 
    end; 
  Dest.handle := hbmp; 
  FreeMem(pbi); 
end;

// 16 Graustufen und 4 BpP
// Wenn man bei Graustufenbildern statt mit 256 auch mit 16 Stufen
// leben kann, verringert sich die Größe der Bitmap-Datei um rund
//die Hälfte.

{$R-}

procedure grau_16_4(Source, Dest: TBitmap); 
var 
  lPal: PLogpalette; 
  i: integer; 
begin 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf4bit; 
  GetMem(lpal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 16); 
  lpal.palVersion := $300; 
  lpal.palNumEntries := 16; 
  for i := 0 to 15 do lpal.palPalEntry[i] := 
    Tpaletteentry((i shl 4) or (i shl 12) or (i shl 20)); 
  Dest.palette := CreatePalette(lpal^); 
  FreeMem(lpal); 
  Dest.canvas.draw(0, 0, Source); 
end;

// Monochrom aber 24 BpP
// Das Bild erscheint schwarz/weiß, die Farbtiefe beträgt aber
// 24 Bit.

            procedure monochrom(Source, Dest: TBitmap); 
var 
  x, y, br: integer; 
  pd: PBytearray; 
begin 
  br := Source.width * 3 - 1; 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  for y := 0 to Source.height - 1 do begin 
    pd := Dest.ScanLine[y]; 
    x := 0; 
    while x < br do begin 
      pd[x] := $FF * ord((pd[x] + pd[x + 1] + pd[x + 2]) > 390); 
      pd[x + 1] := pd[x]; 
      pd[x + 2] := pd[x]; 
      inc(x, 3); 
    end; 
  end; 
end; 

          

// Monochrom und 1 BpP
// Ein echtes Monochrom-Bild mit 1Bit Farbtiefe.

procedure monochrom1(Source, Dest: TBitmap); 
begin 
  Dest.handle := copyimage(Source.handle, IMAGE_BITMAP, 0, 0, 
    LR_COPYRETURNORG or LR_MONOCHROME); 
  Dest.pixelformat := pf1bit; 
end;

// Monochrom3 und 1 BpP
// Für monochrome Bilder habe ich verschiedene Rasterungen für
// Flächen mit unterschiedlich Helligkeit gebastelt, welche die
// Erkennbarkeit des Bildes verbessern soll. Diese Variante hier hat
// neben weißen und schwarzen Flächen eine einzige Art der
// Rasterung. Für das Auge ergeben sich 3 Stufen; deshalb
// "monochrom3". Besonders für kleine Bilder geeignet.

procedure monochrom3(Source, Dest: TBitmap); 
var 
  x, y, br: integer; 
  p: PBytearray; 
begin 
  br := Source.width * 3 - 1; 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  for y := 0 to Source.height - 1 do begin 
    x := 0; 
    p := Dest.scanline[y]; 
    while x < br do begin 
      if (p[x] + p[x + 1] + p[x + 2] + $FF * ord(odd(x xor y))) < 512 
        then p[x] := 0 else p[x] := $FF; 
      p[x + 1] := p[x]; 
      p[x + 2] := p[x]; 
      inc(x, 3); 
    end; 
  end; 
  Dest.handle := copyimage(Dest.handle, IMAGE_BITMAP, 0, 0, 
    LR_COPYRETURNORG or LR_MONOCHROME); 
  Dest.pixelformat := pf1bit; 
end;

// Monochrom4 und 1 BpP
// Diese Variante hier hat neben weißen und schwarzen Flächen zwei
// Arten der Rasterung. Für das Auge ergeben sich 4 Stufen; deshalb
// "monochrom4".

procedure monochrom4(Source, Dest: TBitmap); 
var 
  x, y, z, b, h: integer; 
  p: pbytearray; 
  f, g: integer; 
begin 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  b := Source.width * 3 - 1; 
  h := Source.height - 1; 
  y := 0; 
  while y <= h do begin 
    x := 0; 
    p := Dest.scanline[y]; 
    while x < b do begin 
      g := (p[x + 2] + p[x + 1] + p[x]) div 3; 
      if g < 128 then begin 
        f := g; 
        for z := 0 to 2 do 
          p[x + z] := 0; 
        for z := 3 to 5 do 
          g := (g + p[x + z]); 
        g := g div 3 + f; 
      end else begin 
        f := (256 - g) * 2; 
        for z := 0 to 2 do 
          p[x + z] := 255; 
        for z := 3 to 5 do 
          g := (g + p[x + z]); 
        g := g div 3 - f; 
      end; 
      for z := 3 to 5 do p[x + z] := ord(g > 128) * 255; 
      inc(x, 6); 
    end; 
    inc(y, 2); 
  end; 
  Dest.handle := copyimage(Dest.handle, IMAGE_BITMAP, 0, 0, 
    LR_COPYRETURNORG or LR_MONOCHROME); 
  Dest.pixelformat := pf1bit; 
end;

// Monochrom5 und 1 BpP
// Diese Variante hier hat neben weißen und schwarzen Flächen drei
// Arten der Rasterung. Für das Auge ergeben sich 5 Stufen; deshalb
// "monochrom5".

var 
  schablone: array[0..4] of TBitmap; 
 
procedure schablonen; 
var i: integer; 
begin 
  for i := 0 to 4 do begin 
    schablone[i] := TBitmap.create; 
    with schablone[i] do begin 
      width := 2; 
      height := 2; 
      with canvas do begin 
        brush.color := ord(i < 3) * $FFFFFF; 
        fillrect(cliprect); 
      end; 
    end; 
  end; 
  for i := 1 to 3 do begin 
    with schablone[i].canvas do begin 
      case i of 
        1: pixels[0, 0] := 0; 
        2: begin 
            pixels[0, 0] := 0; 
            pixels[1, 1] := 0; 
          end; 
        3: pixels[0, 1] := $FFFFFF; 
      end; 
    end; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  schablonen; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var x: integer; 
begin 
  for x := 0 to 4 do schablone[x].free; 
end; 
 
procedure monochrom5(Source, Dest: TBitmap); 
var 
  x, y, z, b, h: integer; 
  p: pbytearray; 
  g: word; 
begin 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  b := Source.width * 3 - 1; 
  h := Source.height - 1; 
  y := 0; 
  with Dest.canvas do begin 
    while y <= h do begin 
      x := 0; 
      while x < b do begin 
        g := 0; 
        p := Dest.scanline[y]; 
        for z := 0 to 5 do 
          g := g + p[x + z]; 
        if y = h then g := g * 2 else begin 
          p := Dest.scanline[y + 1]; 
          for z := 0 to 5 do 
            g := g + p[x + z]; 
        end; 
        case g of 
          0..655: draw(x div 3, y, schablone[4]); 
          656..1330: draw(x div 3, y, schablone[3]); 
          1331..2000: draw(x div 3, y, schablone[2]); 
          2001..2490: draw(x div 3, y, schablone[1]); 
        else draw(x div 3, y, schablone[0]); 
        end; 
        inc(x, 6); 
      end; 
      inc(y, 2); 
    end; 
  end; 
  Dest.handle := copyimage(Dest.handle, IMAGE_BITMAP, 0, 0, 
    LR_COPYRETURNORG or LR_MONOCHROME); 
  Dest.pixelformat := pf1bit; 
end;

// Pattern
// Das Bild wird mit einem Muster aus einer Matrix überblendet.

procedure pattern(Source, Dest: TBitmap); 
var 
  x, y, b: integer; 
  z: byte; 
  p: pbytearray; 
const 
  muster: array[0..1, 0..1] of byte = 
  (($83, $55), ($20, $A3)); 
begin 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  b := Source.width * 3 - 1; 
  for y := 0 to source.height - 1 do begin 
    x := 0; 
    p := Dest.scanline[y]; 
    while x < b do begin 
      z := muster[(x div 3) mod 3, y mod 3]; 
      p[x] := (p[x] + z) shr 1; 
      p[x + 1] := (p[x + 1] + z) shr 1; 
      p[x + 2] := (p[x + 2] + z) shr 1; 
      inc(x, 3); 
    end; 
  end; 
  Dest.handle := copyimage(Dest.handle, IMAGE_BITMAP, 0, 0, 
    LR_COPYRETURNORG or LR_MONOCHROME); 
  Dest.pixelformat := pf1bit; 
end;

        
        //
        Diffusion 

        // Fehler-Diffusion nach "Floyd & Steinberg". Die Differenz einer

		// 
        Pixelfarbe zu schwarz oder weiß wird in ungleichen Mengen auf

		// 4 Nachbarpixel 
        verteilt.

procedure Diffusion(Source, Dest: TBitmap); 
var 
  x, y, x3: integer; 
  arr: array of array of single; 
  p: PByteArray; 
  t: single; 
begin 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  setlength(arr, Dest.height, Dest.width); 
  for y := 0 to Dest.height - 1 do begin 
    p := dest.scanline[y]; 
    for x := 0 to Dest.width - 1 do begin 
      x3 := x * 3; 
      arr[y, x] := (p[x3] + p[x3 + 1] + p[x3 + 2]) / 3; 
    end; 
  end; 
  for y := 1 to Dest.height - 2 do 
    for x := 1 to Dest.width - 2 do begin 
      if (arr[y, x] < 128) then begin 
        t := arr[y, x] / 16; 
        arr[y, x] := 0; 
      end else begin 
        t := (arr[y, x] - 255) / 16; 
        arr[y, x] := 1; 
      end; 
      arr[y + 1, x - 1] := arr[y + 1, x - 1] + t * 3; 
      arr[y + 1, x] := arr[y + 1, x] + t * 5; 
      arr[y + 1, x + 1] := arr[y + 1, x + 1] + t; 
      arr[y, x + 1] := arr[y, x + 1] + t * 7; 
    end; 
  for y := 0 to Dest.height - 1 do begin 
    p := dest.scanline[y]; 
    for x := 0 to Dest.width - 1 do begin 
      x3 := x * 3; 
      if arr[y, x] = 0 then p[x3] := 0 else p[x3] := 255; 
      p[x3 + 1] := p[x3]; 
      p[x3 + 2] := p[x3]; 
    end; 
  end; 
  arr := nil; 
  Dest.handle := copyimage(Dest.handle, IMAGE_BITMAP, 0, 0, 
    LR_COPYRETURNORG or LR_MONOCHROME); 
  Dest.pixelformat := pf1bit; 
end;

// Ordered Dither
// Für jedes Pixel wird anhand einer Matrix ein eigener Schwellwert errechnet. 

const 
  sl = 4; 
  a: array[0..sl - 1, 0..sl - 1] of integer = 
  ((0, 8, 2, 10), (12, 4, 14, 6), (3, 11, 1, 9), (15, 7, 13, 5)); 
 
procedure sw(source, dest: TBitmap); 
var 
  p: PBytearray; 
  i, x, y, b3: integer; 
begin 
  if (Source.width = 0) or (Source.height = 0) then exit; 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  i := 768 div (sl * sl); 
  b3 := dest.width * 3; 
  for y := 0 to dest.height - 1 do begin 
    p := dest.scanline[y]; 
    x := 0; 
    while x < b3 do begin 
      p[x] := ord(p[x] + p[x + 1] + p[x + 2] >= 
        a[x mod sl, y mod sl] * i) * $FF; 
      p[x + 1] := p[x]; 
      p[x + 2] := p[x]; 
      inc(x, 3); 
    end; 
  end; 
  Dest.handle := copyimage(Dest.handle, IMAGE_BITMAP, 0, 0, 
    LR_COPYRETURNORG or LR_MONOCHROME); 
  Dest.pixelformat := pf1bit; 
end;