DZone Snippets: pascal code

Thread Process //Pascal class

jonasraoni (Jonas Raoni Soares Silva) — Mon, 07 Jul 2008 07:25:12 GMT

A thread class to open processes on windows and retrieve its output (input isn't supported but it's easy to add).



unit Process;



interface



uses

  SysUtils, Windows, Classes, TLHelp32;



const

  INITIALIZATION_TIMEOUT = 10000;



type

  TStringArray = array of string;

  TProcessArray = array of Cardinal;

  TExceptionEvent = procedure(Sender: TObject; Exception: Exception) of object;

  EProcessError = class(Exception);



  TProcessThread = class(TThread)

  private

    FException: Exception;

    FWatching, FStarted, FSuspended: Boolean;

    FDirectory, FPath, FCommandLine, FEnvironment: PChar;

    FData: string;

    FOnProcessTerminated, FOnDataAvailable: TNotifyEvent;

    InputRead, InputWrite, OutputRead, OutputWrite: THandle;

    FMainProcess: PROCESS_INFORMATION;

    FOnException: TExceptionEvent;

    FOnProcessStarted: TNotifyEvent;

    function GetPriority: TThreadPriority;

    procedure SetPriority(const Value: TThreadPriority);

    procedure FreeResources;

  protected

    procedure CallDataAvailable; virtual;

    procedure CallProcessTerminated; virtual;

    procedure CallProcessOpened; virtual;

    procedure CallException; virtual;

    procedure Execute; override;

  public

    constructor Create(Path, CommandLine, Directory: string; Environment: TStrings = nil; Watch: Boolean = True);

    destructor Destroy; override;



    function IsProcessAlive: Boolean;

    procedure Resume;

    procedure Suspend;

    property OnDataAvailable: TNotifyEvent read FOnDataAvailable write FOnDataAvailable;

    property OnProcessTerminated: TNotifyEvent read FOnProcessTerminated write FOnProcessTerminated;

    property OnProcessStarted: TNotifyEvent read FOnProcessStarted write FOnProcessStarted;

    property OnException: TExceptionEvent read FOnException write FOnException;

    property Data: string read FData;

    property Process: PROCESS_INFORMATION read FMainProcess;

    property Priority: TThreadPriority read GetPriority write SetPriority;



  end;



  TProcessLineThread = class;

  TOnNewLineEvent = procedure(ProcessLine:  TProcessLineThread; const Line: string) of object;

  TProcessLineThread = class(TProcessThread)

  private

    FCurrentLine: string;

    FOnNewLine: TOnNewLineEvent;

    procedure DataAvailable(Sender: TObject);

    procedure Finished(Sender: TObject);

  public

    constructor Create(Path, CommandLine, Directory: string; Environment: TStrings = nil);

    property OnNewLine: TOnNewLineEvent read FOnNewLine write FOnNewLine;

  end;



function KillProcess(const Process: Cardinal): Boolean;

function GetChildrenProcesses(const Process: Cardinal; const IncludeParent: Boolean = True): TProcessArray;



implementation



const

  Priorities: array [TThreadPriority] of Integer =

   (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,

    THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,

    THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);



function GetChildrenProcesses(const Process: Cardinal; const IncludeParent: Boolean): TProcessArray;

var

  Snapshot: Cardinal;

  ProcessList: PROCESSENTRY32;

  Current: Integer;

begin

  Current := 0;

  SetLength(Result, 1);

  Result[0] := Process;

  repeat

    ProcessList.dwSize := SizeOf(PROCESSENTRY32);

    Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

    if (Snapshot = INVALID_HANDLE_VALUE) or not Process32First(Snapshot, ProcessList) then

      Continue;

    repeat

      if ProcessList.th32ParentProcessID = Result[Current] then

      begin

        SetLength(Result, Length(Result) + 1);

        Result[Length(Result) - 1] := ProcessList.th32ProcessID;

      end;

    until Process32Next(Snapshot, ProcessList) = False;

    Inc(Current);

  until Current >= Length(Result);

  if not IncludeParent then

    Result := Copy(Result, 2, Length(Result));

end;



function KillProcess(const Process: Cardinal): Boolean;

var

  Handle: Cardinal;

  List: TProcessArray;

  I: Integer;

begin

  Result := True;

  List := GetChildrenProcesses(Process);

  for I := Length(List) - 1 downto 0 do

    if Result then

    begin

      Handle := OpenProcess(PROCESS_TERMINATE, false, List[I]);

      Result := (Handle <> 0) and TerminateProcess(Handle, 0) and CloseHandle(Handle);

    end;

end;



{ TProcessThread }



procedure TProcessThread.CallDataAvailable;

begin

  if Assigned(FOnDataAvailable) then

    FOnDataAvailable(Self);

end;



procedure TProcessThread.Resume;

var

  SuspendCount: Integer;

begin

  if FStarted then

  begin

    FStarted := True;

    SuspendCount := ResumeThread(FMainProcess.hThread);

    CheckThreadError(SuspendCount >= 0);

    if SuspendCount = 1 then

      FSuspended := False;

  end;

  inherited Resume;

end;



function TProcessThread.GetPriority: TThreadPriority;

begin

  if FStarted then

  begin

    CheckThreadError(GetThreadPriority(FMainProcess.hThread) <> THREAD_PRIORITY_ERROR_RETURN);

  end;

  Result := inherited Priority;

end;



function TProcessThread.IsProcessAlive: Boolean;

var

  Status: Cardinal;

begin

  GetExitCodeProcess(FMainProcess.hProcess, Status);

  Result := Status = STILL_ACTIVE;

end;



procedure TProcessThread.SetPriority(const Value: TThreadPriority);

begin

  if FStarted then

    CheckThreadError(SetThreadPriority(FMainProcess.hThread, Priorities[Value]));

  inherited Priority := Value;

end;



procedure TProcessThread.Suspend;

var

  OldSuspend: Boolean;

begin

  if FStarted then

  begin

    OldSuspend := FSuspended;

    try

      FSuspended := True;

      CheckThreadError(Integer(SuspendThread(FMainProcess.hThread)) >= 0);

    except

      FSuspended := OldSuspend;

      raise;

    end;

  end;

  inherited Suspend;

end;





procedure TProcessThread.CallException;

begin

  if Assigned(FOnException) then

    FOnException(Self, FException);

end;



procedure TProcessThread.CallProcessOpened;

begin

  if Assigned(FOnProcessStarted) then

    FOnProcessStarted(Self);

end;



procedure TProcessThread.CallProcessTerminated;

begin

  if Assigned(FOnProcessTerminated) then

    FOnProcessTerminated(Self);

end;



constructor TProcessThread.Create(Path, CommandLine, Directory: string; Environment: TStrings; Watch: Boolean);

var

  Len, I: Integer;

begin

  inherited Create(True);



  if (Length(CommandLine) > 0) and (Length(Path) > 0) then

    CommandLine := ' ' + CommandLine;



  if Length(Path) > 0 then

  begin

    GetMem(FPath, Length(Path) + 1);

    StrCopy(FPath, PChar(Path));

  end;

  if Length(CommandLine) > 0 then

  begin

    GetMem(FCommandLine, Length(CommandLine) + 1);

    StrCopy(FCommandLine, PChar(CommandLine));

  end;



  if Length(Directory) > 0 then

  begin

    GetMem(FDirectory, Length(Directory) + 1);

    StrCopy(FDirectory, PChar(Directory));

  end;



  FWatching := Watch;



  if Assigned(Environment) then

  begin

    GetMem(FEnvironment, 1);

    Len := 1;

    for I := 0 to Environment.Count - 1 do

    begin

      Inc(Len, Length(Environment[I]) + 1);

      ReallocMem(FEnvironment, Len);

      SetEnvironmentVariable(PChar(Environment.Names[I]), PChar(Environment.ValueFromIndex[I]));

      StrCopy(FEnvironment + Len - Length(Environment[I]) - 2, PChar(Environment[I]));

    end;

    (FEnvironment + Len - 1)^ := #0;

    FreeMem(FEnvironment);

    FEnvironment := nil;

  end;

end;



destructor TProcessThread.Destroy;

begin

  FreeMem(FPath);

  FreeMem(FCommandLine);

  FreeMem(FDirectory);

  FreeResources;

  if Assigned(FEnvironment) then

    FreeMem(FEnvironment);

  inherited;

end;



procedure TProcessThread.Execute;

const

  MAX_BUFFER = 512 * 1024;

var

  MaxBytes, Available, BytesRead: Cardinal;

  Buffer: array[0..MAX_BUFFER] of Char;



  function Read: Boolean;

  begin

    Result := True;

    FillChar(Buffer, MAX_BUFFER, #0);

    PeekNamedPipe(OutputRead, @Buffer, MAX_BUFFER, @BytesRead, @Available, nil);



    if BytesRead < MAX_BUFFER then

    begin

      MaxBytes := BytesRead;

    end

    else

      MaxBytes := MAX_BUFFER;



    if MaxBytes > 0 then

      if ReadFile(OutputRead, Buffer, MaxBytes, BytesRead, nil) then

      begin

        if BytesRead > 0 then

        begin

          FData := StrPas(Buffer);

          Synchronize(CallDataAvailable);

        end;

      end

      else

        Result := False;

  end;



var

  Startup: STARTUPINFO;

  SecurityDescriptor: SECURITY_DESCRIPTOR;

  SecurityAttributes: SECURITY_ATTRIBUTES;

begin

  try

    ZeroMemory(@Startup, SizeOf(STARTUPINFO));

    Startup.cb := SizeOf(STARTUPINFO);

    ZeroMemory(@SecurityDescriptor, SizeOf(SECURITY_DESCRIPTOR));

    ZeroMemory(@SecurityAttributes, SizeOf(SECURITY_ATTRIBUTES));

    InputRead := 0;

    InputWrite := 0;

    OutputRead := 0;

    OutputWrite := 0;



    if Win32Platform = VER_PLATFORM_WIN32_NT then

    begin

      InitializeSecurityDescriptor(@SecurityDescriptor, SECURITY_DESCRIPTOR_REVISION);

      SetSecurityDescriptorDacl(@SecurityDescriptor, True, nil, False);

      SecurityAttributes.lpSecurityDescriptor := @SecurityDescriptor;

    end

    else

      SecurityAttributes.lpSecurityDescriptor := nil;

    SecurityAttributes.nLength := SizeOf(SECURITY_ATTRIBUTES);

    SecurityAttributes.bInheritHandle := True;

    if not CreatePipe(OutputRead, OutputWrite, @SecurityAttributes, 0)

    or not CreatePipe(InputRead, InputWrite, @SecurityAttributes, 0) then

      raise EProcessError.Create('Error while opening pipes');



    SetHandleInformation(OutputRead, HANDLE_FLAG_INHERIT, 0);

    SetHandleInformation(InputWrite, HANDLE_FLAG_INHERIT, 0);



    GetStartupInfo(Startup);

    Startup.dwFlags := STARTF_USESHOWWINDOW OR STARTF_USESTDHANDLES;



    Startup.hStdOutput := OutputWrite;

    Startup.hStdError := OutputWrite;

    Startup.hStdInput := InputRead;



    FlushFileBuffers(OutputWrite);

    FlushFileBuffers(OutputRead);

    FlushFileBuffers(InputRead);

    FlushFileBuffers(InputWrite);



    Startup.wShowWindow := SW_HIDE;



    if not CreateProcess(FPath, FCommandLine, nil, nil, True, CREATE_NEW_CONSOLE OR NORMAL_PRIORITY_CLASS, FEnvironment, FDirectory, Startup, FMainProcess) then

      raise EProcessError.Create('Error while starting Process: ' + SysErrorMessage(GetLastError) + ':' + FPath + ':' + FCommandLine + ':' + FDirectory);

    WaitForInputIdle(FMainProcess.hProcess, INITIALIZATION_TIMEOUT);

    FStarted := True;

    SetPriority(GetPriority);

    Synchronize(CallProcessOpened);

    

    if not FWatching then

      Exit;



    repeat

      if not Read then

        Break;

    until not IsProcessAlive or Terminated;

    Read;



    if not IsProcessAlive then

      Synchronize(CallProcessTerminated);

      

  except

    on E: Exception do

    begin

      FException := E;

      Synchronize(CallException);

    end;

  end;

end;



procedure TProcessThread.FreeResources;

begin

  KillProcess(FMainProcess.dwProcessId);



  if OutputRead <> 0 then

  begin

    CloseHandle(OutputRead);

    OutputRead := 0;

  end;

  if OutputWrite <> 0 then

  begin

    CloseHandle(OutputWrite);

    OutputWrite := 0;

  end;

  if InputWrite <> 0 then

  begin

    CloseHandle(InputWrite);

    InputWrite := 0;

  end;

  if InputRead <> 0 then

  begin

    CloseHandle(InputRead);

    InputRead := 0;

  end;

end;



{  TProcessLineThread }



constructor  TProcessLineThread.Create(Path, CommandLine, Directory: string; Environment: TStrings);

begin

  inherited Create(Path, CommandLine, Directory, Environment);

  OnDataAvailable := DataAvailable;

  OnTerminate := Finished;

end;



procedure  TProcessLineThread.DataAvailable(Sender: TObject);

var

  I, L: Integer;

begin

  I := 0;

  L := Length(Data);

  while I < L do

  begin

    Inc(I);

    if Data[I] in [#13, #10] then

    begin

      if (I < L) and (Data[I+1] in [#13, #10]) then

        Inc(I);

      if Assigned(FOnNewLine) then

        FOnNewLine(Self, FCurrentLine);

      FCurrentLine := '';

    end

    else

      FCurrentLine := FCurrentLine + Data[I];

  end;

end;



procedure  TProcessLineThread.Finished(Sender: TObject);

begin

  if (FCurrentLine <> '') and Assigned(FOnNewLine) then

    FOnNewLine(Self, FCurrentLine);

end;



end.

Pascal's triangle in Ruby

ntk () — Fri, 26 Oct 2007 17:02:28 GMT





# cf. http://www.ruby-forum.com/topic/97105



6.times { k=0; p $*.map!{|i|k+k=i} << 1 }



# ... or ...



ar=[]; 6.times { k=0; p ar.map!{|i|k+k=i} << 1 }





# a more general approach (for polynomials)



class Polynomial



   def triangle(nterms, row, pos=nil)



      return nil if nterms < 2 || row < 1

      nterms = nterms - 2

      num_of_rows = row



      var1 = 0 + nterms   

      var2 = 1 + nterms

      var3 = 3 + nterms 

  

      ar1 = [0, 1, 0]   # first row

      var1.times { ar1.push(0) }

      var1.times { ar1.unshift(0) }



      ar2 = []

      ar3 = []

      ar4 = [[1]]



      for num in 0..(num_of_rows - 1)  



         nextnum = ar1.size - var2



         for nextn in 1..nextnum

            sum = 0

            count = 0

            ar1.each do |n|  

               count += 1 

               if count < var3 then t = sum += n; ar2 << t else break end 

            end



            ar3 << ar2.last

            ar2.clear

            ar1.shift



         end   # second for-loop



         ar1.clear

         ar1 << ar3

         ar1.flatten!



         var2.times { ar1.push(0) }

         var2.times { ar1.unshift(0) }



         ar4 << ar3

         ar3 = []



      end  # first for-loop



      if !pos.nil?

         ret = ar4.at(row).at(pos)

         return "No such position: #{pos} in row: #{row}" if ret.nil?

         ret

      else

         ar4.map! { |r| r.join('-') }

         ar4

      end

   end 

end 





puts Polynomial.new.triangle(2, 5)

puts Polynomial.new.triangle(3, 5)

puts Polynomial.new.triangle(4, 5)

puts Polynomial.new.triangle(5, 5)

puts Polynomial.new.triangle(5, 4, 8)

puts Polynomial.new.triangle(4, 9)

puts Polynomial.new.triangle(4, 9, 10)





#------------------------





class Integer

   def fak

      f=1

      (2..self).each { |i| f *= i   }

      f

   end

end



module Enumerable

   def sum

      inject { |n, m| n + m  }

   end

end



# cf. http://blade.nagaokaut.ac.jp/~sinara/ruby/math/combinatorics/array-rep_perm.rb

class Array

  def rep_perm(n)

    if n < 0

    elsif n == 0

      yield([])

    else

      rep_perm(n - 1) do |x|

	each do |y|

	  yield(x + [y])

	end

      end

    end

  end

end





nterms = 2

exponent = 80

exponent = 8



# create the same number of variable names as there are terms 

# example: ['a', 'b'] for (a+b)**3



var_names = ('a'..'z').to_a.slice(0, nterms)

#var_names = (('a'..'z').to_a << ('A'..'Z').to_a << ('aa'..'zz').to_a).flatten!.slice(0, nterms)



ar1 = []

(0..exponent).to_a.rep_perm(nterms) { |x| p x; ar1 << x if x.sum == exponent }   # example: ... if [2,6].sum == 8

ar1.reverse!



#p ar1

#puts ar1



ar2 = []



ar1.each do |term|



   #puts "term: #{term.inspect}"  # example: term: [5, 0, 0]

   count = 0

   var1 = 1

   term.each { |i| var1 *= i.fak }

   var2 = exponent.fak / var1 

   var3 = "#{var2}   (  #{ term.join('-') << '-' } )"  # prepare term for parsing with gsub below

   ar2 << var3



end



#p ar2



result = ar2.collect do |term|

   p term

   count = -1

   term.gsub!(/(\d+)-/)  { count += 1;  "#{var_names.at(count)}" << '**' << $1 << ' ' }

   term.gsub!(/^(\d+)( +)/, '\1\2*\2')

end



puts result

Single linked list unit

darktemplar (Piotr) — Sun, 07 Jan 2007 17:58:21 GMT

This code is a simple pascal library to handle single-linked-lists

function llsGetItem(id: cardinal; var start: pointer): pointer;

Returns an item of specified ID, it remains in list

function llsTakeOutItem(id: cardinal; var start: pointer): pointer;

Returns an item of specified ID, it is removed from list

procedure llsInsertItem(item: pointer; var start: pointer);

Inserts an item to list(item is a valid header)

function llsGetItemCount(start: pointer): cardinal;

Gets number of items

function llsNewSLLHeader: PSLLItem;

Allocates list item header

procedure llsKillSLLHeader(hdr: pointer);

Deallocated list item header



unit SLLMan;

interface

type

  PSLLItem = ^TSLLItem;

  TSLLItem = record

    Next: pointer;

    Data: pointer;

   end;



function llsGetItem(id: cardinal; var start: pointer): pointer;

function llsTakeOutItem(id: cardinal; var start: pointer): pointer;

procedure llsInsertItem(item: pointer; var start: pointer);

function llsGetItemCount(start: pointer): cardinal;

function llsNewSLLHeader: PSLLItem;

procedure llsKillSLLHeader(hdr: pointer);

       // These ids are numbered from 0

implementation

function malloc(size: cardinal): pointer;

begin

  GetMem(result,size);

end;

function llsGetItemCount(start: pointer): cardinal;

var

  cur: PSLLItem;

  tmp: cardinal;

begin

  if start = nil then begin llsGetItemCount := 0; Exit; end;

  tmp := 1;  cur := start;

  while (cur^.Next <> nil) do

  begin

    Inc(tmp);

    cur := cur^.Next;

  end;

  llsGetItemCount := tmp;

end;

procedure llsKillSLLHeader(hdr: pointer);

begin

  if hdr = nil then Exit;

  Free(hdr);

end;

function llsNewSLLHeader: PSLLItem;

var

  tmp: PSLLItem;

begin

  tmp := malloc(sizeof(TSLLItem));

  tmp^.Next := nil;

  tmp^.Data := nil;

  llsNewSLLHeader := tmp;

end;

function llsGetItem(id: cardinal; var start: pointer): pointer;

var

  cur: PSLLItem;

begin

  if start = nil then begin llsGetItem := nil; Exit; end;

  cur := start;

  while (id<>0) do

  begin

    if cur^.Next <> nil then

        begin

          Dec(id);

          cur := cur^.Next;

        end else

        begin

          llsGetItem := nil;

          Exit;

        end;

  end;

  llsGetItem := cur;

end;



function llsTakeOutItem(id: cardinal; var start: pointer): pointer;

var

  tmp: PSLLItem;

  last: PSLLItem;

begin

  if start = nil then begin llsTakeOutItem := nil; Exit; end;

  if (id = 0) then

    begin

      tmp := start;

      if tmp^.Next = nil then start := nil else start := tmp^.Next;

      llsTakeOutItem := tmp;

      Exit;

    end;

  tmp := start;

  repeat

    dec(id);

    last := tmp;

    tmp := tmp^.Next;

  until (id = 0);

  last^.Next := tmp^.Next;

  llsTakeOutitem := tmp;

end;

procedure llsInsertItem(item: pointer; var start: pointer);

var

  cur: PSLLItem;

begin

 if start = nil then

  begin

    start := item;

    exit;

  end;

 cur := start;

 while (cur^.Next<>nil) do cur := cur^.Next;

 cur^.Next := item;

end;



end.

Wave Plotter //Pascal Class

jonasraoni (Jonas Raoni Soares Silva) — Thu, 15 Jun 2006 19:28:29 GMT

A wave plotter component that is able to draw sin, poly and squared lines, I used this in a osciloscope xD

I didn't liked this code, but the draw part (TWaveShape.paint) is looking cool, I used the same "X" coord to draw the 3 kinds of lines :)

I mean:

loop(x){
case waveType of
wtSin: y := lala;
wtPoly: y := lele;
wtSqr: y := lili;
end;
}



unit WavePlotter;



interface



uses

  forms, dialogs, SysUtils, Classes, Controls, Graphics;



const

  PI2 = PI * 2;



type

  TWaveType = ( wtSqr, wtPoly, wtSin );



  TWave = class( TPersistent )

  public

    waveType: TWaveType;

    color: TColor;

    offset: integer;

    frequency, amplitude, volts, interval, gain: extended;



    procedure AssignTo(Dest: TPersistent); override;

  end;



  TWaveShape = class( TGraphicControl )

  protected

    fWaves: TList;

    fBoxSize: integer;

    fLineColor: TColor;



    function getWave(const index: integer): TWave;

    procedure setBoxSize(const Value: integer);



    function getBackgroundColor: TColor;

    procedure setBackgroundColor(const Value: TColor);

    procedure setLineColor(const Value: TColor);



  public

    constructor create( AOwner: TComponent ); override;

    destructor destroy; override;



    procedure clear;

    procedure delete( const index: integer );



    function add: integer;



    property waves[ const index: integer]: TWave read GetWave;



  published

    procedure paint; override;

    property boxSize: integer read fBoxSize write setBoxSize;

    property backgroundColor: TColor read getBackgroundColor write setBackgroundColor;

    property lineColor: TColor read fLineColor write setLineColor;



    //inherited

    //property Canvas;

    property Align;

    property Anchors;

    property Constraints;

    property DragCursor;

    property DragKind;

    property DragMode;

    property Enabled;

    //property Font;

    property ParentColor;

    //property ParentFont;

    property ParentShowHint;

    property PopupMenu;

    property ShowHint;

    property Visible;

    property OnClick;

    property OnContextPopup;

    property OnDblClick;

    property OnDragDrop;

    property OnDragOver;

    property OnEndDock;

    property OnEndDrag;

    property OnMouseDown;

    property OnMouseMove;

    property OnMouseUp;

    property OnStartDock;

    property OnStartDrag;

  end;



implementation



function max( const a, b: integer ): integer;

begin

  if a > b then

    result := a

  else

    result := b;

end;



{ TWaveShape }



function TWaveShape.add: integer;

begin

  result := fWaves.add( TWave.Create );

end;



procedure TWaveShape.clear;

begin

  while fWaves.count > 0 do begin

    TWave( fWaves[0] ).free;

    fWaves.delete( 0 );

  end;

end;



constructor TWaveShape.create(AOwner: TComponent);

begin

  inherited;

  fWaves := TList.create;

  fLineColor := clGray;

  color := clBtnFace;

  fBoxSize := 50;

end;



procedure TWaveShape.delete(const index: integer);

begin

  if ( index > -1 ) and ( index < fWaves.count ) then begin

    TWave( fWaves[index] ).free;

    fWaves.delete( index );

  end;

end;



destructor TWaveShape.destroy;

begin

  fWaves.free;

  inherited;

end;



function TWaveShape.getBackgroundColor: TColor;

begin

  result := color;

end;



function TWaveShape.getWave(const index: integer): TWave;

begin

  result := nil;

  if ( index > -1 ) and ( index < fWaves.count ) then

    result := TWave( fWaves[ index ] );

end;



procedure TWaveShape.paint;

var

  k, x: integer;

  lastX, lastY: array of integer;

  y: extended;

begin

  if not enabled then

    exit;

  canvas.brush.color := color;

  canvas.fillRect( clientRect );



  setLength( lastY, fWaves.count );

  setLength( lastX, fWaves.count );

  for k := 0 to high( lastY ) do begin

    lastY[k] := clientHeight div 2 + waves[k].offset;

    lastX[k] := 0;

  end;



  for x := 0 to max( clientWidth, clientHeight ) do begin

    with canvas do begin

      pen.color := fLineColor;

      pen.width := 1;

      pen.style := psDot;



      if x mod fBoxSize = 0 then begin

        moveTo( 0, x + trunc( frac( clientHeight / 2 / fBoxSize ) * fBoxSize ) );

        lineTo( clientWidth, x + trunc( frac( clientHeight / 2 / fBoxSize ) * fBoxSize ) );



        moveTo( x, 0 );

        lineTo( x, clientHeight );

      end;



      for k := 0 to fWaves.count - 1 do begin

        with waves[k] do begin

          pen.color := color;

          pen.width := 1;

          pen.style := psSolid;



          y := pi*k + PI2 * x * interval / fBoxSize * frequency;



          case waveType of

            wtSin:

              y := sin( y );

            wtPoly: begin

              y := frac( y / PI2 );

              if y <= 0.25 then

                y := y / 0.25

              else if y <= 0.75 then

                y := ( -y + 0.5 ) / 0.25

              else

                y := ( y - 1 ) / 0.25;

            end;

            wtSqr: begin

              if frac( y / PI2 ) <= 0.5 then

                y := 1

              else

                y := -1;

            end;

          end;

          y := ( y * ( fBoxSize / volts ) * amplitude * gain ) + clientHeight / 2 + offset;

          moveTo( lastX[k], lastY[k] );

          lastX[k] := x;

          lastY[k] := trunc( y );

          lineTo( x, lastY[k] );

        end;

      end;

    end;

  end;

end;



procedure TWaveShape.setBackgroundColor(const Value: TColor);

begin

  color := Value;

  Invalidate;

end;



procedure TWaveShape.setBoxSize(const Value: integer);

begin

  fBoxSize := Value;

  invalidate;

end;





procedure TWaveShape.setLineColor(const Value: TColor);

begin

  fLineColor := Value;

  Invalidate;

end;



{ TWave }



procedure TWave.AssignTo(Dest: TPersistent);

begin

  if Dest.ClassType <> TWave then

    inherited;

  with TWave( Dest ) do begin

    waveType := self.waveType;

    color := self.color;

    offset := self.offset;

    frequency := self.frequency;

    amplitude := self.amplitude;

    volts := self.volts;

    interval := self.interval;

    gain := self.gain;

  end;

end;



end.

Simple Stack //Pascal Class

jonasraoni (Jonas Raoni Soares Silva) — Thu, 15 Jun 2006 19:15:30 GMT

A simple pointer stack...



unit Stack;



interface



uses

  SysUtils, Classes;



type

  TStack = class

  private

    FList: PPointerList;

    FCapacity, FCount: Cardinal;

    procedure Grow;

  public

    destructor Destroy; override;

    procedure Push( const Data: Pointer );

    function Pop: Pointer;

  end;



implementation



{ TStack }



destructor TStack.Destroy;

begin

  FreeMem( FList );

  inherited;

end;



procedure TStack.Grow;

begin

  if FCapacity > 64 then

    Inc( FCapacity, FCapacity div 4 )

  else

    if FCapacity > 8 then

      Inc( FCapacity, 16 )

    else

      Inc( FCapacity, 4 );

  ReallocMem( FList, FCapacity * SizeOf( Pointer ) );

end;



function TStack.Pop: Pointer;

begin

  if FCount > 0 then

  begin

    Dec( FCount );

    Result := FList^[FCount];

  end

  else

    Result := nil;

end;



procedure TStack.Push(const Data: Pointer);

begin

  if FCapacity = FCount then

    Grow;

  FList^[FCount] := Data;

  Inc( FCount );

end;



end.

Files Joiner/Unjoiner //Pascal class

jonasraoni (Jonas Raoni Soares Silva) — Thu, 15 Jun 2006 19:09:02 GMT

This is just a snippet since I didn't added some units that can be replaced without major efforts:
- PathParser.pas: parses paths shortcuts (it's on my bigbold snippets, search on my tags)
- Stack.pas: implements a simple stack (it's on my bigbold snippets, search on my tags)
- ZlibEx.pas: used to compress/decompress the file contents (My ZlibEx is a modified version of this file: http://www.dellapasqua.com/delphizlib)
- MD5.pas: used to calculate the file hash and check consistency when unjoining files
- SysUtils2: Some idiot functions =b

I used this in a personalized installer that I've made in my first job =b



unit FileJoiner;



interface



uses

  SysUtils, SysUtils2, Classes, MD5, ZlibEx, PathParser, Stack;



type

  TOverwriteMode = ( omNo, omAskUser, omIfNewer, omIfOlder, omIfDiff );

  TOverwriteAction = ( oaOverwriteAll, oaNoOverwriteAll, oaYes, oaNo );



  TFileHeader = record

    MD5Hash: TDigestStr;

    ModificationDate: TDateTime;

    Attributes: LongWord;

    Overwrite: TOverwriteMode;

    Size: Int64;

    MustKeep: Boolean;

  end;



  TFileJoinerItem = class

  public

    Source, Destiny: string;

    MustKeep, Recurse: Boolean;

    Overwrite: TOverwriteMode;



    constructor Create( const FromPath, ToPath: string; const OverwriteMode: TOverwriteMode = omIfNewer; const Recursive: Boolean = True; const MustKeepFile: Boolean = False ); overload;

    function Assign( Item: TFileJoinerItem ): TFileJoinerItem;



    procedure Save( const Stream: TStream );

    procedure Load( const Stream: TStream );

  end;



  TCustomFileJoiner = class;



  TFileJoinerFilesCallback = procedure( Sender: TCustomFileJoiner; Item: TFileJoinerItem ) of object;

  TFileJoinerNotifyEvent = procedure( Sender: TCustomFileJoiner ) of object;

  TFileJoinerFileExists = procedure( Sender: TCustomFileJoiner; var CanOverwrite: TOverwriteAction ) of object;



  TJoinerStatus = ( jsIdle, jsJoining, jsUnjoining );



  TCustomFileJoiner = class

  private

    FStream: TStream;

    FCurFile, FTotalFiles: LongWord;

    FCurSize, FTotalSize, FCurPosition, FCurWrittenBytes: Int64;

    FCurFilename: string;

    FCurFileInfo: TFileHeader;

    FOnFileExists: TFileJoinerFileExists;

    FOnWorkEnd, FOnWorkBegin, FOnWork, FOnProcessFile: TFileJoinerNotifyEvent;



    procedure ProgressNotifier( Sender: TObject );



  public

    //properties

    property CurFilename: string read FCurFilename;

    property CurFileInfo: TFileHeader read FCurFileInfo;

    property CurFilePosition: Int64 read FCurPosition;

    property CurWrittenBytes: Int64 read FCurWrittenBytes;

    property CurSize: Int64 read FCurSize;

    property CurFile: LongWord read FCurFile;



    property TotalSize: Int64 read FTotalSize;

    property TotalFiles: LongWord read FTotalFiles;



    //events

    property OnWorkBegin: TFileJoinerNotifyEvent read FOnWorkBegin write FOnWorkBegin;

    property OnWork: TFileJoinerNotifyEvent read FOnWork write FOnWork;

    property OnWorkEnd: TFileJoinerNotifyEvent read FOnWorkEnd write FOnWorkEnd;

    property OnProcessFile: TFileJoinerNotifyEvent read FOnProcessFile write FOnProcessFile;

    property OnFileExists: TFileJoinerFileExists read FOnFileExists write FOnFileExists;

  end;



  TFileJoiner = class( TCustomFileJoiner )

  private

    FPaths: TList;



    function GetItem(const Index: Integer): TFileJoinerItem;

    function GetCount: Integer;

    procedure StreamFile( Sender: TCustomFileJoiner; Item: TFileJoinerItem );

    procedure Compress( Input: TStream );



  public

    constructor Create;

    destructor Destroy; override;



    procedure Join( const Filename: string ); overload;

    procedure Join( const Stream: TStream ); overload;



    procedure SaveList( const Filename: string ); overload;

    procedure SaveList( Stream: TStream ); overload;

    procedure LoadList( const Filename: string ); overload;

    procedure LoadList( Stream: TStream ); overload;



    procedure CountFiles;



    function Add( const FromPath, ToPath: string; const OverwriteMode: TOverwriteMode = omIfNewer; const Recursive: Boolean = False; const MustKeep: Boolean = False ): Integer;

    procedure Clear;

    procedure Remove( const Index: Integer );

    procedure ListFiles( const Callback: TFileJoinerFilesCallback );



    property Count: Integer read GetCount;

    property Items[ const Index: Integer ]: TFileJoinerItem read GetItem; default;

  end;



  TFileUnjoiner = class( TCustomFileJoiner )

  private

    FDataBegin: Int64;

    procedure Decompress( Output: TStream );



  public

    procedure Assign( const Filename: string ); overload;

    procedure Assign( Stream: TStream ); overload;

    procedure UnJoin;

  end;



implementation



{ TCustomFileJoiner }



procedure TCustomFileJoiner.ProgressNotifier(Sender: TObject);

begin

  if Assigned( FOnWork ) then

    with TStream( Sender ) do

    begin

      FCurWrittenBytes := Position - FCurPosition;

      FCurPosition := Position;

      FOnWork( Self );

    end;

end;



{ TFileJoiner }



procedure TFileJoiner.Join( const Filename: string );

begin

  FStream := TFileStream.Create( Filename, fmCreate );

  try

    Join( FStream );

  finally

    FStream.Free;

  end;

end;



procedure TFileJoiner.Join( const Stream: TStream );

var

  Pos: array[0..1] of Int64;

begin

  FStream := Stream;

  if Assigned( FOnWorkBegin ) then

    FOnWorkBegin( Self );



  FCurFile := 0;

  FCurSize := 0;



  //record position to get back later and reserve space on the file to record the "totals"

  Pos[0] := FStream.Position;

  FStream.Seek( SizeOf( FCurFile ) + SizeOf( FCurSize ), soCurrent );



  //write files

  ListFiles( StreamFile );



  //write the totals and get back

  Pos[1] := Stream.Position;

  FStream.Position := Pos[0];

  FStream.Write( FCurFile, SizeOf( FCurFile ) );

  FStream.Write( FCurSize, SizeOf( FCurSize ) );

  FStream.Position := Pos[1];



  //job done

  if Assigned( FOnWorkEnd ) then

    FOnWorkEnd( Self );

end;



procedure TFileJoiner.StreamFile( Sender: TCustomFileJoiner; Item: TFileJoinerItem );

var

  InputFile: TFileStream;

  Pos: array[0..1] of Int64;

begin

  try

    Inc( FCurFile );

    FCurPosition := 0;

    FCurFilename := Item.Source;



    FCurFileInfo.MD5Hash := FileMD5Digest( Item.Source );

    FCurFileInfo.ModificationDate := FileDateToDateTime( FileAge( Item.Source ) );

    FCurFileInfo.Attributes := FileGetAttr( Item.Source );

    FCurFileInfo.Overwrite := Item.Overwrite;



    InputFile := TFileStream.Create( Item.Source, fmOpenRead or fmShareDenyWrite );

    try

      FCurFileInfo.Size := InputFile.Size;

      if Assigned( FOnProcessFile ) then

        FOnProcessFile( Self );



      Pos[0] := FStream.Position;

      //reserve space for the file header and EOF position

      FStream.Seek( SizeOf( FCurFileInfo ) + SizeOf( Pos[0] ), soCurrent );

      StringWrite( FStream, Item.Destiny );



      Compress( InputFile );



      //update the header and get back

      Pos[1] := FStream.Position;

      FStream.Position := Pos[0];

      FStream.Write( FCurFileInfo, SizeOf( FCurFileInfo ) );

      FStream.Write( Pos[1], SizeOf( Pos[1] ) );

      FStream.Position := Pos[1];



      //update summary

      Inc( FCurSize, FCurFileInfo.Size );

    finally

      InputFile.Free;

    end;

  except

    on E: Exception do

      raise EWriteError.CreateFmt( '%s.StreamFile: Error on joining: "%s" - %s',  [ ClassName, FCurFilename, E.Message ] );

  end;

end;



function TFileJoiner.Add(const FromPath, ToPath: string;

  const OverwriteMode: TOverwriteMode; const Recursive: Boolean; const MustKeep: Boolean ): Integer;

begin

  Result := FPaths.Add( TFileJoinerItem.Create( FromPath, ToPath, OverwriteMode, Recursive, MustKeep ) );

end;



procedure TFileJoiner.Clear;

var

  I: Integer;

begin

  for I := FPaths.Count - 1 downto 0 do

  begin

    TFileJoinerItem( FPaths[I] ).Free;

    FPaths.Delete( I );

  end;

end;



constructor TFileJoiner.Create;

begin

  FPaths := TList.Create;

end;



destructor TFileJoiner.Destroy;

begin

  Clear;

  FPaths.Free;

  inherited;

end;



procedure TFileJoiner.CountFiles;

type

  PStackItem = ^TStackItem;

  TStackItem = record

    Data: PChar;

    Searcher: TSearchRec;

  end;



var

  I: Integer;

  Path, Filter: string;

  Stack: TStack;

  CurStack, X: PStackItem;

begin

  FTotalFiles := 0;

  FTotalSize := 0;



  Stack := TStack.Create;

  try

    for I := 0 to FPaths.Count - 1 do

    begin

      Path := Self[I].Source;

      if LastDelimiter( '*?', ExtractFileName( Path ) ) <> 0 then

      begin

        Filter := ExtractFileName( Path );

        Path := ExtractFilePath( Path );

      end

      else if FileExists( Path ) then

      else if DirectoryExists( Path ) then

      begin

        Filter := '*';

        Path := AddSlash( Path );

      end

      else

        raise Exception.CreateFmt( '%s.GetFilesSumary: "%s" não encontrado', [ ClassName, Path ] );



      New( CurStack );

      CurStack^.Data := CopyString( Path );

      repeat

        with CurStack^ do

        begin

          if FindFirst( Data + Filter, faDirectory, Searcher ) = 0 then

          begin

            repeat

              Inc( FTotalFiles );

              Inc( FTotalSize, Searcher.Size );

            until FindNext( Searcher ) <> 0;

            FindClose( Searcher );

          end;



          if Self[I].Recurse and ( FindFirst( Data + Filter, faArchive, Searcher ) = 0 ) then

          begin

            repeat

              if Searcher.Name[1] <> '.' then

              begin

                New( X );

                X^.Data := CopyString( AddSlash( Data + Searcher.Name ) );

                Stack.Push( X );

              end;

            until FindNext( Searcher ) <> 0;

            FindClose( Searcher );

          end;

          FreeMem( Data );

          Dispose( CurStack );

          CurStack := Stack.Pop;

        end;

      until CurStack = nil;

    end;

  finally

    Stack.Free;

  end;

end;



function TFileJoiner.GetItem(const Index: Integer): TFileJoinerItem;

begin

  Result := FPaths.Items[ Index ];

end;



function TFileJoiner.GetCount: Integer;

begin

  Result := FPaths.Count;

end;



procedure TFileJoiner.ListFiles( const Callback: TFileJoinerFilesCallback);

type

  PStackItem = ^TStackItem;

  TStackItem = record

    Source, Destiny: PChar;

    Searcher: TSearchRec;

  end;



var

  Stack: TStack;

  Filter: string;

  Current, X: PStackItem;

  Data: TFileJoinerItem;

  I: Integer;

begin

  Stack := TStack.Create;

  try

    Data := TFileJoinerItem.Create;

    try

      for I := 0 to FPaths.Count - 1 do

      begin

        Data.Assign( Self[I] );

        with Data do

        begin

          Destiny := AddSlash( Destiny );

          if LastDelimiter( '*?', ExtractFileName( Source ) ) <> 0 then

          begin

            Filter := ExtractFileName( Source );

            Source := ExtractFilePath( Source );

          end

          else if FileExists( Source ) then

          begin

            Destiny := Destiny + ExtractFileName( Data.Source );

            Callback( Self, Data );

            Continue;

          end

          else if DirectoryExists( Source ) then

          begin

            Filter := '*';

            Destiny := AddSlash( Destiny + ExtractFileName( RemoveSlash( Source ) ) );

            Source := AddSlash( Source );

          end

          else

            raise Exception.CreateFmt( '%s.ListFiles: "%s" não encontrado', [ ClassName, Source ] );

        end;



        New( Current );

        with Current^ do

        begin

          Source := CopyString( Data.Source );

          Destiny := CopyString( Data.Destiny );

        end;



        repeat

          with Current^ do

          begin

            if FindFirst( Source + Filter, faDirectory, Searcher ) = 0 then

            begin

              repeat

                Data.Source := Source + Searcher.Name;

                Data.Destiny := Destiny + Searcher.Name;

                Callback( Self, Data )

              until FindNext( Searcher ) <> 0;

              FindClose( Searcher );

            end;



            if Data.Recurse and ( FindFirst( Source + '*', faArchive, Searcher ) = 0 ) then

            begin

              repeat

                if Searcher.Name[1] <> '.' then

                begin

                  New( X );

                  X^.Source := CopyString( AddSlash( Source + Searcher.Name ) );

                  X^.Destiny := CopyString( AddSlash( Destiny + Searcher.Name ) );

                  Stack.Push( X );

                end;

              un



Fast Sequential Search/Replace Engine supporting wildcards, backward search, whole words, etc... //Pascal Class
jonasraoni (Jonas Raoni Soares Silva) — Thu, 15 Jun 2006 18:55:44 GMT
A quite fast unit to search/replace strings sequentially (while Seeker.Search() do...) in files/strings done mostly with pointers to improve speed. It's able to search backward, count end of lines, check case-sensitiveness, match whole words and handle wildcards (* and ?), 



The search method was divided into 4 specialized methods, again to improve speed. The right method is choosed according to the options that were setted (wildcard, search backward, etc...)



This is an old code that doesn't match my current skills, anyway it has some cool techniques that I really enjoyed :)





//

//    TNotesSeeker - classe de buscas do Notes.

//

//    Notes, http://notes.codigolivre.org.br

//    Copyright (C) 2003-2004, Equipe do Notes.

//

//    This program is free software; you can redistribute it and/or modify

//    it under the terms of the GNU General Public License as published by

//    the Free Software Foundation; either version 2 of the License, or

//    (at your option) any later version.

//

//    This program is distributed in the hope that it will be useful,

//    but WITHOUT ANY WARRANTY; without even the implied warranty of

//    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

//    GNU General Public License for more details.

//

//    You should have received a copy of the GNU General Public License

//    along with this program; if not, write to the Free Software

//    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

//

//    **************************************************************

//    Revision #0

//      Version  : 1.0.0

//      Date     : 2003-11-30 22:00:00 GMT -3:00

//      Reviewer : Jonas Raoni Soares Silva

//      Changes  : Criada a classe.

//    **************************************************************

//    Revision #1

//      Version  : 1.0.1

//      Date     : 2004-09-09 03:30:00 GMT -3:00

//      Reviewer : Jonas Raoni Soares Silva

//      Changes  : Acho q acabaram-se os bugs... Será??? :]

//    **************************************************************



(*

@abstract(NotesSeeker - classe de buscas do Notes.)

@author(Jonas Raoni Soares Silva )

@created(30 Nov 2003)

*)



unit NotesSeeker;



interface



uses

  SysUtils, Classes;



type



{

  @code(ENotesSeekerException) -

    Notificar erros na classe TNotesSeeker de forma

    profissional, facilitando a interceptação e/ou log de

    erros

}

  ENotesSeekerException = class ( Exception )

  public

    constructor Create(const Msg: string);

    constructor CreateFmt(const Msg: string; const Args: array of const);

  end;



  {Opões de pesquisa: 


   @code(nsHandleEOL) - se você precisar buscar por quebras de linhas, você precisa setar esta opção.


   @code(nsCaseSensitive) - diferenciar maiúsculas de minúsculas.


   @code(nsWholeWords) - retorna apenas palavras inteiras.


   @code(nsBackward) - busca de traz para frente. 


   @code(nsHandleWildCard) - usa coringas * e ? na pesquisa.}

  TNotesSeekerOption = ( nsHandleEOL, nsCaseSensitive, nsWholeWords, nsBackward, nsHandleWildCard );

  { Set de @link(TNotesSeekerOption).}

  TNotesSeekerOptions = set of TNotesSeekerOption;



  TSearchFunction = function: Boolean of object;



{

  @code(TNotesSeeker) -

    Permite fazer buscas em strings com várias opções

}

  TNotesSeeker = class(TObject)

  private

    Jump, LineJump: Cardinal;

    FList: TList;

  protected

    FMatches, FStartAt, FEOLLen, FSearchLen, FCurCol,

    FCurLine, FMatchLen, FMatchLine, FMatchCol: Cardinal;



    FBufferEnd, FBuffer, FBufferBegin, FBufferBackup,

    FEOL, FSearchBegin, FSearch, FSearchEnd: PChar;



    FOptions: TNotesSeekerOptions;



    FContextRightLenght, FContextLeftLenght: Cardinal;



    FKeepText: Boolean;



    function GetText: string;

    function GetReplacedText: string;

    function GetContext: string;

    function GetSearchStr: string;

    function GetRemainingText: string;

    function GetCurByte: Cardinal;

    function GetEOL: string;



    procedure SetOptions(const Value: TNotesSeekerOptions);

    procedure SetText( const Value: string);

    procedure SetSearchStr(const Value: string);

    procedure SetEOL(const Value: string);



    procedure FreeBuffer;

    procedure FreeEOL;

    procedure FreeSearchStr;



    {Search Engines}

    function SearchForward: Boolean;

    function SearchForwardWithWildCard: Boolean;

    function SearchBackward: Boolean;

    function SearchBackwardWithWildCard: Boolean;



  public

    { Efetua a busca: se o termo procurado for encontrado, retorna true, caso contrário retorna false }

    Search: TSearchFunction;



    { Método construtor }

    constructor Create; virtual;

    { Método destruidor }

    destructor Destroy; override;



    { Armazena o tamanho do "match", quando a opção wildcard estiver desligada esta será igual ao tamanho da própria string procurada }

    property MatchLength: Cardinal read FMatchLen;

    { Quando HandleEOL fizer parte das opções, armazenará a linha onde a string procurada foi encontrada }

    property CurLine: Cardinal read FMatchLine;

    { Armazenará a coluna onde a string procurada foi encontrada, se HandleEOL não estiver nas opções, armazenará a mesma coisa que a propriedade CurByte }

    property CurCol: Cardinal read FMatchCol;

    { Armazena a posição ou byte "absoluto" onde a string foi encontrada }

    property CurByte: Cardinal read GetCurByte;

    { Especifica a posição/byte inicial onde a busca deverá começar }

    property StartAt: Cardinal read FStartAt write FStartAt;

    { Retorna o contexto onde a string procurada foi encontrada }

    property Context: string read GetContext;

    { Especifica a quantidade de caracteres que deverão fazer parte do contexto encontrado ao lado esquerdo da string procurada }

    property ContextLeftLenght: Cardinal read FContextLeftLenght write FContextLeftLenght;

    { Especifica a quantidade de caracteres que deverão fazer parte do contexto encontrado ao lado direito da string procurada }

    property ContextRightLenght: Cardinal read FContextRightLenght write FContextRightLenght;

    { Armazena o número de strings que coincidiram com a busca até o presente momento }

    property Matches: Cardinal read FMatches;

    { Permite alterar a sequência de caracteres que demarcam o fim de uma linha }

    property EOL: string read GetEOL write SetEOL;

    { Armazena as opções atualmente habilitadas para a busca, podendo ser alterada a qualquer momento }

    property Options: TNotesSeekerOptions read FOptions write SetOptions;

    { Termo a ser procurado no texto }

    property SearchStr: string read GetSearchStr write SetSearchStr;

    { Texto onde a busca será efetuada }

    property Text: string read GetText write SetText;

    { Texto restante ao término da busca }

    property RemainingText: string read GetRemainingText;

    { Especifica se a classe deverá manter uma cópia do texto setado inicialmente }

    property KeepText: Boolean read FKeepText write FKeepText;

    { Retorna o texto com os replaces, caso KeepText seja falso, essa propriedade se torna sinônimo da propriedade Text }

    property ReplacedText: string read GetReplacedText;



    { Prepara tudo para uma nova busca }

    procedure StartSearch;

    { Carrega o texto da busca a partir de um arquivo }

    procedure LoadFromFile( const AFilename: string );

    { Carrega o texto da busca a partir de um stream }

    procedure LoadFromStream( const AStream: TStream );

    { Carrega o texto da busca a partir de um buffer }

    procedure LoadFromBuffer( const ABuffer: PChar );

    { Efetua a substituição da string encontrada pela string contida em "S" }

    procedure Replace( const S: String );

    { Modo prático para setar as opções }

    procedure EnableOptions( const CaseSensitive: Boolean = true; const WholeWords: Boolean = false; const HandleEOL: Boolean = true; const HandleWildCard: Boolean = false; const Backward: Boolean = false );



  end;



  { Compara Str1 e Str2 de trás pra frente, se as duas forem iguais retorna true, caso contrário false }

  function StrLRComp( S1, S2: PChar; const S2Begin: PChar ): Boolean;

  { Converte para maiúsculo (ANSI) -> VALEUUUUU TIO RUSSÃO hahaha, o que tem no delphi "aplica a alteração"

    Idéia de manter tabela com tudo maiúsculo arrancada de "QStrings 6.07.424 Copyright (C) 2000, 2003 Andrew Dryazgov [ andrewdr@newmail.ru ]" }

  function AnsiUpCase(Ch: Char): Char;



const

  { Caracteres que definem delimitadores de palavra, usada quando a opção WholeWords está ativa }

  WhiteSpaces: set of Char = [' ',#9,#13,#10,'!','"','#','$','%','&','''','(',')','*','+','-','/',':',';','<','=','>','?','@','[','\',']','^','`','{','|','}','~'];



const

  //fiz algumas alterações hehe, o tiozaum russo devia tá começano a ficar cego enqto fazia isso :)

  ToUpperChars: array[0..255] of Char =

    (#$00,#$01,#$02,#$03,#$04,#$05,#$06,#$07,#$08,#$09,#$0A,#$0B,#$0C,#$0D,#$0E,#$0F,

     #$10,#$11,#$12,#$13,#$14,#$15,#$16,#$17,#$18,#$19,#$1A,#$1B,#$1C,#$1D,#$1E,#$1F,

     #$20,#$21,#$22,#$23,#$24,#$25,#$26,#$27,#$28,#$29,#$2A,#$2B,#$2C,#$2D,#$2E,#$2F,

     #$30,#$31,#$32,#$33,#$34,#$35,#$36,#$37,#$38,#$39,#$3A,#$3B,#$3C,#$3D,#$3E,#$3F,

     #$40,#$41,#$42,#$43,#$44,#$45,#$46,#$47,#$48,#$49,#$4A,#$4B,#$4C,#$4D,#$4E,#$4F,

     #$50,#$51,#$52,#$53,#$54,#$55,#$56,#$57,#$58,#$59,#$5A,#$5B,#$5C,#$5D,#$5E,#$5F,

     #$60,#$41,#$42,#$43,#$44,#$45,#$46,#$47,#$48,#$49,#$4A,#$4B,#$4C,#$4D,#$4E,#$4F,

     #$50,#$51,#$52,#$53,#$54,#$55,#$56,#$57,#$58,#$59,#$5A,#$7B,#$7C,#$7D,#$7E,#$7F,

     #$80,#$81,#$82,#$81,#$84,#$85,#$86,#$87,#$88,#$89,#$8A,#$8B,#$8C,#$8D,#$8E,#$8F,

     #$90,#$91,#$92,#$93,#$94,#$95,#$96,#$97,#$98,#$99,#$8A,#$9B,#$8C,#$9D,#$9E,#$9F,

     #$A0,#$A1,#$A1,#$A3,#$A4,#$A5,#$A6,#$A7,#$A8,#$A9,#$AA,#$AB,#$AC,#$AD,#$AE,#$AF,

     #$B0,#$B1,#$B2,#$B2,#$A5,#$B5,#$B6,#$B7,#$A8,#$B9,#$BA,#$BB,#$BC,#$BD,#$BE,#$BF,

     #$C0,#$C1,#$C2,#$C3,#$C4,#$C5,#$C6,#$C7,#$C8,#$C9,#$CA,#$CB,#$CC,#$CD,#$CE,#$CF,

     #$D0,#$D1,#$D2,#$D3,#$D4,#$D5,#$D6,#$D7,#$D8,#$D9,#$DA,#$DB,#$DC,#$DD,#$DE,#$DF,

     #$C0,#$C1,#$C2,#$C3,#$C4,#$C5,#$C6,#$C7,#$C8,#$C9,#$CA,#$CB,#$CC,#$CD,#$CE,#$CF,

     #$D0,#$D1,#$D2,#$D3,#$D4,#$D5,#$D6,#$F7,#$D8,#$D9,#$DA,#$DB,#$DC,#$DD,#$DE,#$9F);



implementation



function StrLRComp( S1, S2: PChar; const S2Begin: PChar ): Boolean;

begin

  while ( S2 <> S2Begin ) and ( S1^ = S2^ ) do begin

    dec( S1 );

    dec( S2 );

  end;

  Result := ( S1^ = S2^ ) and ( S2 = S2Begin );

end;



function AnsiUpCase(Ch: Char): Char;

begin

  Result := ToUpperChars[ ord( ch ) ];

end;





{ class : TNotesSeeker }



{ TNotesSeeker : protected }



function TNotesSeeker.GetText: string;

begin

  if Assigned( FBufferBackup ) then

    Result := StrPas( FBufferBackup )

  else

    Result := ReplacedText;

end;



function TNotesSeeker.GetReplacedText: string;

begin

  Result := StrPas( FBufferBegin );

end;



function TNotesSeeker.GetContext: string;

var

  BeginAt, EndAt: PChar;

begin

  if not ( nsBackward in FOptions ) then begin

    BeginAt := FBuffer - FMatchLen - FContextLeftLenght;

    EndAt := FBuffer+FContextRightLenght;

  end

  else begin

    BeginAt := FBuffer+1-FContextLeftLenght;

    EndAt := FBuffer+1+FMatchLen+FContextRightLenght;

  end;

  if BeginAt > EndAt then

    raise ENotesSeekerException.CreateFmt('GetContext::Range Error "BeginAt(%d) > EndAt(%d)"', [Integer(BeginAt), Integer(EndAt)]);

  if BeginAt < FBufferBegin then

    BeginAt := FBufferBegin;

  if EndAt > FBufferEnd then

    EndAt := FBufferEnd;



  SetString( Result, BeginAt, EndAt-BeginAt );

end;



function TNotesSeeker.GetSearchStr: string;

begin

  Result := StrPas( FSearchBegin );

end;



function TNotesSeeker.GetRemainingText: string;

begin

  Result := '';

  if not ( nsBackward in FOptions ) then

    Result := StrPas( FBuffer )

  else if FBuffer-FBufferBegin > -1 then

    SetString( Result, FBufferBegin, FBuffer-FBufferBegin+1 );

end;



function TNotesSeeker.GetCurByte: Cardinal;

begin

  if nsBackward in FOptions then

    Result := FBufferEnd-1 - FBuffer - FMatchLen

  else

    Result := FBuffer - FMatchLen - FBufferBegin;

end;



function TNotesSeeker.GetEOL: string;

begin

  Result := StrPas( FEOL );

end;



procedure TNotesSeeker.SetOptions(const Value: TNotesSeekerOptions);

begin

  FOptions := Value;

  if nsBackward in Value then

    if nsHandleWildCard in Value then

      Search := SearchBackwardWithWildCard

    else

      Search := SearchBackward

  else if nsHandleWildCard in Value then

    Search := SearchForwardWithWildCard

  else

    Search := SearchForward;

end;



procedure TNotesSeeker.SetText( const Value: string );

begin

  LoadFromBuffer( PChar( Value ) );

end;



procedure TNotesSeeker.SetSearchStr(const Value: string);

begin

  FreeSearchStr;

  FSearchLen := Length( Value );

  GetMem( FSearchBegin, FSearchLen+1 );

  StrCopy( FSearchBegin, PChar( Value ) );

  FSearch := FSearchBegin;

  FSearchEnd := StrEnd( FSearchBegin );

end;



procedure TNotesSeeker.SetEOL(const Value: string);

begin

  FreeEOL;

  FEOLLen := Length( Value );

  GetMem( FEOL, FEOLLen+1 );

  StrCopy( FEOL, PChar( Value ) );

end;





procedure TNotesSeeker.FreeBuffer;

begin

  if Assigned( FBufferBegin ) then begin

    FBufferEnd := nil;

    FBuffer := nil;

    FreeMem( FBufferBegin );

  end;

  if Assigned( FBufferBackup ) then begin

    FreeMem( FBufferBackup );

    FBufferBackup := nil;

  end;

end;



procedure TNotesSeeker.FreeEOL;

begin

  if Assigned( FEOL ) then begin

    FreeMem( FEOL );

    FEOL := nil;

  end;

end;



procedure TNotesSeeker.FreeSearchStr;

begin

  if Assigned( FSearchBegin ) then begin

    FreeMem( FSearchBegin );

    FSearchBegin := nil;

    FSearch := nil;

    FSearchEnd := nil;

  end;

end;







{ TNotesSeeker : public }



constructor TNotesSeeker.Create;

begin

  EOL := #13#10;

  FContextLeftLenght := 10;

  FContextRightLenght := 20;

  Search := SearchForward;

end;



destructor TNotesSeeker.Destroy;

begin

  FreeBuffer;

  FreeSearchStr;

  FreeEOL;

  inherited Destroy;

end;



procedure TNotesSeeker.LoadFromBuffer( const ABuffer: PChar );

begin

  FreeBuffer;

  GetMem( FBufferBegin, StrLen( ABuffer )+1 );

  FBuffer := StrCopy( FBufferBegin, ABuffer );

  FBufferEnd :=  StrEnd( FBufferBegin );

  if FKeepText then begin

    GetMem( FBufferBackup, StrLen( FBufferBegin )+1 );

    StrCopy( FBufferBackup, FBufferBegin );

  end;  

end;



procedure TNotesSeeker.LoadFromFile(const AFilename: string);

var

  FS: TFileStream;

begin

  if not FileExists( AFilename ) then

    raise ENotesSeekerException.CreateFmt( 'LoadFromFile::Arquivo "%s" não encontrado', [AFilename] );

  FS := TFileStream.Create( AFilename, fmOpenRead );

  try

    LoadFromStream( FS );

  finally

    FS.Free;

  end;

end;



procedure TNotesSeeker.LoadFromStream(const AStream: TStream);

var

  Size: Int64;

begin

  FreeBuffer;

  Size := AStream.Size;

  GetMem( FBuffer, Size+1 );

  Size := AStream.Read( FBuffer^, Size );

  ( FBuffer+Size )^ := #0;

  FBufferEnd := (FBuffer+Size);

  FBufferBegin := FBuffer;

  if FKeepText then begin

    GetMem( FBufferBackup, StrLen( FBufferBegin )+1 );

    StrCopy( FBufferBackup, FBufferBegin );

  end;  

end;



procedure TNotesSeeker.StartSearch;

begin

  FMatches := 0;

  FCurLine := 0;

  FCurCol := 0;



  if FSearchLen = 0 then

    raise ENotesSeekerException.Create( 'StartSearch::Propriedade SearchStr está vazia.' );



  if ( FBufferBackup <> FBufferBegin ) and Assigned( FBufferBackup ) then begin

    FreeMem( FBufferBegin );

    GetMem( FBufferBegin, StrLen( FBufferBackup )+1 );

    FBuffer := StrCopy( FBufferBegin, FBufferBackup );

    FBufferEnd := FBuffer + StrLen( FBufferBackup );

  end;



  if nsBackward in FOptions then

    FBuffer := FBufferEnd-1

  else

    FBuffer := FBufferBegin;

end;



procedure TNotesSeeker.Replace(const S: String);

var

  TempBuff: PChar;

  BufferOffset: Integer;

begin

  TempBuff := nil;

  if not ( nsBackward in FOptions ) then begin

    BufferOffset := FBuffer-FMatchLen - FBufferBegin + Length( S );

    GetMem( TempBuff, ( FBuffer-FMatchLen - FBufferBegin) + Length(S) + ( FBufferEnd - FBuffer ) + 1 );

    FBufferEnd := StrLCopy( StrLCopy( StrLCopy( TempBuff, FBufferBegin, FBuffer-FMatchLen - FBufferBegin )+(FBuffer-FMatchLen - FBufferBegin), PChar( S ), Length( S ) )+Length( S ), FBuffer, FBufferEnd - FBuffer )+(FBufferEnd - FBuffer);

    FreeMem( FBufferBegin );

    FBufferBegin := TempBuff;

    FBuffer := FBufferBegin + BufferOffset;

  end

  else begin

    BufferOffset := FBufferEnd - (FBuffer + FMatchLen) + Length( S );

    if FBuffer < FBufferBegin then

      GetMem( TempBuff, FBufferEnd - (FBuffer+FMatchLen) + Length( S ) + ( FBuffer - FBufferBegin ) + 1 )

    else

      GetMem( TempBuff, FBufferEnd - (FBuffer+FMatchLen) + Length( S ) + ( FBuffer - FBufferBegin ) + 1 );

    FBufferEnd := StrLCopy( StrLCopy( StrLCopy( TempBuff, FBufferBegin, FBuffer-FBufferBegin+1 )+(FBuffer-FBufferBegin+1), PChar( S ), Length( S ) )+Length( S ), FBuffer+FMatchLen+1, FBufferEnd-1 - (FBuffer+FMatchLen) )+ ( FBufferEnd-1 - (FBuffer+FMatchLen) );

    FreeMem( FBufferBegin );

    FBufferBegin := TempBuff;

    FBuffer := FBufferEnd - BufferOffset;

  end;

end;





{ ENotesSeekerException }

{ ENotesSeekerException : public }



constructor ENotesSeekerException.Create(const Msg: string);

begin

  inherited Create( 'TNotesSeeker.'+Msg );

end;



constructor ENotesSeekerException.CreateFmt(const Msg: string; const Args: array of const);

begin

  inherited CreateFmt( 'TNotesSeeker.'+Msg, Args );

end;



procedure TNotesSeeker.EnableOptions(const CaseSensitive, WholeWords, HandleEOL, HandleWildCard, Backward: Boolean);

  var Opcoes: TNotesSeekerOptions;

begin

  if CaseSensitive then Include( Opcoes, nsCaseSensitive ) else Exclude( Opcoes, nsCaseSensitive );

  if HandleEOL then Include( Opcoes, nsHandleEOL ) else Exclude( Opcoes, nsHandleEOL );

  if Backward then Include( Opcoes, nsBackward ) else Exclude( Opcoes, nsBackward );

  if HandleWildCard then Include( Opcoes, nsHandleWildCard ) else Exclude( Opcoes, nsHandleWildCard );

  if WholeWords then Include( Opcoes, nsWholeWords ) else Exclude( Opcoes, nsWholeWords );

  SetOptions( Opcoes );

end;



function TNotesSeeker.SearchForward: Boolean;

begin

  Result := True;

  LineJump := 0;

  FMatchLine := 0;

  FMatchCol := 0;

  FMatchLen := 0;

  FSearch := FSearchBegin;



  if FBufferBegin + FStartAt > FBufferEnd then

    FStartAt := FBufferEnd - FBufferBegin;

  while FStartAt > FBuffer-FBufferBegin do begin

    if ( nsHandleEOL in FOptions ) and ( FBuffer^ = FEOL^ ) and ( StrLComp( FBuffer, FEOL, FEOLLen ) = 0 ) then begin

      Inc( FBuffer, FEOLLen );

      Inc( FCurLine );

      FCurCol := 0;

      Continue;

    end

    else

      Inc( FCurCol );

    Inc( FBuffer );

  end;



  while FBuffer <> FBufferEnd do begin

    if ( (nsCaseSensitive in FOptions ) and ( FBuffer^ = FSearch^ ) ) or ( not(nsCaseSensitive in FOptions ) and ( AnsiUpCase( FBuffer^ ) = AnsiUpCase( FSearch^ ) ) ) then begin

      Inc( FMatchLen );

      Inc( FSearch );

      if Result then begin

        Result := False;

        FMatchCol := FCurCol;

        FMatchLine := FCurLine;

        if ( nsWholeWords in FOptions ) and ( FBuffer > FBufferBegin ) and not ( (FBuffer-1)^ in WhiteSpaces ) then begin

          FSearch := FSearchBegin;

          FMatchLen := 0;

          FMatchLine := 0;

          FMatchCol := 0;

        end;

      end;

      if ( nsWholeWords in FOptions ) and ( FMatchLen = FSearchLen ) and ( FBuffer < FBufferEnd-1 ) and not ( (FBuffer+1)^ in WhiteSpaces ) then begin

        FSearch := FSearchBegin;

        FMatchLen := 0;

        FMatchLine := 0;

        FMatchCol := 0;

      end;



      if ( nsHandleEOL in FOptions ) and ( FBuffer^ = FEOL^ ) and ( StrLComp( FBuffer, FEOL, FEOLLen ) = 0 ) then begin

        Inc( FCurLine );

        FCurCol := 0;

        LineJump := FEOLLen-1;

      end

      else if LineJump = 0 then

        Inc( FCurCol )

      else

        Dec( LineJump );



      Inc( FBuffer );

      if FSearch^ = #0 then begin

        Result := True;

        Inc( FMatches );

        Exit;

      end;

    end

    else begin

      Result := True;

      FMatchLen := 0;

      FMatchLine := 0;

      FMatchCol := 0;

      

      if FSearch <> FSearchBegin then begin

        FSearch := FSearchBegin;

        Continue;

      end;



      if ( nsHandleEOL in FOptions ) and ( FBuffer^ = FEOL^ ) and ( StrLComp( FBuffer, FEOL, FEOLLen ) = 0 ) then begin

        Inc( FCurLine );

        FCurCol := 0;

        LineJump := FEOLLen-1;

      end

      else if LineJump = 0 then

        Inc( FCurCol )

      else

        Dec( LineJump );



      Inc( FBuffer )        

    end;

  end;

  Result := False;

end;



function TNotesSeeker.SearchForwardWithWildCard: Boolean;

begin

  Result := True;

  Jump := 1;

  LineJump := 0;

  FMatchLine := 0;

  FMatchCol := 0;

  FMatchLen := 0;

  FSearch := FSearchBegin;



  if FBufferBegin + FStartAt > FBufferEnd then

    FStartAt := FBufferEnd - FBufferBegin;

  while FStartAt > FBuffer-FBufferBegin do begin

    if ( nsHandleEOL in FOptions ) and ( FBuffer^ = FEOL^ ) and ( StrLComp( FBuffer, FEOL, FEOLLen ) = 0 ) then begin

      Inc( FBuffer, FEOLLen );

      Inc( FCurLine );

      FCurCol := 0;

      Continue;

    end

    else

      Inc( FCurCol );

    Inc( FBuffer );

  end;



  while FBuffer <> FBufferEnd do begin

    if FSearch^ = '?' then begin

      Inc( FMatchLen );

      Inc( FSearch );

    end

    else if FSearch^ = '*' then begin

      if (FSearch+Jump)^ = '?' then begin

        Inc( FMatchLen );

        Inc( Jump );

      end

      else if (FSearch+Jump)^ = '*' then begin

        Inc( FSearch, Jump );

        Jump := 1;

        continue;

      end

      else if ( ( nsCaseSensitive in FOptions ) and ( FBuffer^ = (FSearch+Jump)^ ) ) or ( not( nsCaseSensitive in FOptions ) and ( AnsiUpCase( FBuffer^ ) = AnsiUpCase( (FSearch+Jump)^ ) )  ) then begin

        Inc( FMatchLen );

        Inc( Jump );

      end

      else

        Inc( FMatchLen );

      if (FSearch+Jump)^ = #0 then begin

        if (FSearch+Jump-1)^ = '*' then begin

          Inc( FMatchLen, FBufferEnd-FBuffer - 1 );

          FBuffer := FBufferEnd - 1;

        end;

        FSearch := FSearchEnd;

      end;

    end

    else if ( ( nsCaseSensitive in FOptions ) and ( FBuffer^ = FSearch^ ) ) or ( not ( nsCaseSensitive in FOptions ) and ( AnsiUpCase( FBuffer^ ) = AnsiUpCase( FSearch^ ) ) ) then begin

      Inc( FMatchLen );

      Inc( FSearch );

    end

    else begin

      Result := True;

      FMatchLen := 0;

      FMatchLine := 0;

      FMatchCol := 0;

      Jump := 1;

      if FSearch <> FSearchBegin then begin

        FSearch := FSearchBegin;

        Continue;

      end;



      if ( nsHandleEOL in FOptions ) and ( FBuffer^ = FEOL^ ) and ( StrLComp( FBuffer, FEOL, FEOLLen ) = 0 ) then begin

        Inc( FCurLine );

        FCurCol := 0;

        LineJump := FEOLLen-1;

      end

      else if LineJump = 0 then

        Inc( FCurCol )

      else

        Dec( LineJump );



      Inc( FBuffer );

      continue;

    end;



    if Result then begin

      Result := False;

      FMatchCol := FCurCol;

      FMatchLine := FCurLine;

    end;



    if ( nsHandleEOL in FOptions ) and ( FBuffer^ = FEOL^ ) and ( StrLComp( FBuffer, FEOL, FEOLLen ) = 0 ) then begin

      Inc( FCurLine );

      FCurCol := 0;

      LineJump := FEOLLen-1;

    end

    else if LineJump = 0 then

      Inc( FCurCol )

    else

      Dec( LineJump );



    Inc( FBuffer );



    if FSearch^ = #0 then begin

      Result := True;

      Inc( FMatches );

      Exit;

    end;

  end;

  Result := False;

end;



function TNotesSeeker.SearchBackward: Boolean;

begin

  Result := True;

  LineJump := 0;

  FMatchLine := 0;

  FMatchCol := 0;

  FMatchLen := 0;

  FSearch := FSearchEnd-1;



  if FBufferEnd - FStartAt < FBufferBegin then

    FStartAt := FBufferEnd - FBufferBegin;

  while FStartAt > FBufferEnd-1 - FBuffer do begin

    if ( nsHandleEOL in FOptions ) and ( FBuffer-FBufferBegin >= FEOLLen ) and StrLRComp( FBuffer, FEOL+FEOLLen-1, FEOL ) then begin

      Dec( FBuffer, FEOLLen );

      Inc( FCurLine );

      FCurCol := 0;

      Continue;

    end

    else

      Inc( FCurCol );

    Dec( FBuffer );

  end;



  while FBuffer <> FBufferBegin-1 do begin

    if ( (nsCaseSensitive in FOptions ) and ( FBuffer^ = FSearch^ ) ) or ( not(nsCaseSensitive in FOptions ) and ( AnsiUpCase( FBuffer^ ) = AnsiUpCase( FSearch^ ) ) ) then begin

      Inc( FMatchLen );

      Dec( FSearch );

      if Result then begin

        Result := False;

        FMatchCol := FCurCol;

        FMatchLine := FCurLine;



        if ( nsWholeWords in FOptions ) and ( FBuffer < FBufferEnd-1 ) and not ( (FBuffer+1)^ in WhiteSpaces ) then begin

          FSearch := FSearchEnd-1;

          FMatchLen := 0;

          FMatchLine := 0;

          FMatchCol := 0;

        end;

      end;

      if ( nsWholeWords in FOptions ) and ( FMatchLen = FSearchLen ) and ( FBuffer > FBufferBegin ) and not ( (FBuffer-1)^ in WhiteSpaces ) then begin

        FSearch := FSearchEnd-1;

        FMatchLen := 0;

        FMatchLine := 0;

        FMatchCol := 0;

      end;



      if ( nsHandleEOL in FOptions ) and ( FBuffer-FBufferBegin >= FEOLLen ) and StrLRComp( FBuffer, FEOL+FEOLLen-1, FEOL ) then begin

        Inc( FCurLine );

        FCurCol := 0;

        LineJump := FEOLLen-1;

      end

      else if LineJump = 0 then

        Inc( FCurCol )

      else

        Dec( LineJump );



      Dec( FBuffer );

      if FSearch = FSearchBegin-1 then begin

        Result := True;

        Inc( FMatches );

        Exit;

      end;

    end

    else begin

      Result := True;

      FMatchLen := 0;

      FMatchLine := 0;

      FMatchCol := 0;



      if FSearch <> FSearchEnd-1 then begin

        FSearch := FSearchEnd-1;

        Continue;

      end;



      if ( nsHandleEOL in FOptions ) and ( FBuffer-FBufferBegin >= FEOLLen ) and StrLRComp( FBuffer, FEOL+FEOLLen-1, FEOL ) then begin

        Inc( FCurLine );

        FCurCol := 0;

        LineJump := FEOLLen-1;

      end

      else if LineJump = 0 then

        Inc( FCurCol )

      else

        Dec( LineJump );



      Dec( FBuffer );

    end;

  end;

  Result := False;

end;



function TNotesSeeker.SearchBackwardWithWildCard: Boolean;

begin

  Result := True;

  Jump := 1;

  LineJump := 0;

  FMatchLine := 0;

  FMatchCol := 0;

  FMatchLen := 0;

  FSearch := FSearchEnd-1;



  if FBufferEnd - FStartAt < FBufferBegin then

    FStartAt := FBufferEnd - FBufferBegin;

  while FStartAt > FBufferEnd-1 - FBuffer do begin

    if ( nsHandleEOL in FOptions ) and ( FBuffer^ = FEOL^ ) and ( StrLComp( FBuffer, FEOL, FEOLLen ) = 0 ) then begin

      Dec( FBuffer, FEOLLen );

      Inc( FCurLine );

      FCurCol := 0;

      Continue;

    end

    else

      Inc( FCurCol );

    Dec( FBuffer );

  end;



  while FBuffer <> FBufferBegin-1 do begin

    if FSearch^ = '?' then begin

      Inc( FMatchLen );

      Dec( FSearch );

    end

    else if FSearch^ = '*' then begin

      if (FSearch-Jump)^ = '?' then begin

        Inc( FMatchLen );

        Inc( Jump );

      end

      else if (FSearch-Jump)^ = '*' then begin

        Dec( FSearch, Jump );

        Jump := 1;

        continue;

      end

      else if ( ( nsCaseSensitive in FOptions ) and ( FBuffer^ = (FSearch-Jump)^ ) ) or ( not( nsCaseSensitive in FOptions ) and ( AnsiUpCase( FBuffer^ ) = AnsiUpCase( (FSearch-Jump)^ ) )  ) then begin

        Inc( FMatchLen );

        Inc( Jump );

      end

      else

        Inc( FMatchLen );

      if (FSearch-Jump) = FSearchBegin-1 then begin

        if (FSearch-Jump+1)^ = '*' then begin

          Inc( FMatchLen, FBuffer-FBufferBegin );

          FBuffer := FBufferBegin;

        end;

        FSearch := FSearchBegin-1;

      end;

    end

    else if ( ( nsCaseSensitive in FOptions ) and ( FBuffer^ = FSearch^ ) ) or ( not ( nsCaseSensitive in FOptions ) and ( AnsiUpCase( FBuffer^ ) = AnsiUpCase( FSearch^ ) ) ) then begin

      Inc( FMatchLen );

      Dec( FSearch );

    end

    else begin

      Result := True;

      FMatchLen := 0;

      FMatchLine := 0;

      FMatchCol := 0;

      Jump := 1;



      if FSearch <> FSearchEnd-1 then begin

        FSearch := FSearchEnd-1;

        Continue;

      end;



      if ( nsHandleEOL in FOptions ) and ( FBuffer-FBufferBegin >= FEOLLen ) and StrLRComp( FBuffer, FEOL+FEOLLen-1, FEOL ) then begin

        Inc( FCurLine );

        FCurCol := 0;

        LineJump := FEOLLen-1;

      end

      else if LineJump = 0 then

        Inc( FCurCol )

      else

        Dec( LineJump );



      Dec( FBuffer );

      Continue;

    end;



    if Result then begin

      Result := False;

      FMatchCol := FCurCol;

      FMatchLine := FCurLine;

    end;



    if ( nsHandleEOL in FOptions ) and ( FBuffer-FBufferBegin >= FEOLLen ) and StrLRComp( FBuffer, FEOL+FEOLLen-1, FEOL ) then begin

      Inc( FCurLine );

      FCurCol := 0;

      LineJump := FEOLLen-1;

    end

    else if LineJump = 0 then

      Inc( FCurCol )

    else

      Dec( LineJump );



    Dec( FBuffer );

    if FSearch = FSearchBegin-1 then begin

      Result := True;

      Inc( FMatches );

      Exit;

    end;

  end;

  Result := False;

end;



end.






Path parser //Pascal class
jonasraoni (Jonas Raoni Soares Silva) — Thu, 15 Jun 2006 18:40:23 GMT
An unit to get the special folders' path under windows and it also parses paths shortcuts in the form "$(shortcut)/folder/file.ext".





unit PathParser;



interface



uses

  Classes, SysUtils, TypInfo, SysUtils2, ShlObj, ShellApi, Registry, Windows;



type

  TSpecialFolder = ( sfDesktop, sfAppData, sfTemplates, sfPrograms,

    sfPersonal, sfFavorites, sfStartup, sfRecent, sfSendTo, sfStartMenu,

    sfFonts, sfHistory, sfCookies, sfInternetCache, sfCommonFavorites,

    sfCommonDesktop, sfCommonStartup, sfCommonPrograms, sfCommonStartMenu,

    sfProgramFiles, sfTemporary, sfWindows, sfSystem );



  TSpecialFolderSet = set of TSpecialFolder;



  TPathParser = class( TStringList )

  public

    constructor Create( const UseDefaultMap: Boolean = True );

    class function GetSpecialFolder( const Name: TSpecialFolder ): string;

    function Parse( Path: string ): string;

  end;





implementation



{ TPathParser }



uses Dialogs;



constructor TPathParser.Create(const UseDefaultMap: Boolean);

var

  I: TSpecialFolder;

begin

  CaseSensitive := False;

  if UseDefaultMap then begin

    for I := Low( TSpecialFolder ) to High( TSpecialFolder ) do

      Add( RemoveSlash( LowerCase( Copy( GetEnumName( TypeInfo( TSpecialFolder ),

        Ord( I ) ), 3, MAX_PATH ) ) + '=' + GetSpecialFolder( I ) ) );

    Add( RemoveSlash( Format( 'windowsvolume=%s', [ GetSpecialFolder( sfWindows )[1] ] ) ) );

  end;

end;



class function TPathParser.GetSpecialFolder(

  const Name: TSpecialFolder): string;

const

  FoldersMap: array[TSpecialFolder] of Cardinal = ( CSIDL_DESKTOP,

    CSIDL_APPDATA, CSIDL_TEMPLATES, CSIDL_PROGRAMS, CSIDL_PERSONAL,

    CSIDL_FAVORITES, CSIDL_STARTUP, CSIDL_RECENT, CSIDL_SENDTO, CSIDL_STARTMENU,

    CSIDL_FONTS, CSIDL_HISTORY, CSIDL_COOKIES, CSIDL_INTERNET_CACHE,

    CSIDL_COMMON_FAVORITES, CSIDL_COMMON_DESKTOPDIRECTORY, CSIDL_COMMON_STARTUP,

    CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTMENU, 0, 0, 0, 0 );

var

  Res: Bool;

  Path: array[0..MAX_PATH-1] of Char;

  Reg: TRegistry;

begin

  Result := '';

  case Name of

    sfWindows: GetWindowsDirectory( Path, MAX_PATH );

    sfTemporary: GetTempPath( MAX_PATH, Path );

    sfSystem: GetSystemDirectory( Path, MAX_PATH );

    sfProgramFiles:

    begin

      Reg := TRegistry.Create( KEY_READ );

      try

        Reg.RootKey := HKEY_LOCAL_MACHINE;

        Reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion', False );

        Result := AddSlash( Reg.ReadString( 'ProgramFilesDir' ) );

      finally

        Reg.Free;

      end;

      Exit;

    end;

  else

    Res := ShGetSpecialFolderPath( 0, Path, FoldersMap[ Name ], False );

    if not Res then

      raise Exception.Create( ClassName + '.GetSpecialFolder: Error on ShGetSpecialFolderPath' );

  end;

  Result := AddSlash( Path );

end;



function TPathParser.Parse(Path: string): string;

var

  S: string;

  I, I2, Pos: Integer;

begin

  I := 1;

  while I <= Length( Path )-3 do

  begin

    if ( Path[I] = '$' ) and ( Path[I+1] = '(' ) then

    begin

      I2 := I + 2;

      while ( I2 <= Length( Path ) ) and ( Path[I2] <> ')' ) do

        Inc( I2 );

      if I2 > Length( Path ) then

        Break;

      S := Copy( Path, I + 2, I2 - ( I + 2 ) );

      System.Delete( Path, I, I2 - I + 1 );

      Pos := IndexOfName( S );

      if Pos > -1 then

      begin

        System.Insert( ValueFromIndex[Pos], Path, I );

        Inc( I, Length( ValueFromIndex[Pos] ) );

      end

      else

        raise Exception.CreateFmt( '%s.Parse: Variável "%s" inexistente', [ ClassName, S ] ); //I := I2 + 1;

    end

    else

      Inc( I );

  end;

  Result := Path;

end;



end.




Simple bit operations //Pascal functions
jonasraoni (Jonas Raoni Soares Silva) — Thu, 15 Jun 2006 18:35:07 GMT
Get, Clear, Set and Enable bit operations for pascal.





function GetBit(const Value: DWord; const Bit: Byte): Boolean;

begin

  Result := (Value and (1 shl Bit)) <> 0;

end;



function ClearBit(const Value: DWord; const Bit: Byte): DWord;

begin

	Result := Value and not (1 shl Bit);

end;



function SetBit(const Value: DWord; const Bit: Byte): DWord;

begin

	Result := Value or (1 shl Bit);

end;



function EnableBit(const Value: DWord; const Bit: Byte; const TurnOn: Boolean): DWord;

begin

	Result := (Value or (1 shl Bit)) xor (Integer(not TurnOn) shl Bit);

end;




pascal triangle plotter XD
jonasraoni (Jonas Raoni Soares Silva) — Sat, 02 Jul 2005 03:59:46 GMT


//+ Jonas Raoni Soares Silva

//@ http://jsfromhell.com



#include 

#include 



#define MAX 16



int main () {

	int unsigned vetor[MAX], grau, i = 0, j, top, left;



	clrscr();



	printf( "Dado o grau, printar o triangulo de pascal\n" );



	while( grau > MAX && printf( "Digite um numero entre 0 e %d para o grau: ", MAX ) && scanf( "%u", &grau ) );

	while( i++ < grau && !( j = 0 ) && printf( "\n" ) )

		while( j < i && ( j == 0 && ( top = left = vetor[j] = 1 ) ? 1 : j > 0 && j < i-1 && ( top = vetor[j] ) && ( vetor[j] = left + top ) && ( left = top ) ? 1 : ( vetor[j] = 1 ) ) && printf( "%-5d", vetor[j] ) && ++j );

	getch();

	return 0;

}