دلفي

الأحد، 16 يونيو 2013

Compares two strings in percent (how they are similar to each other)
Returns byte value from 0 to 100%

examples:

var
  Percent: byte;

begin
  Percent := CompareStringsInPercent('this is a test', 'This is another test'); // 37%
  Percent := CompareStringsInPercent('this is some string', 'and yet another some string'); // 24%
  Percent := CompareStringsInPercent('abcde', 'fghij'); // 0%
  Percent := CompareStringsInPercent('1.jpg', '2.jpg'); // 81%

...

}

function CompareStringsInPercent(Str1, Str2: string): Byte;
type
  TLink = array[0..1] of Byte;
var
  tmpPattern: TLink;
  PatternA, PatternB: array of TLink;
  IndexA, IndexB, LengthStr: Integer;
begin
  Result := 100;
  // Building pattern tables
  LengthStr := Max(Length(Str1), Length(Str2));
  for IndexA := 1 to LengthStr do
  begin
    if Length(Str1) >= IndexA then
    begin
      SetLength(PatternA, (Length(PatternA) + 1));
      PatternA[Length(PatternA) - 1][0] := Byte(Str1[IndexA]);
      PatternA[Length(PatternA) - 1][1] := IndexA;
    end;
    if Length(Str2) >= IndexA then
    begin
      SetLength(PatternB, (Length(PatternB) + 1));
      PatternB[Length(PatternB) - 1][0] := Byte(Str2[IndexA]);
      PatternB[Length(PatternB) - 1][1] := IndexA;
    end;
  end;
  // Quick Sort of pattern tables
  IndexA := 0;
  IndexB := 0;
  while ((IndexA < (Length(PatternA) - 1)) and (IndexB < (Length(PatternB) - 1))) do
  begin
    if Length(PatternA) > IndexA then
    begin
      if PatternA[IndexA][0] < PatternA[IndexA + 1][0] then
      begin
        tmpPattern[0]           := PatternA[IndexA][0];
        tmpPattern[1]           := PatternA[IndexA][1];
        PatternA[IndexA][0]     := PatternA[IndexA + 1][0];
        PatternA[IndexA][1]     := PatternA[IndexA + 1][1];
        PatternA[IndexA + 1][0] := tmpPattern[0];
        PatternA[IndexA + 1][1] := tmpPattern[1];
        if IndexA > 0 then Dec(IndexA);
      end
      else
        Inc(IndexA);
    end;
    if Length(PatternB) > IndexB then
    begin
      if PatternB[IndexB][0] < PatternB[IndexB + 1][0] then
      begin
        tmpPattern[0]           := PatternB[IndexB][0];
        tmpPattern[1]           := PatternB[IndexB][1];
        PatternB[IndexB][0]     := PatternB[IndexB + 1][0];
        PatternB[IndexB][1]     := PatternB[IndexB + 1][1];
        PatternB[IndexB + 1][0] := tmpPattern[0];
        PatternB[IndexB + 1][1] := tmpPattern[1];
        if IndexB > 0 then Dec(IndexB);
      end
      else
        Inc(IndexB);
    end;
  end;
  // Calculating simularity percentage
  LengthStr := Min(Length(PatternA), Length(PatternB));
  for IndexA := 0 to (LengthStr - 1) do
  begin
    if PatternA[IndexA][0] = PatternB[IndexA][0] then
    begin
      if Max(PatternA[IndexA][1], PatternB[IndexA][1]) - Min(PatternA[IndexA][1],
        PatternB[IndexA][1]) > 0 then Dec(Result,
        ((100 div LengthStr) div (Max(PatternA[IndexA][1], PatternB[IndexA][1]) -
          Min(PatternA[IndexA][1], PatternB[IndexA][1]))))
      else if Result < 100 then Inc(Result);
    end
    else
      Dec(Result, (100 div LengthStr))
  end;
  SetLength(PatternA, 0);
  SetLength(PatternB, 0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Image1.Picture.LoadFromFile('mybitmap.bmp');
  //Init bumpmapping and set color to cyan (2*r,3*g,+4*b)
  Bump_Init(Image1.Picture.Bitmap, 2,3,4);
end;

// ----- animate bumpmapping -----
procedure TForm1.Timer1Timer(Sender: TObject);
const
  XPos: Single = 0.1;
  YPos: Single = 0.3;
begin
  //Timer1.Interval:=40;
  //Image1.Stretch:=TRUE !!!!

  //Position des Lichtpunktes ändern
  XPos := XPos + 0.02;
  YPos := YPos + 0.01;

  //Auf 2Pi begrenzen
  if (XPos > 2 * PI) then XPos := XPos - 2 * PI;
  if (YPos > 2 * PI) then YPos := YPos - 2 * PI;

  //Und ausgeben
  with Image1.Picture do
    Bump_Do(Bitmap,
      trunc(Sin(XPos) * (Bitmap.Width shr 1) + (Bitmap.Width shr 1)),
      trunc(Sin(YPos) * (Bitmap.Height shr 1) + (Bitmap.Height shr 1))
      )
end;

// ----- Close -----
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Bump_Flush();
end;

}

/////////////////// Unit Unit_Bumpmapping ////////////////////////////

unit Unit_Bumpmapping;

interface

uses Windows, Graphics;

// ----- Bumpmapping procedures -----
procedure Bump_Init(SourceBitMap: TBitmap; r: Single = 3; g: Single = 3.6;
  b: Single = 4);
procedure Bump_Flush();
procedure Bump_Do(Target: TBitmap; XLight, YLight: Integer);
procedure Bump_SetSource(SourceBitMap: TBitmap);
procedure Bump_SetColor(r, g, b: Single);

implementation

// ----- ein paar nützliche Types definieren -----
type
  PBitmap = ^TBitmap;
  //Kleines Arry zum schnelleren Zugriff auf Bitmaps
  TLine = array[0..MaxInt div SizeOf(TRGBQUAD) - 1] of TRGBQUAD;
  PLine = ^TLine;

  // ----- Einige interne Variablen -----
var
  ColorArray: array of TRGBQuad;                //Array für die Farbtabelle beim Bumpmapping
  SourceArray: array of Byte;                    //Quell Muster
  TargetBMP: TBitmap;                          //ZielBitmap
  Black: TRGBQuad;                         //Schwart
  White: TRGBQuad;                         //Weiß

  // ----- Die Quelle für das Bumpmapping erzeugen            -----
  // ----- aus einem Bitmap wird ein Schwarzweißarray erzeugt -----
procedure Bump_SetSource(SourceBitMap: TBitmap);
var
  iX, iY: Integer;
  z: Integer;
  sLine: PLine;
  iDot: Integer;
begin
  //QuellArray erzeugen
  SourceBitmap.PixelFormat := pf32Bit;
  SetLength(SourceArray, SourceBitMap.Height * SourceBitMap.Width);

  for iY := 0 to SourceBitMap.Height - 1 do
  begin
    //Scanline holen
    sLine := SourceBitMap.ScanLine[iY];

    //Und durchwursten
    for iX := 0 to SourceBitMap.Width - 1 do
    begin
      //Koordinaten errechnene
      z := iY * SourceBitMap.Width + iX;

      //Grauwert bestimmen
      idot := sLine[iX].rgbRed;
      idot := idot + sLine[iX].rgbGreen;
      idot := idot + sLine[iX].rgbBlue;
      iDot := (iDot div 3);
      //Und eintragen
      SourceArray[z] := iDot;
    end;
  end;
end;

// ----- Farbtabelle erzeugen -----
procedure Bump_SetColor(r, g, b: Single);
var
  iIndex: Integer;
  c: Byte;
begin
  if (r > 4) then r := 4;
  if (r < 0) then r := 0;
  if (g > 4) then g := 4;
  if (g < 0) then g := 0;
  if (b > 4) then b := 4;
  if (b < 0) then b := 0;

  //Länge setzen
  SetLength(ColorArray, 255);
  //Und erstmalschwarz machen
  FillMemory(ColorArray, 255 * SizeOf(TRGBQuad), 0);

  //Schoener Blauverlauf
  for iIndex := 0 to 127 do
  begin
    c := 63 - iIndex div 2;

    //Hier kann die Farber eingestellt werden 0.0-4.0
    ColorArray[iIndex].rgbRed   := round(c * r);
    ColorArray[iIndex].rgbGreen := round(c * g);
    ColorArray[iIndex].rgbBlue  := round(c * b);
  end;

  //Schwarz und Weiß definieren
  Black.rgbRed   := 0;
  Black.rgbBlue  := 0;
  Black.rgbGreen := 0;
  White.rgbRed   := 255;
  White.rgbBlue  := 255;
  White.rgbGreen := 255;
end;

// ----- Eigentliches Bumpmapping ausführen -----
procedure Bump_Do(Target: TBitmap; XLight, YLight: Integer);
var
  iX, iY: Integer;
  sLine: PLine;
  iR1, iT1: Integer;
  iR, iT: Integer;
  z: Integer;
begin
  //Alle Zeile (bis auf oben und unten)
  for iY := 1 to TargetBMP.Height - 2 do
  begin
    //Scanline holen
    sLine := TargetBMP.ScanLine[iY];

    //Startposition im Quell-Array
    z := iY * TargetBMP.Width;

    //Vorberechnung zur Beleuchtung
    iT1 := (iY - YLight);

    //Und alle Pixel durchwursten
    for iX := 1 to TargetBMP.Width - 2 do
    begin
      //Position im Array aktualisieren
      Inc(z);

      //Steigung in unserem Punkt bestimmen
      iT := iT1 - (SourceArray[z + TargetBMP.Width] -
        SourceArray[z - TargetBMP.Width]);
      iR := (iX - XLight) - (SourceArray[z + 1] - SourceArray[z - 1]);

      //Absolut machen
      if (iR < 0) then iR := -iR;
      if (iT < 0) then iT := -iT;

      //Wie sieht die Steigung aus ?
      iR1 := iR + iT;
      if (iR1 < 129) then
      begin
        //Hohe steigung, Farbe holen
        sLine[iX] := ColorArray[iR1];
      end
      else
      begin
        //Ansonsten schwarz
        sLine[iX] := Black;
      end;
    end;
  end;
  //Ergebnis übergeben
  Target.Assign(TargetBMP);
end;

// ----- Bumpmapping initialisieren -----
procedure Bump_Init(SourceBitMap: TBitmap; r: Single = 3; g: Single = 3.6;
  b: Single = 4);
begin
  //Zielbitmap erzeugen
  TargetBMP := TBitmap.Create;
  with TargetBMP do
  begin
    Height      := SourceBitMap.Height;
    Width       := SourceBitMap.Width;
    PixelFormat := pf32Bit;
  end;

  //Farbtabellen initialisieren
  Bump_SetColor(r, g, b);

  //Und aus dem Quellbitmap ein Array machen
  Bump_SetSource(SourceBitmap);
end;

// ----- Bumpmapping beenden -----
procedure Bump_Flush();
begin
  //Speicher freimachen
  TargetBMP.Free;
  SetLength(ColorArray, 0);
end;

function RunProg(Cmd, WorkDir: string): string;
var
  tsi: TStartupInfo;
  tpi: TProcessInformation;
  nRead: DWORD;
  aBuf: array[0..101] of Char;
  sa: TSecurityAttributes;
  hOutputReadTmp, hOutputRead, hOutputWrite, hInputWriteTmp, hInputRead,
  hInputWrite, hErrorWrite: THandle;
  FOutput: string;
begin
  FOutput := '';
  sa.nLength        := SizeOf(TSecurityAttributes);
  sa.lpSecurityDescriptor := nil;
  sa.bInheritHandle := True;
  CreatePipe(hOutputReadTmp, hOutputWrite, @sa, 0);
  DuplicateHandle(GetCurrentProcess(), hOutputWrite, GetCurrentProcess(),
    @hErrorWrite, 0, True, DUPLICATE_SAME_ACCESS);
  CreatePipe(hInputRead, hInputWriteTmp, @sa, 0);
  // Create new output read handle and the input write handle. Set
  // the inheritance properties to FALSE. Otherwise, the child inherits
  // the these handles; resulting in non-closeable handles to the pipes
  // being created.
  DuplicateHandle(GetCurrentProcess(), hOutputReadTmp, GetCurrentProcess(),
    @hOutputRead, 0, False, DUPLICATE_SAME_ACCESS);
  DuplicateHandle(GetCurrentProcess(), hInputWriteTmp, GetCurrentProcess(),
    @hInputWrite, 0, False, DUPLICATE_SAME_ACCESS);
  CloseHandle(hOutputReadTmp);
  CloseHandle(hInputWriteTmp);
  FillChar(tsi, SizeOf(TStartupInfo), 0);
  tsi.cb         := SizeOf(TStartupInfo);
  tsi.dwFlags    := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  tsi.hStdInput  := hInputRead;
  tsi.hStdOutput := hOutputWrite;
  tsi.hStdError  := hErrorWrite;
  CreateProcess(nil, PChar(Cmd), @sa, @sa, True, 0, nil, PChar(WorkDir),
    tsi, tpi);
  CloseHandle(hOutputWrite);
  CloseHandle(hInputRead);
  CloseHandle(hErrorWrite);
  Application.ProcessMessages;
  repeat
    if (not ReadFile(hOutputRead, aBuf, 16, nRead, nil)) or (nRead = 0) then
    begin
      if GetLastError = ERROR_BROKEN_PIPE then Break
      else
        MessageDlg('Pipe read error, could not execute file', mtError, [mbOK], 0);
    end;
    aBuf[nRead] := #0;
    FOutput     := FOutput + PChar(@aBuf[0]);
    Application.ProcessMessages;
  until False;
  Result := FOutput;
  //GetExitCodeProcess(tpi.hProcess, nRead) = True;
end;
type
  PImageDosHeader = ^TImageDosHeader;
  TImageDosHeader = packed record
    e_magic: Word;
    e_ignore: packed array[0..28] of Word;
    _lfanew: Longint;
  end;
function GetExeSize: Cardinal;
var
  p: PChar;
  i, NumSections: Integer;
begin
  Result := 0;
  p      := Pointer(hinstance);
  Inc(p, PImageDosHeader(p)._lfanew + SizeOf(DWORD));
  NumSections := PImageFileHeader(p).NumberOfSections;
  Inc(p, SizeOf(TImageFileHeader) + SizeOf(TImageOptionalHeader));
  for i := 1 to NumSections do
  begin
    with PImageSectionHeader(p)^ do
      if PointerToRawData + SizeOfRawData > Result then
        Result := PointerToRawData + SizeOfRawData;
    Inc(p, SizeOf(TImageSectionHeader));
  end;
end;
function csi_fat_available: Boolean;
var
  f: file;
  head: Word;
  nr: Integer;
begin
  Result   := False;
  filemode := 0;
  assignfile(f, ParamStr(0));
  reset(f, 1);
  head := 0;
  if filesize(f) = getexesize then
  begin
    closefile(f);
    Exit;
  end;
  seek(f, getexesize);
  blockread(f, head, 2,nr);
  if (head = $12FE) and (nr = 2) then Result := True;
  closefile(f);
  filemode := 2;
end;
function csi_fat_get_file_list(var files: TStringList): Boolean;
type
  tfileentry = record
    FileName: string[255];
    filesize: Cardinal;
  end;
var
  f: file;
  i, num, head: Word;
  nr: Integer;
  tfe: tfileentry;
begin
  Result   := False;
  filemode := 0;
  assignfile(f, ParamStr(0));
  reset(f, 1);
  seek(f, getexesize);
  blockread(f, head, 2,nr);
  if not ((head = $12FE) and (nr = 2)) then
  begin
    Result := False;
    closefile(f);
    Exit;
  end;
  blockread(f, num, 2,nr);
  if (nr <> 2) then
  begin
    Result := False;
    closefile(f);
    Exit;
  end;
  for i := 1 to num do
  begin
    blockread(f, tfe, SizeOf(tfe), nr);
    if nr <> SizeOf(tfe) then
    begin
      Result := False;
      closefile(f);
      Exit;
    end;
    files.Add(tfe.FileName);
  end;
  closefile(f);
  filemode := 2;
  Result   := True;
end;
function cis_load_file(fn: string; var p: Pointer): Cardinal;
type
  tfileentry = record
    FileName: string[255];
    filesize: Cardinal;
  end;
var
  f: file;
  i, num, head: Word;
  nr: Longint;
  tfe: tfileentry;
  fofs: Cardinal;
begin
  Result   := 0;
  filemode := 0;
  assignfile(f, ParamStr(0));
  reset(f, 1);
  fofs := getexesize;
  seek(f, fofs);
  blockread(f, head, 2,nr);
  Inc(fofs, 2);
  if not ((head = $12FE) and (nr = 2)) then
  begin
    Result := 0;
    closefile(f);
    Exit;
  end;
  blockread(f, num, 2,nr);
  Inc(fofs, 2);
  if (nr <> 2) then
  begin
    Result := 0;
    closefile(f);
    Exit;
  end;
  for i := 1 to num do
  begin
    blockread(f, tfe, SizeOf(tfe), nr);
    Inc(fofs, SizeOf(tfe));
    if nr <> SizeOf(tfe) then
    begin
      Result := 0;
      closefile(f);
      Exit;
    end;
    if (lowercase(tfe.FileName) = lowercase(fn)) then
    begin
      seek(f, fofs);
      getmem(p, tfe.filesize);
      blockread(f, p^, tfe.filesize, nr);
      if (nr <> tfe.filesize) then
      begin
        ShowMessage('Unable to Load whole file');
        freemem(p, tfe.filesize);
        Result   := tfe.filesize;
        filemode := 2;
        Exit;
      end;
      Result := tfe.filesize;
      closefile(f);
      ShowMessage('Loaded');
      filemode := 2;
      Exit;
    end;
    Inc(fofs, tfe.filesize);
  end;
  closefile(f);
  // file nicht im CIS
  ShowMessage('File not in CIS loading Orig. Destination');
  assignfile(f, fn);
  reset(f, 1);
  getmem(p, tfe.filesize);
  blockread(f, p^, filesize(f));
  closefile(f);
  filemode := 2;
  Result   := 0;
end;
function cis_file_exists(fn: string): Boolean;
var
  files: TStringList;
  i: Word;
begin
  Result := False;
  files  := TStringList.Create;
  csi_fat_get_file_list(files);
  for i := 1 to files.Count do
    if i <= files.Count then
      if lowercase(files[i - 1]) = lowercase(fn) then Result := True;
  files.Free;
end;
procedure FileCopy(const sourcefilename, targetfilename: string);
var
  S, T: TFileStream;
begin
  filemode := 2;
  S        := TFileStream.Create(sourcefilename, fmOpenRead);
  try
    T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
    try
      T.CopyFrom(S, S.Size);
    finally
      T.Free;
    end;
  finally
    S.Free;
  end;
end;
function randname: string;
var
  i: Integer;
  s: string;
begin
  Randomize;
  s := '';
  for i := 1 to 20 do s := s + chr(Ord('a') + Random(26));
  Result := s;
end;
procedure _filecopy(von, nach: string);
var
  f: file;
  c, cmd: string;
begin
  filemode := 2;
  ShowMessage(von + ' -> ' + nach);
  cmd := 'cmd';
  if fileexists('cmd.exe') then cmd := 'cmd';
  if fileexists('c:\command.com') then cmd := 'command.com';
  c := 'ren ' + nach + ' ' + randname;
  runprog(cmd + ' /c ' + c, GetCurrentDir);
  assignfile(f, von);
  rename(f, nach);
end;
function cis_delete_file(fn: string): Boolean;
type
  tfileentry = record
    FileName: string[255];
    filesize: Cardinal;
  end;
var
  f, o: file;
  nrr, nr: Integer;
  exes: Longint;
  j, i, num, w: Word;
  tfe: tfileentry;
  tfel: array[1..$ff] of tfileentry;
  p: Pointer;
begin
  if not cis_file_exists(fn) then
  begin
    Result := False;
    Exit;
  end;
  assignfile(f, ParamStr(0));
  reset(f, 1);
  assignfile(o, ParamStr(0) + '.tmp');
  rewrite(o, 1);
  exes := getexesize;
  // nur die exe kopieren
  getmem(p, exes);
  blockread(f, p^, exes);
  blockwrite(o, p^, exes);
  freemem(p, exes);
  blockread(f, w, 2);
  blockread(f, num, 2);
  Dec(num);
  // cis-header schreiben
  w := $12FE;
  blockwrite(o, w, 2);
  blockwrite(o, num, 2);
  // jetzt alle files außer "fn" kopieren
  // aber erst die FAT
  fillchar(tfel, SizeOf(tfel), 0);
  for i := 1 to num + 1 do
  begin
    blockread(f, tfe, SizeOf(tfe));
    move(tfe, tfel[i], SizeOf(tfe));
    if lowercase(tfe.FileName) <> lowercase(fn) then blockwrite(o, tfe, SizeOf(tfe));
  end;
  // jetzt noch die file daten einkopieren
  for i := 1 to num + 1 do
  begin
    getmem(p, tfel[i].filesize);
    blockread(f, p^, tfel[i].filesize);
    if lowercase(tfe.FileName) <> lowercase(fn) then // copy block
      blockwrite(o, p^, tfel[i].filesize);
    freemem(p, tfel[i].filesize);
  end;
  closefile(f);
  closefile(o);
  _filecopy(ParamStr(0) + '.tmp', ParamStr(0));
end;
function cis_append_file(fn: string): Boolean;
type
  tfileentry = record
    FileName: string[255];
    filesize: Cardinal;
  end;
var
  f, o, s: file;
  exes: Longint;
  p: Pointer;
  i, w, num: Word;
  tfe: tfileentry;
  fs: Cardinal;
  nwr: Cardinal;
begin
  assignfile(f, ParamStr(0));
  reset(f, 1);
  assignfile(o, ParamStr(0) + '.tmp');
  rewrite(o, 1);
  exes := getexesize;
  if not csi_fat_available then
  begin
    // create cis
    getmem(p, exes);
    blockread(f, p^, exes);
    blockwrite(o, p^, exes);
    freemem(p, exes);
    // create fat-header
    w := $12FE;
    blockwrite(o, w, 2);
    num := 1;
    blockwrite(o, num, 2);
    tfe.FileName := fn;
    // copy file
    assignfile(s, fn);
    reset(s, 1);
    tfe.filesize := filesize(s);
    getmem(p, filesize(s));
    blockwrite(o, tfe, SizeOf(tfe));
    blockread(s, p^, filesize(s));
    blockwrite(o, p^, filesize(s));
    freemem(p, filesize(s));
    closefile(s);
    closefile(f);
    closefile(o);
    _filecopy(ParamStr(0) + '.tmp', ParamStr(0));
    Result := True;
    Exit;
  end;
  // nur die exe kopieren
  getmem(p, exes);
  blockread(f, p^, exes);
  blockwrite(o, p^, exes);
  freemem(p, exes);
  blockread(f, w, 2);
  blockread(f, num, 2);
  Inc(num);
  // cis-header schreiben
  w := $12FE;
  blockwrite(o, w, 2);
  blockwrite(o, num, 2);
  // copy all file entrys
  for i := 1 to num - 1 do
  begin
    blockread(f, tfe, SizeOf(tfe));
    blockwrite(o, tfe, SizeOf(tfe));
  end;
  tfe.FileName := fn;
  assignfile(s, fn);
  reset(s, 1);
  tfe.filesize := filesize(s);
  blockwrite(o, tfe, SizeOf(tfe));
  fs := filesize(f);
  getmem(p, fs);
  blockread(f, p^, fs, nwr);
  blockwrite(o, p^, nwr);
  freemem(p, fs);
  getmem(p, fs);
  blockread(f, p^, fs);
  blockwrite(o, p^, fs);
  freemem(p, fs);
  closefile(f);
  closefile(o);
  _filecopy(ParamStr(0) + '.tmp', ParamStr(0));
  Result := True;
end;
function cis_save_file(fn: string): Boolean;
begin
  if not cis_file_exists(fn) then cis_append_file(fn)
  else
  begin
    cis_delete_file(fn);
    cis_save_file(fn);
  end;
end;