X-Face/XFaceTransferInMonochromeBitmap.pas at master · NickRing/X-Face · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
unit XFaceTransferInMonochromeBitmap;

(*
 *  Compface - 48x48x1 image compression and decompression
 *
 *  Copyright (c) James Ashton - Sydney University - June 1990.
 *
 *  Written 11th November 1989.
 *
 *  Delphi conversion Copyright (c) Nicholas Ring February 2012
 *
 *  Permission is given to distribute these sources, as long as the
 *  copyright messages are not removed, and no monies are exchanged.
 *
 *  No responsibility is taken for any errors on inaccuracies inherent
 *  either to the comments or the code of this program, but if reported
 *  to me, then an attempt will be made to fix them.
 *)

{$IFDEF FPC}{$mode delphi}{$ENDIF}

interface

uses
  XFaceInterfaces,
  Graphics,
  SysUtils;

type

  { THexStrTransferIn }

  TXFaceTransferInMonochromeBitmap = class(TInterfacedObject, IXFaceTransferIn)
  private
    FBitmap : Graphics.TBitmap;
    FUnsetRGB : Longint;
  public
    constructor Create(const ABitmap : Graphics.TBitmap);
    destructor Destroy; override;

    procedure StartTransfer();
    function TransferIn(const AIndex : Cardinal) : Byte;
    procedure EndTransfer();
  end deprecated;

type
  EXFaceTransferInMonochromeBitmapBaseException = class(Exception);
  EXFaceTransferInMonochromeBitmapBitmapNotAssigned = class(EXFaceTransferInMonochromeBitmapBaseException);
  EXFaceTransferInMonochromeBitmapBitmapNotMonochrome = class(EXFaceTransferInMonochromeBitmapBaseException);
  EXFaceTransferInMonochromeBitmapWrongSize = class(EXFaceTransferInMonochromeBitmapBaseException);

implementation

uses
  XFaceConstants,
  Windows;

{ TXFaceTransferInBitmap }

constructor TXFaceTransferInMonochromeBitmap.Create(const ABitmap: Graphics.TBitmap);
begin
  inherited Create();

  FBitmap := Graphics.TBitmap.Create;
  FBitmap.Assign(ABitmap);
end;

destructor TXFaceTransferInMonochromeBitmap.Destroy;
begin
  FBitmap.Free;
  inherited;
end;

procedure TXFaceTransferInMonochromeBitmap.EndTransfer();
begin
end;

procedure TXFaceTransferInMonochromeBitmap.StartTransfer();
var
  LMaxLogPalette : Windows.TMaxLogPalette;
  LResult        : Windows.UINT;
begin
  if FBitmap.Empty then
    raise EXFaceTransferInMonochromeBitmapBitmapNotAssigned.Create('Bitmap not assigned');

  if not FBitmap.Monochrome then
    raise EXFaceTransferInMonochromeBitmapBitmapNotMonochrome.Create('Bitmap not monochrome');

  if FBitmap.Width <> XFaceConstants.cWIDTH then
    raise EXFaceTransferInMonochromeBitmapWrongSize.Create(Format('Image not of correct width - %d', [FBitmap.Width]));

  if FBitmap.Height <> XFaceConstants.cHEIGHT then
    raise EXFaceTransferInMonochromeBitmapWrongSize.Create(Format('Image not of correct height - %d', [FBitmap.Height]));

  if FBitmap.PixelFormat <> pf1bit then
    raise EXFaceTransferInMonochromeBitmapWrongSize.Create(Format('Image not of correct depth - %d', [Ord(FBitmap.PixelFormat)]));

  LMaxLogPalette.palVersion := $0300;
  LMaxLogPalette.palNumEntries := 1;
  LResult := Windows.GetPaletteEntries(FBitmap.Palette, 0, 1, PLogPalette(@LMaxLogPalette)^.palPalEntry);
  if LResult = 0 then
    if Windows.GetLastError() <> 0 then
      SysUtils.RaiseLastOSError();

  FUnsetRGB := RGB(LMaxLogPalette.palPalEntry[0].peRed, LMaxLogPalette.palPalEntry[0].peGreen, LMaxLogPalette.palPalEntry[0].peBlue);
end;

function TXFaceTransferInMonochromeBitmap.TransferIn(const AIndex: Cardinal): Byte;
var
  LPixelIdx    : Byte;
  LY           : integer;
  LX           : integer;
  LPixelColour : TColor;
  LPixelRGB    : Longint;
begin
  Result := 0;

  LY := (AIndex - 1) div XFaceConstants.cBYTES_PER_LINE;
  LX := ((AIndex - 1) mod XFaceConstants.cBYTES_PER_LINE) * XFaceConstants.cBITS_PER_WORD;

  LPixelIdx := 1 shl (XFaceConstants.cBITS_PER_WORD - 1);
  while LPixelIdx <> 0 do
  begin
    LPixelColour := FBitmap.Canvas.Pixels[LX, LY];
    LPixelRGB := Graphics.ColorToRGB(LPixelColour);

    if LPixelRGB <> FUnsetRGB then
      Result := Result or LPixelIdx;

    Inc(LX, 1);
    LPixelIdx := LPixelIdx shr 1;
  end;
end;

end.