From e7150ee0453f0890963c26c773e292cdac9a725c Mon Sep 17 00:00:00 2001 From: Markus Birth 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 '); + 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 ` + + +GapRemover parses both ``s in 64Bytes-Blocks. +It copies `` to `` except if a byte in `` is 00h and the byte at the same position in `` is NOT 00h. +Then, the byte from `` is written into ``. + +`` and `` 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 '); + 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 ` + + +GapRemover parses `` in 64Bytes-Blocks. +Those blocks are copied into `` 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 ` + + +GapRemover parses `` in 64Bytes-Blocks. +Those blocks are copied into `` 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 ` + + +GapRemover parses both ``s in 64Bytes-Blocks. +It copies `` to `` except if a byte in `` is 00h and the byte at the same position in `` is NOT 00h. +Then, the byte from `` is written into ``. + +`` and `` 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.