Handling arbitrary bit length data in Delphi? - delphi

I am working on a display/control utility to replace an ancient dedicated hardware controller for a piece of industrial machinary. The controller itself is beyond repair (someone replaced the 1 amp fuse with a 13 amp one "because it kept blowing"). The hardware interface is through a standard RS232 port. The data format is dedicated:
No control characters are used with the exeption of ETB (Chr 23) to demark end of a message.
The data is 7-bit, but only a subset of the possible 7-bit characters is used. The content of each 7-bit data character is therefore effectively reduced to only 6 bits of data.
The data is not character aligned, e.g. for the first message type, the first 3 bits are the message type, the next 8 bits are a counter, the next 15 bits are a data value, next 7 bits are a value etc
So reducing the data from it's 7-bit carrier to it's 6 bit content gives (for example)
| 6 || 6 || 6 || 6 || 6 || 6 || 6 ||~
001001010001010100101010101101010101110111 ~
|3|| 8 || 15 || 7 || ~~
M C D D D
s o a a a
g u t t t
n a a a
t
Specific messages are fixed length but the different messages are of different lengths and contain different numbers of parameters.
I have a working prototype handling one specific message type, but it is currently using way too many case statements ;-).
I am looking for suggestions as to a clean way of handling such packed, arbitrary bit length data?

I assume that different messages/packets have different variable lengths. A clean way to handle arbitrary bit length data like that would be
uses ubitstream;
procedure decode(buffer: Tbytes; var results: Tcustom_record);
var
bstream: TBitStream;
msg: byte; // 3 bits
cnt: byte; // 8 bits
Data_1: Word; // 15 bits
Data_2: Word; // 7 bits
Data_3: Word; // ~~ bits
begin
bstream:=TBitStream.Create;
bstream.Load(buffer, sizeof(buffer) );
msg := bstream.readCardinal(3);
if msg = 1 then begin
cnt := bstream.readCardinal(8);
Data_1 := bstream.readCardinal(15);
Data_2 := bstream.readCardinal(7);
Data_3 := bstream.readCardinal(~~);
end else if msg = 2 then begin // different msg type with different lengths
cnt := bstream.readCardinal(5);
Data_1 := bstream.readCardinal(14);
Data_2 := bstream.readCardinal(12);
Data_3 := bstream.readCardinal(~~);
end; // etc etc...
bstream.free;
end;
You will need ubitstream.pas
unit ubitstream;
interface
uses classes, sysutils;
Type
TBitStream = class
constructor Create;
destructor Free;
public
procedure clear;
procedure LoadFromStr(s: string);
procedure Load(fileName: string); overload;
procedure Load(bs:TBitStream; offset: cardinal; count:cardinal); overload;
procedure Load(bs:TBitStream; count:cardinal); overload;
procedure Load(byteArray: TBytes); overload;
procedure Load(byteArray: TBytes; offset:cardinal); overload;
procedure Save(fileName: string); overload;
procedure Save(var byteArray: TBytes); overload;
function toHex:String;
function toBin:String;
//Sequential Access
function readCardinal(count: integer):cardinal;
function readBit:byte;
function readString(count:cardinal):ansistring;
procedure writeBit(bit: byte);
procedure writeBits(count: cardinal; data: TBytes); overload;
procedure writeBits(count: cardinal; pdata: Pbyte); overload;
procedure writeString(s: ansistring);
//----------------------------------------------------
function getSize:smallint;
procedure setSize(newSize: smallint);
property Size: smallint read getSize write setSize;
function getPos: cardinal;
procedure setPos(newPosition: cardinal);
property Position: cardinal read getPos write setPos;
function eos:boolean;//End Of Stream
protected
//Random Access
function getCardinal(offset: cardinal; count: cardinal):cardinal;
function getBit(offset: cardinal):byte;
function getString(offset: cardinal; count:cardinal; var readCount: cardinal):ansistring;
procedure setBit(offset: cardinal; bit: byte);
procedure setBits(offset: cardinal; count: cardinal; data: TBytes);
//----------------------------------------------------
private
bits: TBytes;//Array of byte;
stream_pos: cardinal; //position for sequential operations bits-based
bitsize: cardinal;
end;
implementation
uses strutils;
constructor TBitStream.Create;
begin
SetLength(bits,1); //initial size is 1b
stream_pos := 0;
bitsize:=8;
end;
destructor TBitStream.Free;
begin
SetLength(bits,0); //free array
bits:=nil;
bitsize:=0;
stream_pos:=0;
end;
procedure TBitStream.clear;
// clear data
begin
bits:=nil;
SetLength(bits,1);
bits[0] := 0;
stream_pos := 0;
bitsize := 8;
end;
function TBitStream.getSize:smallint;
begin
if (bitsize mod 8)>0 then getSize := (bitsize div 8) +1
else getSize := bitsize div 8;
end;
procedure TBitStream.setSize(newSize: smallint);
begin
SetLength(bits,newSize);
bitsize:=newSize*8;
if stream_pos>bitsize then stream_pos:=bitsize; //set to end of stream
end;
function TBitStream.getCardinal(offset: cardinal; count: cardinal):cardinal;
//return count of bits from offset as 32-bit data type
//offset and count size in bits
var
res: cardinal;
i,shift: cardinal;
begin
getCardinal:=0;
if (offset+count>Size*8) then raise Exception.Create('Index out of array bounds!');
if count>32 then exit; //no more than 32-bit
res := getBit(offset);
// writeln(offset,' ',getBit(offset),' ',res);
shift := 1;
for i:=offset+1 to offset+count-1 do begin
res := res or (getBit(i) shl shift);
inc(shift);
// writeln(i,' ',getBit(i),' ',res);
end;
getCardinal := res;
end;
procedure TBitStream.setBit(offset: cardinal; bit: byte);
//offset in bits
var
b: byte;
off1: cardinal;
pos1: byte;
begin
if (offset>=Size*8) then
begin
SetLength(bits,(offset div 8)+1);
end;
bitsize:=offset;
off1 := offset div 8;
pos1 := offset mod 8;
b := bits[off1];
if bit=0 then begin //drop bit
b := b and (not (1 shl pos1));
end else begin //set bit
b := b or (1 shl pos1);
end;
bits[off1] := b;
end;
procedure TBitStream.setBits(offset: cardinal; count: cardinal; data: TBytes);
//set count of bits at offset from bytes array
//offset and count size in bits
var
i,j: cardinal;
b,bit: byte;
byteCount: cardinal;
off: cardinal;
Label STOP;
begin
if (offset+count>=Size*8) then begin
SetLength(bits,((offset+count) div 8)+1); //Reallocate bits array
end;
bitsize:=offset+count;
byteCount := count div 8;
off := offset;
if (count mod 8)>0 then inc(byteCount);
for i:=0 to byteCount-1 do begin //dynamic arrays is zero-based
b := data[i];
for j:=0 to 7 do begin //all bits in byte
bit := (b and (1 shl j)) shr j;
setBit(off,bit);
inc(off);
if (off>offset+count) then goto STOP;
end;
end;
STOP:
end;
function TBitStream.getBit(offset: cardinal):byte;
//offset in bits
var
b: byte;
off1: cardinal;
pos1: byte;
begin
getBit := 0;
if (offset>Size*8) then raise Exception.Create('Index out of array bounds!');
off1 := offset div 8;
pos1 := offset mod 8;
// if (offset mod 8)>0 then inc(off1);
b := bits[off1];
b := (b and (1 shl pos1)) shr pos1;//get bit
getBit := b;
end;
function TBitStream.getString(offset: cardinal; count:cardinal; var readCount: cardinal):ansistring;
//count, offset in bits
var
s: ansistring;
len,i: cardinal;
b: byte;
off: cardinal;
begin
getString:='';
s := '';
readCount := 0;
off := offset;
if (count mod 7)<>0 then exit; //string must contain 7-bits chars....
len := count div 7;
for i:=1 to len do begin
if (offset>Size*8) then raise Exception.Create('Index out of array bounds!');
b := getCardinal(off,7);
inc(off,7);
inc(readCount,7);
if b=$7F then break; //this is EOL code
s := s + ansichar(b);
end;
getString := s;
end;
function TBitStream.toHex:String;
var
i:integer;
s,res:string;
begin
res:='';
for i:=Low(bits) to High(bits) do begin
s := Format('%02.2X ',[bits[i]]);
res := res + s;
end;
toHex := res;
end;
function TBitStream.toBin:String;
var
i,j:integer;
s,res:string;
b: byte;
begin
res:='';
for i:=Low(bits) to High(bits) do begin
//s := Format('%02.2X',[bits[i]]);
b := bits[i];
s:='';
for j:=7 downto 0 do begin
if (b and (1 shl j))>0 then s:=s+'1' else s:=s+'0';
end;
s := s+' ';
res := res + s;
end;
toBin := res;
end;
procedure TBitStream.LoadFromStr(s: string);
//load data from hex string
var
i,j: cardinal;
b: byte;
c1,c2:byte;
begin
clear;
s:=AnsiReplaceStr(s,' ','');
if (length(s) mod 2) <> 0 then exit;
i:=1;j:=0;
SetLength(bits, length(s) div 2);
bitsize:=(length(s) div 2 ) * 8;
repeat
c1:=0; c2:=0;
if s[i] in ['0','1','2','3','4','5','6','7','8','9'] then c1:=ord(s[i])-$30;
if s[i] in ['A','B','C','D','E','F'] then c1:=10+ord(s[i])-$41;
if s[i+1] in ['0','1','2','3','4','5','6','7','8','9'] then c2:=ord(s[i+1])-$30;
if s[i+1] in ['A','B','C','D','E','F'] then c2:=10+ord(s[i+1])-$41;
b:=c1*16+c2;
bits[j]:=b;
inc(i,2);
inc(j);
until i>=length(s);
end;
procedure TBitStream.Load(fileName: string);
//load data from binary file
var
f: file of byte;
i: cardinal;
b: byte;
begin
clear;
i:=0;
assign(f,fileName);
reset(f);
while not eof(f) do begin
blockread(f,b,1);
SetLength(bits,i+1);
bitsize:= (i+1) * 8;
bits[i] := b;
inc(i);
end;
close(f);
end;
procedure TBitStream.Save(fileName: string);
//save data to binary file
var
i:cardinal;
f: file of byte;
b: byte;
begin
assign(f,fileName);
rewrite(f);
for i:=Low(bits) to High(bits) do begin
b := bits[i];
blockwrite(f,b,1);
end;
close(f);
end;
procedure TBitStream.Save(var byteArray: TBytes);
//save data to array of bytes
var
i: cardinal;
begin
byteArray:=nil; //dealloc bytearray
SetLength(byteArray,Size);
for i:=0 to Size-1 do begin
byteArray[i] := bits[i];
end;
end;
procedure TBitStream.Load(bs:TBitStream; offset: cardinal; count: cardinal);
//load data from other stream
//offset/count in bits
var
i,len,off: cardinal;
b: byte;
begin
clear;
off := offset;
len := count div 8;
setLength(bits, len);
bitsize:=count;
for i:=0 to len-1 do begin
b:=bs.getCardinal(off,8);
if (i>Size) then begin
SetLength(bits,i+1);
end;
bits[i] := b;
inc(off,8);
end;
end;
procedure TBitStream.Load(bs:TBitStream; count: cardinal);
//load data from other stream
//count in bits
begin
Load(bs, bs.Position, count);
bs.Position:=bs.Position+count;
end;
procedure TBitStream.Load(byteArray: TBytes);
//load data from array of bytes
var
i,len: cardinal;
begin
clear;
len := High(byteArray)+1;
setLength(bits, len);
bitsize:=len * 8;
for i:=0 to len-1 do begin
bits[i] := byteArray[i];
end;
end;
procedure TBitStream.Load(byteArray: TBytes; offset:cardinal);
//offset in bytes
var
i,len: cardinal;
begin
clear;
len := High(byteArray)+1;
if offset>len then exit;
setLength(bits, len-offset);
bitsize:=(len-offset) * 8;
for i:=offset to len-1 do begin
bits[i-offset] := byteArray[i];
end;
end;
function TBitStream.getPos: cardinal;
begin
getPos := stream_pos;
end;
procedure TBitStream.setPos(newPosition: cardinal);
begin
if (newPosition>bitsize) then exit;
stream_pos := newPosition;
end;
function TBitStream.readCardinal(count: integer):cardinal;
begin
readCardinal := getCardinal(stream_pos, count);
inc(stream_pos,count);
end;
function TBitStream.readBit:byte;
begin
readBit := getBit(stream_pos);
inc(stream_pos);
end;
function TBitStream.readString(count:cardinal):ansistring;
//count in bits
var readCount: cardinal;
begin
readString := getString(stream_pos,count,readCount);
inc(stream_pos,readCount);
end;
procedure TBitStream.writeBit(bit: byte);
begin
setBit(stream_pos,bit);
inc(stream_pos);
end;
procedure TBitStream.writeBits(count: cardinal; data: TBytes);
begin
setBits(stream_pos,count,data);
inc(stream_pos,count);
end;
procedure TBitStream.writeBits(count: cardinal; pdata: pbyte);
var
i:cardinal;
len:cardinal;
bytes: TBytes;
begin
len:=count div 8;
if (count mod 8)>0 then inc(len);
setLength(bytes,len);
for i:=0 to len-1 do begin
bytes[i]:=pdata^;
inc(pdata);
end;
writeBits(count,bytes);
end;
function TBitStream.eos:boolean;
begin
eos := stream_pos=bitsize;//High(bits)+1;
end;
procedure TBitStream.writeString(s: ansistring);
var
i:cardinal;
b:Tbytes;
begin
setLength(b,1);
for i:=1 to length(s) do begin
b[0]:=byte(s[i]);
setBits(stream_pos,7,b);
inc(stream_pos,7);
end;
b[0]:=$7f;
setBits(stream_pos,7,b);
inc(stream_pos,7);
b:=nil;
end;
end.

Use SHL/SHR along with masking to read out of your buffer. I would write a few functions to operate against the buffer (which I would declare as an array of byte) and return the value of a specific number of bits form a starting bit position. For instance, lets say that your largest value will never be more than 16 bits (a word). Since your mapped to an array of bytes, if you always grab 3 bytes from the array (watch for the upper bounds) and throw into an integer you can then mask and shift to get your specific value. The location of the bytes you want to get will then be (assuming a 0 based array):
Byte1Index = FirstBit DIV 8;
Byte2Index = Byte1Index + 1;
Byte3Index = Byte1Index + 2;
Pull these into your integer from your array.
TempInt := 0;
if Byte1Index <= High(Buffer) then
TempInt := Buffer[Byte1Index];
if Byte2Index <= High(Buffer) then
TempInt := TempInt OR ((Buffer[Byte2Index] and $000000FF) SHL 8);
if Byte3Index <= High(Buffer) then
TempInt := TempInt OR ((Buffer[Byte2Index] and $000000FF) SHL 16);
Then adjust your result to align properly
if FirstBit MOD 8 <> 0 then
TempInt := TempInt SHR (FirstBit MOD 8);
Then mask against the most number of bits you want to return:
Result := TempInt AND $00003FFF;
You can build the final mask programatically:
FinalMask := ($FFFFFFFF shl bitcount) xor $FFFFFFFF;
EDIT
This method is currently limited to 32 bits, but can be extended to at the most 64 bits by changing the masks from 32bit integers to 64bit integers (from $FFFFFFFF to $FFFFFFFFFFFFFFFF for example). Performance gains can also be made by not loading the extra bytes if they aren't needed, I just included here examples for 16 bits, however you will always want to grab at least an extra byte if the Bitsneeded + FirstBiT MOD 8 <> 0
For the messaging side of things I would create a base object which knows how to read data out of a buffer, then extend this into an object which knows how to also read parameters, and then create object descendants which know how to process each message type. You would still have a case statement, but it would be at a simple dispatcher level doing nothing more than passing the buffer off to the appropriate object to handle.

One possible way to handle this, while being terribly inefficient in terms of memory usage, would be to break up the bits as the data is read in. So, let's say you read in the data from the port in 8-bit (1-byte) chunks. Your first read would bring in 00100101. Break this into an array of 8 integers (e.g. bits[0] := 0; bits[1] := 0; bits[2] := 1; ...)
Now you can write helper routine(s) that will retrieve the value you are looking for from the array:
function getInt(start, len: integer): integer;
function getChar(start: integer): String;
These functions would use the start (and possibly len) parameters to combine the appropriate bits out of your array into a usable value.

I'd probably use ASM blocks to handle this with some assembler code - if you can use x86 assembly it would be much easier to parse the data and convert them to a more readable format to pass along.

Related

How to detect animated GIF?

I need to detect if a GIF file is animated (more than one frame) or not. Maybe the number of frames is written somewhere in the header of the GIF file?
A very ugly (slow) solution is to load the whole GIF (Vcl.Imaging.GIFImg.TGIFImage.LoadFromFile) and then to check if there is more than one frame. However, for large GIF files this takes seconds.
To improve speed I made a duplicate of that file and I removed some code from LoadFromStream. Of course, the image itself won't decode properly but I don't care. I only need the frame count. And it works:
procedure TGIFImage.LoadFromStream(Stream: TStream);
var
Position: integer;
begin
try
InternalClear;
Position := Stream.Position;
try
FHeader.LoadFromStream(Stream);
FImages.LoadFromStream(Stream);
{ This makes the loading slow:
with TGIFTrailer.Create(Self) do
try
LoadFromStream(Stream);
finally
Free;
end;
Changed(Self);
}
except
Stream.Position := Position;
raise;
end;
finally
end;
end;
Now the loading is only 600ms instead of 6 sec.
How do I use this modified LoadFromStream procedure, without using a full duplicate GIFImg.pas file?
How do I use this modified LoadFromStream procedure, without using a
full duplicate GIFImg.pas file?
Since the classes/methods in the code excerpt you display are not hidden in private/implementation sections, the best course of action would be to write code that duplicates relevant functionality.
Sample implementation can be like the below:
uses
gifimg;
function GifFrameCount(const FileName: string): Integer;
var
Img: TGifImage;
Header: TGIFHeader;
Stream: TFileStream;
Images: TGIFImageList;
begin
Img := TGIFImage.Create;
try
Header := TGIFHeader.Create(Img);
try
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Header.LoadFromStream(Stream);
Images := TGIFImageList.Create(Img);
try
Images.LoadFromStream(Stream);
Result := Images.Image.Images.Count;
finally
Images.Free;
end;
finally
Stream.Free;
end;
finally
Header.Free;
end;
finally
Img.Free;
end;
end;
The function raises an exception for a non-gif file, otherwise returns the frame count.
This FMX library (link1 link2) reads animated gif files. It is much simpler than the VCL one but it does the job well.
I converted the library to VCL.
Clean up
Basically, we need only the GIF structure parser. The frame decoder code (the one that makes the library slow) can be removed.
We can delete:
the TGifFrameList and all code related to it.
all frame decoding code
some of the utility functions like MergeBitmap.
Getting the frame count
In TGifReader.Read procedure there is a var called FrameIndex. Make that public and interrogate it to obtain the final frame count.
You will end up with only a few hundred lines of code. Pretty clean.
Speed
The speed after clean up is impressive.
The execution time is about 650ms for a 50MB gif (199 frames).
I tested the library with about 50 gif files (static and animated).
unit GifParser;
{---------------------------------------------------
The purpose of this unit is to return the FrameGount of an animated gif.
This was converted from FMX.
It will not decode the actual frames!
Originally this was for animated gif in Firemonkey
Pointing: https://stackoverflow.com/questions/45285599/how-to-use-animated-gif-in-firemonkey
Original original code: http://www.raysoftware.cn/?p=559
-------------------------------------------------------------------------------------------------------------}
INTERFACE
USES
System.Classes, System.SysUtils, System.Types, System.UITypes, Vcl.Graphics;
{ 100mb Animated Elementalist Lux Desktop Background.gif = 4.1s }
function IsAnimatedGif(CONST FileName: string): Integer;
TYPE
TGifVer = (verUnknow, ver87a, ver89a);
TInternalColor = packed record
case Integer of
0: (
{$IFDEF BIGENDIAN} R, G, B, A: Byte;
{$ELSE} B, G, R, A: Byte;
{$ENDIF} );
1: (Color: TAlphaColor; );
end;
{$POINTERMATH ON}
PInternalColor = ^TInternalColor;
{$POINTERMATH OFF}
TGifRGB = packed record
R: Byte;
G: Byte;
B: Byte;
end;
TGIFHeaderX = packed record
Signature: array [0 .. 2] of Byte; // * Header Signature (always "GIF") */
Version: array [0 .. 2] of Byte; // * GIF format version("87a" or "89a") */
// Logical Screen Descriptor
ScreenWidth : word; // * Width of Display Screen in Pixels */
ScreenHeight: word; // * Height of Display Screen in Pixels */
Packedbit: Byte; // * Screen and Color Map Information */
BackgroundColor: Byte; // * Background Color Index */
AspectRatio: Byte; // * Pixel Aspect Ratio */
end;
TGifImageDescriptor = packed record
Left: word; // * X position of image on the display */
Top: word; // * Y position of image on the display */
Width: word; // * Width of the image in pixels */
Height: word; // * Height of the image in pixels */
Packedbit: Byte; // * Image and Color Table Data Information */
end;
TGifGraphicsControlExtension = packed record
BlockSize: Byte; // * Size of remaining fields (always 04h) */
Packedbit: Byte; // * Method of graphics disposal to use */
DelayTime: word; // * Hundredths of seconds to wait */
ColorIndex: Byte; // * Transparent Color Index */
Terminator: Byte; // * Block Terminator (always 0) */
end;
TPalette = TArray<TInternalColor>;
{ TGifReader }
TGifReader = class(TObject)
protected
FHeader: TGIFHeaderX;
FPalette: TPalette;
FScreenWidth: Integer;
FScreenHeight: Integer;
FBitsPerPixel: Byte;
FBackgroundColorIndex: Byte;
FResolution: Byte;
FGifVer: TGifVer;
function Read(Stream: TStream): Boolean; overload; virtual;
public
Interlace: Boolean;
FrameIndex: Integer;
function Read(FileName: string): Boolean; overload; virtual;
function Check(Stream: TStream): Boolean; overload; virtual;
function Check(FileName: string): Boolean; overload; virtual;
public
constructor Create; virtual;
property Header: TGIFHeaderX read FHeader;
property ScreenWidth: Integer read FScreenWidth;
property ScreenHeight: Integer read FScreenHeight;
property BitsPerPixel: Byte read FBitsPerPixel;
property Resolution: Byte read FResolution;
property GifVer: TGifVer read FGifVer;
end;
IMPLEMENTATION
USES
Math;
{ 100mb Animated Elementalist Lux Desktop Background.gif = 4.1s }
function IsAnimatedGif(CONST FileName: string): integer;
VAR
GIFImg: TGifReader;
begin
GIFImg := TGifReader.Create;
TRY
GIFImg.Read(FileName);
Result:= GIFImg.FrameIndex; //GifFrameList.Count;
FINALLY
FreeAndNil(GIFImg);
END;
end;
CONST
alphaTransparent = $00;
GifSignature : array [0 .. 2] of Byte = ($47, $49, $46); // GIF
VerSignature87a: array [0 .. 2] of Byte = ($38, $37, $61); // 87a
VerSignature89a: array [0 .. 2] of Byte = ($38, $39, $61); // 89a
function swap16(x: UInt16): UInt16; inline;
begin
Result := ((x and $FF) shl 8) or ((x and $FF00) shr 8);
end;
function swap32(x: UInt32): UInt32; inline;
begin
Result := ((x and $FF) shl 24) or ((x and $FF00) shl 8) or
((x and $FF0000) shr 8) or ((x and $FF000000) shr 24);
end;
function LEtoN(Value: word): word; overload;
begin
Result := swap16(Value);
end;
function LEtoN(Value: Dword): Dword; overload;
begin
Result := swap32(Value);
end;
{ TGifReader }
function TGifReader.Read(FileName: string): Boolean;
var
fs: TFileStream;
begin
Result := False;
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Result := Read(fs);
except
end;
fs.DisposeOf;
end;
function TGifReader.Read(Stream: TStream): Boolean;
var
LDescriptor: TGifImageDescriptor;
LGraphicsCtrlExt: TGifGraphicsControlExtension;
LIsTransparent: Boolean;
LGraphCtrlExt: Boolean;
LFrameWidth: Integer;
LFrameHeight: Integer;
LLocalPalette: TPalette;
LScanLineBuf: TBytes;
procedure ReadPalette(Stream: TStream; Size: Integer; var APalette: TPalette);
Var
RGBEntry: TGifRGB;
I: Integer;
begin
SetLength(APalette, Size);
For I := 0 To Size - 1 Do
Stream.Read(RGBEntry, SizeOf(RGBEntry));
end;
function ProcHeader: Boolean;
begin
With FHeader do
begin
if (CompareMem(#Signature, #GifSignature, 3)) and
(CompareMem(#Version, #VerSignature87a, 3)) or
(CompareMem(#Version, #VerSignature89a, 3)) then
begin
FScreenWidth := FHeader.ScreenWidth;
FScreenHeight := FHeader.ScreenHeight;
FResolution := Packedbit and $70 shr 5 + 1;
FBitsPerPixel := Packedbit and 7 + 1;
FBackgroundColorIndex := BackgroundColor;
if CompareMem(#Version, #VerSignature87a, 3) then
FGifVer := ver87a
else if CompareMem(#Version, #VerSignature89a, 3) then
FGifVer := ver89a;
Result := True;
end
else
Raise Exception.Create('Unknown GIF image format');
end;
end;
function ProcFrame: Boolean;
var
LineSize: Integer;
LBackColorIndex: Integer;
begin
LBackColorIndex:= 0;
With LDescriptor do
begin
LFrameWidth := Width;
LFrameHeight := Height;
Interlace := ((Packedbit and $40) = $40);
end;
if LGraphCtrlExt then
begin
LIsTransparent := (LGraphicsCtrlExt.Packedbit and $01) <> 0;
If LIsTransparent then
LBackColorIndex := LGraphicsCtrlExt.ColorIndex;
end
else
begin
LIsTransparent := FBackgroundColorIndex <> 0;
LBackColorIndex := FBackgroundColorIndex;
end;
LineSize := LFrameWidth * (LFrameHeight + 1);
SetLength(LScanLineBuf, LineSize);
If LIsTransparent
then LLocalPalette[LBackColorIndex].A := alphaTransparent;
Result := True;
end;
function ReadAndProcBlock(Stream: TStream): Byte;
var
Introducer, Labels, SkipByte: Byte;
begin
Stream.Read(Introducer, 1);
if Introducer = $21 then
begin
Stream.Read(Labels, 1);
Case Labels of
$FE, $FF:
// Comment Extension block or Application Extension block
while True do
begin
Stream.Read(SkipByte, 1);
if SkipByte = 0 then
Break;
Stream.Seek(Int64( SkipByte), soFromCurrent);
end;
$F9: // Graphics Control Extension block
begin
Stream.Read(LGraphicsCtrlExt, SizeOf(LGraphicsCtrlExt));
LGraphCtrlExt := True;
end;
$01: // Plain Text Extension block
begin
Stream.Read(SkipByte, 1);
Stream.Seek(Int64( SkipByte), soFromCurrent);
while True do
begin
Stream.Read(SkipByte, 1);
if SkipByte = 0 then
Break;
Stream.Seek(Int64( SkipByte), soFromCurrent);
end;
end;
end;
end;
Result := Introducer;
end;
function ReadScanLine(Stream: TStream; AScanLine: PByte): Boolean;
var
OldPos, PackedSize: longint;
I: Integer;
SourcePtr: PByte;
Prefix: array [0 .. 4095] of Cardinal;
Suffix: array [0 .. 4095] of Byte;
DataComp: TBytes;
B, FInitialCodeSize: Byte;
ClearCode: word;
begin
DataComp := nil;
try
try
Stream.Read(FInitialCodeSize, 1);
OldPos := Stream.Position;
PackedSize := 0;
Repeat
Stream.Read(B, 1);
if B > 0 then
begin
Inc(PackedSize, B);
Stream.Seek(Int64(B), soFromCurrent);
end;
until B = 0;
SetLength(DataComp, 2 * PackedSize);
SourcePtr := #DataComp[0];
Stream.Position := OldPos;
Repeat
Stream.Read(B, 1);
if B > 0 then
begin
Stream.ReadBuffer(SourcePtr^, B);
Inc(SourcePtr, B);
end;
until B = 0;
ClearCode := 1 shl FInitialCodeSize;
for I := 0 to ClearCode - 1 do
begin
Prefix[I] := 4096;
Suffix[I] := I;
end;
finally
DataComp := nil;
end;
except
end;
Result := True;
end;
VAR
Introducer: Byte;
ColorTableSize: Integer;
rendered : array of TBitmap;
begin
Result := False;
FrameIndex:= 0;
if not Check(Stream) then Exit;
FGifVer := verUnknow;
FPalette := nil;
LScanLineBuf := nil;
TRY
Stream.Position := 0;
Stream.Read(FHeader, SizeOf(FHeader));
{$IFDEF BIGENDIAN}
with FHeader do
begin
ScreenWidth := LEtoN(ScreenWidth);
ScreenHeight := LEtoN(ScreenHeight);
end;
{$ENDIF}
if (FHeader.Packedbit and $80) = $80 then
begin
ColorTableSize := FHeader.Packedbit and 7 + 1;
ReadPalette(Stream, 1 shl ColorTableSize, FPalette);
end;
if not ProcHeader then
Exit;
FrameIndex := 0;
while True do
begin
LLocalPalette := nil;
Repeat
Introducer := ReadAndProcBlock(Stream);
until (Introducer in [$2C, $3B]);
if Introducer = $3B then
Break;
Stream.Read(LDescriptor, SizeOf(LDescriptor));
{$IFDEF BIGENDIAN}
nope
with FDescriptor do
begin
Left := LEtoN(Left);
Top := LEtoN(Top);
Width := LEtoN(Width);
Height := LEtoN(Height);
end;
{$ENDIF}
if (LDescriptor.Packedbit and $80) <> 0 then
begin
ColorTableSize := LDescriptor.Packedbit and 7 + 1;
ReadPalette(Stream, 1 shl ColorTableSize, LLocalPalette);
end
else
LLocalPalette := Copy(FPalette, 0, Length(FPalette));
if not ProcFrame then EXIT;
if not ReadScanLine(Stream, #LScanLineBuf[0]) then EXIT;
Inc(FrameIndex);
end;
Result := True;
finally
LLocalPalette := nil;
LScanLineBuf := nil;
rendered := nil;
end;
end;
function TGifReader.Check(Stream: TStream): Boolean;
var
OldPos: Int64;
begin
try
OldPos := Stream.Position;
Stream.Read(FHeader, SizeOf(FHeader));
Result := (CompareMem(#FHeader.Signature, #GifSignature, 3)) and
(CompareMem(#FHeader.Version, #VerSignature87a, 3)) or
(CompareMem(#FHeader.Version, #VerSignature89a, 3));
Stream.Position := OldPos;
except
Result := False;
end;
end;
function TGifReader.Check(FileName: string): Boolean;
var
fs: TFileStream;
begin
Result := False;
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
Result := Check(fs);
except
end;
fs.DisposeOf;
end;
constructor TGifReader.Create;//delete
begin
inherited Create;
end;
end.

firemonkey android crc16 result mismatch with delphi for windows

in two different project i need to use crc16 checksum.one in windows and other in android.i used a code for windows and it worked prefect.
showmessage( bin2crc16(HexToBin('1234')) ); //---> 0EC9
here is used function for winsows
function Pow(i, k: Integer): Integer;
var
j, Count: Integer;
begin
if k>0 then j:=2
else j:=1;
for Count:=1 to k-1 do
j:=j*2;
Result:=j;
end;
function BinToDec(Str: string): Integer;
var
Len, Res, i: Integer;
Error: Boolean;
begin
Error:=False;
Len:=Length(Str);
Res:=0;
for i:=1 to Len do
if (Str[i]='0')or(Str[i]='1') then
Res:=Res+Pow(2, Len-i)*StrToInt(Str[i])
else
begin
//MessageDlg('It is not a binary number', mtInformation, [mbOK], 0);
Error:=True;
Break;
end;
if Error=True then Result:=0
else Result:=Res;
end;
//------------------------------------------------------------------------------
function CRC16CCITT(bytes: array of Byte): Word;
const
polynomial = $1021;
var
crc: Word;
I, J: Integer;
b: Byte;
bit, c15: Boolean;
begin
crc := $FFFF;
for I := 0 to High(bytes) do
begin
b := bytes[I];
for J := 0 to 7 do
begin
bit := (((b shr (7-J)) and 1) = 1);
c15 := (((crc shr 15) and 1) = 1);
crc := crc shl 1;
if ((c15 xor bit) <> false) then crc := crc xor polynomial;
end;
end;
Result := crc and $ffff;
end;
//------------------------------------------------------------------------------
function HexToDec(const Str: string): Integer;
begin
if (Str <> '') and ((Str[1] = '-') or (Str[1] = '+')) then
Result := StrToInt(Str[1] + '$' + Copy(Str, 2, MaxInt))
else
Result := StrToInt('$' + Str);
end;
//------------------------------------------------------------------------------
function bin2crc16(str: string): string;
var
I:integer;
lengthCount : integer;
crcByteArr : array of Byte;
crcOut : Word;
begin
lengthCount := Trunc(length(str)/8);
setlength(crcByteArr , lengthCount );
for I := 0 to lengthCount-1 do
begin
crcByteArr[I] := BinToDec(copy(str, I*8+1, 8));
end;
crcOut := CRC16CCITT(crcByteArr);
result := crcOut.ToHexString;
end;
//------------------------------------------------------------------------------
function HexToBin(Hexadecimal: string): string;
const
BCD: array [0..15] of string =
('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
'1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');
var
i: integer;
begin
Result := '';
for i := Length(Hexadecimal) downto 1 do
Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;
end;
but for android i changed the code to handle zero index string.
the result is different
memo2.Lines.Add( bin2crc16(HexToBin('1234')) ); //-----> 1AFa
here is used functions in android
function BinToDec(Str: string): Integer;
var
Len, Res, i: Integer;
Error: Boolean;
begin
Error:=False;
Len:=Length(Str);
Res:=0;
for i:=0 to Len-1 do
if (Str[i]='0')or(Str[i]='1') then
Res:=Res+Pow(2, Len-i)*StrToInt(Str[i])
else
begin
Error:=True;
Break;
end;
if Error=True then Result:=0
else Result:=Res;
end;
//------------------------------------------------------------------------------
function CRC16CCITT(bytes: array of Byte): Word;
const
polynomial = $1021;
var
crc: Word;
I, J: Integer;
b: Byte;
bit, c15: Boolean;
begin
crc := $FFFF;
for I := 0 to High(bytes) do
begin
b := bytes[I];
for J := 0 to 7 do
begin
bit := (((b shr (7-J)) and 1) = 1);
c15 := (((crc shr 15) and 1) = 1);
crc := crc shl 1;
if ((c15 xor bit) <> false) then crc := crc xor polynomial;
end;
end;
Result := crc and $ffff;
end;
//------------------------------------------------------------------------------
function bin2crc16(str: string): string;
var
I:integer;
lengthCount : integer;
crcByteArr : array of Byte;
crcOut : Word;
begin
lengthCount := Trunc(length(str)/8);
setlength(crcByteArr , lengthCount );
for I := 0 to lengthCount-1 do
begin
crcByteArr[I] := BinToDec(copy(str, I*8, 8));
end;
crcOut := CRC16CCITT(crcByteArr);
result := crcOut.ToHexString;
end;
//-----------------------------------------------------------------------------------
function HexToBin(Hexadecimal: string): string;
const
BCD: array [0..15] of string =
('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
'1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');
var
i: integer;
begin
Result := '';
for i := Length(Hexadecimal)-1 downto 0 do
Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;
end;
//---------------------------------------------------------------------------------
function Pow(i, k: Integer): Integer;
var
j, Count: Integer;
begin
if k>0 then j:=2
else j:=1;
for Count:=1 to k-1 do
j:=j*2;
Result:=j;
end;
how can i fix my problem !?
You have not adjusted your HexToBin function for zero length strings.
There is also an issue in your BinToDec function. Your power calculation is wrong because the index into the string has changed. Possibly the simplest way to deal with it is as follows, although you could also adjust the index in the POW function
function BinToDec(Str: string): Integer;
var
Len, Res, i: Integer;
Error: Boolean;
begin
Error:=False;
Len:=Length(Str);
Res:=0;
for i:=1 to Len do
if (Str[I - 1]='0')or(Str[I - 1]='1') then
Res:=Res+Pow(2, Len-i)*StrToInt(Str[I - 1])
else
begin
Error:=True;
Break;
end;
if Error=True then Result:=0
else Result:=Res;
end;
The last thing to note is that 'Copy' uses One based indexing even on zero based strings, but you have assumed that it is zero indexed. I agree it is confusing, but there it is.

How get size of a Jpeg? [duplicate]

I want to know the width and height of an image file before opening that file.
So, how can I do that?
This refers to JPEG, BMP, PNG and GIF types of image files.
If by 'image file' you mean those raster image files recognised by the VCL's graphics system, and by 'before opening' you mean 'before the user is likely to notice that the file is opened', then you can do this very easily:
var
pict: TPicture;
begin
with TOpenDialog.Create(nil) do
try
if Execute then
begin
pict := TPicture.Create;
try
pict.LoadFromFile(FileName);
Caption := Format('%d×%d', [pict.Width, pict.Height])
finally
pict.Free;
end;
end;
finally
Free;
end;
Of course, the file is opened, and this requires a lot of memory if the image is big. However, if you need to obtain metatada (like dimensions) without loading the file, I believe you need a more 'complicated' solution.
You can try this page. I have not tested it, but it seems pretty reasonable that it will work.
Also, different file types have different ways of getting the width and height.
One of the page answers:
unit ImgSize;
interface
uses Classes;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
implementation
uses SysUtils;
function ReadMWord(f: TFileStream): word;
type
TMotorolaWord = record
case byte of
0: (Value: word);
1: (Byte1, Byte2: byte);
end;
var
MW: TMotorolaWord;
begin
// It would probably be better to just read these two bytes in normally and
// then do a small ASM routine to swap them. But we aren't talking about
// reading entire files, so I doubt the performance gain would be worth the trouble.
f.Read(MW.Byte2, SizeOf(Byte));
f.Read(MW.Byte1, SizeOf(Byte));
Result := MW.Value;
end;
procedure GetJPGSize(const sFile: string; var wWidth, wHeight: word);
const
ValidSig : array[0..1] of byte = ($FF, $D8);
Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
var
Sig: array[0..1] of byte;
f: TFileStream;
x: integer;
Seg: byte;
Dummy: array[0..15] of byte;
Len: word;
ReadLen: LongInt;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
ReadLen := f.Read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
ReadLen := 0;
if ReadLen > 0 then
begin
ReadLen := f.Read(Seg, 1);
while (Seg = $FF) and (ReadLen > 0) do
begin
ReadLen := f.Read(Seg, 1);
if Seg <> $FF then
begin
if (Seg = $C0) or (Seg = $C1) then
begin
ReadLen := f.Read(Dummy[0], 3); // don't need these bytes
wHeight := ReadMWord(f);
wWidth := ReadMWord(f);
end
else
begin
if not (Seg in Parameterless) then
begin
Len := ReadMWord(f);
f.Seek(Len - 2, 1);
f.Read(Seg, 1);
end
else
Seg := $FF; // Fake it to keep looping.
end;
end;
end;
end;
finally
f.Free;
end;
end;
procedure GetPNGSize(const sFile: string; var wWidth, wHeight: word);
type
TPNGSig = array[0..7] of byte;
const
ValidSig: TPNGSig = (137, 80, 78, 71, 13, 10, 26, 10);
var
Sig: TPNGSig;
f: tFileStream;
x: integer;
begin
FillChar(Sig, SizeOf(Sig), #0);
f := TFileStream.Create(sFile, fmOpenRead);
try
f.Read(Sig[0], SizeOf(Sig));
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
exit;
f.Seek(18, 0);
wWidth := ReadMWord(f);
f.Seek(22, 0);
wHeight := ReadMWord(f);
finally
f.Free;
end;
end;
procedure GetGIFSize(const sGIFFile: string; var wWidth, wHeight: word);
type
TGIFHeader = record
Sig: array[0..5] of char;
ScreenWidth, ScreenHeight: word;
Flags, Background, Aspect: byte;
end;
TGIFImageBlock = record
Left, Top, Width, Height: word;
Flags: byte;
end;
var
f: file;
Header: TGifHeader;
ImageBlock: TGifImageBlock;
nResult: integer;
x: integer;
c: char;
DimensionsFound: boolean;
begin
wWidth := 0;
wHeight := 0;
if sGifFile = '' then
exit;
{$I-}
FileMode := 0; // read-only
AssignFile(f, sGifFile);
reset(f, 1);
if IOResult <> 0 then
// Could not open file
exit;
// Read header and ensure valid file
BlockRead(f, Header, SizeOf(TGifHeader), nResult);
if (nResult <> SizeOf(TGifHeader)) or (IOResult <> 0)
or (StrLComp('GIF', Header.Sig, 3) <> 0) then
begin
// Image file invalid
close(f);
exit;
end;
// Skip color map, if there is one
if (Header.Flags and $80) > 0 then
begin
x := 3 * (1 SHL ((Header.Flags and 7) + 1));
Seek(f, x);
if IOResult <> 0 then
begin
// Color map thrashed
close(f);
exit;
end;
end;
DimensionsFound := False;
FillChar(ImageBlock, SizeOf(TGIFImageBlock), #0);
// Step through blocks
BlockRead(f, c, 1, nResult);
while (not EOF(f)) and (not DimensionsFound) do
begin
case c of
',': // Found image
begin
BlockRead(f, ImageBlock, SizeOf(TGIFImageBlock), nResult);
if nResult <> SizeOf(TGIFImageBlock) then
begin
// Invalid image block encountered
close(f);
exit;
end;
wWidth := ImageBlock.Width;
wHeight := ImageBlock.Height;
DimensionsFound := True;
end;
',' : // Skip
begin
// NOP
end;
// nothing else, just ignore
end;
BlockRead(f, c, 1, nResult);
end;
close(f);
{$I+}
end;
end.
And for BMP (also found at the page I mentioned):
function FetchBitmapHeader(PictFileName: String; Var wd, ht: Word): Boolean;
// similar routine is in "BitmapRegion" routine
label ErrExit;
const
ValidSig: array[0..1] of byte = ($FF, $D8);
Parameterless = [$01, $D0, $D1, $D2, $D3, $D4, $D5, $D6, $D7];
BmpSig = $4d42;
var
// Err : Boolean;
fh: HFile;
// tof : TOFSTRUCT;
bf: TBITMAPFILEHEADER;
bh: TBITMAPINFOHEADER;
// JpgImg : TJPEGImage;
Itype: Smallint;
Sig: array[0..1] of byte;
x: integer;
Seg: byte;
Dummy: array[0..15] of byte;
skipLen: word;
OkBmp, Readgood: Boolean;
begin
// Open the file and get a handle to it's BITMAPINFO
OkBmp := False;
Itype := ImageType(PictFileName);
fh := CreateFile(PChar(PictFileName), GENERIC_READ, FILE_SHARE_READ, Nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (fh = INVALID_HANDLE_VALUE) then
goto ErrExit;
if Itype = 1 then
begin
// read the BITMAPFILEHEADER
if not GoodFileRead(fh, #bf, sizeof(bf)) then
goto ErrExit;
if (bf.bfType <> BmpSig) then // 'BM'
goto ErrExit;
if not GoodFileRead(fh, #bh, sizeof(bh)) then
goto ErrExit;
// for now, don't even deal with CORE headers
if (bh.biSize = sizeof(TBITMAPCOREHEADER)) then
goto ErrExit;
wd := bh.biWidth;
ht := bh.biheight;
OkBmp := True;
end
else
if (Itype = 2) then
begin
FillChar(Sig, SizeOf(Sig), #0);
if not GoodFileRead(fh, #Sig[0], sizeof(Sig)) then
goto ErrExit;
for x := Low(Sig) to High(Sig) do
if Sig[x] <> ValidSig[x] then
goto ErrExit;
Readgood := GoodFileRead(fh, #Seg, sizeof(Seg));
while (Seg = $FF) and Readgood do
begin
Readgood := GoodFileRead(fh, #Seg, sizeof(Seg));
if Seg <> $FF then
begin
if (Seg = $C0) or (Seg = $C1) or (Seg = $C2) then
begin
Readgood := GoodFileRead(fh, #Dummy[0],3); // don't need these bytes
if ReadMWord(fh, ht) and ReadMWord(fh, wd) then
OkBmp := True;
end
else
begin
if not (Seg in Parameterless) then
begin
ReadMWord(fh,skipLen);
SetFilePointer(fh, skipLen - 2, nil, FILE_CURRENT);
GoodFileRead(fh, #Seg, sizeof(Seg));
end
else
Seg := $FF; // Fake it to keep looping
end;
end;
end;
end;
ErrExit: CloseHandle(fh);
Result := OkBmp;
end;
As a complement to Rafael's answer, I believe that this much shorter procedure can detect BMP dimensions:
function GetBitmapDimensions(const FileName: string; out Width,
Height: integer): boolean;
const
BMP_MAGIC_WORD = ord('M') shl 8 or ord('B');
var
f: TFileStream;
header: TBitmapFileHeader;
info: TBitmapInfoHeader;
begin
result := false;
f := TFileStream.Create(FileName, fmOpenRead);
try
if f.Read(header, sizeof(header)) <> sizeof(header) then Exit;
if header.bfType <> BMP_MAGIC_WORD then Exit;
if f.Read(info, sizeof(info)) <> sizeof(info) then Exit;
Width := info.biWidth;
Height := abs(info.biHeight);
result := true;
finally
f.Free;
end;
end;
If anyone yet interested in retrieving TIFF image dimensions without loading the graphic, there is a proven method that works perfectly for me in all environments. I also found another solution for that, but it returned wrong values from Illustrator-generated TIFFs. But there is a fantastic graphic library, called GraphicEx by Mike Lischke (TVirtualStringTree's very talented developer). There are implementations of many popular image formats and all of them descend from the base class TGraphicExGraphic, that implements ReadImageProperties virtual method. It is stream-based and only reads the fileheader in all implementations. So it is lightning-fast... :-)
So, here is a sample code, that retrieves a TIFF's dimensions (the method is the same for all graphic implementation, PNG,PCD,TGA,GIF,PCX,etc):
Uses ..., GraphicEx,...,...;
Procedure ReadTifSize (FN:String; Var iWidth,iHeight:Integer);
Var FS:TFileStream;
TIFF:TTIFFGraphic;
Begin
iWidth:=0;iHeight:=0;
TIFF:=TTIFFGraphic.Create;
FS:=TFileStream.Create(FN,OF_READ);
Try
TIFF.ReadImageProperties(FS,0);
iWidth:=TIFF.ImageProperties.Width;
iHeight:=TIFF.ImageProperties.Height;
Finally
TIFF.Destroy;
FS.Free;
End;
End;
That's all... :-) And this is the same for all the graphic implementations in the unit.
I don't like Rafael's solution for JPEG files too much because his algorithm parses every single byte until it hits FFC0. It doesn't make use of the fact that almost all markers (except FFD8, FFD9 and FFFE) are followed by two length bytes, allowing to skip from marker to marker. So I suggest the following procedure (which I condensed even a little more by stuffing checking for a marker and retrieving a value into the same function):
procedure GetJPGSize(const Filename: string; var ImgWidth, ImgHeight: word);
const
SigJPG : TBytes = [$FF, $D8];
SigC01 : TBytes = [$FF, $C0];
SigC02 : TBytes = [$FF, $C1];
var
FStream: TFileStream;
Buf: array[0..1] of Byte;
Offset,CheckMarker : Word;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
function SameValue(Sig:TBytes):Boolean;
begin
Result := CompareMem(#Sig[0], #Buf[0], Length(Sig));
end;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
function CheckMarkerOrVal(var Value:Word):Boolean;
begin
FStream.ReadData(Buf, Length(Buf));
Value := Swap(PWord(#Buf[0])^);
Result := (Buf[0] = $FF);
end;
//--------------------------------------------------------------------------------------------------------------------------------------------------------------
begin
FStream := TFileStream.Create(Filename, fmOpenRead);
Try
// First two bytes in a JPG file MUST be $FFD8, followed by the next marker
If not (CheckMarkerOrVal(CheckMarker) and SameValue(SigJPG))
then exit;
Repeat
If not CheckMarkerOrVal(CheckMarker)
then exit;
If SameValue(SigC01) or SameValue(SigC02) then begin
FStream.Position := FStream.Position + 3;
CheckMarkerOrVal(ImgHeight);
CheckMarkerOrVal(ImgWidth);
exit;
end;
CheckMarkerOrVal(Offset);
FStream.Position := FStream.Position + Offset - 2;
until FStream.Position > FStream.Size div 2;
Finally
FStream.Free;
end;
end;
Since GetGIFSize in Rafael's answer is broken and utterly complicated, here is my personal version of it:
function GetGifSize(var Stream: TMemoryStream; var Width: Word; var Height: Word): Boolean;
var
HeaderStr: AnsiString;
begin
Result := False;
Width := 0;
Height := 0;
//GIF header is 13 bytes in length
if Stream.Size > 13 then
begin
SetString(HeaderStr, PAnsiChar(Stream.Memory), 6);
if (HeaderStr = 'GIF89a') or (HeaderStr = 'GIF87a') then
begin
Stream.Seek(6, soFromBeginning);
Stream.Read(Width, 2); //Width is located at bytes 7-8
Stream.Read(Height, 2); //Height is located at bytes 9-10
Result := True;
end;
end;
end;
I found it by reading the RFC.

Reading variables from array of byte when positioned with arbitrary bit length

In Delphi XE3 I am trying to decode some data being read from a UDP-socket.
Apparently the data encoded like this (chronological order as listed):
NAME BITS TYPE
RECURRENCE INDICATOR 1 BOOLEAN
TRANSMITTER CODE 24 STRING
LATITUDE 25 INTEGER
LONGITUDE 26 INTEGER
DERIVATION 4 INTEGER
//I am not able to reach the documentation from work but the lat and long
//translates with a constant of 0.00000536441, so you take the binary (2 based)
//number, convert to decimal (10 based) and multiply with the constant for the
//float value of the coordinates.
Per now, my code looks like this (yes- this is early stage test and manual calculations):
procedure TForm1.UDPUDPRead(AThread: TIdUDPListenerThread; AData: array of Byte;
ABinding: TIdSocketHandle);
var
s: string;
recInd: Boolean;
trCode: String;
lat, long, deri: Integer;
begin
Label1.Caption := IntToStr(Length(AData)) + ' bytes received # ' +
TimeToStr(Time);
s := BytesToHex(AData);
If CheckBox2.Checked Then Memo1.Lines.Clear;
Memo1.Lines.Add(s);
end;
The questions is how can I set the variables recInd, trCode, lat, long and deri from that array of bytes?
Desired function would be someting like:
function SubBin(AData: array of byte; start, length: integer):array of byte
//Used like this:
recInd := SubBin(AData, 0, 1);
trCode := SubBin(AData, 1, 24);
lat := SubBin(AData, 25, 25);
long := SubBin(AData, 50, 26);
deri := SubBin(AData, 76, 4);
Assuming bit order MSB first, you can try something like this (not debugged, not optimized, just as an idea):
function ExtractBitArray(AData:TBytes; AFrom,ALength:Integer): TBytes;
var
ByteIdxFrom: integer;
i: integer;
BitEndOfs: integer;
Mask: byte;
procedure ___ShiftBytesRight(var ABuf:TBytes);
var
CFhi,CFlo: Byte;
B: byte;
i: integer;
begin
CFHi := 0;
for i := low(ABuf) to high(ABuf) do
begin
B := ABuf[i];
CFlo := B;
B := (B shr 1) or CFhi;
ABuf[i] := B;
CFhi := CFlo shl 7 and $80;
end;
end;
begin
ByteIdxFrom := AFrom div 8;
BitEndOfs := (AFrom + ALength) mod 8;
//
SetLength(Result,ALength div 8 + 1);
for i := Low(Result) to High(Result) do
Result[i] := AData[ByteIdxFrom + i];
//
if BitEndOfs>0 then
for I := BitEndOfs to 7 do
___ShiftBytesRight(Result);
//
Mask := $FF;
for i := ALength mod 8 to 7 do
Mask := Mask shr 1;
Result[0] := Result[0] and Mask;
end;
I finally came up with something in general looking like this:
procedure decode(adata: array of bytes; var results: Tcustom_record);
var
bstream: TBitStream;
buffer: Tbytes;
ALen: integer;
begin
ALen := Length(AData);
SetLength(buffer, ALen);
if ALen <> 0 then begin
Move(AData[0], buffer[0], ALen);
end;
bstream:=TBitStream.Create;
bstream.Load(buffer, sizeof(buffer) );
results.RECURRENCE_INDICATOR :=bstream.readBit;
results.TRANSMITTER_CODE :=bstream.readCardinal(24);
results.LATITUDE :=bstream.readCardinal(25);
results.LONGITUDE :=bstream.readCardinal(26);
results.DERIVATION :=bstream.readCardinal(4);
after digging down in the code i found i realized that TBitStream has to be defined:
unit ubitstream;
interface
uses classes,sysutils;
Type
TBitStream = class
constructor Create;
destructor Free;
public
procedure clear;
procedure Load(fileName: string); overload;
procedure Load(bs:TBitStream; offset: cardinal; count:cardinal); overload;
procedure Load(bs:TBitStream; count:cardinal); overload;
procedure Load(byteArray: TBytes); overload;
procedure Load(byteArray: TBytes; offset:cardinal); overload;
procedure Save(fileName: string); overload;
procedure Save(var byteArray: TBytes); overload;
function toHex:String;
function toBin:String;
//Sequental Access
function readCardinal(count: integer):cardinal;
function readBit:byte;
function readString(count:cardinal):ansistring;
procedure writeBit(bit: byte);
procedure writeBits(count: cardinal; data: TBytes); overload;
procedure writeBits(count: cardinal; pdata: Pbyte); overload;
procedure writeString(s: ansistring);
//----------------------------------------------------
function getSize:smallint;
procedure setSize(newSize: smallint);
property Size: smallint read getSize write setSize;
function getPos: cardinal;
procedure setPos(newPosition: cardinal);
property Position: cardinal read getPos write setPos;
function eos:boolean;//End Of Stream
protected
//Random Access
function getCardinal(offset: cardinal; count: cardinal):cardinal;
function getBit(offset: cardinal):byte;
function getString(offset: cardinal; count:cardinal; var readCount: cardinal):ansistring;
procedure setBit(offset: cardinal; bit: byte);
procedure setBits(offset: cardinal; count: cardinal; data: TBytes);
//----------------------------------------------------
private
bits: Array of byte;
stream_pos: cardinal; //postinion for sequental operations bits-based
end;
implementation
constructor TBitStream.Create;
begin
SetLength(bits,1); //initial size is 1b
stream_pos := 0;
end;
destructor TBitStream.Free;
begin
SetLength(bits,0); //free array
end;
procedure TBitStream.clear;
// clear data
begin
SetLength(bits,1);
bits[0] := 0;
stream_pos := 0;
end;
function TBitStream.getSize:smallint;
begin
getSize := High(bits) + 1; //index is zero-based
end;
procedure TBitStream.setSize(newSize: smallint);
begin
SetLength(bits,newSize);
if stream_pos>newSize-1 then stream_pos:=High(bits)+1;
end;
function TBitStream.getCardinal(offset: cardinal; count: cardinal):cardinal;
//return count of bits from ofsset as 32-bit data type
//offset and count size in bits
var
res: cardinal;
i,shift: cardinal;
begin
getCardinal:=0;
if (offset+count>Size*8) then raise Exception.Create('Index out of array bounds!');
if count>32 then exit; //no more than 32-bit
res := getBit(offset);
// writeln(offset,' ',getBit(offset),' ',res);
shift := 1;
for i:=offset+1 to offset+count-1 do begin
res := res or (getBit(i) shl shift);
inc(shift);
// writeln(i,' ',getBit(i),' ',res);
end;
getCardinal := res;
end;
procedure TBitStream.setBit(offset: cardinal; bit: byte);
//offset in bits
var
b: byte;
off1: cardinal;
pos1: byte;
begin
if (offset>=Size*8) then SetLength(bits,(offset div 8)+1);
off1 := offset div 8;
pos1 := offset mod 8;
b := bits[off1];
if bit=0 then begin //drop bit
b := b and (not (1 shl pos1));
end else begin //set bit
b := b or (1 shl pos1);
end;
bits[off1] := b;
end;
procedure TBitStream.setBits(offset: cardinal; count: cardinal; data: TBytes);
//set count of bits at ofsset from bytes array
//offset and count size in bits
var
i,j: cardinal;
b,bit: byte;
byteCount: cardinal;
off: cardinal;
Label STOP;
begin
if (offset+count>=Size*8) then SetLength(bits,((offset+count) div 8)+1); //Reallocate bits array
byteCount := count div 8;
off := offset;
if (count mod 8)>0 then inc(byteCount);
for i:=0 to byteCount-1 do begin //dynamic arrays is zero-based
b := data[i];
for j:=0 to 7 do begin //all bits in byte
bit := (b and (1 shl j)) shr j;
setBit(off,bit);
inc(off);
if (off>offset+count) then goto STOP;
end;
end;
STOP:
end;
function TBitStream.getBit(offset: cardinal):byte;
//offset in bits
var
b: byte;
off1: cardinal;
pos1: byte;
begin
getBit := 0;
if (offset>Size*8) then raise Exception.Create('Index out of array bounds!');
off1 := offset div 8;
pos1 := offset mod 8;
// if (offset mod 8)>0 then inc(off1);
b := bits[off1];
b := (b and (1 shl pos1)) shr pos1;//get bit
getBit := b;
end;
function TBitStream.getString(offset: cardinal; count:cardinal; var readCount: cardinal):ansistring;
//count, odffset in bits
var
s: ansistring;
len,i: cardinal;
b: byte;
off: cardinal;
begin
getString:='';
s := '';
readCount := 0;
off := offset;
if (count mod 7)<>0 then exit; //string must contain 7-bits chars....
len := count div 7;
for i:=1 to len do begin
if (offset>Size*8) then raise Exception.Create('Index out of array bounds!');
b := getCardinal(off,7);
inc(off,7);
inc(readCount,7);
if b=$7F then break; //this is EOL code
s := s + ansichar(b);
end;
getString := s;
end;
function TBitStream.toHex:String;
var
i:integer;
s,res:string;
begin
res:='';
for i:=Low(bits) to High(bits) do begin
s := Format('%02.2X ',[bits[i]]);
res := res + s;
end;
toHex := res;
end;
function TBitStream.toBin:String;
var
i,j:integer;
s,res:string;
b: byte;
begin
res:='';
for i:=Low(bits) to High(bits) do begin
//s := Format('%02.2X',[bits[i]]);
b := bits[i];
s:='';
for j:=7 downto 0 do begin
if (b and (1 shl j))>0 then s:=s+'1' else s:=s+'0';
end;
s := s+' ';
res := res + s;
end;
toBin := res;
end;
procedure TBitStream.Load(fileName: string);
//load data from binary file
var
f: file of byte;
i: cardinal;
b: byte;
begin
clear;
i:=0;
assign(f,fileName);
reset(f);
while not eof(f) do begin
blockread(f,b,1);
SetLength(bits,i+1);
bits[i] := b;
inc(i);
end;
close(f);
end;
procedure TBitStream.Save(fileName: string);
//save data to binary file
var
i:cardinal;
f: file of byte;
b: byte;
begin
assign(f,fileName);
rewrite(f);
for i:=Low(bits) to High(bits) do begin
b := bits[i];
blockwrite(f,b,1);
end;
close(f);
end;
procedure TBitStream.Save(var byteArray: TBytes);
//save data to array of bytes
var
i: cardinal;
begin
SetLength(byteArray,Size);
for i:=0 to Size-1 do begin
byteArray[i] := bits[i];
end;
end;
procedure TBitStream.Load(bs:TBitStream; offset: cardinal; count: cardinal);
//load data from other stream
//offset/count in bits
var
i,len,off: cardinal;
b: byte;
begin
clear;
off := offset;
len := count div 8;
setLength(bits, len);
for i:=0 to len-1 do begin
b:=bs.getCardinal(off,8);
if (i>Size) then SetLength(bits,i+1);
bits[i] := b;
inc(off,8);
end;
end;
procedure TBitStream.Load(bs:TBitStream; count: cardinal);
//load data from other stream
//count in bits
begin
Load(bs, bs.Position, count);
bs.Position:=bs.Position+count;
end;
procedure TBitStream.Load(byteArray: TBytes);
//load data from array of bytes
var
i,len: cardinal;
begin
clear;
len := High(byteArray)+1;
setLength(bits, len);
for i:=0 to len-1 do begin
bits[i] := byteArray[i];
end;
end;
procedure TBitStream.Load(byteArray: TBytes; offset:cardinal);
//offset in bytes
var
i,len: cardinal;
begin
clear;
len := High(byteArray)+1;
if offset>len then exit;
setLength(bits, len-offset);
for i:=offset to len-1 do begin
bits[i-offset] := byteArray[i];
end;
end;
function TBitStream.getPos: cardinal;
begin
getPos := stream_pos;
end;
procedure TBitStream.setPos(newPosition: cardinal);
begin
stream_pos := newPosition;
end;
function TBitStream.readCardinal(count: integer):cardinal;
begin
readCardinal := getCardinal(stream_pos, count);
inc(stream_pos,count);
end;
function TBitStream.readBit:byte;
begin
readBit := getBit(stream_pos);
inc(stream_pos);
end;
function TBitStream.readString(count:cardinal):ansistring;
//count in bits
var readCount: cardinal;
begin
readString := getString(stream_pos,count,readCount);
inc(stream_pos,readCount);
end;
procedure TBitStream.writeBit(bit: byte);
begin
setBit(stream_pos,bit);
inc(stream_pos);
end;
procedure TBitStream.writeBits(count: cardinal; data: TBytes);
begin
setBits(stream_pos,count,data);
inc(stream_pos,count);
end;
procedure TBitStream.writeBits(count: cardinal; pdata: pbyte);
var
i:cardinal;
len:cardinal;
bytes: TBytes;
begin
len:=count div 8;
if (count mod 8)>0 then inc(len);
setLength(bytes,len);
for i:=0 to len-1 do begin
bytes[i]:=pdata^;
inc(pdata);
end;
writeBits(count,bytes);
end;
function TBitStream.eos:boolean;
begin
eos := stream_pos=High(bits)+1;
end;
procedure TBitStream.writeString(s: ansistring);
var
i:cardinal;
c: byte;
eos:byte;
begin
for i:=1 to length(s) do begin
c:=byte(s[i]);
setBits(stream_pos,7,TBytes(#c));
inc(stream_pos,7);
end;
eos:=$7f;
setBits(stream_pos,7,TBytes(#eos));
inc(stream_pos,7);
end;
end.

How can I quickly convert an array of numeral characters into an integer?

Situation: a whole number saved as hex in a byte array(TBytes). Convert that number to type integer with less copying, if possible without any copying.
here's an example:
array = ($35, $36, $37);
This is '5', '6', '7' in ansi. How do I convert it to 567(=$273) with less trouble?
I did it by copying twice. Is it possible to be done faster? How?
You can use LookUp Table instead HexToInt...
This procedure works only with AnsiChars and of course no error checking is provided!
var
Table :array[byte]of byte;
procedure InitLookupTable;
var
n: integer;
begin
for n := 0 to Length(Table) do
case n of
ord('0')..ord('9'): Table[n] := n - ord('0');
ord('A')..ord('F'): Table[n] := n - ord('A') + 10;
ord('a')..ord('f'): Table[n] := n - ord('a') + 10;
else Table[n] := 0;
end;
end;
function HexToInt(var hex: TBytes): integer;
var
n: integer;
begin
result := 0;
for n := 0 to Length(hex) -1 do
result := result shl 4 + Table[ord(hex[n])];
end;
function BytesToInt(const bytes: TBytes): integer;
var
i: integer;
begin
result := 0;
for i := 0 to high(bytes) do
result := (result shl 4) + HexToInt(bytes[i]);
end;
As PA pointed out, this will overflow with enough digits, of course. The implementation of HexToInt is left as an exercise to the reader, as is error handling.
You can do
function CharArrToInteger(const Arr: TBytes): integer;
var
s: AnsiString;
begin
SetLength(s, length(Arr));
Move(Arr[0], s[1], length(s));
result := StrToInt(s);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
a: TBytes;
begin
a := TBytes.Create($35, $36, $37);
Caption := IntToStr(CharArrToInteger(a));
end;
If you know that the string is null-terminated, that is, if the final character in the array is 0, then you can just do
function CharArrToInteger(const Arr: TBytes): integer;
begin
result := StrToInt(PAnsiChar(#Arr[0]));
end;
procedure TForm1.FormCreate(Sender: TObject);
var
a: TBytes;
begin
a := TBytes.Create($35, $36, $37, 0);
Caption := IntToStr(CharArrToInteger(a));
end;
The most natural approach, however, is to use an array of characters instead of an array of bytes! Then the compiler can do some tricks for you:
procedure TForm1.FormCreate(Sender: TObject);
var
a: TCharArray;
begin
a := TCharArray.Create(#$35, #$36, #$37);
Caption := IntToStr(StrToInt(string(a)));
end;
It cannot be any faster than that ;-)
function HexToInt(num:pointer; size:Cardinal): UInt64;
var i: integer;
inp: Cardinal absolute num;
begin
if(size > SizeOf(Result)) then Exit;
result := 0;
for i := 0 to size-1 do begin
result := result shl 4;
case(PByte(inp+i)^) of
ord('0')..ord('9'): Inc(Result, PByte(inp+i)^ - ord('0'));
ord('A')..ord('F'): Inc(Result, PByte(inp+i)^ - ord('A') + 10);
ord('a')..ord('f'): Inc(Result, PByte(inp+i)^ - ord('a') + 10);
end;
end;
end;
function fHexToInt(b:TBytes): UInt64; inline;
begin
Result:=HexToInt(#b[0], Length(b));
end;
...
b:TBytes = ($35, $36, $37);
HexToInt(#b[0], 3);
fHexToInt(b);

Resources