<p>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.
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;
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)) <> 0)]);
End;
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
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]);
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');
more on script: 318_excel_export.txt
Multitask enabled Delay
procedure Delay2(msecs: integer); var
FirstTickCount: longint;
begin
FirstTickCount:= GetTickCount; repeat Application.ProcessMessages; {allowing access to other controls, widgets, etc.} until ((GetTickCount-FirstTickCount) >= Longint(msecs));
end;
Test it with:
with TStopWatch.create do begin start Delay2(500) stop writeln(getValueStr) end;
procedure DB_XML_AliasConverter; //uses
//Classes, SysUtils, DB, DBTables, Provider, DBClient;
var
i: Integer; BDEAlias: string; abase, abasepath: string; aParams, TableNames: TStringList; aDataSetProvider: TDataSetProvider; CDataSet: TClientDataSet; Table: TTable;
begin
BDEAlias:= 'DBDEMOS'; TableNames:= TStringList.Create; AParams:= TStringList.Create; with TSession.Create(NIL) do try //AutoSessionName := True; SessionName:= 'MainSession3'; GetAliasParams(BDEAlias, AParams); OpenDatabase(BDEAlias); abasepath:= aParams[0]; Delete(abasepath,1,7) GetTableNames(abasepath,, True, False, TableNames); finally Close; Free; end {TSession}; Table:= TTable.Create(NIL); aDataSetProvider:= TDataSetProvider.Create(NIL); CDataSet:= TClientDataSet.Create(NIL); try Table.DatabaseName:= BDEAlias; //tablenames[2]; //Table.Params.Assign(AParams); Writeln('base name '+Table.DatabaseName); for i:= 0 to Pred(TableNames.Count) do begin Table.TableName:= TableNames[i]; writeln('table to XML '+Table.Tablename) Table.Open; aDataSetProvider.DataSet:= Table; CDataSet.SetProvider(TComponent(aDataSetProvider)); CDataSet.Open; CDataSet.SaveToFile(ExePath+'crypt\'+ ChangeFileExt(Table.TableName,'.xml'),dfXMLUTF8); CDataSet.Close; Table.Close end; CreateDBGridForm(tableNames); finally Table.Free; CdataSet.Free; aDataSetProvider.Free; //ASession.Free; AParams.Free; tableNames.Free; end;
end;
Recursive Select Statement
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 < aFileSize do begin HttpClient.Request.ContentRangeStart:= aBuffer.Size; if aBuffer.Size + RECV_BUFFER_SIZE < aFileSize then HttpClient.Request.ContentRangeEnd:= aBuffer.Size + RECV_BUFFER_SIZE - 1; writeln('file progress: '+inttostr(aBuffer.size)); Application.ProcessMessages; HttpClient.Get1(myURL, aBuffer); // wait until done aBuffer.SaveToFile(Exepath+myFile); end; //HttpClient.OnWorkBegin:= @HttpWorkBegin; //HttpClient.OnWork:= @HttpWork; //HttpClient.OnWorkEnd:= @HttpWorkEnd; finally aBuffer.Free; end; finally HttpClient.Free; end;
end;
Third Law of Kepler to find the height of a Geostationary Satellite
(1/27.5)^2 = (x/384000)^3 ca. 42000 km - 6300 ~ 36000 km
the idea ist to get the moon as relation to the daly track around the earth 1/27 per day
and the solve it with maXbox:
maxCalcF('((1/27.32)^2)^(1/3)*384E3-6371'); >>>35961.8421987704
The Moon has an orbit radius of 3.8x108 m and a period of 27.3 days. Use this information to calculate the radius (RS) of the orbit of a geostationary satellite.
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
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:
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;
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
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 := '([^;]*)(\;)?';
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');
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;
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');
with the so called double implication you can switch a light from 2 different points in distance and the logic table is this:
0 0: 1 0 1: 0 1 0: 0 1 1: 1
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)])
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'));
HUMAT: Entropy form: SIGMASUM j=1 to n (pj * log 1 / pj).
SIGMASUMpj * log(1 / pj)
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;
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;
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;
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');
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 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!
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
<!-- end content -->
<div class="visualClear"></div>