PHASH

From Free Pascal wiki

Calculating Perceptual hashes (PHASH) and comparing image similarity)

Here is a program to calculate the perceptual hash for images different than a CRC or md5 hash a perceptual hash will be similar for similar images. A slight change in the image (sharpen, blur, resize) will give perceptual hash that is similar where a CRC or MD5 hash will be completely different. I looked for a PHASH program for pascal and could not find any. I did find three methods for getting a perceptual hash. The first was using a DCT transform but the code was written in C and was not easy to link the program in. The second way is to resize it and make a hash based on whether each pixel was more or less then its next neighbor. The third way was to use image moments. ImageMagick(IM) uses this method but I found that after a certain threshold the images where radically different. Also calculating the differences required a lot of computing power as you had to square the difference of 42 numbers for each image comparison. I tried all three methods, only the first had good promise. The last one was not even part of the IM Lazarus interface.

This program uses ImageMagick and I want to express my appreciation for the work of the translators of this tool to work with Lazarus. However I had a lot of problems getting it to work properly. First because it has not kept up with the code there were some routines that did not work because they have been deprecated (and no longer available) in ImageMagick. Second because some of the newer routines were missing entirely. And third because I was using the Q8 version of ImageMagick and it appeared that the translation was for the Q16 version. PPixelPacket for instance assumes the colors are 16 bit and not 8 bit so I had to change how I handled the structure). I use 8 bit ImageMagick because 99.99999% of the pictures I wanted to process are 8 bit or less and the Q8 program is much faster then the Q16 version.

To get this to work under windows 7 you need to compile under 32bit mode (and call 32 bit ImageMagick) as the calling conventions for 64 bit are quite different and Lazarus does not support the 64 bit calling conventions. (this may change but keep it in mind).

This program takes one main argument - the directory to parse for images (currently only JPG and GIF but you can add more). The program maintains a file 'yalls' that contains information for each image it finds in that directory - deleting files that no longer exists, adding new files and if the md5 does not match recalculating data for that file. (for speed you can have it skip the md5 check and just rewrite existing lines for files by placing SKIP before the directory argument. Since I had a specific set of directories to parse if you do not use any argument it will parse those directories. The output file will consist of one line for each image it finds consisting of fields separated by blanks. The program expects the filenames are without spaces and would need modification otherwise. There was a memory leak with the program and after about 200,000 images it crashed. This may be gone but if the program dies just move the yall file to yalls and restart with JPEGINFO SKIP to restart from where it ended.

The output file contains:

 MD5 - 32 hex bytes of the MD5 sum of the entire file.
 Signature - 64 hex bytes that comes from IM identify that is I think the md5 of the image only
 PHASH - 16 hex bytes of the DCT hash of the image
 Date of the file in YYYYMMDDHHMMSS format (from ImageMagick identify)
 Size in bytes of the file
 Bitdepth of the image
 Width of the image
 Height of the image
 Filename of the image
 Complete fileid of the image
 Example:
 md5       fb54e12c44d2b14d4d3266251109799e
 signature 2318170444932902d0541895584df4c2f8f38ad8b1d4dad899870760817422f2
 phash     CCFB4EAEF3F30C0D
 date      20151001010847
 size      901
 bitdepth  8
 width     32
 width     32
 filename  01.gif
 fid       F:\CCC\01.gif


I will add another program later if there is interest that calculates phash similarity. This program was written on a windows7 platform. Basically to get phash similarity you count the number of bits that are different. If that number is 0 the pictures are likely to be the same, if it is over 10 the pictures are likely to be different, otherwise the pictures may be similar to some degree. Note it takes about 24 hours to process 700000 images with this program on my computer. I estimate it may take another 24 hours to compare these hashes up to 4 bit differences. At least twice that for 8 bit differences.

program JPEGInfo;

{$APPTYPE CONSOLE} {$R-}

uses strutils,sysutils,classes, md5,magick_wand, ImageMagick,DateUtils;


{ Bytes = array[0..0] of Byte;}
{ LongWords = array[0..255] of Byte;}


type
  clr = record
    red:byte;
    green:byte;
    blue:byte;
    opacity:byte;
  end;
var
 allfile:text;
 infile:text;
 donedir,donefname, inrec:string;
 skipped,deleted,added,modified,count:longword;
 wand: PMagickWand;
 updatefileexists, skipmd5check,notstarted,readnextrec :boolean;
 dctmatrix : array[0..7,0..31] of real;
 status: MagickBooleanType;
 starttime:tdatetime;
 filename:pchar;
 udir,ufname:string;
 Size : Integer;
 timed:longint;
 DirName: string;

procedure ThrowWandException(wand: PMagickWand);
var
  description: PChar;
  severity: ExceptionType;
begin
  description := MagickGetException(wand, @severity);
  WriteLn(Format('An error occurred. Description: %s', [description]));
  description := MagickRelinquishMemory(description);
  Abort;
end;

function pad(msg:string;len:byte):string;
var par : byte;
begin
   result := msg;
   if length(msg) > len then result := copy(msg,1,len);
   while length(result) < len do result := result + ' ';
   for par := 1 to len do if ord(result[par]) < 32 then result[par] := ' ';
end;

{read the next old file record into inrec and fileid into donefname,donedir}
procedure getnextok;
var i: integer;

procedure skipitem;
begin
   while (i < length(inrec)) and (inrec[i] <> ' ') do inc(i);
end;

procedure skipspaces;
begin
   while inrec[i] = ' ' do inc(i)
end;
begin
   if eof(infile) then donedir := chr(255)
   else begin
      readln(infile,inrec);
      i := 1;
      skipitem; {md5}  skipspaces;   {fb54e12c44d2b14d4d3266251109799e}
      skipitem; {md6}  skipspaces;   {2318170444932902d0541895584df4c2f8f38ad8b1d4dad899870760817422f2}
      skipitem; {phash} skipspaces;  {CCFB4EAEF3F30C0D}
      skipitem; {date} skipspaces;   {20151001010847}
      skipitem; {size} skipspaces;   {         901}
      skipitem; {depth} skipspaces;  {  8}
      skipitem; {width} skipspaces;  {     32}
      skipitem; {height} skipspaces; {     32}
      skipitem; {name} skipspaces;   {01.gif                   }
      donefname:= copy(inrec,i,999); {F:\CCC\01.gif}
      i := rpos('\',donefname);
      if i = 0 then writeln('error reading line from yalls:',inrec);
      donedir := StringReplace(uppercase(copy(donefname,1,i)),'\',' ',[rfReplaceAll]);;
      donefname := uppercase(copy(donefname,i+1,9999));
   end;
   readnextrec := false;
end;
function GetDif(time:longint):string;
var part: longint; t:longint;
begin
   result := '';
   t := time;
   if time > 86400 then begin
      part := t div 86400;
      t := t mod 86400;
      result := result + format('%.2d',[part])+' '; end;
   if time >  3600 then begin
      part := t div  3600;
      t := t mod  3600;
      result := result + format('%.2d',[part])+':';  end;
   if time >    60 then begin
      part := t div    60;
      t := t mod    60;
      result := result + format('%.2d',[part])+':'; end;
   if time >     0 then
      result := result + format('%.2d',[t]);
end;

function gethash:string;
var
  intermediate : array[0..7,0..31] of real;
  i,j,r,c,k:byte;
  img:array[0..31,0..31] of byte;
  dctresult:array[0..7,0..7] of real;
  pimg: Pimage;
  pack:record case integer of
     1:( pkt:PPixelPacket);
     2:( co:^clr);
  end;
  hash,one:qword; med:DOUBLE;
begin
   result := 'xxxxxxxxxxxxxxxx'; { in case an error occurs}
   try
      {Resize the image to 32x32. If it is my test case file
       'f:\ccc\01.gif' then it is already at the correct size and I
        found that if imagemagic resizes it the file gets changed ---
        I did not want that, it might be faster to grayscale the image
        first then resize but not if you use MagickQuantizeImage too slow}
      if uppercase(filename) <> 'F:\CCC\01.GIF' then
         MagickResizeImage(wand, 32, 32, LanczosFilter, 1.0);
      {now we convert the image to grayscale - this procedure is similar to
        MagickQuantizeImage(wand, 256, GRAYColorspace, iszero, iszero, iszero);
         but is a LOT faster. BTW I don't know why I had to use variables
         for this function. The conversion numbers were selected to be
         close to what MagickQuantizeImage used. Note I had an issue
         here. Under Q8 IM GetAuthenticPixels it returns an array of
         byte values for colors but the lazarus interface mapped it to word sizes.
         You could get an entire array of values with getauthenticpixels but
         the speed won't be much different so I didn't bother.
         We dump the results into the img array}
      pimg := GetImageFromMagickWand(wand);
      for j := 0 to 31 do begin
         for i := 0 to 31 do begin
            pack.pkt := GetAuthenticPixels(pimg, i, j, 1, 1, nil);
            img[i,j] :=round(pack.co^.red*0.072+
                             pack.co^.green*0.715+
                             pack.co^.blue*0.213);
         end;
      end;
      {results are in the img array. Now do matrix multiplcation
          DCTMATRIX * img * transposed(DCTMATRIX)
       since we only need the top 8x8 array we only do the
       calculations for that part}
      {intermediate = DCTMATRIX*IMG}
      fillchar(intermediate,sizeof(intermediate),0);
      for r := 0 to 7 do
         for c := 0 to 31 do
            for k := 0 to 31 do
                intermediate[r,c] := intermediate[r,c] +
                                     dctmatrix[r,k]*img[k,c];
      {dctresult  = intermediate*transposed(DCTMATRIX)}
      fillchar(dctresult,sizeof(dctresult),0);
      for r := 0 to 7 do
         for c := 0 to 7 do
            for k := 0 to 31 do
                dctresult[r,c] := dctresult[r,c] +
                intermediate[r,k]*dctmatrix[c,k]{inverted dctmatrix};
      {now we need to calculate the median value. Note the first value
       (0,0) is much too large and affects the median value too much.
       To fix it is set to 0 but perhaps some other solution can be done
       such as do a log on the value}
      med := 0;
      dctresult[0,0] := 0;
      for r := 0 to 7 do
         for c := 0 to 7 do
            med := med + dctresult[r,c];
      med := med / 64;
      {the hash is calculated by setting the bit of
       each value greater than the median}
      one := 1;
      hash := 0;
      for r := 0 to 7 do
         for c := 0 to 7 do begin
            if dctresult[r,c] > med then inc(hash,one);
            one := one shl 1;
         end;
      one := 1;
      {return the phash}
      result := inttohex(hash,16);
   finally
   end;
end;

procedure processfile(dir:string;fname:string);
var
  F: file;
  idents:pchar;
  i:integer;
  md5,md6, date, fsize,depth,imageheight,imagewidth,fno:string;
  P: Pointer;
begin
   inc(count);
   if (count mod 1000) = 1 then begin
      timed := SecondsBetween(Now,starttime);
      writeln('at count ',count-1,' E:'+ GetDif(timed)+' D:',deleted,' A:',added,' M:',modified,' S:',skipped,' ',dir,fname);
   end;
   filename := pchar(dir+fname);
   udir := StringReplace(uppercase(dir),'\',' ',[rfReplaceAll]);;
   ufname := uppercase(fname);
   if updatefileexists then begin
   if readnextrec then getnextok;
   while (udir > donedir) or ((udir = donedir) and (ufname > donefname)) do begin getnextok; inc(deleted); end;
   if skipmd5check then
      if (udir+ufname) = (donedir+donefname) then begin
            inc(skipped);
            writeln(allfile,inrec);
            readnextrec := true;
         exit;
      end;
    end;
   TRY
      Assign(F,FileName);
      FileMode:=fmOpenRead + fmShareDenyNone;
      Reset(F, 1);
      Size := FileSize(F);
      GetMem(P, Size);
      BlockRead(F, P^, Size);
      md5 := md5print(md5buffer(p^,Size));
   finally
      FreeMem(P);
      CloseFile(F);
   end;
   if updatefileexists then begin
      if (udir+ufname) = (donedir+donefname) then begin
         if copy(inrec,1,32) = md5 then begin
            inc(skipped);
            writeln(allfile,inrec);
            readnextrec := true;
            exit;
         end;
         inc(modified);
      end
      else inc(added);
   end;
   if notstarted then begin
      notstarted := false;
      writeln('Started at line:',count,' with file:',filename);
   end;
   try
      wand := NewMagickWand;
      status := MagickReadImage(wand, filename);
      if (status = MagickFalse) then ThrowWandException(wand);
      idents   := magickidentifyimage(wand);
      md6   := copy(idents,pos('signature:',idents)+11,64);
      i := pos('date:modify:',idents)+13;
      if i = 0 then i := pos('date:create:',idents)+13;
      date  := copy(idents,i   ,4)+copy(idents,i+ 5,2)+copy(idents,i+ 8,2)+
               copy(idents,i+11,2)+copy(idents,i+14,2)+copy(idents,i+17,2);
      fsize := copy(idents,pos('Filesize:',idents)+10,64);
      i := POS(Chr(10),FSIZE);
      if i > 0 then fsize := copy(fsize,1,i-1);
      i := pos('Depth:',   idents)+7;
      depth := copy(idents, i,1);
      i := pos('Geometry:',idents)+10;
      imageheight    := copy(idents, i,99);
      i := pos('x',imageheight);
      imagewidth := copy(imageheight,i+1,99);
      imageheight := copy(imageheight,1,i-1);
      i := pos('+',imagewidth);
      imagewidth := copy(imagewidth,1,i-1);
      fno := fname;
      if length(fno) < 22 then fno := pad(fno,25);
      writeln(allfile,md5,' ',md6,' ',gethash,' ',date:14,' ',
           size:12, depth:2,imageheight:7,imagewidth:7,' ',
           fno,' ',filename);
    finally
       wand := DestroyMagickWand(wand);
    end;
end;

// Recursive procedure to build a list of files
procedure FindFiles(StartDir: string);
var
  SR: TSearchRec;
  IsFound: Boolean;
begin
  if StartDir[length(StartDir)] <> '\' then  StartDir := StartDir + '\';
  { Build a list of the files in directory StartDir
    (but not the directories!)                         }
  IsFound := FindFirst(StartDir+'*.*', faAnyFile-faDirectory, SR) = 0;
  while IsFound do begin
    if (uppercase(extractFileExt(sr.name)) = '.JPG')
       or (uppercase(extractFileExt(sr.name)) = '.GIF')
          then processfile(StartDir,SR.Name);
    IsFound := FindNext(SR) = 0;
  end;
  FindClose(SR);
  // Build a list of subdirectories
  IsFound := FindFirst(StartDir+'*.*', faDirectory, SR) = 0;
  while IsFound do begin
    if ((SR.Attr and faDirectory) <> 0) and (SR.Name[1] <> '.') then
       FindFiles(StartDir + SR.Name);
    IsFound := FindNext(SR) = 0;
  end;
  FindClose(SR);
end;

{$R *.res}
procedure makedct;
var c1:real; ii,p,q: byte;
begin
   c1 := 1/sqrt(32);
   for ii := 0 to 31 do dctmatrix[0,ii] := c1;
   c1 := c1*2;
   for p := 1 to 7 do
      for q := 0 to 31 do
          dctmatrix[p,q] := c1 * cos(pi/64*p*(2*q+1));
end;

begin
  starttime := now;   {keep track of time}
  {have we started processing files as opposed to copy old recs}
  notstarted := true;
  skipmd5check := false; {on copy skip md5 check}
  DirName := ParamStr(1); {did he pass a filename}
  if length(dirname) > 3 then
     if copy(upcase(dirname),1,4) = 'SKIP' then begin
        dirname := paramstr(2);
        skipmd5check := true;
  end;
  count := 0;
  deleted := 0; modified := 0; added := 0; skipped := 0;
  {allow access to file while writing it}
  FileMode:=fmOpenwrite + fmShareDenyNone;
  assign(allfile,'yall');
  rewrite(allfile);
  readnextrec := true;
  updatefileexists := fileexists('yalls');
  if updatefileexists then begin
     {allow access to file while reading it}
     FileMode:=fmOpenwrite + fmShareDenyNone;
     assign(infile,'yalls');
     reset(infile);
     getnextok;
  end;

  MagickWandGenesis;
  makedct;  {make DCT matrix (or at least what is needed)}
  {This is a set of directories that I desired to maintain}
  if (dirname = 'F:\') or (dirname = 'F:\') or
     (length(dirname) < 3) then  begin
     FindFiles('F:\CCC\');
     FindFiles('F:\CD\');
     FindFiles('F:\CHECK\');
     FindFiles('F:\QDISK\');
  end
  else FindFiles(DirName); {or use a user supplied directory name}
  writeln('found:',count,' files ',' Deleted:',deleted,' Added:',added,' Changed:',modified,' SKIPPED:',skipped);
  close(allfile);
  if updatefileexists then close(infile);
  MagickWandTerminus;
  { I get paranoid and like to keep a few versions of the files around}
  if fileexists('yalls.005') then deletefile('yalls.005');
  if fileexists('yalls.004') then renamefile('yalls.004','yalls.005');
  if fileexists('yalls.003') then renamefile('yalls.003','yalls.004');
  if fileexists('yalls.002') then renamefile('yalls.002','yalls.003');
  if fileexists('yalls.001') then renamefile('yalls.001','yalls.002');
  if fileexists('yalls') then renamefile('yalls','yalls.001');
  renamefile('yall','yalls');
end.