Friday, December 25, 2009

Burrows–Wheeler transform

Authors: Michael Burrows and David Wheeler
As some of you might noticed, I haven't posted in quite some time, this is because I'm working on a secret compression algorithm, but I'm willing to share some knowledge about how compression works and what I've implemented or discovered.
I'm writing this post about Burrows–Wheeler transform(a.K.a. block sorting) because it really really really shaked me about how it works.
This block sorting is done before compression so that a lot of repeating bytes/characters in data will get one-after-another, other methods are also used after BWT, like Move-To-Front(which I'm saving for another post... sorry).
More information about history and authors can be found on Wikipedia.
The idea is that you take some data(let's say 256 bytes) encode it and your output should be 257 bytes, why?
input = 256 bytes -encode-> output = 256 bytes + 1 byte for index.
As you read this post you will understand that the more data you encode the bigger the index is but the more memory you need(but not necessarily).
BWT Encoding
Definition: take the data that you wish to encode, create a matrix with first row being the data, for each byte/character in data add a new row with first byte/character to be the second character in precedent row until you have a square matrix(number of columns = number of rows), i.e.
data: "abcde"
constructing the matrix:
abcde <-- the data !! bcdea <-- shifted row from original data(precedent) cdeab <-- shifted row from precedent row deabc eabcd -------- stop! no. columns = no. rows!! -------- Now sort the first column of the matrix in alphabetical order(along with it's rows), in the above example there's no need for sorting! now search in the matrix for the row(first row = ZERO as index) that matches your original data and that row number will tell you the index with which you can reconstruct the original data, in the above example the INDEX = 0 (ZERO). The output is the last column of the matrix "eabcd" and index = 0.
Decoding
The extraordinary thing about this encoding is the decoding, it's out of the box!
So we know the last column of the matrix and the index, we know that first column of the matrix is the encoded data in alphabetical order.
WARNING!! In order to decode you do not need to reconstruct the entire matrix, you just need to sort the encoded data in alphabetical order and put the sorted column next to the encoded one and you get:
a _ _ _ e
b _ _ _ a
c _ _ _ b
d _ _ _ c
e _ _ _ d
Now assign indexes to the left column starting from row zero = 0 and increment it by 1 for each row and you get:
0 a _ _ _ e
1 b _ _ _ a
2 c _ _ _ b
3 d _ _ _ c
4 e _ _ _ d
at this point you just need to assign indexes to the last column so that the index of char "a" from first column will be assigned to the char "a" from last column like so:
0 a _ _ _ e 4
1 b _ _ _ a 0
2 c _ _ _ b 1
3 d _ _ _ c 2
4 e _ _ _ d 3
Now we know:
- first column
- last column
- the index
- the first and last char of the original data "a" and "e"
Decoding is done by starting from last column where the char's index is equal to the index you received along with encoded data.
So index = 0(which is "a", we already know the first char) we go along the row to the first column and we find out that the 2nd char is "b"(1 b <-- a 0), now we know the 2nd char and the index = 1, we go to the last column and where index is 1 and go along the row from right to left and we get the 3rd char "c" along with a new index which is 2, again we go to the last column where index = 3 and go along the row from right to left and find out that the 4th char is "d", again we get a new index which is 3, go to the last column find the the row where index is 3, go along it to the left and find the new index which is not important because we already know the last char but just for the sake of the theory we got the last char which is "e", voia! you have decoded the message, of course the algorithm can be improved by using indexes directly, but first you must understand how it works! Now a real example of the power of BWT. Let's presume you wish to encode "i can what you can", create the matrix:

i can what you can <-- original data can what you cani can what you cani an what you cani c n what you cani ca what you cani can what you cani can hat you cani can w at you cani can wh t you cani can wha you cani can what you cani can what ou cani can what y u cani can what yo cani can what you cani can what you ani can what you c ni can what you ca





After creating the matrix, you have to sort it by first column of each row, in order of appearance of each character that is repeating and the sort result is
can what you cani
 what you cani can
 you cani can what
 cani can what you
an what you cani c
at you cani can wh
ani can what you c
can what you cani 
cani can what you 
hat you cani can w
i can what you can
n what you cani ca
ni can what you ca
ou cani can what y
t you cani can wha
u cani can what yo
what you cani can 
you cani can what

the output is " ntuchc wnaayao "(last two chars of out put is two spaces, copy-paste it" and index = 10(counting first row as 0).
Problem, reconstruct the initial data based on the small example presented above with matrix sorted, index known and everything in front of you, to help you even more I make the indexes also here there are:
0  |  can what you cani | 10
1  |  what you cani can | 11
2  |  you cani can what | 14
3  |  cani can what you | 15
4  | an what you cani c | 7
5  | at you cani can wh | 9
6  | ani can what you c | 8
7  | can what you cani  | 0
8  | cani can what you  | 1
9  | hat you cani can w | 16
10 | i can what you can | 12
11 | n what you cani ca | 4
12 | ni can what you ca | 5
13 | ou cani can what y | 17
14 | t you cani can wha | 6
15 | u cani can what yo | 13
16 | what you cani can  | 2
17 | you cani can what  | 3

Have fun and drop me a comment if you like the post or the sort.

Wednesday, December 16, 2009

Understanding arrays

One of the most hard-to-understand thing for a beginner in programming(from my point of view) is the array.
If you're a "nub" in programming and arrays are making fun of you, then you should continue reading as I walk you to the bright side of arrays.
Consider a glass of milk as a element of a array and 2 glasses of milk as a array of milk glass, in Delphi code you can define as
// define a new type as record called TMilkGlass
type TMilkGlass = record
                // some info about the milk glass
                Height,
                Quantity : integer;
     end;

// define the array of TMilkGlass defined above
type TArrayOfMilkGlass = array of TMilkGlass;
When you define a array of some type, you tell Delphi's compiler how much memory to allocate when the array size is increased(when you add a new element) or how much memory to free when array size is decreased(when you delete a element).
A way simpler example of the above example would be:
- the milk glass

- the array of milk glass

Seeing the above array of milk glasses, we can observe that we have 6 milk glasses we can define a array like so
type TArrayOfMilkGlass = array[0..5] of TMilkGlass;
When you define a new array of type and you DO NOT mention a range like in above example [0..5] this type of array is called "dynamic array", a array with range i.e. [0..5] is called "static array".
At this time your eyes should be opened(if not, keep trying, don't give up!), but remember:
- dynamic arrays: when you define a dynamic array you must set the length of the array before accessing a element, otherwise you will get a Access Violator :), use SetLength - in order to set the length of the array, Length - to get the length of the array, Low - to get the first element, High - to get the last element.
example of fooling around with a dynamic array
var x : array of integer;
begin
     // allocate space in array for 50 integers
     SetLength(x, 50);
     // get the length of array
     ShowMessage(IntToStr(Length(x)));
     // show as message the first element from array
     ShowMessage(IntToStr(x[Low(x)]));
     // show as message the last element from array
     ShowMessage(IntToStr(x[High(x)]));
     // show as message the starting index of array
     // keeping in consideration that x could have
     // been defined as:
     // x: array[-5..20] of integer;
     ShowMessage(IntToStr(Low(x)));
     // show as message the ending index of array
     ShowMessage(IntToStr(High(x)));
     // free allocated space for x
     SetLength(x, 0);
end;
Note: that arrays that contain objects|classes, needs you to handle the creation and freeing of the objects, array will NOT create or free objects by itself.
- static arrays: Note: that you cannot set the length of a static array at runtime! this type of array is mostly used when you need to define a list of TYPE at design time that would hold some kind of data with a fixed size.
If you have any questions, don't hesitate to ask.
See also all post with array label.

Sunday, December 13, 2009

Bitmap flip and mirror

Yesterday I and a friend of mine needed a bitmap flip(horizontally) algorithm that should be extremely fast. As most of you might know that ScanLine is the fastest approach in manipulating bitmaps, we browsed the net for a already cooked one so we don't waste time.
Well we found some good some bad but at the end we came to the conclusion that we should invest 10-15 min. to create a faster one. The algorithm that my friend created is in procedure FlipHorizontal, I modified the code to be more convenient but the actual definition was procedure FlipBitmap(var thisBitmap: TBitmap).
Anyways here is a class helper which gives 4 handy procedures to a TBitmap.
Note: in order to use the bellow code you must copy-paste all code in the unit you wish to use the flips or mirrors OR add uDGBitmap to uses clause and access directly like BitmapVariable.FlipVertical|FlipHorizontal|MirrorVertical|MirrorHorizontal
unit uDGBitmap;

interface

uses SysUtils,
     Windows,
     Graphics;

// bitmap max width = 32768 pixels
const CMAX_BITMAP_WIDTH = 1024 * 32;

// define a static array of TRGBTriple
type TArrayOfPixel = array[0..CMAX_BITMAP_WIDTH -1] of TRGBTriple;
     PArrayOfPixel = ^TArrayOfPixel;

type TDGBitmap = class Helper for TBitmap
     public
           // define public procedures
           procedure FlipHorizontal;
           procedure FlipVertical;
           procedure MirrorHorizontal;
           procedure MirrorVertical;
     end;

implementation

{ TDGBitmap }

procedure TDGBitmap.FlipHorizontal;
var y, x : Integer;
    Row : PArrayOfPixel;
    tmp : TRGBTriple;
begin
     for y := 0 to Self.Height -1 do begin
         // scan each line starting from top
         Row := Self.ScanLine[y];
         // from left side of the bitmap to half it's size
         for x := 0 to Self.Width div 2 do begin
             // replace left side with right side of the bitmap
             // this is the magical flip
             tmp := Row[x];
             Row[x] := Row[Self.Width -x -1];
             Row[Self.Width -x -1] := tmp;
         end;// for x := 0 to Self.Width div 2 do begin
     end;// for y := 0 to Self.Height -1 do begin
end;

procedure TDGBitmap.FlipVertical;
var i, y : integer;
    RowSrc, RowDest : PArrayOfPixel;
    // temporary bitmap on which we draw the
    // flipped bitmap
    tmpBitmap : TBitmap;
begin
     // create a temporary bitmap
     tmpBitmap := TBitmap.Create;
     // assign self to it
     tmpBitmap.Assign(Self);
     // scan each line starting from top
     for y := 0 to Self.Height -1 do begin
         // RowSrc is current line from self
         RowSrc := Self.ScanLine[y];;
         // RowDest is current line from tmpBitmap
         RowDest := tmpBitmap.ScanLine[Self.Height -1 -y];
         // copy each pixel from RowSrc to RowDest
         for i := 0 to Self.Width -1 do
             RowDest[i] := RowSrc[i];
     end;// for y := 0 to Self.Height -1 do begin
     // copy all data from tmpBitmap to self
     Self.Assign(tmpBitmap);
     // free allocated memory
     FreeAndNil(tmpBitmap);
end;

procedure TDGBitmap.MirrorHorizontal;
var tmpBmp : TBitmap;
    Left : integer;
begin
     // create a temporary bitmap
     tmpBmp := TBitmap.Create;
     // assign data from self
     tmpBmp.Assign(Self);
     // flip it horizontally
     tmpBmp.FlipHorizontal;
     Left := Self.Width;
     // increase the width of bitmap
     // by two
     Self.Width := Self.Width * 2;
     // draw the temporary bitmap
     // with x = Left and y = 0
     Self.Canvas.Draw(Left, 0, tmpBmp);
     // free allocated memory
     FreeAndNil(tmpBmp);
end;

procedure TDGBitmap.MirrorVertical;
var tmpBmp : TBitmap;
    Top : integer;
begin
     // create a temporary bitmap
     tmpBmp := TBitmap.Create;
     // assign data from self
     tmpBmp.Assign(Self);
     // flip it vertically
     tmpBmp.FlipVertical;
     Top := Self.Height;
     // increase the height of bitmap
     // by two
     Self.Height := Self.Height * 2;
     // draw the temporary bitmap
     // with x = 0 and y = Top
     Self.Canvas.Draw(0, Top, tmpBmp);
     // free allocated memory
     FreeAndNil(tmpBmp);
end;

end.

Tuesday, December 8, 2009

Turbo parser example

Here is a example of counting tokens from a file with Turbo parser.
Create a new VCL forms application, drop a TOpenDialog(rename it to OpenDialog) and a TButton on the form, double-click Button1 and copy-paste this code:
procedure TForm1.Button1Click(Sender: TObject);
// token record that holds the type and count
type TTokenRecord = record
                  Token : TurboTokenType;
                  Count : Integer;
     end;

// array of tokens
type TTokenRecordArray = array of TTokenRecord;

var Parser : TurboParser;
    Token : TurboTokenType;
    TokenArr : TTokenRecordArray;

      // this procedure tries to find "Token" type in
      // TokenArr and increment the count.
      // if "Token" type does not exist in array then
      // it creates a entry for it by increasing the
      // number of elements in "TokenArr"
      procedure CountThisToken;
      var index : Integer;
      begin
           for index := Low(TokenArr) to High(TokenArr) do
               if TokenArr[index].Token = Token then begin
                  Inc(TokenArr[index].Count);
                  Exit;
               end;// if TokenArr[i].Token = Token then begin
           SetLength(TokenArr, Length(TokenArr) +1);
           TokenArr[High(TokenArr)].Token := Token;
           TokenArr[High(TokenArr)].Count := 1;
      end;// procedure CountThisToken;

      // this procedure loops through all elements
      // in "TokenArr" and creates a formated string
      // Token "NAME" Count = VALUE + LineBreak
      // Token "NAME" Count = VALUE ...
      procedure ShowCounters;
      var s : string;
          i : integer;
      begin
           s := EmptyStr;
           for i := Low(TokenArr) to High(TokenArr) do
               s := s + Format('Token "%s" Count = %d', [
                 TurboTokenToString(TokenArr[i].Token), TokenArr[i].Count]) + #$D#$A;
           ShowMessage(s);
      end;// procedure ShowCounters;

begin
     if OpenDialog.Execute then begin
        // create a instance of TurboParser class and
        // assign the filename
        Parser := TurboParser.Create(OpenDialog.FileName);
        // start a loop
        while True do begin
              // grab next token
              Token := Parser.GetNextToken;
              // if reached EOF(End-Of-File) or internal error
              // then exit loop
              if Token in [ttEndOfFile, ttInternalError] then
                 Break;
              // find and increment the count of this token
              CountThisToken;
        end;// while True do begin
        // show a formated message with all counters
        ShowCounters;
        // free allocated memory to parser
        FreeAndNil(Parser);
        // set the length of "TokenArr" to zero
        SetLength(TokenArr, 0);
     end;// if OpenDialog.Execute then begin
end;
This is a demo file which on which I've tested the above code(wrote in 7-8 minutes, yes it's that easy to use TurboParser -- which can be easily modified and/or extended)
application TurboParserExample
{
 include
 {
  "filename.extension",
  "otherfilename.extension"
 }

 function main
 {

 }
}
and here is the message I got
---------------------------
Project1
---------------------------
Token "application" Count = 1
Token "" Count = 6
Token "{" Count = 3
Token "include" Count = 1
Token "" Count = 5
Token "." Count = 2
Token "}" Count = 3
Token "function" Count = 1

---------------------------
OK   
---------------------------

Monday, December 7, 2009

Delphi Distiller v1.82 released





New release of Delphi Distiller, currently on version 1.82.
Updates(source http://www.liteapplications.com/)
> Automatically select page for currently installed Delphi version (this feature was present in previous versions but disappeared in v1.80 by mistake).

> Undo button in packages and experts manager allows to discard changes in case that you messed up your selections.

> "Run Delphi 2010" button between "Start Weareg2" and "Stop Weareg2". This makes it easier to call the three of them in a row, since Weareg2 doesn't need to be active after D2010 has started. The "Run Delphi 2010" button saves any pending changes automatically.

MD5 hash: 3ed88cbbf6f5ca8f1f54a777ce79cc6c

Turbo parser

Oh yeah! finally finished a working parser for Turbo, I'm not 100% sure it's bug-free but I hope so :)
The parser is made out of 3 units:
- uTurboParser -- TurboParser class(based on TJvInterpreterParser)
- uTurboParserConst -- constants and variables that TurboParser needs
- uTurboUtils -- this is a work in progress
and here are comes the source code starting with
uTurboParser.pas
(*
  uTurboParser -- is part of Turbo project
  Copyright© Dorin Duminica

  Usage of this file is permited for comercial and non-comercial programs.

  NOTE: if you optimize some of the bellow functions please let me know
*)

unit uTurboParser;

interface

uses
    SysUtils,
    Classes,
    uTurboUtils,
    uTurboParserConst;

type TurboParser = class
     private
            FSource, FPCPos : PChar;
            SourceString : string;
            function GetPos: Integer;
            procedure SetPos(Value: Integer);
            procedure RaiseParserError(const Msg: string; const Args: array of TVarRec);
     public
           TokenValue : string;
     public
           procedure LoadFromFile(const FileName: string);
           function GetNextTokenString: string;
           function GetNextToken: TurboTokenType;
           function TokenAsBoolean: Boolean;
           function TokenAsChar: Char;
           function TokenAsDouble: Double;
           function TokenAsInteger: Integer;
           function TokenAsString: string;
     public
           property Position: Integer
                    read GetPos write SetPos;
     public
           constructor Create(const FileName: string = '');
           destructor Destroy; override;
     end;

implementation uses Windows, Dialogs;

{ TurboParser }

constructor TurboParser.Create(const FileName: string);
begin
     LoadFromFile(FileName);
end;

destructor TurboParser.Destroy;
begin
     SourceString := EmptyStr;
end;

function TurboParser.GetNextTokenString: string;
var
  P, F: PChar;
  F1: PChar;
  I: Integer;
  PrevPoint: Boolean;

  procedure Skip;
  begin
       case P[0] of
            '(':
                if P[1] = '*' then begin
                   F := P + 2;
                   while True do begin
                         F := StrScan(F, '*');
                         if F = nil then
                            RaiseParserError(SBadRemark, [P - PChar(FSource)]);
                         if F[1] = ')' then begin
                            Inc(F);
                            Break;
                         end;// if F[1] = ')' then begin
                         Inc(F);
                   end;// while True do begin
                   P := F + 1;
                end;// if P[1] = '*' then begin
            '*':
                if (P[1] = ')') then
                   RaiseParserError(SBadRemark, [P - PChar(FSource)]);
            '/':
                if (P[1] = '/') then
                   while not CharInSet(P[0], TURBO_LF_CR_NULL) do
                         Inc(P)
                else
                    if (P[1] = '*') then begin
                       F := P + 2;
                       while True do begin
                             F := StrScan(F, '*');
                             if F = nil then
                                RaiseParserError(SBadRemark, [P - PChar(FSource)]);
                             if F[1] = '/' then begin
                                Inc(F);
                                Break;
                             end;// if F[1] = '/' then begin
                             Inc(F);
                       end;// while True do begin
                       P := F + 1;
                    end;// if (P[1] = '*') then begin
       end;// case P[0] of
       while CharInSet(P[0], TURBO_SPACE_LF_CR_TAB) do
             Inc(P);
  end;// procedure Skip;

begin
     { New Token }
     F := FPCPos;
     P := FPCPos;
     PrevPoint := false;
     if (P > PChar(FSource)) and (P[-1] = '.') then
        PrevPoint := true;
     { Firstly skip spaces and remarks }
     repeat
           F1 := P;
           Skip;
     until F1 = P;
     F := P;
     if CharInSet(P[0], TURBO_IDFIRSTSYMBOLS) or PrevPoint and IsCharAlpha(P[0]) then begin
        { token }
        while CharInSet(P[0], TURBO_IDSYMBOLS) or PrevPoint and IsCharAlpha(P[0]) do
              Inc(P);
        SetString(Result, F, P - F);
     end else
         if CharInSet(P[0], TURBO_CONSTSYMBOLS10) then begin
            { number }
            while CharInSet(P[0], TURBO_CONSTSYMBOLS10) or (P[0] = '.') do begin
                  if (P[0] = '.') and (P[1] = '.') then
                     Break;
                  Inc(P);
            end;// while CharInSet(P[0], TURBO_CONSTSYMBOLS10) or (P[0] = '.') do begin
            SetString(Result, F, P - F);
         end else
             if ((P[0] = '$') and CharInSet(P[1], TURBO_CONSTSYMBOLS)) then begin
                { hex number }
                Inc(P);
                while CharInSet(P[0], TURBO_CONSTSYMBOLS) do
                      Inc(P);
                SetString(Result, F, P - F);
             end else
             if P[0] = '''' then begin
                { string constant }
                Inc(P);
                while not CharInSet(P[0], TURBO_LF_CR_NULL) do begin
                      if P[0] = '''' then
                         if P[1] = '''' then
                            Inc(P)
                         else
                             Break;
                      Inc(P);
                end;// while not CharInSet(P[0], TURBO_LF_CR_NULL) do begin
                Inc(P);
                SetString(Result, F, P - F);
                I := 2;
                while I < Length(Result) - 1 do begin
                      if Result[I] = '''' then
                         Delete(Result, I, 1);
                      Inc(I);
                end;// while I < Length(Result) - 1 do begin
             end else
                 if ((P[0] = '#') and CharInSet(P[1], TURBO_CONSTSYMBOLS10)) then begin
                    { Char constant }
                    Inc(P);
                    while CharInSet(P[0], TURBO_CONSTSYMBOLS10) do
                          Inc(P);
                    SetString(Result, F + 1, P - F - 1);
                    Result := '''' + Chr(StrToInt(Result)) + '''';
                 end else
                     if CharInSet(P[0], ['>', '=', '<', '.']) then begin
                        if (P[0] = '.') and (P[1] = '.') then begin
                           Result := '..';
                           Inc(P, 2);
                        end else
                            if (P[0] = '>') and (P[1] = '=') then begin
                               Result := '>=';
                               Inc(P, 2);
                            end else
                                if (P[0] = '<') and (P[1] = '=') then begin
                                   Result := '<=';
                                   Inc(P, 2);
                                end else
                                    if (P[0] = '<') and (P[1] = '>') then begin
                                       Result := '<>';
                                       Inc(P, 2);
                                    end else begin
                                        Result := P[0];
                                        Inc(P);
                                    end;
                     end else
                         if P[0] = #0 then
                            Result := EmptyStr
                         else begin
                              Result := P[0];
                              Inc(P);
                         end;
     FPCPos := P;
end;

function TurboParser.GetNextToken: TurboTokenType;
begin
     TokenValue := GetNextTokenString;
     Result := StringToTurboToken(TokenValue);
end;

function TurboParser.GetPos: Integer;
begin
     Result := FPCPos - PChar(FSource);
end;

procedure TurboParser.LoadFromFile(const FileName: string);
begin
     SourceString := FileToString(FileName);
     FSource := PChar(SourceString);
     FPCPos := PChar(FSource);
end;

procedure TurboParser.RaiseParserError(const Msg: string; const Args: array of TVarRec);
begin
     raise Exception.CreateFmt(Msg, Args);
end;

procedure TurboParser.SetPos(Value: Integer);
begin
     FPCPos := PChar(FSource) + Value;
end;

function TurboParser.TokenAsBoolean: Boolean;
begin
     Result := (StringToTurboToken(TokenValue) = ttTrue);
end;

function TurboParser.TokenAsChar: Char;
begin
     StringIsChar(TokenValue, Result);
end;

function TurboParser.TokenAsDouble: Double;
begin
     StringIsDouble(TokenValue, Result);
end;

function TurboParser.TokenAsInteger: Integer;
begin
     StringIsInteger(TokenValue, Result);
end;

function TurboParser.TokenAsString: string;
begin
     StringIsString(TokenValue, Result);
end;

end.
uTurboParserConst.pas
(*
  uTurboParserConst -- is part of Turbo project
  Copyright© Dorin Duminica

  Usage of this file is permited for comercial and non-comercial programs.

  NOTE: if you optimize some of the bellow functions please let me know
*)

unit uTurboParserConst;

interface

type TurboHash = type Integer;

type TurboTokenType =
     (
                 ttEndOfFile,
                 ttInternalError,
                 ttUnknown,
                 ttIdentifier,
                 ttApplication,
                 ttConsole,
                 ttLibrary,
                 ttInclude,
                 ttSemicolumn,
                 ttResource,
                 ttIn,
                 ttConst,
                 ttEnum,
                 ttVar,
                 ttClass,
                 ttLB,
                 ttRB,
                 ttLS,
                 ttRS,
                 ttPoint,
                 ttFunction,
                 ttBegin,
                 ttEnd,
                 ttReturn,
                 ttInitialization,
                 ttFinalization,
                 ttIf,
                 ttElse,
                 ttWhile,
                 ttDo,
                 ttSwitch,
                 ttColumn,
                 ttDefault,
                 ttTry,
                 ttExcept,
                 ttFinally,
                 ttLabel,
                 ttGoTo,
                 ttFactorial,
                 ttNot,
                 ttPower,
                 ttAnd,
                 ttOr,
                 ttXor,
                 ttShl,
                 ttShr,
                 ttMod,
                 ttIntDiv,
                 ttPercent,
                 ttMul,
                 ttDiv,
                 ttPlus,
                 ttMinus,
                 ttEqual,
                 ttNotEqual,
                 ttGreater,
                 ttLess,
                 ttGreaterOrEqual,
                 ttLessOrEqual,
                 ttAssign,
                 ttAssignMul,
                 ttAssignDiv,
                 ttAssignPlus,
                 ttAssignMinus,
                 ttTrue,
                 ttFalse,
                 ttVInteger,
                 ttVChar,
                 ttVString,
                 ttVDouble
     );

const szTurboTokenType = sizeof(TurboTokenType);

type TurboTokenRec = record
                  TokenType: TurboTokenType;
                  Value: string;
                  Hash: TurboHash;
     end;

const CTURBO_KEYWORD_COUNT = 61;

// this is a map of all available tokens in Turbo initializaed with
// hash = 0, because in the initialization section of unit
// each token will be hashed
var TurboTokens: array[0..CTURBO_KEYWORD_COUNT -1] of TurboTokenRec =
    (
     (TokenType: ttApplication    ; Value: 'application';    Hash: 0),
     (TokenType: ttConsole        ; Value: 'console';        Hash: 0),
     (TokenType: ttLibrary        ; Value: 'Library';        Hash: 0),
     (TokenType: ttInclude        ; Value: 'include';        Hash: 0),
     (TokenType: ttSemicolumn     ; Value: ';';              Hash: 0),
     (TokenType: ttResource       ; Value: 'resource';       Hash: 0),
     (TokenType: ttIn             ; Value: 'in';             Hash: 0),
     (TokenType: ttConst          ; Value: 'const';          Hash: 0),
     (TokenType: ttEnum           ; Value: 'enum';           Hash: 0),
     (TokenType: ttVar            ; Value: 'var';            Hash: 0),
     (TokenType: ttClass          ; Value: 'class';          Hash: 0),
     (TokenType: ttLB             ; Value: '(';              Hash: 0),
     (TokenType: ttRB             ; Value: ')';              Hash: 0),
     (TokenType: ttLS             ; Value: '[';              Hash: 0),
     (TokenType: ttRS             ; Value: ']';              Hash: 0),
     (TokenType: ttPoint          ; Value: '.';              Hash: 0),
     (TokenType: ttFunction       ; Value: 'function';       Hash: 0),
     (TokenType: ttBegin          ; Value: '{';              Hash: 0),
     (TokenType: ttEnd            ; Value: '}';              Hash: 0),
     (TokenType: ttReturn         ; Value: 'return';         Hash: 0),
     (TokenType: ttInitialization ; Value: 'initialization'; Hash: 0),
     (TokenType: ttFinalization   ; Value: 'finalization';   Hash: 0),
     (TokenType: ttIf             ; Value: 'if';             Hash: 0),
     (TokenType: ttElse           ; Value: 'else';           Hash: 0),
     (TokenType: ttWhile          ; Value: 'while';          Hash: 0),
     (TokenType: ttDo             ; Value: 'do';             Hash: 0),
     (TokenType: ttSwitch         ; Value: 'switch';         Hash: 0),
     (TokenType: ttColumn         ; Value: ':';              Hash: 0),
     (TokenType: ttDefault        ; Value: 'default';        Hash: 0),
     (TokenType: ttTry            ; Value: 'try';            Hash: 0),
     (TokenType: ttExcept         ; Value: 'except';         Hash: 0),
     (TokenType: ttFinally        ; Value: 'finally';        Hash: 0),
     (TokenType: ttLabel          ; Value: 'label';          Hash: 0),
     (TokenType: ttGoTo           ; Value: 'goto';           Hash: 0),
     (TokenType: ttFactorial      ; Value: '!';              Hash: 0),
     (TokenType: ttNot            ; Value: 'not';            Hash: 0),
     (TokenType: ttAnd            ; Value: 'and';            Hash: 0),
     (TokenType: ttOr             ; Value: 'or';             Hash: 0),
     (TokenType: ttXor            ; Value: 'xor';            Hash: 0),
     (TokenType: ttShl            ; Value: 'shl';            Hash: 0),
     (TokenType: ttShr            ; Value: 'shr';            Hash: 0),
     (TokenType: ttMod            ; Value: 'mod';            Hash: 0),
     (TokenType: ttIntDiv         ; Value: 'div';            Hash: 0),
     (TokenType: ttPercent        ; Value: '%';              Hash: 0),
     (TokenType: ttMul            ; Value: '*';              Hash: 0),
     (TokenType: ttDiv            ; Value: '/';              Hash: 0),
     (TokenType: ttPlus           ; Value: '+';              Hash: 0),
     (TokenType: ttMinus          ; Value: '-';              Hash: 0),
     (TokenType: ttEqual          ; Value: '=';              Hash: 0),
     (TokenType: ttNotEqual       ; Value: '<>';             Hash: 0),
     (TokenType: ttGreater        ; Value: '>';              Hash: 0),
     (TokenType: ttLess           ; Value: '<';              Hash: 0),
     (TokenType: ttGreaterOrEqual ; Value: '>=';             Hash: 0),
     (TokenType: ttLessOrEqual    ; Value: '<=';             Hash: 0),
     (TokenType: ttAssign         ; Value: ':=';             Hash: 0),
     (TokenType: ttAssignMul      ; Value: '*=';             Hash: 0),
     (TokenType: ttAssignDiv      ; Value: '/=';             Hash: 0),
     (TokenType: ttAssignPlus     ; Value: '+=';             Hash: 0),
     (TokenType: ttAssignMinus    ; Value: '-=';             Hash: 0),
     (TokenType: ttTrue           ; Value: 'true';           Hash: 0),
     (TokenType: ttFalse          ; Value: 'false';          Hash: 0)
    );

const LowTurboTokens = Low(TurboTokens);
      HighTurboTokens = High(TurboTokens);

const TURBO_UNDERSCORE      = ['_'];
      TURBO_DIGITS          = ['0'..'9'];
      TURBO_DOUBLE_CHARS    = TURBO_DIGITS + ['.'];
      TURBO_A_TO_F          = ['A'..'F', 'a'..'f'];
      TURBO_A_TO_Z          = ['A'..'Z', 'a'..'z'];
      TURBO_HEX             = TURBO_DIGITS + TURBO_A_TO_F;
      TURBO_IDSYMBOLS       = TURBO_UNDERSCORE + TURBO_DIGITS + TURBO_A_TO_Z;
      TURBO_IDFIRSTSYMBOLS  = TURBO_UNDERSCORE + TURBO_A_TO_Z;
      TURBO_CONSTSYMBOLS    = TURBO_DIGITS + TURBO_A_TO_F;
      TURBO_CONSTSYMBOLS10  = TURBO_DIGITS;
      TURBO_SEPARATORS      = ['(', ')', ',', '.', ';'];
      TURBO_CR              = #$D;
      TURBO_LF              = #$A;
      TURBO_TAB             = #9;
      TURBO_NULL            = #0;
      TURBO_SPACE           = ' ';
      TURBO_CRLF            = TURBO_CR + TURBO_LF;
      TURBO_LF_CR_TAB       = [TURBO_LF, TURBO_CR, TURBO_TAB];
      TURBO_SPACE_LF_CR_TAB = [TURBO_SPACE, TURBO_LF, TURBO_CR, TURBO_TAB];
      TURBO_LF_CR_NULL      = [TURBO_LF, TURBO_CR, TURBO_NULL];

resourcestring
              SBadRemark = 'Bad remark at position: %d';

implementation uses uTurboUtils;


procedure HashTokens;
var i : integer;
    s : string;
begin
     for i := LowTurboTokens to HighTurboTokens do begin
         s := TurboTokens[i].Value;
         TurboTokens[i].Hash := TurboHashString(s);
     end;// for i := LowTurboTokens to HighTurboTokens do begin
end;

initialization
              HashTokens;

end.
uTurboUtils.pas
(*
  uTurboUtils -- is part of Turbo project
  Copyright© Dorin Duminica

  Usage of this file is permited for comercial and non-comercial programs.

  NOTE: if you optimize some of the bellow functions please let me know
*)

unit uTurboUtils;

interface

uses SysUtils, uTurboParserConst;

function TurboHashString(const s: string): TurboHash;
function FileToString(const FileName: string): string;
function FileToStringA(const FileName: string): AnsiString;
function FileToStringU(const FileName: string): string;
function TurboTokenToString(thisToken: TurboTokenType): string;
function StringToTurboToken(const s: string): TurboTokenType;
function StringIsHex(const s: string): Boolean; overload;
function StringIsHex(const s: string; var Value: Integer): Boolean; overload;
function StringIsChar(const s: string): Boolean; overload;
function StringIsChar(const s: string; var Value: Char): Boolean; overload;
function StringIsString(const s: string): Boolean; overload;
function StringIsString(const s: string; var Value: string): Boolean; overload;
function StringIsInteger(const s: string): Boolean; overload;
function StringIsInteger(const s: string; var Value: Integer): Boolean; overload;
function StringIsDouble(const s: string): Boolean; overload;
function StringIsDouble(const s: string; var Value: Double): Boolean; overload;
function IsFileUnicode(const FileName: string): Boolean;
function IsFileUTF8(const FileName: string): Boolean;

implementation uses Classes, Windows;

function TurboHashString(const s: string): TurboHash;
var i : integer;
    c : Char;
begin
     Result := 0;
     for i := 1 to Length(s) do begin
         c := s[i];
         c := UpCase(c);
         Result := ((Result shl 7) or (Result shr 25)) + Ord(c);
     end;// for i := 1 to Length(s) do begin
end;

function FileToString(const FileName: string): string;
begin
     Result := EmptyStr;
     if not FileExists(FileName) then
        Exit;
     if IsFileUnicode(FileName) or IsFileUTF8(FileName) then
        Result := FileToStringU(FileName)
     else
         Result := String(FileToStringA(FileName));
end;

function FileToStringA(const FileName: string): AnsiString;
var FileStream : TFileStream;
begin
     Result := AnsiString(EmptyStr);
     if not FileExists(FileName) then
        Exit;
     FileStream := TFileStream.Create(FileName, fmOpenRead);
     SetLength(Result, FileStream.Size);
     FileStream.Read(Pointer(Result)^, FileStream.Size);
     FreeAndNil(FileStream);
end;

function FileToStringU(const FileName: string): string;
var FileStream : TFileStream;
begin
     Result := EmptyStr;
     if not FileExists(FileName) then
        Exit;
     FileStream := TFileStream.Create(FileName, fmOpenRead);
     SetLength(Result, FileStream.Size);
     FileStream.Read(Pointer(Result)^, FileStream.Size);
     FreeAndNil(FileStream);
end;

function TurboTokenToString(thisToken: TurboTokenType): string;
var i : integer;
begin
     Result := EmptyStr;
     for i := LowTurboTokens to HighTurboTokens do
         if TurboTokens[i].TokenType = thisToken then begin
            Result := TurboTokens[i].Value;
            Exit;
         end;// if TurboTokens[i].TokenType = thisToken then begin
end;

function StringToTurboToken(const s: string): TurboTokenType;
var i : integer;
    h : TurboHash;
begin
     if s = EmptyStr then begin
        Result := ttEndOfFile;
        Exit;
     end;// if s = EmptyStr then begin
     Result := ttUnknown;
     h := TurboHashString(s);
     for i := LowTurboTokens to HighTurboTokens do
         if TurboTokens[i].Hash = h then begin
            Result := TurboTokens[i].TokenType;
            Exit;
         end;// if TurboTokens[i].Hash = h then begin
     if StringIsHex(s) or StringIsInteger(s) then begin
        Result := ttVInteger;
        Exit;
     end;// if StringIsHex(s) or StringIsInteger(s) then begin
     if StringIsString(s) then begin
        Result := ttVString;
        Exit;
     end;// if StringIsString(s) then begin
     if StringIsChar(s) then begin
        Result := ttVChar;
        Exit;
     end;// if StringIsChar(s) then begin
     if StringIsDouble(s) then begin
        Result := ttVDouble;
        Exit;
     end;// if StringIsDouble(s) then begin
end;

function StringIsHex(const s: string): Boolean;
var i : integer;
begin
     Result := False;
     if Length(s) > 1 then begin
        if s[1] = '$' then
           for i := 2 to Length(s) do
               if not CharInSet(s[i], TURBO_HEX) then
                  Exit;
     end else
         Exit;
     Result := True;
end;

function StringIsHex(const s: string; var Value: Integer): Boolean;
begin
     Value := 0;
     Result := StringIsHex(s);
     if Result then
        Value := StrToInt(s);
end;

function StringIsChar(const s: string): Boolean;
var c : char;
begin
     Result := StringIsChar(s, c);
end;

function StringIsChar(const s: string; var Value: Char): Boolean;
const CHAR_ORDINAL = '#';
      CHAR_HEX = '#$';
var i, p, len : integer;
begin
     Result := True;
     len := Length(s);
     p := Pos(CHAR_HEX, s);
     if p = 1 then begin
        // in this case we have something like #$HEX_VALUE
        // check if remaining chars are hex
        for i := 3 to Len do
            if not CharInSet(s[i], TURBO_HEX) then
               Exit;
        Value := Char(StrToInt(Copy(s, 2, Length(s) -1)));
        Exit;
     end else begin
         // in this case we have something like #ORDINAL_VALUE
         // check if remaining chars are digits
         for i := 2 to Len do
             if not CharInSet(s[i], TURBO_DIGITS) then
                Exit;
         p := Pos(CHAR_ORDINAL, s);
         if p = 1 then begin
            Value := Char(StrToInt(Copy(s, 2, Length(s) -1)));
            Exit;
         end;// if p = 1 then begin
     end;// if p = 1 then begin
     Result := False;
end;

function StringIsString(const s: string): Boolean;
begin
     Result := (Length(s) >= 2) and ((s[1] = '"') and (s[Length(s)] = '"'));
end;

function StringIsString(const s: string; var Value: string): Boolean;
begin
     Result := StringIsString(s);
     if Result then
        Value := Copy(s, 2, Length(s) -1);
end;

function StringIsInteger(const s: string): Boolean;
var i : integer;
begin
     Result := False;
     for i := 1 to Length(s) do
         if not CharInSet(s[i], TURBO_DIGITS) then
            Exit;
     Result := True;
end;

function StringIsInteger(const s: string; var Value: Integer): Boolean;
begin
     Result := StringIsInteger(s);
     if Result then
        Value := StrToInt(s);
end;

function StringIsDouble(const s: string): Boolean;
var d : Double;
begin
     Result := StringIsDouble(s, d);
end;

function StringIsDouble(const s: string; var Value: Double): Boolean;
var i, PointCount : integer;
begin
     Result := False;
     PointCount := 0;
     for i := 1 to Length(s) do
         case s[i] of
              '.': Inc(PointCount);
              '0'..'9': ;
              else
                  Exit;
         end;// case s[i] of
     if PointCount <= 1 then begin
        Value := StrToFloat(s);
        Result := True;
        Exit;
     end;// if PointCount <= 1 then begin
end;

function IsFileUnicode(const FileName: string): Boolean;
var hFile : THandle;
    Buffer: Word;
    BytesRead: DWORD;
begin
     Result := False;
     hFile := FileOpen(FileName, FILE_SHARE_READ);
     if hFile <> INVALID_HANDLE_VALUE then
        try
           Buffer := 0;
           SetFilePointer(hFile, 0, nil, FILE_BEGIN);
           Result := ReadFile(hFile, Buffer, SizeOf(Buffer), BytesRead, nil) and
                     (BytesRead>=SizeOf(Buffer)) and
                     ((Buffer=$FEFF) or (Buffer=$FFFE));
        finally
               CloseHandle(hFile);
        end;// try...
end;

function IsFileUTF8(const FileName: string): Boolean;
var hFile : THandle;
    Buffer: packed array[0..2] of byte;
    BytesRead: DWORD;
begin
     Result := False;
     hFile := FileOpen(FileName, FILE_SHARE_READ);
     if hFile <> INVALID_HANDLE_VALUE then
        try
           FillChar(Buffer, SizeOf(Buffer), 0);
           SetFilePointer(hFile, 0, nil, FILE_BEGIN);
           Result := ReadFile(hFile, Buffer, SizeOf(Buffer), BytesRead, nil) and
                     (BytesRead>=SizeOf(Buffer)) and
                     ((Buffer[0]=$EF) and (Buffer[1]=$BB) and (Buffer[2]=$BF));
        finally
               CloseHandle(hFile);
        end;
end;

end.
Turbo roadmap
[X] complete grammar
[X] dynamic parser which can be easily extended in the future
[-] expression evaluator
[-] compiler
[-] first program(GUI and console)
[-] Turbo IDE(which can be extended using Turbo)

Note that anyone can join the project if he/she has:
- medium Delphi knowledge
- the will to learn new things

Thursday, December 3, 2009

Turbo grammar

Surprise, surprise!
Do you guess what Santa will post today? Yes! that's right, the grammar for Turbo!
Abstract definition of a application|console|library in Turbo

application|console|library IDENTIFIER_NAME
{
        // use external libraries
        using LIBRARY_NAME1;
        using LIBRARY_NAME2;

        // include files as resource
        resource RESOURCE_NAME in "[PATH\]FILENAME.EXTENSION";

        // define constants
        const CONST_NAME = CONST_VALUE;

        const CONST_ARRAY_NAME = [VALUE_LIST];

        // enumeration
        enum {ENUM_NAME[, ENUM_NAME_LIST}

        // define variables
        var VAR_NAME[, VAR_NAME_LIST];

        // define class
        class CLASS_NAME ( BASE_CLASS_NAME )
        {
                // define class constants
                const CONST_NAME = CONST_VALUE;

                // define class variables
                var VAR_NAME[, VAR_NAME_LIST];

                // define class functions
                function FUNCTION_NAME( PARAM[, PARAM_NAME_LIST)
                {
                        // define function constants
                        const CONST_NAME = CONST_VALUE;

                        // define function variables
                        var VAR_NAME[, VAR_NAME_LIST];

                        return RETURN_VALUE;
                }
        }

        // define application's MAIN function, reserved word!
        // this will be executed only in application|console mode
        // for library use "initialization" simulate "main"
        function main
        {
                // do something
        }
}

But wait! that's some JavaScript(ECMA Script) combined with C#?!
Yup! and a bit of Delphi(Pascal) if you continue reading.
After searching the net for hours I came to the conclusion that C-like languages are more welcomed by masses.

Here is how statements will be defined in Turbo
STATEMENTS
-- IF
        if (CONDITION)
                STATEMENT;

        if (CONDITION)
        {
                STATEMENT_LIST;
        }
        else
        {
                STATEMENT_LIST;
        }


-- FOR
        for (IDENTIFIER = VALUE; CONDITION; UPDATE_EXPRESSION)
                STATEMENT;

        for (IDENTIFIER = VALUE; CONDITION; UPDATE_EXPRESSION)
        {
                STATEMENT_LIST;
        }


-- WHILE
        while (CONDITION)
                STATEMENT;

        while (CONDITION)
        {
                STATEMENT_LIST;
        }


-- DO
        do
        {
                STATEMENT_LIST;
        }
        while (CONDITION);


-- SWITCH
        switch (IDENTIFIER|VALUE)
        {
                CASE_VALUE: STATEMENT;

                default: STATEMENT;
        }

        switch (IDENTIFIER|VALUE)
        {
                CASE_VALUE:
                {
                        STATEMENT_LIST;
                }

                default:
                {
                        STATEMENT;
                }
        }


-- TRY
        try
        {
                STATEMENT_LIST;
        }

        try
        {
                STATEMENT_LIST;
        }
        except
        {
                DO_ON_EXCEPTION;
        }

        try
        {
                STATEMENT_LIST;
        }
        finally
        {
                DO_FINALLY;
        }

        try
        {
                STATEMENT_LIST;
        }
        except
        {
                DO_ON_EXCEPTION;
        }
        finally
        {
                DO_FINALLY;
        }
But wait, there's more! initialization and finalization of application|console|library
INITIALIZATION/FINALIZATION
executes a statement or statement list at the initialization or
finalization of the application|console|library.

ex:

initialization
        STATEMENT;

initialization
{
        STATEMENT_LIST;
}

finalization
        STATEMENT;

finalization
{
        STATEMENT_LIST;
}
Even if you love labels or not, there will be goto's!
LABELS
using labels is possible by writing "label" keyword before the label name
label LABEL_NAME:

use "goto LABEL_NAME;" to jump to a label
How about embeding binary or text files?
RESOURCES
you can embed external files(binary files, text files, etc.) by using
the following syntax

resource RESOURCE_NAME in "[PATH\]FILENAME.EXTENSION";

RESOURCE_NAME -- will be used to access resource
Here they come, who? the operators!
OPERATORS
!       factorial, retrieves the factorial value of IDENTIFIER
ex:     a!

^       power, BASE^EXPONENT
ex:     a ^ b

not     negate
ex:     not a, negate value of a

and     logial AND
ex:     a and b, a and b is true

or      logical OR
ex:     a or b, a or b is true

xor     exclusive OR
ex:     a xor b

shl     bitwise shift left
ex:     a shl b, shift a's bits to the left by b

shr     bitwise shift right
ex:     a shr b, shift a's bits to the right by b

mod     modulo
ex:     a mod b, the remain of dividing a by b

div     integer division
ex:     a div b, divide a by b and return a integer value

%       percent left of right
ex:     a % b is equal to a * b / 100

*       multiply
ex:     a * b

/       divide
ex:     a / b

+       add
ex:     a + b

-       subtract
ex:     a - b

=       equal
ex:     a = b, check equality

>       greater than
ex:     a > b

<       less than
ex:     a < b

>=      greater or equal
ex:     a >= b

<=      less or equal
ex:     a <= b

:=      assignment
ex:     a := b

*=      assignment of multiplication
ex:     a *= b, same as a := a * b

/=      assignment of division
ex:     a /= b, same as a := a / b

+=      assignment by addition
ex:     a += b, same as a := a + b;

-=      assignment by subtraction
ex:     a -= b, same as a := a - b;

IDENTIFIER++    increment IDENTIFIER's VALUE
IDENTIFIER--    decrement IDENTIFIER's VALUE
And who can forget about the good old comments?
COMMENTS
-- single line
        // comment

-- multiline
        /* comment line 1
           comment line 2
                ...
           comment line n */
STRINGS
-- strings are between double quotes
"this is a simple string"
CHARACTERS
characters can be represented as single "a" or
#128 -- 128 is it's ordinal value
characters can be concatenated with strings
ex: "this is a simple string" + #128 = "this is a simple string €"
But where are the numbers?
NUMBERS
-- integer 1, 2, 3
-- hex $FFAACC
-- float 123.456
Any comments?

Wednesday, December 2, 2009

Turbo project start

After reading comments on Turbo's grammar I've decided that I will stick with a grammar similar to Pascal even though it's a bit too verbose -- new programmers can take advantage of this and embrace the world of computer programming, therefore I will start working on a parser for Turbo, if anyone is willing to contribute to the project please let me know via e-mail or post a comment.
From now on I will post the progress of Turbo.
Turbo roadmap
[-] complete grammar
[-] dynamic parser which can be easily extended in the future
[-] expression evaluator
[-] compiler
[-] first program(GUI and console)
[-] Turbo IDE(which can be extended using Turbo)

Thursday, November 26, 2009

How about a new interpreter language similar to Delphi?

I'm thinking for a long time about creating a interpreted language with the hope that will improve application development by at least 200%, you might think I'm joking now or that I'm out of my mind, but read on and you will understand how development time decreases.
Did you know that you "waste" somewhere between 5 and 10% of your time writing variable types? I mean
var myvar : TMyType;
how about the time wasted "asking" Google to help you with your question? Oh... not to mention about the bad names(in most programming and interpreted languages) for functions classes, i.e. writeln, readln, print, printf, strcpy, etc.
Anywayz I don't want to waste more of your time with this kind of stuff, I'm pretty sure you got the idea until now.
Here's the grammar(until now for my "to be" interpreted language")
Language: Turbo
application|console IDENTIFIER

  include|import|use|uses 'filename.extension';// not sure yet about the include

  var IDENTIFIER[, IDENTIFIER1, IDENTIFIERN];

  class IDENTIFIER extends|for IDENTIFIER

    private|public

      var IDENTIFIER[, IDENTIFIER1, IDENTIFIERN];

      function IDENTIFIER(PARAMETER[, PARAMETER1, PARAMETER2])
      end; {function}

  end; {class}

  function IDENTIFIER(PARAMETER[, PARAMETER1, PARAMETER2])
    var IDENTIFIER[, IDENTIFIER1, IDENTIFIERN];
    | code
  end; {function}

If statement

  if CONDITION then
    |
  end; {if}

  if CONDITION then
    |
  else
    |
  end; {if]

For statement

  for var index :=|= INTEGER VALUE to|downto INTEGER VALUE [step INTEGER VALUE] do
    | in the for loop you can assign the value of "index" variable
    | as in good old Pascal
  end; {for}

While and repeat statements
  while CONDITION do
    |
  end; {while}

  repeat
    |
  until CONDITION; {repeat}

Case

  case VALUE[INTEGER, STRING, CHAR] of
    IDENTIFIER|[INTEGER|STRING|CHAR VALUE]:
      |
    end; {IDENTIFIER|[INTEGER|STRING|CHAR VALUE] case}
    else
      |
    end; {else case}
  end; {case}

Try
-- there can be 4 types of tries
1:
  try
    | just try to execute code nothing else matters
  end; {try}

2:
  try
    | execute code and execute except block on exception
  except
    |
  end; {try}

3:
  try
    | try to execute code, no matter what, the code in finally
    | block gets executed
  finally
    |
  end; {try}

4:
  try
    | try to execute code, handle exception and execute finally block
    | like two nested tries in Delphi
  except
    |
  finally
    |
  end; {try}

Initialization and finalization of a include file or application|console

  initialization
     |
  finalization
     |

end; {application|console}
As you can see there are no begins I consider as wasting time to write, any declaration ends with end keyword.
The main idea is that all function/class names tell you what it actually does, for instance StringCopy, to copy a part from a string and Console.WriteLine(I know it's like delphi combined with .NET, but it actually looks clean!).
I think it will be created in Delphi but compiled with Freepascal so it can go cross platform baby!
Anyways, I really want to read your opinions and maybe start the project with someone.

Reserved names in Access

In all projects I work, we use Postgresql as database, therefore I'm used to this kind of SQL syntax
INSERT INTO "TableName"("FieldOne", "FieldTwo", "FieldN") VALUES('Value1', 'Value2', 'ValueN');
but yesterday I had to implement and use a local database made in access and access it using ADO, all was OK until I've encountered a superficial error, I had to insert a new record but one of the fields has the name Date, now here's where the error comes, Date is a reserved word!! therefore I got a lot of errors and didn't knew where the problem came from until I've surrounded each field name between brackets like "[" and "]" in this case the field name is not treated as reserved word even though it is
-- the error
INSERT INTO aTable(FieldOne, FieldTwo, Date) VALUES('x', 'x', #2009-25-12 14:14:00#);

-- after figuring out the problem here is the new insert script
INSERT INTO aTable([FieldOne], [FieldTwo], [Date]) VALUES('x', 'x', #2009-25-12 14:14:00#);
So in order to play safe, put each field name between "[" and "]" and you will know that this won't be the error when you get sql syntax error :).
Postgre, on the other hand, has a much better syntax because, each table name or field name must be between double quotes and functions or reserved words are not.
If you know any other error like the one I've mentioned above, feel free to comment.

Friday, November 20, 2009

Delphi project explained

This is another post for Delphi beginners.
In this post I will try to explain what a Delphi project contains and how a GUI application is created.
Start Delphi > File -> New -> Application|VCL Forms Application press SHIFT+CTRL+S(this shortcut saves all files opened in Delphi IDE) save everything to a folder without naming them.
At this point you should have 4 or 5 files(I'm not sure from what version of Delphi they introduced ProjectName.dproj(xml) -- you can delete the .dproj file it will be automatically recreated) file, and here are the names of files
- Project1.dpr -- this is the program with which you should be familiar i.e.
program delphiOnSteroids;
begin
     WriteLn('Hi dudes!');
     ReadLn;
end.
- Project1.res -- this file keeps the application's icon, it can be deleted and will be recreated after IDE shows you and error file which says that the resource file cannot be found and it will be recreated
- Unit1.dfm -- files with *.dfm extension contains information about objects on the form and form information, i.e. control width, height, color, font, etc.
- Unit1.pas -- this file contains code that defines and implements a new class of form with ease.

Did you know that when you create a new form and add a few controls on the form, modify them, add events, etc. you basically create a new class without even noticing?
Here is unit1.pas after creating a new project and saving it without modifying anything but adding two variables in order to explain the private and public keywords
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm1 = class(TForm)
  private
         ImAPrivateString: String;
// ImAPrivateString can be viewed only by descendants
// of this class or by class it self
    { Private declarations }
  public
        ImAPublicInteger: Integer;
//ImAPublicInteger can be accessed publicly by
// typing the name of the identifier which is of type this class.identifier
// for instance Form1.ImAPublicInteger := 2009;
    { Public declarations }
  end;

var
  Form1: TForm1; // this is a unit variable which can be accessed from
// other units by adding this unit to it's uses clause
// i.e. uses unit1;
// this variable means nothing without this line of code in the *.dpr file
// Application.CreateForm(TForm1, Form1);
// the above procedure creates a new form of type TForm1 and assigns
// it to Form1 variable which is the name of the form in unit1

implementation

{$R *.dfm} // this is a compiler directive which tells the compiler
// something like, *whistle* hey compiler the file with same name as 
// mine but with *.dfm extension is my form's properties, you know
// what to do with them!

end.
Let's analyze the *.dpr file
program Project1; // define the name of the program
// MUST be same as filename.dpr(without ".dpr) in our case Project1.dpr

uses
  Forms, // need this in order to create forms
// as you can see here you can also declare a relative path
// for instance UnitX in '..\DistancedUnit.pas'
// you even have a comment to let you know that it's about Form1
  Unit1 in 'Unit1.pas' {Form1};

// the ProjectName.res file that I was talking about
// compiler adds this to the executable
{$R *.res}

begin
// Delphi developers are saying this:
// This used to call InitProc, which was only used for COM and CORBA.
// Neither is used with the .NET version 
// about Application.Initialize;
  Application.Initialize;
// this is something new introduced since Delphi 2007 if I'm 
// not mistaken
  Application.MainFormOnTaskbar := True;
// creates and assigns a instance of type TForm to the unit
// variable Form1 in Unit1.pas
  Application.CreateForm(TForm1, Form1);
// this will start your application and shows Form1
// if you write somewhere Application.MainForm := SomeFormVariable
// then when that form closes your application terminates!
  Application.Run;
end.
About the *.dfm files, it's actually plain text, images/resources of components are stored as hex strings, you can call a *.dfm a better storage than the *.ini file, when you call Application.CreateForm(bla bla) the application reads the *.dfm stored in the *.exe as resource and creates the controls as defined in the *.dfm with lightning speed using RTTI(Run Time Type Information).

Thursday, November 19, 2009

Delphi and C fusion

Yesterday I found out about an interesting programming language called Go.
From their website examples you can clearly see that Go is trying to shout at Delphi and C/C++ programmers, example
func main() {
  fmt.Printf("Hello, 世界\n")
}
from the above example, a Delphi programmer would say that it should be a procedure not a function(func) because it does not have a result type... a C programmer can see that void is replaced by func.

What I really hate in all programming languages is that programmers are trying to "compress" names(of function, constants, variables, etc.) so it would be less typing involved in the future, take for example strcpy, WHY the hell didn't they just name it strcopy or even StringCopy?! or strlen and so on...


Another thing I hate in C/C++/Java(and others inspired by them) is the assignment, because it's the equal sign "=" why not "==" and "=" to check equality ex. if (a=b){}, but nooo they had to use "==" which according to your math logic it means nothing, when you write IDENTIFIER = VALUE it doesn't have any logic, because you assign a value to the IDENTIFIER variable, rite?
Anywayz Go has something special which attracts me but only because it's new, I don't really think any other programming language can attract me more than Delphi, Delphi has all I really need(and if not, then hes step brother comes into play and takes over a.K.a Freepascal):
- Language is very readable
- Very powerful
- True RAD(Rapid Application Development), I really bulive that RAD comes from Delphi, can't think of any other programming language which is more RAD than Delphi...
- The most powerful IDE in the business, not to mention Delphi 7 released in 2002 which has so many freaking feauters that no other IDE at that time had...
- the list is so long but I'm tired after a long day at work so I let you think of the rest.
Don't get me wrong, I'm not one of those guys(my programming languages is better/faster/bla bla than yours), I've tried C++, C, Java, Python, Ruby and Visual Basic(I really really really hate this programming language, it has something that makes me wanna scream!) but I couldn't find other programming language that worth my time, from all mentioned above I could work in C for some time but I would give up after 2k lines of code and about 700 curly brackets(those makes you dizzzzzy).
Ok back to Go :), from what I can see Go is here and will Go pretty sooon(in my opinion), why? take this example from their website
func unhex(c byte) byte {
    switch {
    case '0' <= c && c <= '9':
        return c - '0'
    case 'a' <= c && c <= 'f':
        return c - 'a' + 10
    case 'A' <= c && c <= 'F':
        return c - 'A' + 10
    }
    return 0
}
can you see the similarity with C and Delphi? if no it's ok... take this
func unhex(c byte) byte
|    |     | |     |
|    |     | |     +-- result type as in Delphi "function unhex(c: byte): byte"
|    |     | +-- variable type similar to Delphi's "x: byte"
|    |     +-- parameter defined as in Delphi "ParamName: Type" without ":"
|    +-- function name...
+-- func -> function
from what you can see is more like: hey Mickey! take 30% Delphi, 40% C, 5% dirt and mix them up to get a 75% "programming language", but this is just me, as the authors says "Go compilers produce fast code fast. Typical builds take a fraction of a second yet the resulting programs run nearly as quickly as comparable C or C++ code."
Nearly?! wth? who cares if it's fast as C/C++, is it productive? um wait, you have to write code in Notepad :P nice... dudes! where's it's IDE?!
Will Go be more than just a joke, will it take the crown as the most used programming language? Does Go have what it takes to worth talking about, well it should... I wrote a post on it, please do visit their website, download it test it and let me know what's your opinion!

Tuesday, November 17, 2009

Delphi 2010 team easter egg

Today I was wondering what's the new team easter egg in Delphi 2010, so I went to Help > About press ALT key and type TEAM and here it is, the names of Delphi 2010 team

How to get system idle time

If you ever need to get system idle time here are two methods which will be more than helpful.
// retrieves idle time in miliseconds
function GetIdleTime: Cardinal;
const szLastInputInfo = sizeof(TLastInputInfo);
var LastInput: TLastInputInfo;
begin
     LastInput.cbSize := szLastInputInfo;
     GetLastInputInfo(LastInput);
     Result := GetTickCount -LastInput.dwTime;
end;

type TIdleTime = (itWeeks, itDays, itHours, itMin, itSec);

// retrieves idle time in hour, minutes or seconds
function GetIdleTimeEx(IdleTime: TIdleTime): Cardinal;
// because GetIdleTime returns idle time in miliseconds
// we need to transform miliseconds according to our needs
const CIT_SEC = 1000; // 1 miliseconds is 1 second
      CIT_MIN = CIT_SEC * 60; // 60 seconds is 1 minute
      CIT_HOUR = CIT_MIN * 60; // 60 minutes is 1 hour
      CIT_DAYS = CIT_HOUR * 24; // 24 hours is 1 day
      CIT_WEEKS = CIT_DAYS * 7; // 7 days is 1 week
begin
     Result := 0;
     case IdleTime of
          itWeeks: Result := GetIdleTime div CIT_WEEKS;
          itDays: Result := GetIdleTime div CIT_DAYS;
          itHours: Result := GetIdleTime div CIT_HOUR;
          itMin: Result := GetIdleTime div CIT_MIN;
          itSec: Result := GetIdleTime div CIT_SEC;
     end;//case IdleTime of
end;
Usage
ShowMessage(Format('System Idle for %d minute(s)', [GetIdleTimeEx(itMin)]));
If you need to get the idle time in seconds just use itSec in stead of itMin and so on.

Monday, November 16, 2009

Go go Multi-Threading

For those that don't know what threads are, here's your chance to understand.
A thread is like an application running in your application, each thread is a new application. If you create a new VCL Application in Delphi and hit F9 to run it boom you've created a thread.
The idea of thread is that you can accomplish multiple tasks in same time, at this time most PC's have processors with 2 or more core, this is a good thing, because a processor can handle a limited number of threads until it goes crazy and user needs to restart hes PC(it happened to me few times...).
So bottom line, why do I need threads? well think of your torrent client, could it handle 2 or more downloads in same time without threads? well it could but it would be very slow because an alternative to threads would be a list of tasks that needs to be done and a loop that will execute operation, but that would freeze your application and your brain trying to solve bugs.
Now that we know something about threads, here's how you can create your custom thread that does a custom task, first you need to create a new class which inherits from TThread defined in Classes.pas.
type TCustomThread = class(TThread)
     private
            FMin, FMax: Integer;
            Position : integer;
            ProgressBar : TProgressBar;
     private
            procedure UpdateProgress;
            procedure SetProgressBarOptions;
     public
           procedure Execute; override;
     public
           constructor Create(withProgressBar: TProgressBar);
           destructor Destroy; override;
end;
and then implement it's methods
{ TCustomThread }

constructor TCustomThread.Create(withProgressBar: TProgressBar);
begin
     FMin := 0;
     FMax := 30000;
     // assign the progress bar
     ProgressBar := withProgressBar;
     // let thread free itself
     FreeOnTerminate := True;
     // do not create suspended, let it go as soon as it is created
     inherited Create(False);
end;

destructor TCustomThread.Destroy;
begin
     ProgressBar.Position := 0;
     inherited;
end;

procedure TCustomThread.Execute;
var i : Integer;
begin
     // set progressbar options
     Synchronize(SetProgressBarOptions);
     for i := FMin to FMax do begin
         // check if Self(thread) is terminated, if so exit
         if Terminated then
            Exit;
         Position := i;
         // call Synchronize to make sure you won't get errors
         // from VCL's
         Synchronize(UpdateProgress);
     end;// for i := ProgressBar.Min to ProgressBar.Max do begin
end;

procedure TCustomThread.UpdateProgress;
begin
     // force application to repaint itself and handle messages
     Application.ProcessMessages;
     // update progress bar position
     ProgressBar.Position := Position;
end;

procedure TCustomThread.SetProgressBarOptions;
begin
     ProgressBar.Min := FMin;
     ProgressBar.Max := FMax;
end;
Let's understand what TCustomThread does, it gets created using a progressbar as parameter, I've overwritten it's Execute procedure(this is the procedure which gets executed), it executes a for loop which calls UpdateProgress with Synchronize procedure which won't raise an exception if the VCL is not thread safe.
A demo application can be downloaded from this link(only source code).

Saturday, November 14, 2009

Save/Load controls from IniFile using RTTI

Here's a nice trick that you can use if you're in a hurry and need to implement a method to save/load controls to/from a ini file.
This method is using RTTI(Run Time Type Information), actually 3 methods from TypInfo unit: IsPublishedProp(checks if object has property), GetPropValue(retrieves the value of a property) and SetPropValue(sets the value of a property).
I've created a unit which handles saving and loading.
uDGCtrlUtils.pas
unit uDGCtrlUtils;

interface

uses
    SysUtils,
    Controls,
    Classes,
    Forms,
    IniFiles;

// this is the array of properties, the names are case sensitive
const CONTROL_PROPS: array[0..4] of string =
      ('Left', 'Top', 'Width', 'Height', 'Visible');

(*
you can also add more properties like Caption
increase the length of array by 1 from 4 to 5

const CONTROL_PROPS: array[0..5] of string =
      ('Left', 'Top', 'Width', 'Height', 'Visible', 'Caption');
and add Caption in the array
*)


  procedure SaveControls(toIniFile: TIniFile; fromForm: TForm);
  procedure LoadControls(fromIniFIle: TIniFile; toForm: TForm);
  procedure SaveControlsToFile(const FileName: string; fromForm: TForm);
  procedure LoadControlsFromFile(const FileName: string; toForm: TForm);

implementation

uses TypInfo;

procedure SaveControls(toIniFile: TIniFile; fromForm: TForm);
var i, j : integer;
    obj : TComponent;
    s, sec : string;
begin
     // store the section
     sec := fromForm.Name;
     // for each component on form
     for i := 0 to fromForm.ComponentCount -1 do begin
         // get it's reference into obj
         obj := fromForm.Components[i];
         // for each property defined in array
         for j := Low(CONTROL_PROPS) to High(CONTROL_PROPS) do
             // check if component has that property using RTTI
             if IsPublishedProp(obj, CONTROL_PROPS[j]) then begin
                // format the string ComponentName.Property
                s := Format('%s.%s', [obj.Name, CONTROL_PROPS[j]]);
                // write data to ini file
                toIniFile.WriteString(sec, s, GetPropValue(obj, CONTROL_PROPS[j]));
             end;// if IsPublishedProp(obj, CONTROL_PROPS[j]) then begin
     end;// for i := 0 to fromForm.ComponentCount -1 do begin
end;

procedure LoadControls(fromIniFIle: TIniFile; toForm: TForm);
var i, j : integer;
    obj : TComponent;
    s, sec, value : string;
begin
     // store the section
     sec := toForm.Name;
     // for each component on form
     for i := 0 to toForm.ComponentCount -1 do begin
         // get it's reference into obj
         obj := toForm.Components[i];
         // for each property defined in array
         for j := Low(CONTROL_PROPS) to High(CONTROL_PROPS) do
             // check if component has that property using RTTI
             if IsPublishedProp(obj, CONTROL_PROPS[j]) then begin
                // format the string ComponentName.Property
                s := Format('%s.%s', [obj.Name, CONTROL_PROPS[j]]);
                // read data from ini file
                value := fromIniFIle.ReadString(sec, s, EmptyStr);
                // check if value is not '' (EmptyStr)
                if value <> EmptyStr then
                   // set the property
                   SetPropValue(obj, CONTROL_PROPS[j], value);
             end;// if IsPublishedProp(obj, CONTROL_PROPS[j]) then begin
     end;// for i := 0 to fromForm.ComponentCount -1 do begin
end;

procedure SaveControlsToFile(const FileName: string; fromForm: TForm);
var ini : TIniFile;
begin
     ini := TIniFile.Create(FileName);
     SaveControls(ini, fromForm);
     FreeAndNil(ini);
end;

procedure LoadControlsFromFile(const FileName: string; toForm: TForm);
var ini : TIniFile;
begin
     ini := TIniFile.Create(FileName);
     LoadControls(ini, toForm);
     FreeAndNil(ini);
end;

end.
Example of usage
// saving
...
begin
     if SaveDialog.Execute then
        SaveControlsToFile(SaveDialog.FileName, Self);
end;

// loading
...
begin
     if OpenDialog.Execute then
        LoadControlsFromFile(OpenDialog.FileName, Self);
end;
You can do anything you wish with the above unit, modify, sell, use in commercial products, etc.

Tuesday, November 10, 2009

Logical error

Yesterday a friend of mine asked me something this:

Facts:
- you have 3 units, u1, u2 and u3.
- u1 is the main unit which contains main form with a button called Button1.
- u2 contains a global function called Sum declared as
function Sum(a, b: integer): integer:
begin
     Result := a + b;
end;
- u3 also contains a global function called Sum declared as
function Sum(a, b: integer): integer:
begin
     Result := a * b;
end;
- u1(the main unit) has u2 and u3 in uses clause and on Button1's OnClick event has the fallowing code
...
begin
     ShowMessage('Result = ' + IntToStr(Sum(3, 3)));
end;

Question: What would be the result of using Sum function with 3 as first parameter and 3 as second parameter?
I know you tend to say 6 as result but Delphi says NO! This is a so called logical error because if you have two units which both have a function called Sum(in this case) Delphi will use Sum function from last unit added in uses clause.
You don't bulive me? then test it yourself, here's the code

unit1.pas
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses unit2, unit3;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
     ShowMessage('Result = ' + IntToStr(Sum(3, 3)));
end;

end.

unit2.pas
unit Unit2;

interface

function sum(a, b: integer): integer;

implementation

function sum(a, b: integer): integer;
begin
     Result := a + b;
end;

end.

unit3.pas
unit Unit3;

interface

function sum(a, b: integer): integer;

implementation

function sum(a, b: integer): integer;
begin
     Result := a * b;
end;

end.

Sunday, November 8, 2009

Another interpreter with source code

There are a lot of Delphi interpreters out there, if you know some that worth mentioning and I didn't post them please comment on this post or e-mail me.
TArtFormula is a nice interpreter both mathematical and automation, I'm not so good at writing or advertising so I just copy-paste the info from Artem Parlyuk's(author) web site http://artsoft.nm.ru/works.html

ArtFormula package contains two nonvisual Delphi componenst for symbolic expression parsing and evaluation. Provides runtime scripting engine for automating your programs.

Provides:
7 arithmetic operations
10 logical operations
6 bitwise operations
string concatenation
22 arithmetic functions
10 statistical functions
2 logical functions
16 string functions
13 date functions
14 programming functions
User defined constant
Up to 255 user defined variables
Up to 255 user defined functions (modules)
Symbolical differentiation of functions with basic simplification of resulting derivatives

Arithmetic operation:
x + y, x - y, x * y, x / y, x % y (Mod), x ^ y (power), x\ y (Div)

Logical operation (true=1, false=0):
x > y, x < y, x >= y, x <= y, x = y, x <> y, ! x (not), x & y (and), x | y (or), x xor y

Bitwise operations:
x && y (band), x || y (bor), !!x (bnot), x bxor y, x >> y (shr), x << y (shl) Predefined constants:
Pi = 3.1415926535897932385
True = 1
False = 0

Functions:
sin, cos, tan, sinh, cosh, tanh, asin, acos, atan, asinh, acosh, atanh, sqrt, exp, log, lg (log base 10), int (integer part of a number), frac (fractional part of a number), abs, sign, rnd, randomize
max(x,y...), min(x,y,...), count(x,y,...), sum(x,y,...), sumofsquares(x,y,...), avg(x,y,...), variance(x,y,...), variancep(x,y,...), stddev(x,y,...), stddevp(x,y,...)
iff(cond,x,y) (if cond = true then result = x else result = y),
isnumber(x)
chr(x), length(s), trim(s), trimleft(s), trimright(s) lowercase(s), uppercase(s), midstr(s,x,y), leftstr(s,x), rightstr(s,x), pos(s,t), code(s), format(s,x), formatf(s,x), stringofchar(c,n), concat(s1,s2,...)
date(s), now, formatdate(s,d), year(d), month(d), day(d), hour(d), minute(d), second(d), millisecond(d), isleapyear(n), dayofweek(d), encodedate(y,m,d)

Programming:

TArtFormula provides two styles of programming: formula style and scripting style. The first style assumes that all statements have the form of function call. The second style imply that you use common program language notation.

For example:

block(defines('i','n'), set('n',1),
series(set('i',1), val('i')<=5, inc('i'), set('n',val('n')*val('i'))), msg('5! = '+val('n'),'result',0)) Is equal to: begin var 'i', 'n' end; $n:=1; for $i:=1; $i<=5; $i++ do $n := $n*$i; next; msg('5! = '+val('n'),'result',0); end You can mix two styles in one program. TArtFormula programming language supports: Variables definitions Assigmnent statement Increment and Decrement operations Return function Compound statement (BEGIN... END) IF statement WHILE loop UNTIL loop FOR loop Interface functions: msg('text','caption',props), input('caption', 'text', defvalue) Spreadsheet applicatiuon:

TArtFormula can be used in spreadsheet application. E.g. using GetVarsCount and GetVarValue event handlers one can implement calculation of sum(a1:b4), avg(c1:c99) and similar function calls, where a1:b4 and c1:c99 are range of sheet cells.

Retrieve special folders using static class

There are many times when you need the path to System32 or Windows folder or event the drive where windows is installed, at this time you need to get those paths dynamically because not everyone installs windows on default drive C:.
I've created a class specially for that reason without using the shell functions
unit uDGSysFolders;

interface

uses
    SysUtils,
    Windows;

(* define a TBuffer type as array of char *)
type TBuffer = array[0..250] of Char;

(* store it's size in a constant for faster access *)
const szBuffer = sizeof(TBuffer);

(* declare a static(doesn't need creation) class *)
type DGSystemFolders = class
     public
           (* C:\Windows\System32 *)
           class function System32Folder: string;
           (* C:\Windows *)
           class function WindowsFolder: string;
           (* C:\ *)
           class function WindowsDrive: string;
           (* C *)
           class function WindowsDriveChar: Char;
     end;

implementation

{ DGSystemFolders }

class function DGSystemFolders.System32Folder: string;
var Buffer : TBuffer;
begin
     GetSystemDirectory(Buffer, szBuffer);
     Result := Buffer;
end;

class function DGSystemFolders.WindowsDrive: string;
var tmp : string;
begin
     tmp := System32Folder;
     Result := Copy(tmp, 1, Pos('\', tmp));
end;

class function DGSystemFolders.WindowsDriveChar: Char;
var tmp : string;
begin
     tmp := System32Folder;
     Result := tmp[1];
end;

class function DGSystemFolders.WindowsFolder: string;
var tmp : string;
    i : integer;
begin
     tmp := System32Folder;
     for i := Length(tmp) downto 1 do
         if tmp[i] = '\' then begin
            Result := Copy(tmp, 1, i -1);
            Exit;
         end;// if tmp[i] = '\' then begin
end;

end.
Usage: add uDGSysFolders to uses clause
...
begin
     ShowMessage(DGSystemFolders.System32Folder);
end;

Saturday, November 7, 2009

Make sure an event is not fired

Recently I've been assigned with a task, this task is about making sure that an event will not fire unless user has the right to fire it.
In other words, you have a button in a multi user application and user X does not have the right to delete from database or to add to database, this can be easily done by writing Button.Enabled := False right? wrong, what if the user has some knowledge about windows, I mean he knows how to enable/disable a control with external applications like WinSpy++ or any other software which has option to modify a windows control behavior.
In this case you need a slick way to be absolutely sure that is not possible(it's not 100% sure only 99.99% because softice can come into play but there are few people capable to work with it and at that time you can't really do anything to protect your application) here's my implementation:
I've started by creating a unit which defines and implements two classes: TCtrlHolder and TCtrlHolderList.
type TCtrlHolder = class
                 public
                       Obj : TButton;
                       Name : string;
                       AllowedClick,
                       DeniedClick : TNotifyEvent;
                 public
                       procedure SetEnable(T: boolean);
                 public
                       constructor Create(onButton: TButton);
     end;// type TCtrlHolder = class

type TCtrlHolderList = class
                     private
                            FCtrlList : TList;
                            procedure DisplayDeniedMessage(Sender: TObject);
                     public
                           UserMessage : string;
                     public
                           function AddCtrl(thisCtrl: TCtrlHolder): integer;
                           procedure ReadRightsFromINI(const FileName: string);
                     public
                           constructor Create(const WithMessage: string = '');
                           destructor Destroy; override;
     end;// type TCtrlHolderList = class
The TCtrlHolder is just an intermediate class between the control(button in this case) and TCtrlHolderList which only holds the controls.
implementation
{ TCtrlHolderList }

function TCtrlHolderList.AddCtrl(thisCtrl: TCtrlHolder): integer;
begin
     thisCtrl.DeniedClick := DisplayDeniedMessage;
     Result := FCtrlList.Add(thisCtrl)
end;

constructor TCtrlHolderList.Create(const WithMessage: string = '');
begin
     FCtrlList := TList.Create;
end;

destructor TCtrlHolderList.Destroy;
var i : integer;
    tmp : TObject;
begin
     for i := FCtrlList.Count -1 downto 0 do begin
         tmp := FCtrlList[i];
         FreeAndNil(tmp);
         FCtrlList.Delete(i);
     end;//for i := FCtrlList.Count -1 downto 0 do begin
     FreeAndNil(FCtrlList);
end;

procedure TCtrlHolderList.DisplayDeniedMessage(Sender: TObject);
begin
     if UserMessage <> EmptyStr then
        MessageDlg(UserMessage, mtWarning, [mbOk], 0)
     else
         MessageDlg('Access denied', mtWarning,[mbOK], 0);
end;

procedure TCtrlHolderList.ReadRightsFromINI(const FileName: string);
var ini : TIniFile;
    i : integer;
    s : string;
begin
     ini := TIniFile.Create(FileName);
     for i := 0 to FCtrlList.Count -1 do begin
         s := ini.ReadString('rights', TCtrlHolder(FCtrlList[i]).Name, 'xxx');
         if s <> 'xxx' then
            TCtrlHolder(FCtrlList[i]).SetEnable(StrToBool(s));
     end;// for i := 0 to FCtrlList.Count -1 do begin
     FreeAndNil(ini);
end;

{ TCtrlHolder }

constructor TCtrlHolder.Create(onButton: TButton);
begin
     Obj := onButton;
     Name := Obj.Name;
     AllowedClick := Obj.OnClick;
     if not Obj.Enabled then
        Obj.OnClick := DeniedClick;
end;

procedure TCtrlHolder.SetEnable(T: boolean);
begin
     Obj.Enabled := T;
     if T then
        Obj.OnClick := AllowedClick
     else
         Obj.OnClick := DeniedClick;
end;
The idea is very simple and elegant, you only assign an event based on the rights, no conditions in the real OnClick event.
A demo application can be downloaded from this link(only source code is provided).

Friday, November 6, 2009

Lightning fast math expression evaluator

A few days ago I found a very fast and very well structured math expression evaluator which is actually a compiler, it is called Pegtop Delphi Math Component Library and can be found http://www.pegtop.net/delphi/components/math/download.htm.
Output of expression sin(sqrt(sqr x + sqr y)*7) /7
fldcw word ptr [esi+10]
fld qword ptr [esi+00]
fmul st(0), st(0)
fstp qword ptr [esi+20]
fld qword ptr [esi+08]
fmul st(0), st(0)
fadd qword ptr [esi+20]
fsqrt
fstp qword ptr [esi+28]
fld qword ptr [esi+30]
fmul qword ptr [esi+28]
fsin
fstp qword ptr [esi+38]
fld qword ptr [esi+40]
fdivr qword ptr [esi+38]
ret
(42 bytes)
Nice huh?

C like JIT interpreter in Delphi

Are you in need of a freeware fast C like JIT interpreter?
Look no further I present to you BeRoScript, it's created by Benjamin Rosseaux a.K.a. "Bero" and can be downloaded from this link, if link is broken then contact Benjamin directly, I'm sure he will send it to you.
Here's a taste of BeRoScript language from demo files provided with interpreter
File: prime.bs(prime number)
int main() {
 long i,k,gefunden=0;
 for (i=2;i<=2048;i++) {
  byte prime=1;
  for (k=2;k<=i;k++) {
   if (i!=k) {
    if ((i%k)==0) {
     prime=0;
     break;
    }
   }
  }
  if (prime) {
   printf(i," ist eine Primezahl\r\n");  
   gefunden++;
  }
 } 
 printf(gefunden," Primezahlen im Zahlenbereich 2 bis 2048 gefunden!\r\n");  
}
File: oop.bs(object oriented programming)
enum Geschlechter { maennlich=0, weiblich }
object Mensch {
 string Name;
 int Alter;
 int Geschlecht;
};
object Ort {
 string Adresse;
};
object Schule(Ort) {
 string Form;
};
object Lehrer(Mensch,Schule) {
 string Fach;
};
object Schueler(Mensch,Schule) {
 bool IstGut;
};
int Mensch::EineZahl() {
 return 1234;
}
void Mensch::printdata() {
 printf("Name: ",Name,"\n");
 printf("Alter: ",Alter,"\n");
 printf("Geschlecht: ",Geschlecht?"weiblich":"maennlich","\n");
}
void Ort::printdata() {
 printf("Adresse: ",this->Adresse,"\n");
}
void Schule::printdata() {
 inherited();
 printf("Schulform: ",this->Form,"\n");
}
void Lehrer::printdata() {
 inherited Mensch();
 inherited Schule();
 printf("Unterrichtet: ",Fach,"\n");
 printf(inherited Mensch.EineZahl()*2,"\n\n");
}
void Schueler::printdata() {
 inherited Mensch.printdata();
 inherited Schule.printdata();
 printf("Status: ",this->IstGut?"liefert gute Leistungen":"ist super faul","\n");
 printf(inherited EineZahl(),"\n\n");
}
void main(){
 Lehrer HerrMustermann;
 Schueler Max;
 HerrMustermann.Name="Tom Mustermann";
 HerrMustermann.Alter=38;
 HerrMustermann.Geschlecht=maennlich;
 HerrMustermann.Adresse="Musterstrasse 123";
 HerrMustermann.Form="Gesamtschule";
 HerrMustermann.Fach="Mathematik";
 Max.Name="Max Schmidt";
 Max.Alter=18;
 Max.Geschlecht=maennlich;
 Max.Adresse="Musterstrasse 123";
 Max.Form="Gesamtschule";
 Max.IstGut=true;
 HerrMustermann.printdata();
 Max.printdata();
} 
File: Zahlenrate.bs(pay rates)
int main() {
 printf("BeRoScript Zahlenraten - Version 1.00\n");
 printf("Copyright (C) 2004, Benjamin Rosseaux\n\n");
 printf("Gib deinen Namen ein: ");
 string name=trim(readstring());
 if(length(name)==0)name="Unbekannter";
 readln();
 printf("\nAlso ",name,", bist du fuers Spiel bereit? ;)\n\n");
 nochmal:
 int meinezahl,zahl=1000,versuche=10;
 bool gewonnen=false;
 unsigned char taste;
 meinezahl=round(random()*100);
 printf("Du muss nun eine Zahl zwischen 0 und 100 erraten! (-1=Ende)\n");
 printf("Du hast 10 Versuche!\n\n");
 while((meinezahl!=zahl)&&(zahl>=0)&&(versuche>0)){
  printf("Gebe deine Zahl ein: ");
  zahl=readint();
  if(versuche>1){
   if(zahl<0){
    break;
   }else if(meinezahlzahl){
    printf("Meine Zahl ist groesser\n");
   }else{
    printf("\nRichtig, ",name,"! Meine Zahl war ",zahl,"\n\n");
    gewonnen=true;
    break;
   }
  }
  if(--versuche){
   if(versuche==1){
    printf(name,"! Du hast nur noch einen einizigen Versuch!\n\n");
   }else{
    printf("Du hast noch ",versuche," Versuche!\n\n");
   }
  }
 }
 if(!gewonnen){
  printf("\nDu hast leider verloren! Meine Zahl war ",meinezahl,"\n\n");
 }
 readln();
 falscheeingabe:
 printf("Nochmal? (j/n)");
 taste=readchar();
 switch(taste){
  case 'j':case 'J':printf("\nOh, yeah ;)\n\n");readln();goto nochmal;
  case 'n':case 'N':printf("\nSchade, ja denn, bis bald, ",name,"! ;)\n");readln();break;
  default:printf("\nUps, falsche Eingabe ;)\n\n");readln();goto falscheeingabe;
 }
}

Friday, October 30, 2009

Get the last entry from a database table

Let's say you got a table(Users) with 3 fields(ID, FirstName and LastName), you need to get the last ID entry in that table, in this case you can use this nice SQL function
SELECT MAX("ID") FROM "Users";
you can do same for any other field, let's say FirstName
SELECT MAX("FirstName") FROM "Users";
MAX - is a SQL function which returns the last entry in the specified table.

How to pass a stream to a database query

In previous post I've shown you how to save a TRichEdit/TDBRichEdit or descendant to a TStream, now heres how to pass that stream to a INSERT query
// your procedure/function
var stream : TStream;
begin
     // the insert query
     myQuery.SQL.Text := 'INSERT INTO "Mytable"("MyStreamField") VALUES(:RichEdit)';
     // get TRichEdit as stream with helper function
     stream := RichEditToStream(myRichEdit);
     // create a new parameter with field type as ftBlob and parameter
     // type as ptInput
     myQuery.Params.CreateParam(ftBlob, 'RichEdit', ptInput);
     // now load the parameter from stream
     // we can also use myQuery.myQuery.Params[0].LoadFromStream();
     myQuery.ParamByName('RichEdit').LoadFromStream(stream, ftBlob);
     // we free the stream here
     FreeAndNil(stream);
     // execute the sql
     myQuery.ExecSQL;
     // clear the parameters
     myQuery.Params.Clear;
end;

How to save/load a TRichEdit to/from a string/stream

Recently I had to save a TRichEdit as a string so I can save it in a database field, after 1-2 hours I came up with this solutions
// this function extracts formatted string from a
// TRichEdit/TDBRichEdit or descendant and returns it as a TStream
function RichEditToStream(thisRichEdit: TRichEdit): TStream;
var ss : TStringStream;
begin
     ss := TStringStream.Create(EmptyStr);
     thisRichEdit.Lines.SaveToStream(ss);
     Result := ss;
     // you might need to set position to zero
     Result.Position := 0;
     // REMEMBER to free the stream variable
end;

// this functions returns the formatted of a
// TRichEdit/TDBRichEdit or descendant as plain string
function RichEditToString(thisRichEdit: TRichEdit): string;
var ss : TStringStream;
begin
     ss := TStringStream(RichEditToStream(thisRichEdit));
     Result := ss.DataString;
     FreeAndNil(ss);
end;

// this procedure loads formatted string from a
// string and loads it into a TRichEdit/TDBRichEdit or
// descendant
procedure RichEditFromStream(thisRichEdit: TRichEdit;
          const theString: string);
var ss : TStringStream;
begin
     ss := TStringStream.Create(theString);
     thisRichEdit.Lines.LoadFromStream(ss);
     FreeAndNil(ss);
end;

Friday, October 23, 2009

Boyer-Moore-Horspool algorithm

If you ever need to search a string very fast then you should use Boyer-Moore-Horspool algorithm, it's so fast that you can search 80Mb text files in under 300 miliseconds!
Example of implementation in Delphi
function search(pat: string; text: string): integer;
var
  i, j, k, m, n: integer;
  skip: array [0..MAXCHAR] of integer;
  found: boolean;
begin
  found := FALSE;
  search := 0;
  m := length(pat);
  if m=0 then
  begin
    search := 1;
    found := TRUE;
  end;
  for k:=0 to MAXCHAR do
    skip[k] := m;   {*** Preprocessing ***}
  for k:=1 to m-1 do
    skip[ord(pat[k])] := m-k;
  k := m;
  n := length(text);            {*** Search ***}
  while not found and (k <= n) do
  begin
    i := k; j := m;
    while (j >= 1) do
    begin
      if text[i] <> pat[j] then
        j := -1
      else
      begin
        j := j-1;
        i := i-1;
      end;
      if j = 0 then
      begin
        search := i+1;
        found := TRUE;
      end;
      k := k + skip[ord(text[k])];
    end;
  end;
end;
This snippet is taken from www.delphidabbler.com, it can be viewed fallowing this link.
In a few days I will post a trie implementation which is way faster than Boyer-Moore.

Wednesday, October 21, 2009

Terminating a process

If at any point you wish to terminate a/your process instantly then you should take a look at TerminateProcess function in Windows SDK(Software Developer Kit) help which comes with Delphi.
TerminateProcess function is defined as
BOOL TerminateProcess(
    HANDLE hProcess, // handle to the process 
    UINT uExitCode  // exit code for the process  
   );
Parameters information according to Delphi Help
hProcess
  Identifies the process to terminate.
  Windows NT: The handle must have PROCESS_TERMINATE access. For more information, see Process Objects(in Windows SDK Help).

uExitCode
  Specifies the exit code for the process and for all threads terminated as a result of this call. Use the GetExitCodeProcess function to retrieve the process's exit value. Use the GetExitCodeThread function to retrieve a thread's exit value.
Create a new VCL application, add a button, double-click that button and copy-paste
procedure TForm1.Button1Click(Sender: TObject);
begin
  TerminateProcess(GetCurrentProcess, 0);
end;
Your application should terminate instantly.

Tuesday, October 13, 2009

Make the mouse wheel work properly in TListBox

Here is how to a make a descentant of a TListBox to behave properly when user tries to scroll using the mouse wheel.Instead of scrolling down to the bottom of the list
this code will make TListBox to scroll by one item at a time,regardless of the mouse wheel direction up or down.

unit sodListBox;
interface
uses
Classes
,StdCtrls
,Windows
,Messages
;
type
TsodListBox = class(TListBox)
private
{ Private declarations }
protected
{ Protected declarations }
procedure WndProc(var Message : TMessage);override;
public
{ Public declarations }
constructor Create(AOwner:TComponent);override;
destructor  Destroy;override;
published
{ Published declarations}
end;

implementation
{------------------------------------------------------------------------------}
constructor TsodListBox .Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
{------------------------------------------------------------------------------}
destructor TsodListBox .Destroy;
begin
inherited;
end;
{------------------------------------------------------------------------------}
procedure TsodListBox .WndProc(var Message: TMessage);
var
i : SmallInt;
begin
case Message.Msg of
WM_MOUSEWHEEL :
begin
//Changing the message code from mousewheel to keydown
Message.Msg    := WM_KEYDOWN;
Message.LParam := 0;
//Finding the direction of mousewheel up or down.
i              := HiWord(Message.WParam);
//Simulating a keystroke according to mousewheel direction.
if i > 0 then
Message.WParam := VK_UP
else
Message.WParam := VK_DOWN;
end;
end;
inherited WndProc(Message);
end;
{------------------------------------------------------------------------------}

There you go you now have a TListBox behaving properly to mousewheel.

Blogroll(General programming and Delphi feeds)