From e7150ee0453f0890963c26c773e292cdac9a725c Mon Sep 17 00:00:00 2001
From: Markus Birth <mbirth@gmail.com>
Date: Tue, 19 Aug 2003 20:54:04 +0200
Subject: [PATCH] Initial commit
---
GapMerger/GapMerger.cfg | 38 ++++++
GapMerger/GapMerger.dof | 139 ++++++++++++++++++++
GapMerger/GapMerger.dpr | 114 +++++++++++++++++
GapMerger/README.md | 15 +++
GapRemover/GapRemover.cfg | 38 ++++++
GapRemover/GapRemover.dof | 139 ++++++++++++++++++++
GapRemover/GapRemover.dpr | 81 ++++++++++++
GapRemover/README.md | 11 ++
README.md | 31 +++++
rbrConsTools/rbrConsTools.pas | 234 ++++++++++++++++++++++++++++++++++
10 files changed, 840 insertions(+)
create mode 100644 GapMerger/GapMerger.cfg
create mode 100644 GapMerger/GapMerger.dof
create mode 100644 GapMerger/GapMerger.dpr
create mode 100644 GapMerger/README.md
create mode 100644 GapRemover/GapRemover.cfg
create mode 100644 GapRemover/GapRemover.dof
create mode 100644 GapRemover/GapRemover.dpr
create mode 100644 GapRemover/README.md
create mode 100644 README.md
create mode 100644 rbrConsTools/rbrConsTools.pas
diff --git a/GapMerger/GapMerger.cfg b/GapMerger/GapMerger.cfg
new file mode 100644
index 0000000..9d13f67
--- /dev/null
+++ b/GapMerger/GapMerger.cfg
@@ -0,0 +1,38 @@
+-$A8
+-$B-
+-$C+
+-$D+
+-$E-
+-$F-
+-$G+
+-$H+
+-$I+
+-$J-
+-$K-
+-$L+
+-$M-
+-$N+
+-$O+
+-$P+
+-$Q-
+-$R-
+-$S-
+-$T-
+-$U-
+-$V+
+-$W-
+-$X+
+-$YD
+-$Z1
+-cg
+-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+-H+
+-W+
+-M
+-$M16384,1048576
+-K$00400000
+-LE"c:\program files\borland\delphi7\Projects\Bpl"
+-LN"c:\program files\borland\delphi7\Projects\Bpl"
+-w-UNSAFE_TYPE
+-w-UNSAFE_CODE
+-w-UNSAFE_CAST
diff --git a/GapMerger/GapMerger.dof b/GapMerger/GapMerger.dof
new file mode 100644
index 0000000..914d0d0
--- /dev/null
+++ b/GapMerger/GapMerger.dof
@@ -0,0 +1,139 @@
+[FileVersion]
+Version=7.0
+[Compiler]
+A=8
+B=0
+C=1
+D=1
+E=0
+F=0
+G=1
+H=1
+I=1
+J=0
+K=0
+L=1
+M=0
+N=1
+O=1
+P=1
+Q=0
+R=0
+S=0
+T=0
+U=0
+V=1
+W=0
+X=1
+Y=1
+Z=1
+ShowHints=1
+ShowWarnings=1
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+NamespacePrefix=
+SymbolDeprecated=1
+SymbolLibrary=1
+SymbolPlatform=1
+UnitLibrary=1
+UnitPlatform=1
+UnitDeprecated=1
+HResultCompat=1
+HidingMember=1
+HiddenVirtual=1
+Garbage=1
+BoundsError=1
+ZeroNilCompat=1
+StringConstTruncated=1
+ForLoopVarVarPar=1
+TypedConstVarPar=1
+AsgToTypedConst=1
+CaseLabelRange=1
+ForVariable=1
+ConstructingAbstract=1
+ComparisonFalse=1
+ComparisonTrue=1
+ComparingSignedUnsigned=1
+CombiningSignedUnsigned=1
+UnsupportedConstruct=1
+FileOpen=1
+FileOpenUnitSrc=1
+BadGlobalSymbol=1
+DuplicateConstructorDestructor=1
+InvalidDirective=1
+PackageNoLink=1
+PackageThreadVar=1
+ImplicitImport=1
+HPPEMITIgnored=1
+NoRetVal=1
+UseBeforeDef=1
+ForLoopVarUndef=1
+UnitNameMismatch=1
+NoCFGFileFound=1
+MessageDirective=1
+ImplicitVariants=1
+UnicodeToLocale=1
+LocaleToUnicode=1
+ImagebaseMultiple=1
+SuspiciousTypecast=1
+PrivatePropAccessor=1
+UnsafeType=0
+UnsafeCode=0
+UnsafeCast=0
+[Linker]
+MapFile=0
+OutputObjs=0
+ConsoleApp=1
+DebugInfo=0
+RemoteSymbols=0
+MinStackSize=16384
+MaxStackSize=1048576
+ImageBase=4194304
+ExeDescription=
+[Directories]
+OutputDir=
+UnitOutputDir=
+PackageDLLOutputDir=
+PackageDCPOutputDir=
+SearchPath=
+Packages=
+Conditionals=
+DebugSourceDirs=
+UsePackages=0
+[Parameters]
+RunParams=
+HostApplication=
+Launcher=
+UseLauncher=0
+DebugCWD=
+[Language]
+ActiveLang=
+ProjectLang=
+RootDir=
+[Version Info]
+IncludeVerInfo=0
+AutoIncBuild=0
+MajorVer=1
+MinorVer=0
+Release=0
+Build=0
+Debug=0
+PreRelease=0
+Special=0
+Private=0
+DLL=0
+Locale=1033
+CodePage=1252
+[Version Info Keys]
+CompanyName=
+FileDescription=
+FileVersion=1.0.0.0
+InternalName=
+LegalCopyright=
+LegalTrademarks=
+OriginalFilename=
+ProductName=
+ProductVersion=1.0.0.0
+Comments=
+[HistoryLists\hlUnitAliases]
+Count=1
+Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
diff --git a/GapMerger/GapMerger.dpr b/GapMerger/GapMerger.dpr
new file mode 100644
index 0000000..3e1426a
--- /dev/null
+++ b/GapMerger/GapMerger.dpr
@@ -0,0 +1,114 @@
+program GapMerger;
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils,
+ Windows,
+ rbrConsTools in '..\rbrConsTools\rbrConsTools.pas';
+
+const
+ AppTitle: string = 'eMule Gap Merger';
+ AppVersion: string = '1.0';
+
+var
+ OldConsTitle: PChar;
+ infile1,infile2,outfile: file of char;
+ Buf1, Buf2: array[1..64] of char;
+ i,i1,i2,j: integer;
+ WX,WY: integer;
+ ct,bw,be: integer;
+ ofs,ifs: longint;
+ incon: longint;
+ isempty: boolean;
+
+begin
+try
+ OldConsTitle := PChar(AllocMem(256));
+ GetConsoleTitle(OldConsTitle,255);
+ SetConsoleTitle(PChar(AppTitle+' '+AppVersion));
+ TextColor(white);
+ WriteLn('--==# '+AppTitle+' '+AppVersion+' #==--');
+ TextColor(LightGray);
+ WriteLn('(c)2003 by Markus Birth <mbirth@webwriters.de>');
+ WriteLn;
+ if (ParamCount<3) then begin
+ TextColor(LightRed);
+ WriteLn('Not enough actual parameters.');
+ TextColor(LightGray);
+ SetConsoleTitle(OldConsTitle);
+ Halt(1);
+ end;
+ Write('Assigning files...');
+ AssignFile(infile1,ParamStr(1));
+ AssignFile(infile2,ParamStr(2));
+ AssignFile(outfile,ParamStr(3));
+ WriteLn('done.');
+ Write('Opening files (existing output file will be overwritten)...');
+ Reset(infile1);
+ Reset(infile2);
+ Rewrite(outfile);
+ WriteLn('done.');
+ if (FileSize(infile1)=FileSize(infile2)) then begin
+ ifs := FileSize(infile1);
+ WriteLn('Infiles are each ',ifs,' Bytes ~ ',ifs DIV 64,' Blocks');
+ Write('Start merging...');
+ WX := WhereX;
+ WY := WhereY;
+ ct := 0;
+ bw := 0;
+ be := 0;
+ incon := 0;
+ repeat
+ BlockRead(infile1,Buf1,SizeOf(Buf1),i1);
+ BlockRead(infile2,Buf2,SizeOf(Buf2),i2);
+ if (i2>i1) then i := i2 else i := i1;
+ isempty := true;
+ for j:=1 to 64 do begin
+ if (Ord(Buf1[j])=0) AND (Ord(Buf2[j])<>0) then Buf1[j] := Buf2[j];
+ if (Ord(Buf2[j])<>0) AND (Buf1[j]<>Buf2[j]) then Inc(incon);
+ if (Ord(Buf1[j])<>0) then isempty := false;
+ end;
+ BlockWrite(outfile,Buf1,i);
+ Inc(bw);
+ if isempty then Inc(be);
+ Inc(ct);
+ if (ct>=10000) then begin
+ GotoXY(WX,WY);
+ Write(bw,' Blocks written (',be,' empty)');
+ ct := 0;
+ end;
+ until i=0;
+ GotoXY(WX,WY);
+ Write(bw,' Blocks written (',be,' empty)');
+ WriteLn(' ... done.');
+ ofs := FileSize(outfile);
+ WriteLn('Outfile is ',ofs,' Bytes ~ ',ofs DIV 64,' Blocks');
+ if (incon>0) then begin
+ TextColor(LightRed);
+ WriteLn('WARNING! Inconsistencies found! Output file may be corrupt!');
+ WriteLn(incon,' inconsistent byte(s) found! (',incon*100/ofs:7:3,'%)');
+ TextColor(LightGray);
+ end;
+ end else begin
+ TextColor(lightred);
+ WriteLn('!!ERROR!! Infiles have different sizes.');
+ TextColor(lightgray);
+ end;
+ Write('Closing files...');
+ CloseFile(infile1);
+ CloseFile(infile2);
+ CloseFile(outfile);
+ WriteLn('done.');
+ SetConsoleTitle(OldConsTitle);
+except
+ on e: Exception do begin
+ TextColor(LightRed+blink);
+ WriteLn('error!');
+ TextColor(LightRed);
+ TextBackground(Black);
+ WriteLn('Exception: '+e.Message);
+ TextColor(LightGray);
+ end;
+end;
+end.
+
diff --git a/GapMerger/README.md b/GapMerger/README.md
new file mode 100644
index 0000000..521cc3d
--- /dev/null
+++ b/GapMerger/README.md
@@ -0,0 +1,15 @@
+GapMerger for eMule
+===================
+
+Syntax: `GapMerger <infile1> <infile2> <outfile>`
+
+
+GapRemover parses both `<infilex>`s in 64Bytes-Blocks.
+It copies `<infile1>` to `<outfile>` except if a byte in `<infile1>` is 00h and the byte at the same position in `<infile2>` is NOT 00h.
+Then, the byte from `<infile2>` is written into `<outfile>`.
+
+`<infile1>` and `<infile2>` have to be same size.
+
+
+I wrote this because I sometimes download the same file 2 times and both downloads have gaps at different parts of the file.
+This tool merges all data into one file.
diff --git a/GapRemover/GapRemover.cfg b/GapRemover/GapRemover.cfg
new file mode 100644
index 0000000..9d13f67
--- /dev/null
+++ b/GapRemover/GapRemover.cfg
@@ -0,0 +1,38 @@
+-$A8
+-$B-
+-$C+
+-$D+
+-$E-
+-$F-
+-$G+
+-$H+
+-$I+
+-$J-
+-$K-
+-$L+
+-$M-
+-$N+
+-$O+
+-$P+
+-$Q-
+-$R-
+-$S-
+-$T-
+-$U-
+-$V+
+-$W-
+-$X+
+-$YD
+-$Z1
+-cg
+-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+-H+
+-W+
+-M
+-$M16384,1048576
+-K$00400000
+-LE"c:\program files\borland\delphi7\Projects\Bpl"
+-LN"c:\program files\borland\delphi7\Projects\Bpl"
+-w-UNSAFE_TYPE
+-w-UNSAFE_CODE
+-w-UNSAFE_CAST
diff --git a/GapRemover/GapRemover.dof b/GapRemover/GapRemover.dof
new file mode 100644
index 0000000..914d0d0
--- /dev/null
+++ b/GapRemover/GapRemover.dof
@@ -0,0 +1,139 @@
+[FileVersion]
+Version=7.0
+[Compiler]
+A=8
+B=0
+C=1
+D=1
+E=0
+F=0
+G=1
+H=1
+I=1
+J=0
+K=0
+L=1
+M=0
+N=1
+O=1
+P=1
+Q=0
+R=0
+S=0
+T=0
+U=0
+V=1
+W=0
+X=1
+Y=1
+Z=1
+ShowHints=1
+ShowWarnings=1
+UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
+NamespacePrefix=
+SymbolDeprecated=1
+SymbolLibrary=1
+SymbolPlatform=1
+UnitLibrary=1
+UnitPlatform=1
+UnitDeprecated=1
+HResultCompat=1
+HidingMember=1
+HiddenVirtual=1
+Garbage=1
+BoundsError=1
+ZeroNilCompat=1
+StringConstTruncated=1
+ForLoopVarVarPar=1
+TypedConstVarPar=1
+AsgToTypedConst=1
+CaseLabelRange=1
+ForVariable=1
+ConstructingAbstract=1
+ComparisonFalse=1
+ComparisonTrue=1
+ComparingSignedUnsigned=1
+CombiningSignedUnsigned=1
+UnsupportedConstruct=1
+FileOpen=1
+FileOpenUnitSrc=1
+BadGlobalSymbol=1
+DuplicateConstructorDestructor=1
+InvalidDirective=1
+PackageNoLink=1
+PackageThreadVar=1
+ImplicitImport=1
+HPPEMITIgnored=1
+NoRetVal=1
+UseBeforeDef=1
+ForLoopVarUndef=1
+UnitNameMismatch=1
+NoCFGFileFound=1
+MessageDirective=1
+ImplicitVariants=1
+UnicodeToLocale=1
+LocaleToUnicode=1
+ImagebaseMultiple=1
+SuspiciousTypecast=1
+PrivatePropAccessor=1
+UnsafeType=0
+UnsafeCode=0
+UnsafeCast=0
+[Linker]
+MapFile=0
+OutputObjs=0
+ConsoleApp=1
+DebugInfo=0
+RemoteSymbols=0
+MinStackSize=16384
+MaxStackSize=1048576
+ImageBase=4194304
+ExeDescription=
+[Directories]
+OutputDir=
+UnitOutputDir=
+PackageDLLOutputDir=
+PackageDCPOutputDir=
+SearchPath=
+Packages=
+Conditionals=
+DebugSourceDirs=
+UsePackages=0
+[Parameters]
+RunParams=
+HostApplication=
+Launcher=
+UseLauncher=0
+DebugCWD=
+[Language]
+ActiveLang=
+ProjectLang=
+RootDir=
+[Version Info]
+IncludeVerInfo=0
+AutoIncBuild=0
+MajorVer=1
+MinorVer=0
+Release=0
+Build=0
+Debug=0
+PreRelease=0
+Special=0
+Private=0
+DLL=0
+Locale=1033
+CodePage=1252
+[Version Info Keys]
+CompanyName=
+FileDescription=
+FileVersion=1.0.0.0
+InternalName=
+LegalCopyright=
+LegalTrademarks=
+OriginalFilename=
+ProductName=
+ProductVersion=1.0.0.0
+Comments=
+[HistoryLists\hlUnitAliases]
+Count=1
+Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
diff --git a/GapRemover/GapRemover.dpr b/GapRemover/GapRemover.dpr
new file mode 100644
index 0000000..48d6b59
--- /dev/null
+++ b/GapRemover/GapRemover.dpr
@@ -0,0 +1,81 @@
+program GapRemover;
+{$APPTYPE CONSOLE}
+
+uses
+ SysUtils,
+ Windows,
+ rbrConsTools in '..\rbrConsTools\rbrConsTools.pas';
+
+const
+ AppTitle: string = 'eMule Gap Remover';
+ AppVersion: string = '1.0';
+
+var
+ OldConsTitle: PChar;
+ infile,outfile: file of char;
+ Buf: array[1..64] of char;
+ i,j: integer;
+ isnull: boolean;
+ WX,WY: integer;
+ ct,bw,bs: integer;
+ ofs,ifs: longint;
+
+begin
+ OldConsTitle := PChar(AllocMem(256));
+ GetConsoleTitle(OldConsTitle,255);
+ SetConsoleTitle(PChar(AppTitle+' '+AppVersion));
+ TextColor(white);
+ WriteLn('--==# '+AppTitle+' '+AppVersion+' #==--');
+ TextColor(LightGray);
+ WriteLn('(c)2003 by Markus Birth <mbirth@webwriters.de>');
+ WriteLn;
+ if (ParamCount<2) then begin
+ TextColor(LightRed);
+ WriteLn('Not enough actual parameters.');
+ TextColor(LightGray);
+ SetConsoleTitle(OldConsTitle);
+ Halt(1);
+ end;
+ Write('Assigning files...');
+ AssignFile(infile,ParamStr(1));
+ AssignFile(outfile,ParamStr(2));
+ WriteLn('done.');
+ Write('Opening files (existing output file will be overwritten)...');
+ Reset(infile);
+ Rewrite(outfile);
+ WriteLn('done.');
+ ifs := FileSize(infile);
+ WriteLn('Infile is ',ifs,' Bytes ~ ',ifs DIV 64,' Blocks');
+ Write('Start copying...');
+ WX := WhereX;
+ WY := WhereY;
+ ct := 0;
+ bw := 0;
+ bs := 0;
+ repeat
+ BlockRead(infile,Buf,SizeOf(Buf),i);
+ isnull := true;
+ for j:=1 to 64 do if Ord(Buf[j])<>0 then isnull:=false;
+ if NOT isnull then begin
+ BlockWrite(outfile,Buf,i);
+ Inc(bw);
+ end else Inc(bs);
+ Inc(ct);
+ if (ct>=10000) then begin
+ GotoXY(WX,WY);
+ Write('Blocks: ',bw+bs,' processed / ',bw,' written / ',bs,' skipped');
+ ct := 0;
+ end;
+ until i=0;
+ GotoXY(WX,WY);
+ Write('Blocks: ',bw+bs,' processed / ',bw,' written / ',bs,' skipped');
+ WriteLn(' ... done.');
+ ofs := FileSize(outfile);
+ WriteLn('Outfile is ',ofs,' Bytes ~ ',ofs DIV 64,' Blocks');
+ WriteLn('Outfile is ',ofs*100/ifs:7:3,'% of Infile');
+ Write('Closing files...');
+ CloseFile(infile);
+ CloseFile(outfile);
+ WriteLn('done.');
+ SetConsoleTitle(OldConsTitle);
+end.
diff --git a/GapRemover/README.md b/GapRemover/README.md
new file mode 100644
index 0000000..e9fc82a
--- /dev/null
+++ b/GapRemover/README.md
@@ -0,0 +1,11 @@
+GapRemover for eMule
+====================
+
+Syntax: `GapRemover <infile> <outfile>`
+
+
+GapRemover parses `<infile>` in 64Bytes-Blocks.
+Those blocks are copied into `<outfile>` if they contain anything other than 00h-Bytes.
+
+I wrote this because my Media Player keeps freezing when there are errors in the stream.
+This procedure keeps the freezes short.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..5102397
--- /dev/null
+++ b/README.md
@@ -0,0 +1,31 @@
+eMule-Tools
+===========
+
+GapRemover
+----------
+
+Syntax: `GapRemover <infile> <outfile>`
+
+
+GapRemover parses `<infile>` in 64Bytes-Blocks.
+Those blocks are copied into `<outfile>` if they contain anything other than 00h-Bytes.
+
+I wrote this because my Media Player keeps freezing when there are errors in the stream.
+This procedure keeps the freezes short.
+
+
+GapMerger
+---------
+
+Syntax: `GapMerger <infile1> <infile2> <outfile>`
+
+
+GapRemover parses both `<infilex>`s in 64Bytes-Blocks.
+It copies `<infile1>` to `<outfile>` except if a byte in `<infile1>` is 00h and the byte at the same position in `<infile2>` is NOT 00h.
+Then, the byte from `<infile2>` is written into `<outfile>`.
+
+`<infile1>` and `<infile2>` have to be same size.
+
+
+I wrote this because I sometimes download the same file 2 times and both downloads have gaps at different parts of the file.
+This tool merges all data into one file.
diff --git a/rbrConsTools/rbrConsTools.pas b/rbrConsTools/rbrConsTools.pas
new file mode 100644
index 0000000..f0b3990
--- /dev/null
+++ b/rbrConsTools/rbrConsTools.pas
@@ -0,0 +1,234 @@
+unit rbrConsTools;
+
+interface
+
+ const
+ Black = 0;
+ Blue = 1;
+ Green = 2;
+ Cyan = 3;
+ Red = 4;
+ Magenta = 5;
+ Brown = 6;
+ LightGray = 7;
+ DarkGray = 8;
+ LightBlue = 9;
+ LightGreen = 10;
+ LightCyan = 11;
+ LightRed = 12;
+ LightMagenta = 13;
+ Yellow = 14;
+ White = 15;
+ blink = 128;
+
+ procedure TextColor(x: byte);
+ procedure TextBackground(x: byte);
+ procedure GotoXY(x,y: integer);
+ function WhereX: integer;
+ function WhereY: integer;
+ procedure ClrScr;
+ procedure ClrEol;
+ function ReadKeyAsWord: Word;
+ function keypressed: boolean;
+ function ProgBar(width: integer; pos: double; memslot: byte = 1; forcewrite: boolean = false): boolean;
+ function ProgBarLn(width: integer; pos: double; memslot: byte = 1; forcewrite: boolean = false): boolean;
+ function ProgBarAt(x,y: integer; width: integer; pos: double; memslot: byte = 1; forcewrite: boolean = false): boolean;
+ function working(step: longint = 1; memslot: byte = 1): boolean;
+
+implementation
+
+ uses Windows;
+
+ const
+ wiString = '/-\|';
+
+ var
+ hConsoleInput: THandle;
+ hConsoleOutput: THandle;
+ wiPos: array[1..10] of byte;
+ wkPos: array[1..10] of longint;
+ ProgBarSave: array[1..10] of integer;
+ i: integer;
+
+ procedure TextColor(x: byte);
+ var BI : CONSOLE_SCREEN_BUFFER_INFO;
+ att : word;
+ begin
+ GetConsoleScreenBufferInfo(hConsoleOutput, BI);
+ att := BI.wAttributes;
+ att := att AND $F0;
+ { ANDing with 11110000 to let the current bg-color remain }
+ SetConsoleTextAttribute(hConsoleOutput, x+att);
+ end;
+
+ procedure TextBackground(x: byte);
+ var BI : CONSOLE_SCREEN_BUFFER_INFO;
+ att : word;
+ begin
+ GetConsoleScreenBufferInfo(hConsoleOutput, BI);
+ att := BI.wAttributes;
+ att := att AND $0F;
+ { ANDing with 00001111 to let the current fg-color remain }
+ SetConsoleTextAttribute(hConsoleOutput, x*$10+att);
+ end;
+
+ procedure GotoXY(x,y: integer);
+ var Pos: COORD;
+ begin
+ Pos.X := x-1;
+ Pos.Y := y-1;
+ { 1 is subtracted because the top-left pos in Pascal was (1,1) instead of (0,0) }
+ SetConsoleCursorPosition(hConsoleOutput,Pos);
+ end;
+
+ function WhereX: integer;
+ var SBI: CONSOLE_SCREEN_BUFFER_INFO;
+ begin
+ GetConsoleScreenBufferInfo(hConsoleOutput,SBI);
+ WhereX := SBI.dwCursorPosition.X + 1;
+ { 1 is added because in Pascal the top-left position was (1,1) and not (0,0) }
+ end;
+
+ function WhereY: integer;
+ var SBI: CONSOLE_SCREEN_BUFFER_INFO;
+ begin
+ GetConsoleScreenBufferInfo(hConsoleOutput,SBI);
+ WhereY := SBI.dwCursorPosition.Y + 1;
+ { 1 is added because in Pascal the top-left position was (1,1) and not (0,0) }
+ end;
+
+ procedure ClrScr;
+ var coordScreen: COORD;
+ SBI: CONSOLE_SCREEN_BUFFER_INFO;
+ charsWritten: longword;
+ ConSize: longword;
+ begin
+ coordScreen.X := 0; coordScreen.Y := 0;
+ GetConsoleScreenBufferInfo(hConsoleOutput, SBI);
+ ConSize := SBI.dwSize.X * SBI.dwSize.Y;
+ FillConsoleOutputCharacter(hConsoleOutput, ' ', ConSize, coordScreen, charsWritten);
+ FillConsoleOutputAttribute(hConsoleOutput, SBI.wAttributes, ConSize, coordScreen, charsWritten);
+ SetConsoleCursorPosition(hConsoleOutput, coordScreen);
+ end;
+
+ procedure ClrEol;
+ var tC :tCoord;
+ Len,Nw: longword;
+ Cbi : TConsoleScreenBufferInfo;
+ begin
+ GetConsoleScreenBufferInfo(hConsoleOutput, cbi);
+ len := cbi.dwsize.x-cbi.dwcursorposition.x;
+ tc.x := cbi.dwcursorposition.x;
+ tc.y := cbi.dwcursorposition.y;
+ FillConsoleOutputAttribute(hConsoleOutput,cbi.wAttributes,len,tc,nw);
+ FillConsoleOutputCharacter(hConsoleOutput,#32,len,tc,nw);
+ end;
+
+ function ReadKeyAsWord: Word;
+ var Read: Cardinal;
+ Rec: _INPUT_RECORD;
+ begin
+ repeat
+ Rec.EventType := KEY_EVENT;
+ ReadConsoleInput(hConsoleInput, Rec, 1, Read);
+ until (Read = 1) AND (Rec.Event.KeyEvent.bKeyDown);
+ Result := Rec.Event.KeyEvent.wVirtualKeyCode;
+ end;
+
+ function ReadKey: Char;
+ var Ch: Char;
+ NumRead: DWORD;
+ SaveMode: DWORD;
+ begin
+ GetConsoleMode(hConsoleInput, SaveMode);
+ SetConsoleMode(hConsoleInput, 0);
+ NumRead := 0;
+ while NumRead < 1 do ReadConsole(hConsoleInput, @Ch, 1, NumRead, nil);
+ SetConsoleMode(hConsoleInput, SaveMode);
+ Result := Ch;
+ end;
+
+ function keypressed: boolean;
+ var NumberOfEvents: longword;
+ InputRec: TInputRecord;
+ NumRead: DWORD;
+ begin
+ Result := false;
+ GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);
+ if NumberOfEvents > 0 then begin
+ if PeekConsoleInput(hConsoleInput, InputRec, 1, NumRead) then begin
+ if (InputRec.EventType = KEY_EVENT) AND (InputRec.Event.KeyEvent.bKeyDown) AND (InputRec.Event.KeyEvent.AsciiChar > #0) then begin
+ Result := true;
+ end else begin
+ FlushConsoleInputBuffer(hConsoleInput);
+ end;
+ end;
+ end;
+ end;
+
+ function ProgBarChanged(width: integer; pos: double; memslot: byte = 1): boolean;
+ var nexstep: integer;
+ begin
+ nexstep := Trunc(3 * width * pos); // 3 steps in 1 char
+ // WriteLn('this: ',ProgBarSave[memslot],' --- next: ',nexstep);
+ if (ProgBarSave[memslot] <> nexstep) then Result := true else Result := false;
+ end;
+
+ function ProgBar(width: integer; pos: double; memslot: byte = 1; forcewrite: boolean = false): boolean;
+ var cp, curstep: integer;
+ begin
+ if (forcewrite) OR (ProgBarChanged(width, pos, memslot)) then begin
+ curstep := Trunc(3 * width * pos);
+ cp := 1;
+ while cp<=width do begin
+ if (curstep>=cp*3) then Write(Chr($db))
+ else if (curstep>=(cp-1)*3+2) then Write(Chr($b2))
+ else if (curstep>=(cp-1)*3+1) then Write(Chr($b1))
+ else Write(Chr($b0));
+ Inc(cp);
+ end;
+ ProgBarSave[memslot] := Trunc(3 * width * pos);
+ Result := true;
+ end else begin
+ Result := false;
+ GotoXY(WhereX+width, WhereY);
+ end;
+ end;
+
+ function ProgBarLn(width: integer; pos: double; memslot: byte = 1; forcewrite: boolean = false): boolean;
+ begin
+ Result := ProgBar(width, pos, memslot, forcewrite);
+ WriteLn;
+ end;
+
+ function ProgBarAt(x,y: integer; width: integer; pos: double; memslot: byte = 1; forcewrite: boolean = false): boolean;
+ begin
+ if (ProgBarChanged(width, pos, memslot)) OR (forcewrite) then begin
+ GotoXY(x,y);
+ Result := ProgBar(width, pos, memslot, true);
+ end else Result := false;
+ end;
+
+ function working(step: longint = 1; memslot: byte = 1): boolean;
+ begin
+ if (wkPos[memslot]>=step) then begin
+ Write(wiString[wiPos[memslot]]);
+ Inc(wiPos[memslot]);
+ if (wiPos[memslot] > Length(wiString)) then wiPos[memslot] := 1;
+ wkPos[memslot] := 1;
+ Result := true;
+ end else begin
+ Inc(wkPos[memslot]);
+ Result := false;
+ end;
+ end;
+
+begin
+ for i:=1 to 10 do begin
+ wiPos[i] := 1;
+ wkPos[i] := 1;
+ end;
+ hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
+ hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
+
+end.