maXbox / Wiki / maxbox

maXbox is a free programming tool with an inbuilt delphi engine in one exe! It is designed for teaching, test and analyze methods and algorithms for Win and Linux (CLX). maXbox is built on RemObjects PascalScript, the smart evolution of programming. Scripting in the box has a main advantage: An open script means you can look at the code, see how it works, change it so it works better for you and run it once again in the box. If it fits your idea give your changes of the script back to the community and reuse as you can.

by the way: files and shuffle mode is close behind, the best shuffle code is from Don Knuth (elegant and efficient):

 procedure Shuffle(vQ: TStringList);
 var j, k: integer;
     tmp: String;
 begin  
   randomize;
   for j:= vQ.count -1 downto 0 do begin
     k:= Random(j+1);
     tmp:= (vQ[j]);
     vQ[j]:= vQ[k];
     vQ[k]:= tmp;
   end;
 end;


 procedure bitmapPower;
  var mymap: TBitmap;
  begin
    mymap:= TBitmap.Create;
    mymap:= CaptureScreen1(Rect(150,150,600,600));
    with mymap do begin
      saveToFile(exepath+'screenmap.bmp');
      Free;
    end;           
    writeln('filesize bmp '+intToStr(GetFileSize(exepath+'screenmap.bmp')));
    ConvertImage(exepath+'screenmap.bmp',exepath+'screenmap.png');
    writeln('filesize png '+intToStr(GetFileSize(exepath+'screenmap.png')));
    OpenFile(exepath+'screenmap.png'); 
    //CaptureScreenFormat(exepath+'screenmapdirect','.png');
  end;

Current Development to mX3 V3.0
Current Development to mX4 V4.0
API Code
Entropy and Cryptography
Object Oriented
Arduino
Bugs
Performance
Tuning

Current Development to mX3 V3.1

Just converted and registered TStringGrid/TDrawGrid (Grid/QGrid) for the proof of Concept Memory Game with a Grid of bitmaps. also TPrinter and TMediaPlayer for more output DBCommon, DBTypes and DBTables in Progress, not all finished but DBX in V3.2 possible, for now in V3.1 for e.g.:

const SQLQuery = 'select * from customer where company like "%SCUBA%";

procedure DoQuery(aDB: TDataBase); var i: integer;

   dQuery: TQuery;

begin

  dQuery:= TQuery.create(self); 
  with dQuery do begin
  DatabaseName:= aDB.DataBaseName;
    try
       //openDataBase; or Close;
       //GetQuery(SQLQuery, dQuery)
       SQL.Clear;
       //SQL.Text:= 'select * from customer';
       SQL.Text:= SQLQuery;
       Open;
       Writeln(inttostr(RecordCount)+' Records found: ')
       for i:= 0 to RecordCount - 1 do begin
         Writeln(intToStr(i)+' '+fieldbyname('Company').asString)
         Next;
       end;  
       //ExecSQL;
      finally
        Close;
        Free;
        CloseDataBase(aDB)
      end;
   end

end;

A big example of 3 ways (DBX, BDE, ADO-OLEDB (ODBC)) to connect a Firebird/Interbase DB shows script

http://www.softwareschule.ch/examples/301_SQL_DBfirebird3.htm

CodeHunter

Just build the StreamDream in comming soon mX 3.0

procedure getHTTP_PNG(vimage: TImage); var

 idHTTP: TIDHTTP;
 //mpng: TPNGGraphic;
 pngStream: TMemoryStream;

begin

 myURL:= 'http://www.softwareschule.ch/images/maxboxgui29.png';
 with TLinearBitmap.Create do
 try
   idHTTP:= TIdHTTP.Create(NIL)
   pngStream:= TMemoryStream.create;
   //OptimizeMem
   idHTTP.Get1(myURL, pngStream)
   pngStream.Position:= 0;
   LoadFromStream2(pngstream, 'PNG');
   myimage.Picture:= NIL;
   AssignTo(myimage.Picture.Bitmap);
 finally
   Dispose;
   Free;
   idHTTP.Free
   pngStream.Free;
 end;

end;

// my favor to mX3.2 convert an image as easy as that:

procedure ConvertImage(vsource, vdestination: string); begin

 with TLinearBitmap.Create do
 try
   LoadFromFile(vsource);
   //Assign(Bmp);
   SaveToFile(vdestination);
 finally
   Dispose;
   Free;
 end;

end;

The same goes for a script loader with a ScriptStream!:

Procedure GetScriptAndRun; var

 scriptStream: TFileStream;
 idHTTP: TIDHTTP;
 myURL, ascript: string;

begin

 ascript:= '210_public_private_cryptosystem.txt';
 myURL:= 'http://www.softwareschule.ch/download/'+ascript;
 if not FileExists(ExePath+ascript) then begin
   scriptStream:= TFileStream.create(ExePath+'examples/'+ascript, fmCreate)
   idHTTP:= TIdHTTP.create(NIL)
   try
     idHTTP.Get1(myURL, scriptStream)
   finally
     idHTTP.Free
     scriptStream.Free;
     maxform1.color:= clRed;
   end;
 end;      
 Showmessage('Script will be loaded and executed in another box!');
 ExecuteShell(ExePath+'maxbox3.exe','"'+ExePath+'examples\'+ascript+'"');
 //playMP3(ExePath+mp3song);

end;

function ExtractUrlPath1(const FileName: string): string; var I: Integer; begin

I:= LastDelimiter('/:', FileName);
Result:= Copy(FileName, 1, I);

end;

function ExtractUrlName1(const FileName: string): string; var I: Integer; begin

I:= LastDelimiter('/:', FileName);
Result:= Copy(FileName, I + 1, 255);

end;

writeln(extractUrlPath1('http://www.softwareschule.ch/maxbox.htm')) result: http://www.softwareschule.ch/ writeln(extractUrlName1('http://www.softwareschule.ch/maxbox.htm')) result: maxbox.htm

Change a Row in a StringGrid

tmp:= TStringList.Create;
with sGrid1 do begin
  tmp.Assign(rows[5]);
  rows[5].Assign(rows[6]);
  rows[6].Assign(tmp);
end;
tmp.Free;

case CreateMessageDialog('Text the maXbox', mtWarning,[mbYes,mbNo,mbCancel]).ShowModal

         of  mrYes: ShowMessage('Yes');
             mrNo: ShowMessage('No');
             mrCancel: ShowMessage('Cancel');
         end;

3 Steps of Clear Code Test:

Step 1: Exchange

procedure exchange(var a,b: integer); begin

 a:= a+b;
 b:= a-b;
 a:= a-b;

end;

Step 2: TimesTable Solution

Function TimesTable2(row,col: integer; tab: byte):string;

var i,j: integer; 
begin
  for i:= 1 to row do
   for j:= 1 to col do begin
     result:= result+ Format('%-*.3d',[tab,i*j])
     if j=col then result:= result+#13#10;
   end;
end;

Step 3: Tokenizer

Procedure strTokenizer(const S: string; Delims:TSysCharSet; Results:TStrings); var i,j: integer; tmp: string; begin

 i:= 1; j:= 1;
 while true do begin
   writeln('this is s2 part '+intToStr(i)); //debug
   while (i <= Length(S)-1) And Not (S[i] in Delims) do
     Inc(i);
   tmp:= trim(Copy(S,j,i-j));
   if tmp <>  then
     Results.Add(tmp);
   if (i <= Length(S)) And (S[i] in Delims) then
     Inc(i); //skip the delimiter
   j:= i;
   if i >= Length(S) then Break;
 end;

end;

Test Function Overall

function Average(a,b,c: Extended): Extended;

begin
  //returns the average of 3 passed numbers
  Result:= Mean([a, b, c]);
end;

ShowMessageFmt('Average of 2, 13 and 56 = %f',[Average(2,13,56)]);
 Assert(Format('%.2f',[average(2,13,56)])='23.67','must be 23.67');

Education Recursion

 function rectestWord(ac: string; n: byte): bool;
 begin
   if n < length(ac) then
     rectestWord(ac,n+1);
   write(ac[n]);   //rec back
 end;

function faculty(n: integer): integer;
begin
 if n < 2 then 
   result:= 1 else
   result:= n * faculty(n-1);
 end;

Palindrome Checker (RegEx and Recursion in One) //***************************************maXbox

procedure palindromeTest(asc: string; out sout: string; n: byte);
begin
  if n <= length(asc) then begin
    palindromeTest(asc,sout,n+1);
    sout:= sout+ asc[n];
  end;
end;  

function PalindromeChecker(asc: string): boolean;
var tmpstr: string;
begin
  result:= false;
  asc:= ReplaceRegExpr('[^a-zA-Z]',asc,,true);
  palindromeTest(asc,tmpstr, 1);
  if CompareText(DelSpace(asc),DelSpace(tmpstr))= 0 then
    result:= true;
end;

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

function PalindromeChecker2(asc: string): boolean;

begin
  result:= false;
  asc:= ReplaceRegExpr('[^a-zA-Z]',asc,,true);
  if CompareText(asc,ReverseString(asc))=0 then
    result:= true;
end;

Josephus Problem and 3 Solutions!

function josephus(n,k: byte): integer;

  var r,i: integer;
  begin
  r:= 0
  i:= 2
  while i <= n do begin
    r:= (r + k) mod i;
    i:= i+ 1
    write(intToStr(r)+ ' ');  //debug
  end;  
  result:= r+1;
 end;

function josephus2(n,k: byte): integer;
  var r,i: integer;
  begin
  r:= 0 i:= 2
  while i <= n do begin
    r:= (r+k) mod i;
    inc(i)
  end;  
  result:= r+1
 end; 

 function josephus_rec(n,k: byte): integer;
  begin
  if n = 1 then
    result:= 1
  else
    result:= (josephus_rec(n-1,k) +k-1) mod n+1
  end;

 function josephusProblem_Function(n,k: integer): integer;
 var i,p,kt: smallint;
   aist: array of char;
 begin
  SetArrayLength(aist,n);
  kt:= 2;
  p:= 0;
  for i:= 0 to length(aist)-1 do aist[i]:= '1';//init array
  while kt <= length(aist) do begin    
    for i:= 0 to length(aist)-1 do begin
      if aist[i]= '1' then inc(p);
      if p = k then begin
        aist[i]:= 'X';
        inc(kt);
        p:= 0;
      end;
    end;
  end; 
  for i:= 0 to length(aist)-1 do  //solution out
    if aist[i]= '1' then result:= (i+1);
end;

 procedure josephusProblem_Graphic(n,k: integer);
 var i,p,kt: smallint;
   aist: array of char;
 begin
  SetArrayLength(aist,n);
  kt:= 2;
  p:= 0;
  for i:= 0 to length(aist)-1 do aist[i]:= '1';//init array
  while kt <= length(aist) do begin    
    for i:= 0 to length(aist)-1 do begin
      if aist[i]= '1' then inc(p);
      if p = k then begin
        aist[i]:= 'X';
        inc(kt);
        p:= 0;
      end;
    end;
    for i:= 0 to length(aist)-1 do  //line out
      write(aist[i]+' ');
    writeln();
  end; 
  for i:= 0 to length(aist) -1 do  //solution out
    if aist[i]= '1' then writeln('Survived '+inttoStr(i+1));
end;

//******************************* CoCreate Object (without constructor)

{Function CaptureScreen : TBitmap;
 Function CaptureScreen1( Rec : TRect) : TBitmap;}

 var mbit: TBitmap; 

 mbit:= captureScreen;
 mbit.SaveToFile(exepath+'co_objscreen.bmp');
 searchandOpenDoc(exepath+'co_objscreen.bmp');
 mbit.Free;

//******************************* StrToWord with StrtoInt (StrtoWord is buggy)

  htimes:= '12';
  Ahour:= strtoInt(htimes);
  DecodeTime(Now, AMin, AMin, ASec, AMSec);
  PrintF(' %0.2d : %0.2d', [AHour, AMin]);

Example of the month:

Richter Generator to show:

http://www.softwareschule.ch/examples/069_Richter_MATRIX.TXT

Input Query and RegEx PathFinder to show:

http://www.softwareschule.ch/examples/480_regex_pathfinder.txt

Input Query and RegEx PathFinder to show:

http://www.softwareschule.ch/examples/480_regex_pathfinder.txt

Clever Function Copy2SymbDel

 mystr:= 'this is the m@x that rocks';
 writeln('Copy2SymbDel1: '+Copy2SymbDel(mystr, '@'));
 writeln('Copy2SymbDel2: '+mystr);

    >Copy2SymbDel1: this is the m
    >Copy2SymbDel2: @x that rocks

Magic Card Trick

Due to recent advances, it's now possible to sense the vibrations caused by the human voice as the sound impacts the speakers attached to your PC!?!.

http://www.softwareschule.ch/examples/471_cardmagic2.txt

or just ALL cards to show:

http://www.softwareschule.ch/examples/472_allcards.txt

maXbox to Excel Export (maXcel)

function SaveAsExcelFile(AGrid: TStringGrid; aSheetName, aFileName: string): Boolean;

var

 XLApp, Sheet: OLEVariant;
 i, j: Integer;

begin

 // Create Excel-OLE Object
 Result:= False;
 XLApp:= CreateOleObject('Excel.Application');
 try
   // Hide or show Excel
   XLApp.Visible:= true;
   // Add new Workbook
   XLApp.Workbooks.Add(xlWBatWorkSheet);
   Sheet:= XLApp.Workbooks[1].WorkSheets[1];
   Sheet.Name:= aSheetName;
 for i:= 0 to AGrid.ColCount -1 do
   for j:= 0 to AGrid.RowCount -1 do 
      XLApp.Cells[i+2,j+1]:= agrid.cells[i,j]; //direct fill
   try  // Save Worksheet
     XLApp.Workbooks[1].SaveAs(aFileName);
     Result:= True;
   except
     Msg('maxcel export error'); // Error ?
   end;
 finally   // Quit Excel
   if not VarIsEmpty(XLApp) then begin
     XLApp.DisplayAlerts:= False;
     XLApp.Quit;
     XLAPP:= Unassigned;
     Sheet:= Unassigned;
   end;
 end;

end;

call:

 myst:= TStringGrid.create(self)  //fill with data

if SaveAsExcelFileDirect(myst, 'maxceltestmap',Exepath+'maxceltest3.xls')
             then msg('maxcel export success');

Smart/Small Manual for maXbox

25 User Tips for mX3 3.9.9

- Install: just save your maxboxdef.ini before and then extract the zip file!

- Toolbar: Click on the red maXbox Sign (right on top) opens your work directory or jump to <Help>

- Menu: With <F2> you check syntax with <F8> you debug and <F9> you compile!

- Menu: With <Crtl><F3> you can search for code on examples

- Menu: Open in menu Output a new instance <F4> of the box to compare or prepare your scripts

- Menu: Set Interface Naviagator in menu /View/Intf Navigator

- Menu: Switch or toogle between the last 2 scripts in menu File/LoadLast (History is set to 9 files)

- Inifile: Set memory report in ini: MEMORYREPORT=Y :report on memory leaks on shutdown by dialog

- Context Menu: You can printout your scripts as a pdf-file or html-export

- Context: You do have a context menu with the right mouse click

- Menu: With the UseCase Editor you can convert graphic formats too.

- Menu: On menu Options you find Addons as compiled scripts

- IDE: You don't need a mouse to handle maXbox, use shortcuts

- Menu: Check Options/ProcessMessages! if something is wrong or you can't see graphics in a time

- IDE: Drag n' drop your scripts in the box or the model in use case editor (Cut,Copy,Paste always available)

- Editor: You can get templates as code completion with <ctrl j> in editor like classp or iinterface or ttimer (you type classp and then CTRL J),or you type tstringlist and <Ctrl><J>

- Menu: In menu output (console) you can set output menu in edit mode by unchecking <read only output>

- Editor: After the end. you can write or copy notes or descriptions concerning the app or code

- Code: If you code a loop till key-pressed use function: isKeyPressed;

- Code: Macro set the macros #name, #date, #host, #path, #file, #head #sign, see Tutorial maxbox_starter25.pdf

- Editor: - Dbl Click on Word in Editor search amount of words with highlighting, Dbl Click on Bookmarks to delete and Click and mark to drag a bookmark

- Menu: To start handling from CD-ROM (read only mode) uncheck in Menu /Options/Save before Compile

- IDE: A file info with system and script information you find in menu Program/Information

- IDE: Make a screenshot of the content and environment in menu Output/Save Screenshot

- IDE: Use a boot loader script 'maxbootscript.txt' (as auto start) to change the box each time you start it.

- IDE: With escape or <Ctrl> Q you can also leave the box or stop a script in menu program - stop program

Current Development to mX4 V4.0

Switch between Pascal and C = PasCal

  float convertToF(float temperatureC)
   {
    return (temperatureC * 9.0 / 5.0) + 32.0;
   }

  function convertToF(temperatureC: float): float;
  begin
    result:= (temperatureC * 9.0/5.0) + 32.0;
  end;

In the version 3.8 we upgrade from mX3 (delphi2007) to mX4 compiler (delphi2009) A Unit support, Boot-Loader Scripting and Version Check routine is already workable The idea of a BOOTSCRIPT is before start the maXbox you can alter, init or change functions or features of the OpenTools API in maXbox, so the bootscript is named maxbootscript.txt and all those routines will be executed by starting the box. For example you change the buttons or color options of the editor or you set some monitor or processing functions valid for all scripts to be executed.

With mX4 we do have full decompile or debug possibility of the scripts, mX3 < 3.6 had some trouble with event handler in it.

Type Conversion like floatToString are with implicit or explicit type casts, so an error is shown but the script runs anyway. The full variant support depends on a compiler directive in pascalscript.inc

With the CPort as a Serial Component we now have support for Arduino, see Tutorial 18 The new Package/Component Model Viewer is included, see menu /Debug/Units Explorer

RegEX PCRE Lib integration finished in 3.9.6:

//I have the following REGEX: //^(\[[A-Za-z0-9,]+\])?([A-Za-z0-9]+:)?([A-Za-z]+)$?([^$]*)\)?$ (*When presented with Set(ID,99) Perl returns: 1:[], 2:[], 3:[Set], 4:[ID,99] - as I expected

Delphi's Reg ex returns:

Group 1:[] Group 2:[] Group 3:[Set] Group 4:[ID,99]

procedure DelphiCoreCodeRegEx; var

 regEx: TPerlRegEx;
 i: integer;

begin

 try
   { TODO -oUser -cConsole Main : Insert code here }
   regEx:= TPerlRegEx.Create;
   try
     regEx.RegEx := '^(\[[A-Za-z0-9,]+\])?([A-Za-z0-9]+:)?([A-Za-z]+)\(?([^\)]*)\)?$';
     regEx.Subject := 'Set(ID,99)';
     WriteLn('Regex: '+regEx.RegEx);
     WriteLn('Subject:'+regEx.Subject);
     WriteLn();
     if regEx.Match then begin
         for i:= 1 to 4 do
           WriteLn(Format('Group %d:[%s]',[i,regEx.Groups[i]]));
       end
     else
       WriteLn('Subject did not match the regular expression');
     ReadLn();
   finally
     regEx.Free;
   end;
 except
   //on E: Exception do
     Writeln('E.ClassName'+ ': '+ E.Message);
 end;
end;

Profiler and QueryByExample (QBE) is done by Jedi and implemented in maXbox:

QBEQuery1:= TJvQBEQuery.create(self);
   with QBEQuery1 do begin
     //parent
     DatabaseName:= 'DBDEMOS'
     with QBE do begin
       add('Query')
       add();
       add('SORT: EMPLOYEE.DB->"LastName", EMPLOYEE.DB->"FirstName"');
       add();
       add('EMPLOYEE.DB | EmpNo  | LastName | FirstName | PhoneExt |');
       add('            | Check  | Check    | Check     | Check    |');
       add();
       add('EndQuery');
     end;
     Active:= True;
     for i:= 0 to Recordcount - 1 do begin
       for z:= 0 to Fieldcount - 1 do 
         Write((Fields[z].asString)+'  ');
       Writeln(#13#10)
       Next;
     end;
   //StmtHandle
   //StartParam:= '<>'; //Params:= '<>';
   //ParamData:= <>
   Close;
   Free;
 end;

http://www.softwareschule.ch/examples/332_jprofiler_form2.txt http://www.softwareschule.ch/examples/332_jprofiler_form2.htm http://www.softwareschule.ch/examples/333_querybyexample.txt

Another Cool Feature is the TCustomImageList:

//////////////////// digi clock rock procedure DigiTForm1_FormActivate(Sender: TObject); //Startinit on Form var i,t: integer; begin

 pb[1]:=pb1; pb[2]:=pb2; pb[3]:=pb3;
 pb[4]:=pb4; pb[5]:=pb5; pb[6]:=pb6;
 for i:= 1 to 6 do zeit[i]:= 0;
 imgL:= TCustomImageList.Create(self);
 ReadComponentResFile(ExePath+picpath+'MyImageClockList7Segment.dat', imgl);
 with imgL do begin
   //@Bitmap.DrawMode:= dmBlend  //assign; setbounds
    Height:= 50;
    Width:= 30;
   {for t:= 0 to 9 do //image, mask
      Add(getbmp(exePath+picpath+'7seg'+inttostr(t)+'.bmp'),
                   getbmp(exePath+picpath+'7segaus.bmp'));} 
 end;
 WriteComponentResFile(ExePath+picpath+'MyImageClockList7Segment.dat', imgL);

end;

procedure DigiTForm1_TimerTimer(Sender: TObject); var i: integer;

   s,s1: String;
   t: TDateTime;

begin

 t:= Now;
 //Formate, 6-parts of s
 DateTimeToString(s,'hhmmss',t);
 //Number assign and draw
 for i:= 1 to 6 do begin
   s1:= MidStr(s,i,1);
   zeit[i]:= strToInt(s1);
   imgL.Draw(pb[i].Canvas,1,1,zeit[i],true);
 end;

end;

http://www.softwareschule.ch/examples/336_digiclock2.htm http://www.softwareschule.ch/examples/336_digiclock2.txt

For a 64 version a way to query the env. is:

bstr:= ifThen(IsWow64, 'maxbox3_64.exe','maxbox3.exe');
 if Winexec32(Format(ExePath+'%s',[bstr]),SW_Show) then 
      writeln('EXE '+bstr+' is running');

JVChart, CodeSearchEngine and BigInteger has been finished

Exception Handling with decompile address out: for example you set a function with false type:

function HexToStr(Value: string): string;

and then you mistaken the para type integer instead of string, but it will compile, the registration is a literal in addfunction:

Sender.AddFunction(@HexToStr, 'function HexToStr(Value: integer): string;');

but at runtime you get

Exception: Access violation at address 004069A0 in module 'maxbox3_9.exe'. Read of address 00000F98 at 0.3461

So you can find the error at 0.3461 with the decompiler:

[3450] PUSHVAR Base[1] // 3
[3456] CALL 165
[3461] POP // 2
[3462] POP // 1

then you go to CALL 165 and you see the miserable function: Proc [165]: External Decl: \01\00 HEXTOSTR

Design Mind Mapping of the 4.0 IDE >> To help prioritize and design them, I'd like to better understand the >> various requests for editor improvements (e.g. auto-complete, better >> syntax highlighting). What are the user experience problems you're >> trying to solve? For who? (Please be more specific than "making >> maXbox more like other IDEs". If that's the goal, I think we're >> better off making it easier to let you use those other IDEs.) >> >> Anything that requires heuristic parsing of incomplete / invalid code >> (e.g. because you're in the middle of typing it) is probably beyond >> the scope of what we can reasonably do (unless there's a great >> library or example to draw on). That is, I don't think we're going >> to be able to do things like dynamically parse the user sketch as >> it's being typed, extract the names of functions defined in the >> sketch, and provide dynamic syntax highlighting / command completion >> for calls to those functions elsewhere in the sketch. On the other >> hand, looking for a known string like PrintF() to appear in >> your script and dropping down a list of arguments doesn't seem so unrealistic. >> >> The overall point is that, for each feature request, we're trying to >> balance the degree to which we can improve the user experience with >> the feasibility / difficulty of implementation. Keep that in mind as >> we discuss improvements to the IDE.

Just a glance for an app:

mX4 Proview

[File:MX_screenshotwin8.png Preview]

MemoryStream overloading

As no direct overloading is possible, we do it by name conventions:

For example a write to buffer with an dynamic array of byte is WriteBufferABD:

procedure CreateEmptyZipFile; var i: integer;

 zipfile: wideString;
 //ezip: TByteArray; =(80,75,5,6,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
 ezip: TByteDynArray;
 ms: TMemoryStream;

begin

 SetLength(ezip, 25);   //for ZIP Header
   ezip[0]:=80; ezip[1]:=75; ezip[2]:=5; ezip[3]:=6; 
   for i:= 4 to 23 do ezip[i]:= 0;

 zipfile:= exepath+'examples\'+AZIPFILE;
 // create a new empty ZIP file
 ms:= TMemoryStream.Create;
 writeln(ObjectToStr(ms));  //debug pointer
 try
   //ms.WriteBuffer array of byte of dynamic size;
   ms.WriteBufferABD(ezip, length(ezip));
   ms.SaveToFile(Zipfile);
 finally
   ms.Free;
 end;

end;

Tower of Hanoi Decoded

PROGRAM Tower_of_Hanoi_Steps_SolutionSequence; //Uses Crt; {

**************************************************************************
solution of the tower of hanoi with a codelist, double recursion!,
codelist with 12 patterns of 4 steps, codesequence in 24 solution steps!
 loc's= 134, ex. _80ff
try to program it with a canvas object to visualize
************************************************************************** }

//uses crt;

Const SOLUTIONFILE = 'hanoilist.txt';

Type

   TPatterns=  array[1..12] of shortstring;

var answer: string;

   steps, step4, i: integer;
   patt: shortstring;
   varray: TPatterns;
   pattlst, seqlist: TStringlist;

//The 12 Main Step Patterns!

procedure initPatternArray; //codelist begin

 varray[1]:=   'a to b a to c b to c a to b ';
 varray[2]:=   'a to b a to c b to c b to a ';
 varray[3]:=   'a to c a to b c to b a to c ';
 varray[4]:=   'a to c a to b c to b c to a ';
 varray[5]:=   'b to a b to c a to c b to a ';
 varray[6]:=   'b to a b to c a to c a to b ';
 varray[7]:=   'b to c b to a c to a b to c ';
 varray[8]:=   'b to c b to a c to a c to b ';
 varray[9]:=   'c to a c to b a to b c to a ';
 varray[10]:=  'c to a c to b a to b a to c ';
 varray[11]:=  'c to b c to a b to a c to b ';
 varray[12]:=  'c to b c to a b to a b to c ';

end;

procedure Search_Write_Codes; var vs, tmp: shortstring;

  i,k, found: integer;

begin

 found:= 0;
 writeln('pattern codes ---------- for solution: '+answer);
 for i:= 0 to pattlst.count - 1 do begin
   vs:= pattlst.strings[i]
   for k:= 1 to high(varray) do
     if vs = varray[k] then begin
       //writeln('patt code: '+inttostr(k));
       inc(found)
       tmp:= tmp +(inttostr(k)+'-')
       //write(inttostr(k)+'-');               //-fast
       //if found mod 32 = 0 then writeln(); //-fast
     if found mod 24 = 0 then begin 
       seqlist.add(tmp);
       tmp:= ;
     end; 
   end;    
 end;
 seqlist.add(tmp) //last/first segment
 writeln('Nr of codes: ' +inttostr(found))

end;

procedure move(high: integer; a,c,b: char); begin

 if high > 1 then begin
   move(high-1,a,b,c);
   //writeln(a+' to '+c);   //-fast
   inc(step4)
   patt:= patt+a+' to '+c+' ';
   if step4 mod 4 = 0 then begin
     pattlst.add(patt)
     patt:= ;
   end;   
   move(high-1,b,c,a);
   inc(steps)
 end else begin
   //writeln(a+' to '+c)   //-fast
   inc(step4)
   patt:= patt+a +' to '+c+' ';
   if step4 mod 4 = 0 then begin
     pattlst.add(patt)
     patt:= ;
   end;   
   inc(steps)
 end; 
 //writeln(' very last test')

end;

begin //main

 steps:= 0;
 step4:= 0;
 initPatternArray;
 pattlst:= TStringlist.create;
 seqlist:= TStringlist.create;
 answer:= readln('How much on a pile ?');
 Writeln('Pile solution of: '+(answer))
 move(strtoInt(answer),'a','b','c');
 Writeln('had total '+inttoStr(steps)+ ' steps');
 for i:= 0 to pattlst.count - 1 do      //-fast
   writeln(pattlst.strings[i]);
 Search_Write_Codes; 
 writeln('Nr of codelines: '+inttostr(seqlist.count)+ ' in file '+SOLUTIONFILE)
 seqlist.savetoFile(exepath+'examples\'+SOLUTIONFILE)
 seqlist.Free; 
 pattlst.Free;

 {Writeln('or '+chr(bintoint(inttobin(ord('A') OR ord('B')))))
 Writeln('xor '+chr(ord('A') XOR ord('B')))
 Writeln('and '+chr(ord('A') AND ord('B')))
 Writeln('not and'+chr((NOT ord('A') AND ord('B'))))}

End.

The 12 Main Step Patterns! --1-------2-------3-------4------- A 1,2,3,4 a to b a to b a to c a to c a to c a to c a to b a to b b to c b to c c to b c to b a to b b to a a to c c to a --5-------6--------7-------8------ B 5,6,7,8 b to a b to a b to c b to c b to c b to c b to a b to a a to c a to c c to a c to a b to a a to b b to c c to b --9-------10-------11------12----- C 9,10,11,12 c to a c to a c to b c to b c to b c to b c to a c to a a to b a to b b to a b to a c to a a to c c to b b to c

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

This is the solution code sequence for all even piles! repeat n/24:

3-6-11-3-5-12-3-(5/6)-11-4-5-11-3-6-11-(3/4)-5-12-3-5-11-4-5-(11/12)

This is the solution code sequence for all odd piles!:

1-10-7-1-9-8-1-(9/10)-7-2-9-7-1-10-7-(1/2)-9-8-1-9-7-2-9-(7/8)

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

www.softwareschule.ch/examples/080_pas_hanoi2_file.txt

Closures, RegEx and Threads

And the story goes on: A Function containing at least one free variable is called an Open Term. In order to get to a fully functional Function, all free variables have to be bound (turning that open term into a closed term). For this to be done, the compiler reaches out to the so called lexical environment, in which that Function was defined and tries to find a binding. This process is called closing over which results in a closed expression or â€“ for short â€“ a Closure.

Before I get into closures, I want to address the constant use of the word as a misnomer. The term Closures is very frequently treated as a synonym for the term anonymous methods. Though closures are specific to anonymous methods, they are not the same concept. Anonymous methods are possible without closures. Do not use the terms interchangeably.

 function belowFirst(const xs: array of Integer): array of Integer;
 var i: Integer;
 begin
   for i:= 1 to high(xs) do
     if xs[i] < xs[0] then 
       result[i]:= xs[i]
 end;

 main: setlength(mba,10)
 mba:= belowFirst([5,1,7,4,9,11,3]);     //Open Array Constructor
 for i:= 1 to 9 do write(intToStr(mba[i]));

the same in Scala: 01 val belowFirst = ( xs : List[Int] ) => { 02 03 val first = xs( 0 ) 05 val isBelow = ( y : Int ) => y < first 07 for( x <- xs; if( isBelow( x ) ) yield x 08 } 10 ... 11 belowFirst( List( 5, 1, 7, 4, 9, 11, 3 ) ) // => List( 1, 4, 3 )

//Avoid globals and various lines with a strategy pattern:

function loadPForm(vx, vy: integer): TForm; var psize: integer;

   ppform: TForm;

begin

 psize:= vx*vy
 //constructor
 ppform:= TForm.Create(self);
 with ppform do begin
   caption:= 'LEDBOX, click to edit, dblclick write out pattern'+
                ' Press <Return> to run the Sentence';  
   width:= (vx*psize)+ 10 + 300;
   height:= (vy*psize)+ 30;
   BorderStyle:= bsDialog;
   Position:= poScreenCenter;
   //onKeyPress:= @FormKeyPress
   //OnClick:= @Label1Click;
   //OnClose:= @closeForm;
   Show;
 end;
 result:= ppform;

end;

procedure LetBitmaponForm(aform: TForm); var mbitmap: TBitMap; begin

 mbitmap:= TBitmap.Create;
 try
   mbitmap.LoadFromFile(Exepath+BITMAP);
   aform.Canvas.Draw(370,170, mbitmap);
 finally
   //aForm.Free;
   mbitmap.Free;
 end;

end;

Call: LetBitmaponForm(loadPForm(8,8));

Closure Pattern with procedure type:

type TProc = procedure(VAR x: single);

    TProc2 = procedure();
    TPredicate = function(const x: integer): bool;

procedure ShowHourGlass(aProc: TProc2);
var OldCursor: TCursor; 
begin 
 OldCursor := Screen.Cursor; 
 Screen.Cursor := crHourGlass; 
 try 
  //aProc(x); 
   aProc(); 
   showmessage('^fct2 after');
 finally 
  Screen.Cursor := OldCursor 
 end; 
end;

PROCEDURE fct2; //as closure
 var i: integer;
 BEGIN  
   for i:= 1 to 99996666 do 
     Sin(i);
   sleep(4000)
   showmessage('^fct2 in');
 END;

Call:

  ShowHourGlass(@fct2);

RegEx in maxbox has some components one is the RegExp Studio it goes like this:

 email:= 'max@kleiner.com';
 rex:= '[\w\d\-\.]+@[\w\d\-]+(\.[\w\d\-]+)+';

 writeln('email is: '+booleanToString(ExecRegExpr(rex, email)))

How do I get the last term in URL between slashes ie 'last' using regex?

 myURL = 'http://www.kleiner.ch/kleiner/download/G9_japan.mp3';

 mp3song1:= ReplaceRegExpr('([^/]+)/?$',myurl,',true); //show all except last
 -->http://www.kleiner.ch/kleiner/download/

 mp3song1:= ReplaceRegExpr('([^/]+)?/',myurl,',true); //show only last extract
 -->G9_japan.mp3

 writeln('regex extract test: '+mp3song1)

Test also with:
mp3song1:= ExtractWord(5,myurl,['/']);

Pascal Parser Regex

function ParseReturnType(const AText: string): string;

 Parser.Pattern := '((\w+)\.)*\w+';

function ParseDefaultValue(const AText: string): string;

 Parser.Pattern := '\s*\=\s*(.*|\w+|(\+|\-)?\d+\.\d+)';

function ParseTypeName(const AText: string): string;

 Parser.Pattern := '(?:\s*\:\s*)&?(((\w+)\.)*(\w+))';

procedure ParseParamNames(Routine: TRoutineDeclaration; const AText: string);

 Parser.Pattern := '&?(((\w+)\.)*\w+)(?:\s*,|:)';

function ParseSingleDeclaration(Routine: TRoutineDeclaration; const AText: string): TParamType;

 Parser.Pattern := '((const|var|out)?(?:\s)*&?(\w+)(\s*,\s*\w+)*(?:\s*\:\s*)&?((\w+)\.)*(\w+)(\s*\=\s*(.*|\w+|\d+))?)';

function ParseTypeDeclaration(Routine: TRoutineDeclaration; const AText: string): TParamType;

 Parser.Pattern := '([^;]*)(\;)?';

API Code

Window Themes and Color

To set a color in a Panel or to override themes two ways are possible: - controlstyle set - parentbackground

 with mypanel do begin
    caption:= '********maXboxMP3********';  
    controlstyle:= controlstyle - [csParentBackground,csOpaque];

 mypanel:= TPanel.Create(self)
    with mypanel do begin
    ParentBackground:= false;
    color:= clyellow;

Error Handling

 Forget the FormatMessage() take the sysErrorMessage!
 Convert the OS Error Code into a User Friendly Message
 trying to remove a non existing folder or RemoveDir deletes an existing empty directory.

 RemoveDir('k:\NoSuchFolder') ;
 ShowMessage('System Error Message: '+ SysErrorMessage(GetLastError)) ;
 >System Error Message: The system cannot find the file specified

Service, App or Session?

 function isService: boolean;
 begin
   result:= NOT(Application is TApplication);
   {result:= Application is TServiceApplication;}
 end;

 function isApplication: boolean;
 begin
   result:= Application is TApplication;
 end;

 //SM_REMOTESESSION = $1000
 function isTerminalSession: boolean;
 begin
   result:= GetSystemMetrics(SM_REMOTESESSION) > 0;
 end;

function GetShortPathName(lname, sname: pchar; mpath: longint): bool;

 external 'GetShortPathNameW@kernel32.dll stdcall';

//undocumented !

function MessageBoxTimeOut(hWnd: HWND; lpText: PChar; lpCaption: PChar; uType: UINT;

wLanguageId: WORD; dwMilliseconds: DWORD): Integer; external 'MessageBoxTimeoutA@user32.dll stdcall';

 iFlags:= $0 or $00010000 or $00000040;
    iResult:= MessageBoxTimeout(Application.Handle,
        'Test a timeout of 2 seconds.','MessageBoxTimeout Test',iFlags,0,2000);

BitBlt: Own Mouse Moving Pic Cursor

procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); //var FOldRect: TRect; //makes a blur and zoom effect begin

 //firsttime:= true;   //move tester
 { 1) Restore Form1: copy storage onto Form1 at its old location }
 //FOldRect:= Rect(280, 200, X , Y);
 if FirstTime then FirstTime:= False
   else BitBlt(bfrm.Canvas.Handle, FOldRect.Left, FOldRect.Top,
    FPic.Width,FPic.Height, FStorage.Canvas.Handle,0,0,SRCCOPY);
 { save old location }
 FNewRect:= Rect(X, Y, X + FPic.Width, Y + FPic.Height);
 FOldRect:= FNewRect;
 { 2) Save copy: copy rectangle from Form1 to storage at new location.}
 BitBlt(FStorage.Canvas.Handle,0,0, FPic.Width, FPic.Height,
        bfrm.Canvas.Handle, FNewRect.Left, FNewRect.Top,  SRCCOPY);
 { 3) copy the image to Form1 using SRCINVERT }
 BitBlt(bfrm.Canvas.Handle, FNewRect.Left, FNewRect.Top, FPic.Width, FPic.Height,
        FPic.Canvas.Handle,0,0, SRCAND);

end;

function NumProcessThreads2: integer; var

 hsnapshot: THandle;
 Te32: TTHREADENTRY32;
 proch: dWord;

begin

 Result:= 0;
 proch:= GetCurrentProcessID;
 hSnapShot:= CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);

 Te32.dwSize:= sizeof(Te32);
 if Thread32First(hSnapShot, Te32) then begin
   if Te32.th32OwnerProcessID = proch then
     inc(Result);
   while Thread32Next(hSnapShot, Te32) do begin
     if Te32.th32OwnerProcessID = proch then
       inc(Result);
   end;
 end;
 CloseHandle(hSnapShot);
 writeln('WinDir '+getwindir);
 writeln('SysDir '+getsysdir);
 //getsystempath

end;

For example, the thread queues are more than lists of messages--they also maintain some state information. Some messages (like WM_PAINT) aren't really queued, but synthesized from the additional state information when you query the queue and it's empty. Messages sent to windows owned by other threads are actually posted to the receiver's queue rather than being processed directly, but the system makes it appear like a regular blocking send from the caller's point of view; this can cause deadlock (because of circular sends back to the original thread).

function FileTimeGMT2 (FileName: STRING): TDateTime;

        // Returns the Date and Time of the last modification of the given File
        // The Result is zero if the file could not be found
        // The Result is given in UTC (GMT) time zone

VAR

 Handle         : THandle;
 FindData       : TWin32FindData;
 SystemFileTime : TSystemTime;
 mf: TFileTime;

begin

 Result := 0.0;
 Handle := FindFirstFile (PChar (FileName), FindData);
 IF Handle <> INVALID_HANDLE_VALUE THEN BEGIN
   WFindClose (Handle);
   IF (FindData.dwFileAttributes AND FILE_ATTRIBUTE_DIRECTORY) = 0 THEN
     // FileTimeToSystemTime(FindData.ftLastWriteTime, SystemFileTime); 
     IF FileTimeToSystemTime(FindData.ftLastWriteTime, SystemFileTime) THEN BEGIN
       with SystemFileTime do begin
         if messagebeep(4) then 
           Result:= EncodeDate (wYear, wMonth, wDay) +
         EncodeTime (wHour, wMinute, wSecond, wMilliseconds);
       end;
     END;
   END;

END;

procedure OpenIEURL(aURL:string); var sz: string; begin

 Application.ProcessMessages;
 aURL:= trim(aURL);
 if aURL= then Exit;
 with TRegistry.Create do try
    rootkey:= HKey_Classes_Root;
    OpenKey('\htmlfile\shell\open\command',false);
    try 
      sz:= ReadString();
      writeln('test of IE readkey '+sz) 
    except
      sz:= ; 
    end;
    CloseKey;
 finally
     Free;
 end;
 if sz= then Exit;
 sz:= copy(sz, pos('"',sz)+1, length(sz));
 sz:= copy(sz, 1, pos('"',sz)-1);
 if pos('http://',aURL)<>1 then aURL:='http://'+aURL;
 //ShellExecute(0,'open',PChar(z), PChar(aURL), nil, sw_ShowNormal); 
 //ShellExecute(0,'open', PChar(aURL), nil, nil, sw_Show);

end;

Procedure HideWindowForSecondsT(secs: integer);

Var T : tdateTime; begin

 ShowWindow(Self.Handle, SW_Hide);
 ShowWindow(Application.Handle, SW_Hide);
 T:= Time;
 Repeat
   Application.ProcessMessages;
 Until Time - T > secs / 24 / 3600;
 ShowWindow(Self.Handle, SW_Show);
 ShowWindow(Application.Handle, SW_Show);

end;

//if IsTCPPortOpen(8080,getIP('127.0.0.1')) then
  if IsTCPPortOpen(9000,getIP(getHostName)) then
      writeln('Port Open Started') else 
      writeln('Port not open');

DataBase Init

procedure newDBTableScript; begin

 with TTable.Create(self) do begin
   Active:= false;
   databasename:= 'DBDEMOS';
   //databasename:= 'knabe';
   tablename:= 'maxtable3';
   tabletype:= ttparadox;
   with fielddefs do begin
     Clear;
     add('field1',ftinteger,0,false)
     add('field2',ftinteger,0,false)
     add('field3',ftfloat,0,false)
   end;
   CreateTable; 
   active:= true;
   Insert;
    FieldbyName('field1').value:= 44;
    FieldbyName('field2').value:= 55;
    FieldbyName('field3').value:= 3.1415;
   Post;
   Close;  
 end;

end;

Create a Table with Index procedure CreateATable(DBName, TblName : String); //Path Alias & Table Name to Create var tbl: TTable; begin

 tbl:= TTable.Create(self);
 with tbl do begin
   Active:= False;
   DatabaseName:= DBName;
   TableName:= TblName;
   TableType:= ttParadox;
   with FieldDefs do begin
     Clear;
     Add('LastName', ftString, 30, False);
     Add('FirstName', ftString, 30, False);
     Add('Address1', ftString, 40, False);
     Add('Address2', ftString, 40, False);
     Add('City', ftString, 30, False);
     Add('ST', ftString, 2, False);
     Add('Zip', ftString, 10, False);
     Add('ZipCode', ftInteger, 0, False);
   end;
   {Add a Primary Key to the table}
   with IndexDefs do begin
     Clear;
     Add('Field1Index2', 'LastName;FirstName', [ixPrimary,IxUnique]);
   end;
   CreateTable; {Make the table}
 end;

end;

procedure addRecord(DBName, TblName : String); begin

 with TTable.Create(self) do begin
   Active:= false;
   databasename:= DBName;
   tablename:= TblName;
   active:= true;
   Insert;
     FieldbyName('LastName').value:= getRandomString(28);
     FieldbyName('FirstName').value:= getRandomString(15);
     FieldbyName('Address1').value:= getRandomString(39);
     FieldbyName('Address2').value:= 'milkywaymax 42';
     FieldbyName('City').value:= 'Randomia';
     FieldbyName('ST').value:= '19';
     FieldbyName('Zip').asString:= getrandomString(9);
     FieldbyName('ZipCode').asInteger:= random(1000);
   Post;
   Close;  
 end;

end;

Firebird 2.5.2

Released November 06, 2012. Updated March 24, 2013. Works well with 301_SQL_DBfirebird4.txt

CONNECTSTRING = 'Provider=MSDASQL;DSN=mxfirebird;Uid=sysdba;Pwd=masterkey'; $Provider=MSDASQL.1;Persist Security Info=False;Data Source=mxfirebird

* Purpose  : Demonstrates 3 ways Queries in Datasets (DBX, BDE, ADO(ODBC)) on 64bit!
* History  : TSQLConnection, TSQLDataSet, TSQLQuery

http://www.softwareschule.ch/examples/301_SQL_DBfirebird5.txt

 procedure ConnectFireBird(const aDBname: string);
  var
    connect: TSQLConnection;
    DataSet: TSQLDataSet;
    dataQuery: TSQLQuery;
 begin
 connect:= TSQLConnection.Create(NIL);
 try
   with connect do begin
     ConnectionName:= 'VCLScanner';
     DriverName:= 'Firebird';//'INTERBASE';   //or Firebird
     LibraryName:= 'dbxint30.dll';
     VendorLib:= 'GDS32.DLL';
     GetDriverFunc:= 'getSQLDriverINTERBASE';
     Params.Add('User_Name=SYSDBA');
     Params.Add('Password=masterkey');
     Params.Add('Database='+ADBNAME);
     LoginPrompt:= false;
     Open;
     dataQuery:= SQLReturn(connect)
     dataSet:= DataSetQuery(connect) 
     //finalize objects 
     if Connected then begin
       DataSet.Close;
       DataSet.Free;
       dataQuery.Close;
       dataQuery.Free;
       Close; //connect
       Free;
     end; 
   end;  //with
 except
   E:= Exception.Create('SQL Connect Exception: ');
   Showmessage(E.message+'SQL or connect missing')
 end;
 end;

 procedure BDEDataBaseConnect;
 var aParams, aTblNames: TStringList;
   aSession: TSession;
   dbMain: TDatabase;
   i: integer;

begin

 AParams:= TStringList.Create;  
 aTblNames:= TStringList.Create; 
 //create a session to get alias parameters list 
 ASession:= TSession.Create(NIL);  
 ASession.SessionName:= 'Session4';  
 dbMain:= TDatabase.Create(NIL);  
 try  
   ASession.GetAliasParams(BDEAlias, AParams);
   for i:= 0 to aparams.count -1 do 
     writeln(aParams[i]);
   with dbMain do begin  
     Params.Assign(AParams);  
     dbMain:= ASession.OpenDatabase(BDEAlias);
     Writeln('Database is: '+dbMain.DataBaseName)
     KeepConnection:= True;
     GetTableNames(aTblNames, false)
     Writeln('Tables are: ');
     for i:= 0 to atblNames.count-1 do 
       Write(atblnames[i]+' ');
     doQuery(dbMain);
   end;
 finally  
   DBMain.Free;
   ASession.Free;  
   AParams.Free;
   aTblNames.Free;
 end;

end;

 Procedure SetADOSETAccess2;
 var i,z: integer;
      ws: TWideStrings;
 begin  
 with TAdoDataSet.Create(self) do begin
   cachesize:= 500;
   commandText:= SQLQUERY;
   //String:= 'Provider=MSDASQL;DSN=mx3base;Uid=sa;Pwd=admin';
   connectionString:= CONNECTSTRING;
   //try
   Open;
   //except   
   Writeln(intToStr(Recordcount)+' records found:')
   //end;
   for i:= 0 to Recordcount - 1 do begin
     for z:= 0 to Fieldcount - 1 do 
       Write((Fields[z].asString)+'  ');
     Writeln(#13#10)
     Next;
   end;
   Close;
   Free;        
 end; //TAdoDataSet
 Writeln('List Provider Names: ')
 ws:= TWideStringList.Create;
 getProviderNames(ws)
 for i:= 1 to ws.Count-1 do 
   writeln(inttostr(i) +' '+ws.strings[i]);
 ws.free;  
 end;

Floating Point Test Routine

By comparing a float point result like a double or extended type delivers a reference value is needed. Second a loop or iteration is needed to prove the approximation of the lasting result. I got the idea to make it with a well known series. There are several well-known proofs of the divergence of the harmonic series. Two of them are given below but one is chosen, cause it converges to ln(2) as our reference point. The series

   sum_{n = 1}^\infty \frac{(-1)^{n + 1}}{n} \;
   = 1 - {1}/{2}+{1}/{3}-{1}/{4}-{1}/{5}.... = ln(2)

is known as the alternating harmonic series. This series converges by the alternating series test.

In particular, the sum is equal to the natural logarithm of 2!:

for i:= 1 to 50000000 do begin //zeta: double or extended;

    if i mod 2 = 0 then
        zeta:= zeta - 1/i else
        zeta:= zeta + 1/i;
    end;

50000 = 0.693137180659968 100000 = 0.693142180584982 500000 = 0.693146180561005 10^6 = 0.693146680560255 5*10^6 = 0.693147080560068 50*10^6= 0.693147170560399

ln(2) = 0.693147180559945

Leibniz formula:

    zeta:= 0;
    tac:= true;
    for i:= 1 to 50000 do 
      if NOT (i mod 2 = 0) then begin 
        tac:= not tac;
        if tac then
          zeta:= zeta - 1/i else
        zeta:= zeta + 1/i;
      end;  

      writeln('harmonic alternate leibniz formula to PI/4: '+floatToStr(zeta))  
      writeln(floatToStr(maxcalc('PI/4')))
      writeln(floatToStr(PIOn4))

did some test routines from fundamentals4

 SelftestPEM;
 SelfTestCFundamentUtils;
 SelfTestCFileUtils;
 SelfTestCDateTime;
 SelfTestCTimer;
 SelfTestCRandom;

also

 A:= EncodeDateTime(2001, 09, 02, 12, 11, 10, 0);
 Assert2(Month(A) = 9, 'EncodeDateTime');
 S:= GMTTimeToRFC1123TimeA(A, True);
 Assert2(S = '12:11:10 GMT','GMT');
 S:= GMTDateTimeToRFC1123DateTimeA(A, True);
 Assert2(S = 'Sun, 02 Sep 2001 12:11:10 GMT', 'GMTDateTimeToRFC1123DateTime');

Boolean Logic

with the so called double implication you can switch a light from 2 different points in distance and the logic table is this:

in code they said a biconditional goes like this:

function biImplicationtoMuch(a,b: boolean): boolean;
 begin
   result:= (NOT a OR b) AND (NOT b or a);
 end;

BUT its easier like this:

 function biImplication(a,b: boolean): boolean;
 begin
   result:= NOT(a XOR b);
 end;

 for i:= 0 to 1 do
   for l:= 0 to 1 do
     printF(' %d %d: %d ',[i,l,biImplication(bool(i),bool(l))]);

0 0: 1 
0 1: 0 
1 0: 0 
1 1: 1

see example of all boolean functions:

http://www.softwareschule.ch/examples/308_bitbox3.htm

http://www.softwareschule.ch/examples/308_bitbox3.txt

Proposal for Abbreviation Symbol

 01 FALSE    //Contradiction
 02 AND      //Conjunction x*y
 03 INHIB    //Inhibition x*^y
 04 PRAEP    //Prependence x
 05 PRAE     //Presection ^x*y
 06 POST     //Postpendence y
 07 XOR      //Exclusive OR x*^y+^x*y
 08 OR       //Disjunction OR = x+y
 09 NOR      //Rejection
 10 AEQ      //Equivalence x<-->y, ^x*^y+x*y
 11 NEGY     //Y Negation ^y
 12 IMPY     //Y Implication y-->x; x+^y
 13 NEGX     //X Negation ^x
 14 IMPX     //X Implication x-->y; ^x+y
 15 NAND     //Exclusion
 16 TRUE     //TRUE Tautology

Boolean Laws Proof

procedure letBooleanLaws(a,b,c: boolean);
 begin
  // bool laws in one line
   writeln('distributiv and: '+booltostr(a and(b or c) = a and b or a and c,true));
   writeln('distributiv or  : '+booltostr(a or b and c = (a or b) and (a or c),true));
   writeln('associativ and: '+booltostr(a and (b and c) = a and b and c, true));
   writeln('associativ or  : '+booltostr(a or (b or c) = (a or b) or c, true));
 end;

   for i:= 0 to 1 do 
     for k:= 0 to 1 do 
       for t:= 0 to 1 do begin
         a:= boolean(i); b:= boolean(k); c:= boolean(t);
         printF('Boolean Law: %d%d%d',[a,b,c]);
         letBooleanLaws(a,b,c);
       end;

Teaching for Proof:

   // AB=(A'+B')'
   writeln('mutata: '+boolToStr(a AND b = not(not a OR not b),true));
   // A'B'=(A+B)'
   writeln('mutatb: '+boolToStr(not a AND not b = not(a OR b),true));
   // (A'B')'=A+B
   writeln('mutatc: '+boolToStr(not(not a AND not b)=(a OR b),true));

     for i:= 0 to 1 do 
       for k:= 0 to 1 do begin
         a:= boolean(i); b:= boolean(k);
         printF('Boolean Mutater Law: %d%d',[a,b]);
         letMutaterLaws(a,b);
       end; 
   or letMutaterLawsBin(10,12);

 //Proof A XOR B = NOT(A=B)
   for i:= 0 to 1 do 
      for k:= 0 to 1 do begin
        A:= bool(i); B:= bool(k);
        writeln(booleanToString(A XOR B = NOT(A=B)))
      end;
  //shorter 
  for i:= 0 to 1 do 
    for k:= 0 to 1 do 
      PrintF('BinSet: %d%d = %d',[i,k,bool(i XOR k) = NOT bool(i=k)])

Big Int Numbers or Big Decimals

function BigMulu2(aone, atwo: string): string; var bigint, bigint1, bigintres: TXRTLInteger; begin

 XRTLFromString(aone, bigint, 10);
 XRTLFromString(atwo, bigint1, 10);
 XRTLMul(bigint,bigint1,bigintres);
 result:= XRTLToString(bigintres,10,10);

end;

function BigExp2(aone, atwo: string): string; var bigint, bigint1, bigintres: TXRTLInteger; begin

 XRTLFromString(aone, bigint, 10);
 XRTLFromString(atwo, bigint1, 10);
 XRTLExp(bigint,bigint1,bigintres);
 result:= XRTLToString(bigintres,10,10);

end;

   writeln(BigMulu('123456789','123456789'));   //intern
   writeln(BigMulu2('123456789','123456789'));
   maXcalcF('123456789*123456789');
    //writeln(BigExp2('12','1000'));
   maXcalcF('12^1000');
   writeln(BigExp('12','1000'));

Entropy Mystery

HUMAT: Entropy form: SIGMASUM j=1 to n (pj * log 1 / pj).

$S I G M A S U M p j * l o g (1 / p j)$

The implicit unpredictability or randomness of a propabilitiy p can be measured by the extent to which it ist possible to compress data like a tar or zip archive:

much compressible -> less random -> more predictable

This is the entropy, a measure of how much randomness (unpredictable) it contains.

To explain entropy with a coin goes like this: E.g. a fair coin has two outcomes, each with a probability of 1/2 so the entropy is

1/2 log 2 + 1/2 log 2 = 1

PrintF('max. Entropy of coin 0.5p: %f',[0.5*log2(2)+0.5*log2(2)]); 
> max. Entropy of coin 0.5p: 1.00

This is sort of logic, the coin flip contains one bit of randomness, but what if the coin is not fair (manipulated), if it has a 3/4 chance of turning up heads:

3/4 log 4/3 + 1/4 log 4 = 0.81

PrintF('div. Entropy of coin 0.75p+0.25p: %.2f',[0.75*log2(4/3)+0.25*log2(4)]);
> div. Entropy of coin 0.75p+0.25p: 0.81

 maXcalcF('0.5*log(2)/log(2)+0.5*log(2)/log(2)')  
 > 1
 maXcalcF('0.75*log(4/3)/log(2)+0.25*log(4)/log(2)')  
 > 0.81

unit StEclpse;

 TStEclipseType = (etLunarPenumbral, etLunarPartial, etLunarTotal,
                   etSolarPartial, etSolarAnnular, etSolarTotal,
                   etSolarAnnularTotal);

 TStContactTimes = packed record
   UT1,                         {start of lunar penumbral phase}
   UT2,                         {end of lunar penumbral phase}
   FirstContact,                {start of partial eclipse}
   SecondContact,               {start of totality}
   MidEclipse,                  {mid-eclipse}
   ThirdContact,                {end of totality}
   FourthContact   : TDateTime; {end of partial phase}
 end;

Helmholtz Function

Big increase Entropy in the beginning then decreases away to zero

  fct_table(40, 150, 20, clblue, fct4x, 'Helmholtz(x)');

  procedure fct4e(var x: single);
  begin
    x:= -150*(power(x,2)/(power(30+power(x,2),2)));
  end;

Entropy and Cryptography

HUMAT: you cant compress a strong cipher (output of a cryptographic function), cause it has high entropy (randomness).

less compressible -> most random -> not predictable

To explain entropy with a coin goes like this:

PrintF('max. Entropy of coin 0.5p: %f',[0.5*log2(2)+0.5*log2(2)]);

PrintF('div. Entropy of coin 0.75p+0.25p: %.2f',[0.75*log2(4/3)+0.25*log2(4)]);

SHA1 with Indy

function Indy_SHA1Hash(apath: string): string; var

 idsha1: TIdHashSHA1;  //shaback: T5x4LongWordRecord;
 shaStream: TMemoryStream;

begin

  idsha1:= TIDHashsha1.Create;
  shaStream:= TMemoryStream.Create;
  try
    shaStream.Position:= 0;
    shaStream.LoadFromFile(ExePath+'maxbox3.exe');
    //writeln('Indy SHA1 Proof: '+idsha1.asHEX(shaback)); debug
    result:= idsha1.AsHEX(idsha1.HashValue(shaStream));
  finally  
    idsha1.free;
    shaStream.Free;
  end;

end;

Object Oriented

A with statement with type casting

 with TClientSocket.create(self) do begin
     //writeln(TClientSocket(socket).host);
     writeln('TCustomWinSocket host: '+TCustomWinSocket(Socket).remotehost);
     writeln('TCustomWinSocket port: '+intToStr(TCustomWinSocket(Socket).remoteport));
     Free
   end;

cause of

public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
   property Socket: TClientWinSocket read FClientSocket;

 TClientWinSocket = class(TCustomWinSocket)
 private
   FClientType: TClientType;
 protected
   procedure SetClientType(Value: TClientType);
 public
   procedure Connect(Socket: TSocket); override;
   property ClientType: TClientType read FClientType write SetClientType;
 end;

ShowModal shows a window and waits until it is closed. Until closing, you can't interact with any other form of the application. What many do not know: You can define a result value on events of the ShowModal Form, which you can use very clean in your program. For example to check which date a user has clicked.

 procedure TdbOpenDlg_Button1Click(Sender: TObject);
 begin
   dbOpenDlg.ModalResult:= mrOK;
 end;

 procedure TdbOpenDlg_CalBtnFromClick(Sender: TObject);
 begin
 dbOpenDlg:= TdbOpenDlg.create(self)
 with dbOpenDlg do begin
   setbounds(0,0,400,400)
   //showmodal later
 end;
  with TButton.create(dbopenDlg) do begin
    parent:= dbopenDlg;
    setbounds(20,200,100,40)
    caption:= 'OK Date';
    onclick:= @TdbOpenDlg_Button1Click;
  end;  
 try
  with TDateTimePicker.create(dbopenDlg) do begin
    parent:= dbopenDlg;
    SetBounds(20,20,100,100);
    if dbopenDlg.showModal = mrOK then
      BeginDate:= Datetime;
    writeln('date with time: '+datetimetostr(Datetime));
  end;
   writeln('get date back '+datetostr(begindate));   //debug
 finally
   dbopenDlg.Free;
 end;
 end;

Arduino

Open a COM Port and use Arduino as Timer:

 const COMPORT ='COM12';
   var cPort: TComPort;

 procedure InitCreateComPort(Sender: TObject);
 begin
   cPort:= TComPort.Create(self);
     with cPort do begin
     BaudRate:= br9600;
     Port:= COMPORT;
     Parity.Bits:= prNone;
     StopBits:= sbOneStopBit;
     DataBits:= dbEight;
   end;
 end;

procedure SetArduinoTime(Sender: TObject);

  var arduinoTime,aout: shortstring;
  begin
  arduinoTime:= FormatDatetime('HHmmssddMMyyyy',Now)
  //+intToStr(DayOfWeek(Now-1)); 
  //formatdatetime('"stop is:" hh:mm:ss:zzz', time)) 
  WriteLn(arduinoTime);
  //pass the time to COM port
  try
    cPort.Open;
  except 
    writeln(' No free com port found! ');
    //cPort.Free;
  end;      
  cPort.WriteStr(arduinoTime)
  //while (true) do 
  repeat
    aout:=;
    cport.ReadStr(aout, 21)
        //if aout <>  then
    WriteLn('From Arduino: ' + aout);
    sleep(1000)
  until iskeyPressed;  
  cPort.Close;    
  cPort.Free;    
end;

Save Space with Function Chaining

 For example you want to replace chars in a file A and save it to a file B:
   //fst:= '<contains name="uPSDisassembly"/> <contains name="uPSComponent_COM"/>' and so on
   //e.g. we want to add a CR LF to a XML file with no CRLF before

   fst:= fileToString('..\'+'containstest.txt');   
   afst2:= ReplaceString(fst,'"/> ','"/>'+CRLF);
   stringToFile('..\'+'containstest2.txt',afst2,true);

Second you can save fst on var with parameter passing

   afst2:= ReplaceString(filetostring('..\'+'containstest.txt'),'"/> ','"/>'+CRLF);
   Stringtofile('..\'+'containstest3.txt',afst2,true);

Third you can pass all vars by a one liner (not so maintainable):

   StringTofile('..\'+'contain2.txt',ReplaceString(fileToString('..\'+'contain.txt'),'"/> ','"/>'+CRLF),true);   

   OpenDoc('..\'+'contain2.txt');

Bugs

1. COM Port Information:

  Defect: When using the menu/ Program/Information and you don't have a COM Port in use the window will fail
  Propose: Avoid the Information window when loading multiple scripts
  Cause: while query available COM Ports an out of index exception occurs
  State: Solved

2. Streams with File/Memory Stream:

  Defect: When using an array of byte an abstract error occurs
  Propose: Avoid the TStream as parameter, use TFileStream direct
  Cause: no overloading possible so the names are different - 
         procedure ReadAB(Buffer: TByteArray;Count:LongInt)');
         procedure WriteAB(Buffer: TByteArray;Count:LongInt)');
  State: Open

3. Full Text Finder:

  Defect: When using on 64bit 120 dots per inch resolution the form is not size able
  Propose: Move the splitter up or down to size the window
  Cause: Panels are fix
  State: Open

4. Button Set

  Defect: When using buttonset you have to name it each one
  Propose: Name the real set name
  Cause: sets are limited
  State: Open

  will not work: case CreateMessageDialog('Text the maXbox', mtWarning,[mbYesNoCancel]).ShowModal 
  works: case CreateMessageDialog('Text the maXbox', mtWarning,[mbYes,mbNo,mbCancel]).ShowModal 
           of  mrYes: ShowMessage('Yes');
               mrNo: ShowMessage('No');
               mrCancel: ShowMessage('Cancel');
           end;

5. File Stream Buffer

  Defect: When using filestream buffer read/write (fs.WriteBufferInt(v, 2);)
  Propose: use string or FileS.WriteInt(Buff,1);
  Cause: Exception: Stream write error.
  State: Open

6. High() of Enumerator and Set

  Defect: When using high(set) its always 255
  Propose: use 1 to n instead;
  Cause: invalid type cast
  State: Open

    suit:TShortSuit;   // TShortSuit=(CardS,CardD,CardC,CardH);
    for suit1:= low(TShortSuit) to high(TShortSuit) do  won't work
    for suit1:= 0 to 3 do begin
      cards0[4*(i-11)+suit1]:= TForm1_makecard(startx,starty,i,TShortSuit(suit1));

7. Themes Color in Panel, Label, Bars etc.

  Defect: When set color in panel it inherits the parent color
  Propose: use controlstyle
  Cause: themes override the color
  State: Solved (with property ParentBackground)

  To set a color in a Panel or to override themes two ways are possible: - controlstyle set - 
  parentbackground:
  with mypanel do begin
     caption:= '********maXboxMP3********';  
     controlstyle:= controlstyle - [csParentBackground,csOpaque];
  mypanel:= TPanel.Create(self)
     with mypanel do begin
     ParentBackground:= false;
     color:= clyellow;

8. Open other files with maXbox (Open with...)

  Defect: When you set maXbox as process to open a file with another extension it cant find it
  Propose: drag and drop the file you want to open
  Cause: it want to open and run the file at the same time
  State: In Work

Performance

Performance is dark chapter cause maXbox is an interpreter But it does have more functions precompiled than interpreted!

As a comparison take the EightQueens Problem [8*8] You had to set 8 queens on a chessboard without collision {recursive solution to the Eight Queens problem} As a long time runner I set it to 14 Queens:

\examples\044_pas_14queens_solwith14.txt

Take the following reference implemantation for measures:

http://www.softwareschule.ch/examples/044_queens_performer2.txt

http://www.softwareschule.ch/examples/044_queens_performer2.htm

Result: 365596 solutions Time: start is: 21:30:32:233 all codestrings of solutions stop is: 23:19:44:183 1 h run time: 49:11:950 mX3 executed: 23.05.2014 23:19:44 Runtime: 1:49:13.10 Memoryload: 52% use

file in editor: 6215131 lines Very slow but all solutions are painted in a file (94.7 MB (99'331'007 Bytes)) , e.g. the last solution one:

365596

XXXXXXXXXXXXXQ XXXXXXXXXXXQXX XXXXXXXXXQXXXX XXXXXXXQXXXXXX XXQXXXXXXXXXXX XXXXQXXXXXXXXX XQXXXXXXXXXXXX XXXXXXXXXXQXXX QXXXXXXXXXXXXX XXXXXQXXXXXXXX XXXXXXXXXXXXQX XXXXXXXXQXXXXX XXXXXXQXXXXXXX XXXQXXXXXXXXXX

solution string: 14/12/10/8/3/5/2/11/1/6/13/9/7/4

08 Queens: 92 solutions: 0 h run time: 00:00:376

09 Queens: 352 solutions: 0 h run time: 00:01:493

10 Queens: 724 solutions: 0 h run time: 00:06:460

11 Queens: 2680 solutions: 0 h run time: 00:32:107

12 Queens: 14200 solutions: 0 h run time: 02:58:011

13 Queens: 73712 solutions: 0 h run time: 17:24:995

Compiled solution with 14 Queens (365596 solutions) Intel Core 2 Quad (Q9559, 2.83 GHz) 9712ms!

Tuning

To speed up a script has following rules:

1. Set the Application.ProcessMessages OFF:

in menu Options/ProcessMessages

or in code with processMessagesOFF; //more speed

2. use internal functions instead of script functions:

e.g. FileSearch('firstdemo.txt',exepath))

3. Start a seconde instance of maXbox with F4

Current Development to mX3 V3.0

V3.0 supports more graphic formats, I work with

ImageFileLibBCB for Delphi/BCB on sourceforge

which supports many formats, with this library, Delphi programs can read and write BMP, ICO, CUR, PNG, MNG, PCX, TIFF and JPEG 2000 bitmaps. RAS, PNM, PGM, PPM, HIPS images can be loaded, but not created.

Concerning Indy, the SMPT, IdDayTime, hashCRC and message support is going on, maXbox becomes a simple mailbox too, also the Indy globals with a lot of network functions like to get the hostname is under way

The conversion of the TPSImport_StrUtils is already done, soundex and much string functions will be possible

a lot of delphi (sysutils, system) and indy functions (indy globals) are now going to convert to the box, by end of september a beta will be available to get first impressions of maXbox3

Also mX3 on Linux is on the way, ported Indy 9 to Kylix3 so graphics and math functions too. Release date for mX3 win and mX3 linux will be the January 31th on 2011.

Improvments of 64Bit, PNG, and Ansi/WideStrings are done, Dialogs and Plugins are under way (e.g. MP3-Player and POP3-Mail Function) From October to February time will spent on tuning, testing, tutorials and a list of all functions in mX3 Sysutils.converted and a thread function (casting&converting) has done, now I'm updating all the examples from _1 to _150 in categories base, math, graphic, statistic, system, net and internet.

>>>Release Date for mX3 (Win and Linux) will be the 31.th of January 2011!

Function CharToBin(_Chr: Char): String; Var

  i: Integer;

Begin

  For i:= SizeOf(_Chr) * 8 - 1 Downto 0 Do

Result:= Format('%s%d', [Result, Byte((Ord(_Chr) And (1 Shl i))

Select to_char(id)||chr(9)||rtrim(lpad(' ',2*(level-1)) || bez,' ')||

chr(9)||rtrim(ueberschrift,' ')||chr(9)||rtrim(text,' ') from knoten

start with id=69 connect by prior id=parent

SHL EXponent:

var i: int64;

for i:= 1 to 32 do
    printF('Bin exponent with SHL: 2^%d = %d',[i, i SHL i DIV i]);

bin exp with SHL: 2^1 = 2 bin exp with SHL: 2^2 = 4 bin exp with SHL: 2^3 = 8 bin exp with SHL: 2^4 = 16 bin exp with SHL: 2^5 = 32.........

Minesweeper Game, January 2013:

http://www.softwareschule.ch/examples/285_minesweeper2.htm

Working with BigIntegers:

function BigMulu2(aone, atwo: string): string; var bigint, bigint1, bigintres: TXRTLInteger; begin

 XRTLFromString(aone, bigint, 10);
 XRTLFromString(atwo, bigint1, 10);
 XRTLMul(bigint,bigint1,bigintres);
 result:= XRTLToString(bigintres,10,10);

end;

function BigExp2(aone, atwo: string): string; var bigint, bigint1, bigintres: TXRTLInteger; begin

 XRTLFromString(aone, bigint, 10);
 XRTLFromString(atwo, bigint1, 10);
 XRTLExp(bigint,bigint1,bigintres);
 result:= XRTLToString(bigintres,10,10);

end;

writeln(BigMulu2('123456789','123456789'));
maXcalcF('123456789*123456789');


//Environment Info:
SaveString(ExePath+'\Examples\envinfo.txt',GetEnvironmentString);   
OpenFile(ExePath+'\Examples\envinfo.txt');

Generate QRCode

{This is using the Google Charts API, but it does demonstrate a quick and easy way to get QR barcodes in a maXbox, Delphi or Lazarus/FreePascal application.

Const

  UrlGoogleQrCode='http://chart.apis.google.com/chart?chs=%dx%d&cht=qr&chld=%s&chl=%s';

var

  QrImgCorrStr : array [0..3] of string; // =('L','M','Q','H');

procedure GetQrCode(Width,Height: Word; Correct_Level: string; const Data:string); var

 encodedURL: string;
 idhttp: TIdHttp;// THTTPSend;
 png: TLinearBitmap;//TPNGObject;
 pngStream: TMemoryStream;

begin

 encodedURL:= Format(UrlGoogleQrCode,[Width,Height, Correct_Level, HTTPEncode(Data)]);
 //WinInet_HttpGet(EncodedURL,StreamImage);
 idHTTP:= TIdHTTP.Create(NIL)
 pngStream:= TMemoryStream.create;
 with TLinearBitmap.Create do try
   idHTTP.Get1(EncodedURL, pngStream)
   pngStream.Position:= 0;
   LoadFromStream2(pngStream,'PNG');
   FImage.Picture:= NIL;
   AssignTo(FImage.picture.bitmap);
   SaveToFile(ExePath+'mX3QRCode.png');
   //OpenDoc(ExePath+'mX3QRCode.png');
 finally
   Dispose;
   Free;
   idHTTP.Free
   pngStream.Free;
 end;

end;

Call to invoke:

 GetQrCode(150,150,'Q', 'this is maXland on the maXbox');

HTTP Download with MemoryStream and Progress:

procedure GetFileDownloadProgress(myURL, myFile: string); var

 HttpClient: TIdHttp;
 aFileSize: Int64;
 aBuffer: TMemoryStream;

begin

 HttpClient:= TIdHttp.Create(NIL);
 try
   //HttpClient.Head('http://somewhere.ch/somefile.pdf');
   HttpClient.Head(myURL);
   aFileSize := HttpClient.Response.ContentLength;
     Writeln('FileSize of MemStream Download: '+inttoStr(aFileSize));
   aBuffer:= TMemoryStream.Create;
   try
     while aBuffer.Size &lt;Help&gt;