Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/nastroje/d23456/SPLBASE.ZIP/Splbase/Include/SplUnit1.pas

Pascal/Delphi Source File | 2001-08-05 | 13.7 KB | 535 lines

(*********** SplitBase Data Management Systems ***********
 *                                                       *
 *           Copyright (c) 2001 Leon O. Romain           *
 *                                                       *
 *                     [e-mail]                    *
 *                                                       *
 *********************************************************)

{
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}

unit SplUnit1;

interface

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

type
  TForm1 = class(TForm)
    GroupBox1: TGroupBox;
    Edit1: TEdit;
    GroupBox2: TGroupBox;
    Edit2: TEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    Button7: TButton;
    Button8: TButton;
    Button9: TButton;
    Button10: TButton;
    Button11: TButton;
    Memo1: TMemo;
    procedure Button9Click(Sender: TObject);
    procedure Button10Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button8Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button11Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  dogen: boolean {Starts and stops automatic data generation};

implementation

{$R *.DFM}

{$I splinc}


function spellnum ( num : string ) : string;
{This procedure converts a string digits into its English
 string equivalent. The number must be a value less than 10
 billion converted into a string of length 10 and filled
 left with zeroes if necessary}
var
   x : integer;
   s, s1 : string;
   ar : array [0..32] of string[10];
   p, p3, cnt, ck : integer;
begin
   p := 32;
   p3 := 1;
   s := '';
   if strtointdef ( num, -1 ) < 0 then
      num := '';
   if num <> '' then
   begin
      ar[0] := 'zero';
      ar[1] := 'one';
      ar[2] := 'two';
      ar[3] := 'three';
      ar[4] := 'four';
      ar[5] := 'five';
      ar[6] := 'six';
      ar[7] := 'seven';
      ar[8] := 'eight';
      ar[9] := 'nine';
      ar[10] := 'ten';
      ar[11] := 'eleven';
      ar[12] := 'twelve';
      ar[13] := 'thirteen';
      ar[14] := 'fourteen';
      ar[15] := 'fifteen';
      ar[16] := 'sixteen';
      ar[17] := 'seventeen';
      ar[18] := 'eighteen';
      ar[19] := 'nineteen';
      ar[20] := 'twenty';
      ar[21] := 'thirty';
      ar[22] := 'fourty';
      ar[23] := 'fifty';
      ar[24] := 'sixty';
      ar[25] := 'seventy';
      ar[26] := 'eighty';
      ar[27] := 'ninety';
      ar[28] := 'hundred';
      ar[29] := '';
      ar[30] := 'thousand';
      ar[31] := 'million';
      ar[32] := 'billion';
      if num [1] <> '0' then
      begin
         x := strtoint ( num[1] );
         s := s + ar [x] + ' ' + ar [p] + ' ';
      end;
   end
   else
      s := '';
   p := p - 1;
   cnt := 2;
   ck := 0;

   while cnt <= length ( num ) do
   begin
      if num[cnt] <> '0' then
      begin
         if p3 = 1 then
         begin
            x := strtoint ( num[cnt] );
            s := s + ar [x] + ' hundred ';
            cnt := cnt + 1;
            p3 := p3 + 1;
            ck := 2;
         end
         else if p3 = 2 then
         begin
            if num[cnt] = '1' then
            begin
               s1 := num[cnt] + num [cnt + 1];
               x := strtoint ( s1 );
               s := s + ar [x] + ' ';
               p3 := p3 + 1;
               cnt := cnt + 1;
               ck := 1;
            end
            else
            begin
               s1 := num[cnt];
               x := strtoint ( s1 );
               s := s + ar [x + 18] + ' ';
               p3 := p3 + 1;
               cnt := cnt + 1;
               if num[cnt] = '0' then
                  ck := 1
               else
                  ck := 3;
            end
         end
         else
         begin
            if ck <> 1 then
            begin
               x := strtoint ( num[cnt] );
               s := s + ar [x] + ' ';
               ck := 2;
            end;
            if ck > 0 then
               s := s + ar [p] + ' ';
            cnt := cnt + 1;
            ck := 0;
            p := p - 1;
            p3 := 1;
         end
      end
      else
      begin
         if p3 = 3 then
         begin
            if ck <> 1 then
            begin
               x := strtoint ( num[cnt] );
               if ( x > 0 ) or ( ( s = '' ) and
                                 ( cnt = 10 ) ) then
               begin
                  s := s + ar [x] + ' ';
                  ck := 2;
               end
            end;
            if ck > 0 then
               s := s + ar [p] + ' ';
            cnt := cnt + 1;
            ck := 0;
            p := p - 1;
            p3 := 1;
         end
         else
         begin
            cnt := cnt + 1;
            p3 := p3 + 1;
         end;
      end;
   end;
   spellnum := s;
end;

procedure TForm1.Button9Click(Sender: TObject);
begin
   close
end;

procedure TForm1.Button10Click(Sender: TObject);
{Automatically inputs 1 million even numbers from 2 to
 2000000 into the database from different angles to also
 test its strength. Process can be terminated by clicking
 the "stop" button.}
var
   x : integer;
   ll : array [1..4] of longint;
   cnt : longint;
   s1, s2 : string;
begin
   if not ( activedb ) then
   begin
      showmessage ('No active database.');
      dogen := true;
   end;
   if dogen then
   begin
      button10.Caption := '&Generate';
      dogen := false;
   end
   else
   begin
      dogen := true;
      button10.Caption := '&Stop';
      ll[1] := 500000;
      ll[2] := 500002;
      ll[3] := 1500000;
      ll[4] := 1500002;
      x := 1;
      cnt := 0;
      s1 := timetostr ( time );
      edit1.Text := s1;
      repeat
         s1 := inttostr ( ll[x] );
         while length ( s1 ) < 10 do
            s1 := '0' + s1;
         setlength ( s1, 10 );
         s2 := spellnum ( s1 );
         if s2 <> '' then
         begin
            edit2.Text := s1;
            memo1.Text := s2;
            if odd ( x ) then
               ll[x] := ll[x] - 2
            else
               ll[x] := ll[x] + 2;

            if addfield ( s1, 1 ) then
            begin
               if addfield ( s2, 2 ) then
               begin
                  if not ( addrec ( s1 ) ) then
                     showmessage ( inttostr ( splerr.recnum ) + ' ' +
                                   splerr.recstr );
               end
               else
                  showmessage ( inttostr ( splerr.recnum ) + ' ' +
                                splerr.recstr );
            end
            else
               showmessage ( inttostr ( splerr.recnum ) + ' ' +
                             splerr.recstr );

            x := x + 1;
            if x = 5 then
               x := 1;
            cnt := cnt + 1;
         end
         else
         begin
            edit2.Text := 'Error generating number.';
            memo1.Text := 'Illegal or non positive number.';
            dogen := false
         end;

         application.ProcessMessages;

      {until (topbox^.count = splmax) or (dogen = false);}
      until (cnt >= 1000000) or (dogen = false);
      edit1.Text := edit1.Text + ' - ' + timetostr ( time )
                    + ' - ' + inttostr ( cnt ) + ' - ' +
                    inttostr ( reccount );
   end;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   dogen := false;
   if initspl then
   begin
      initbase;
      edit2.Text := 'Splitter database system initialized.'
   end
   else
      edit2.text := 'Initialization failed.'
end;

procedure TForm1.Button6Click(Sender: TObject);
var
   s : string;
begin
   initbase;
   if setspl ('010140') then
   begin
      if createspl ('test') then
         edit2.Text := 'Splitter Database created.'
      else
      begin
         s := inttostr ( splerr.recnum ) + ' ' +
         splerr.recstr;
         edit2.Text := s;
      end
   end
   else
   begin
      s := inttostr ( splerr.recnum ) + ' ' +
      splerr.recstr;
      edit2.Text := s;
   end
end;

procedure TForm1.Button7Click(Sender: TObject);
var
   s : string;
begin
   initbase;
   if openspl ('test') then
   begin
      limrec := reccount;
      edit2.Text := 'Splitter Database opened.';
      memo1.text := curdtb + ' - ' +
                    inttostr ( allrec.size ) + ' - ' +
                    inttostr ( limrec );
   end
   else
   begin
      s := inttostr ( splerr.recnum ) + ' ' +
      splerr.recstr;
      edit2.Text := s;
   end
end;

procedure TForm1.Button8Click(Sender: TObject);
var
   s1, s2 : string;
begin
   if activedb then
   begin
      s1 := edit1.Text;
      while length ( s1 ) < 10 do
         s1 := '0' + s1;
      setlength ( s1, 10 );
      s2 := spellnum ( s1 );
      if s2 <> '' then
      begin
         edit2.Text := s1;
         memo1.Text := s2;
         if addfield ( s1, 1 ) then
         begin
            if addfield ( s2, 2 ) then
            begin
               if addrec ( s1 ) then
                  showmessage ('Record sucessfuly inserted.')
               else
                  showmessage ( inttostr ( splerr.recnum ) + ' ' +
                                splerr.recstr );
            end
            else
               showmessage ( inttostr ( splerr.recnum ) + ' ' +
                             splerr.recstr );
         end
         else
            showmessage ( inttostr ( splerr.recnum ) + ' ' +
                          splerr.recstr );
      end
      else
      begin
         showmessage ('Illegal input. Not a positive number.');
         edit2.Text := s1;
         memo1.Text := 'Illegal value.';
      end;
   end
   else
      showmessage ('No active database.');
end;

procedure TForm1.Button5Click(Sender: TObject);
var
   s : string;
begin
   if activedb then
   begin
      s := edit1.Text;
      while length ( s ) < 10 do
         s := '0' + s;
      edit1.Text := s;
      if getrec ( s ) then
      begin
         showmessage ('Record found.');
         memo1.Text := 'Record found.';
         edit2.text := getfield ( 1 );
         memo1.Text := getfield ( 2 );
      end
      else
      begin
         showmessage ('Record not found.');
         memo1.Text := inttostr ( splerr.recnum ) + ' '
                       + splerr.recstr;
      end
   end
   else
      showmessage ('No active database.');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if not (dbempty) then
   begin
      if firstrec then
      begin
         edit2.text := getfield ( 1 );
         memo1.Text := getfield ( 2 );
      end
      else
         memo1.Text := inttostr ( splerr.recnum ) + ' '
                       + splerr.recstr;
   end
   else
      showmessage ('Database empty or not loaded.')
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
   if not (dbempty) then
   begin
      if lastrec then
      begin
         edit2.text := getfield ( 1 );
         memo1.Text := getfield ( 2 );
      end
      else
         memo1.Text := inttostr ( splerr.recnum ) + ' '
                       + splerr.recstr;
   end
   else
      showmessage ('Database empty or not loaded.')
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   if not (dbempty) then
   begin
      if nextrec then
      begin
         edit2.text := getfield ( 1 );
         memo1.Text := getfield ( 2 );
      end
      else
         memo1.Text := inttostr ( splerr.recnum ) + ' '
                       + splerr.recstr;
   end
   else
      showmessage ('Database empty or not loaded.')
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
   if not (dbempty) then
   begin
      if prevrec then
      begin
         edit2.text := getfield ( 1 );
         memo1.Text := getfield ( 2 );
      end
      else
         memo1.Text := inttostr ( splerr.recnum ) + ' '
                       + splerr.recstr;
   end
   else
      showmessage ('Database empty or not loaded.')
end;

procedure TForm1.Button11Click(Sender: TObject);
begin
   if delrec then
      showmessage ('Record properly deleted.')
   else
   memo1.Text := inttostr ( splerr.recnum ) + ' '
                 + splerr.recstr;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
   if releasespl then
      showmessage ('Splitter database system released.')
   else
      showmessage ('Error releasing Splitter database system.');
end;

end.