Skip to content

Instantly share code, notes, and snippets.

@ssg

ssg/lwx.pas

Created August 25, 2011 20:06
Show Gist options
  • Save ssg/1171732 to your computer and use it in GitHub Desktop.
Save ssg/1171732 to your computer and use it in GitHub Desktop.
Download ZIP
ListWorx - BBS shopping list generator
Raw
lwx.pas
{ List Selector - (c) 1995 SSG
"it's a nice day to debug" /SSG
news:
-----
19th Jan 96 - 00:21 - added modified check...
21nd May 96 - 04:20 - fixed sort bug...
17th Mar 97 - 03:24 - added wizcat format...
}
{$M 8192,32768,655360}
{$G+,A+}
{$IFNDEF DPMI}
HELL! We need dpmi dude...
{$ENDIF}
{$DEFINE EXEPROTECTION}
uses
Strings,XStream,Debris,Disk,XBuf,Dos,XStr,XErr,QText,XIO,Objects;
const
lVersion : string[4] = '1.12';
offRoad : array[1..2] of char = 'GS';
kbEsc = $011b;
kbIns = $5200;
kbDel = $5300;
kbCtrlPgUp = $8400;
kbF1 = $3b00;
kbAltA = $1e00;
kbAltH = $2300;
kbAltP = $1900;
kbAltZ = $2c00;
kbAltX = $2d00;
kbUp = $4800;
kbDown = $5000;
kbPgUp = $4900;
kbPgDn = $5100;
kbHome = $4700;
kbEnd = $4f00;
kbF2 = $3c00;
kbF3 = $3d00;
kbRight = $4d00;
kbLeft = $4b00;
kbTab = $0f09;
type
TEXEHeader = Record
Id : Word;
LastPageSize : Word;
FileSize : Word; { in 512 byte pages }
RelCount : word;
HdrSize : Word; { in 16 byte paragraphs}
MinMem : word; { in 16 byte paragraphs}
MaxMem : Word; { in 16 byte paragraphs}
SSInit : Word;
SPInit : Word;
NegSum : Word;
IPInit : Word;
CSInit : Word;
RelOfs : Word;
OverlayCount : Word;
Unused1 : word;
Unused2 : word;
end;
TEvent = word;
PList = ^TList;
TList = record
Next : PList;
id : word;
Name : string[12];
end;
PFileRec = ^TFileRec;
TFileRec = record
Name : string[12];
Attr : byte;
Size : longint;
Time : longint;
end;
PSel = ^TSel;
TSel = record
Name : string[12];
Time : string[8];
List : word;
Tag : boolean;
Size : longint;
Desc : PString;
end;
PSelColl = ^TSelColl;
TSelColl = object(TSortedCollection)
procedure FreeItem(item:pointer);virtual;
function Compare(k1,k2:pointer):integer;virtual;
end;
PSelDateColl = ^TSelDateColl;
TSelDateColl = object(TSortedCollection)
function Compare(k1,k2:pointer):integer;virtual;
procedure FreeItem(item:pointer);virtual;
end;
PLister = ^TLister;
TLister = object(TObject)
Bounds : TRect;
List : PCollection;
Focused : integer;
Start : integer;
Next : PLister;
constructor Init(var R:TRect);
destructor Done;virtual;
procedure Draw;virtual;
procedure Handle(var Event:TEvent);virtual;
procedure FocusItem(item:integer);virtual;
procedure TagItem(item:integer; enable:boolean);virtual;
function IsTagged(item:integer):boolean;virtual;
function GetText(item:integer):string;virtual;
function GetHelp:string;virtual;
end;
PSelLister = ^TSelLister;
TSelLister = object(TLister)
Owner : PLister;
LastKW : string[40];
Total : comp;
Filename : string[40];
Modified : boolean;
constructor Init(var R:TRect; afile:FnameStr; aowner:PLister);
procedure Handle(var Event:TEvent);virtual;
function GetText(item:integer):string;virtual;
function IsTagged(item:integer):boolean;virtual;
function GetHelp:string;virtual;
procedure TagItem(item:integer; enable:boolean);virtual;
function ReadList(afile:FnameStr):boolean;
procedure CalcTotal(tagged:boolean);
procedure SaveList;
procedure LoadList;
end;
PFileLister = ^TFileLister;
TFileLister = object(TLister)
CurDir : FnameStr;
LastFoc : integer;
LastSta : integer;
Child : PSelLister;
constructor Init(var R:TRect);
procedure Handle(var Event:TEvent);virtual;
function GetText(item:integer):string;virtual;
function GetHelp:string;virtual;
procedure ReadDir(adir:FnameStr);
end;
PFileColl = ^TFileColl;
TFileColl = object(TSortedCollection)
function Compare(k1,k2:pointer):integer;virtual;
procedure FreeItem(item:pointer);virtual;
end;
const
lists : PList = NIL;
FocList : PLister = NIL;
LList : PLister = NIL;
RList : PLister = NIL;
lastMsg : string = '';
var
WinRect : TRect;
SaveBuf : pointer;
SaveBufSize : word;
ScrXSize,ScrYSize : byte;
procedure XFont;external;
{$L XFONT}
function GetAuthor:string;
begin
GetAuthor := offRoad[2]+offRoad[2]+offRoad[1];
end;
procedure Stub(amsg:string);
var
add:byte;
begin
if amsg = lastMsg then exit;
add := (scrXSize-length(amsg)) div 2;
amsg := Duplicate(#32,add)+amsg;
qLocate(0,scrYSize-1);
qSetColor(Yellow,Magenta);
qWrite(amsg+Duplicate(#32,scrXSize-length(amsg)));
lastMsg := amsg;
end;
procedure XYWrite(x,y:integer; s:string);
begin
qLocate(x,y);
qWrite(s);
end;
function Addlist(aname:FnameStr):word;
var
P,P1:PList;
lastid : word;
begin
P := lists;
lastid := 0;
while P <> NIL do begin
if P^.Id > lastid then lastid := P^.Id;
if P^.Name = aname then begin
addlist := P^.id;
exit;
end;
if P^.Next = NIL then break;
P := P^.Next;
end;
if P = NIL then begin
New(lists);
P1 := lists;
end else begin
New(P1);
P^.Next := P1;
end;
P1^.Id := lastid+1;
P1^.Name := aname;
P1^.Next := NIL;
addlist := lastid+1;
end;
function GetListName(alist:word):string;
var
P:PList;
begin
GetListName := '';
P := lists;
while P <> NIL do begin
if P^.id = alist then begin
GetListName := P^.Name;
exit;
end;
P := P^.Next;
end;
end;
procedure DestroyWindow;
begin
Move32(SaveBuf^,Mem[Segb800:0],SaveBufSize);
FreeMem(SaveBuf,SaveBufSize);
end;
procedure CreateWindow(xsize,ysize:integer; afc,abc:byte);
var
line:string;
y:integer;
stay:integer;
x:integer;
begin
SaveBufSize := scrYSize*scrXSize*2;
GetMem(SaveBuf,SaveBufSize);
Move32(Mem[SegB800:0],SaveBuf^,SaveBufSize);
line := Duplicate(#32,xsize);
qSetColor(afc,abc);
stay := (scrYSize-ysize) div 2;
x := (scrXSize-xsize) div 2;
WiNRect.Assign(0,0,xsize,ysize);
WinRect.Move(x,stay);
for y:=stay to stay+ysize-1 do begin
qLocate(x,y);
qWrite(line);
end;
end;
function GetInput(aprompt:string; alen:byte; var s:string):boolean;
var
stax:byte;
c:char;
y:integer;
begin
GetInput := false;
CreateWindow(length(aprompt)+alen+3,3,Black,Green);
y := WinRect.A.Y+1;
qLocate(WinRect.A.X+1,y);
stax := WinRect.A.X + length(aprompt)+2;
qWrite(aprompt);
qSetColor(White,Green);
qLocate(stax,y);
qWrite(s+#219);
inc(stax,length(s));
repeat
c := qGetChar;
case c of
#8 : if s <> '' then begin
qLocate(stax-1,y);
qWrite(#219#32);
dec(byte(s[0]));
dec(stax);
end;
#13 : begin
GetInput := true;
break;
end;
#27 : break;
#32..#255 : if length(s) < alen then begin
inc(byte(s[0]));
s[length(s)] := c;
qLocate(stax,y);
qWrite(c+#219);
inc(stax);
end;
end; {case}
until false;
DestroyWindow;
end;
procedure GenericHelp;
var
x,y:integer;
const
HIRR:array[1..12] of PChar = (
'[Ctrl-PgUp] Go back a dir',
'[Ins] Select olayi',
'[Space] Zeki bi select',
'[Enter] Okey anlaminda',
'[Esc] Terminator',
'[Ctrl-Alt-Del] Reboot computer',
'[End] Go end',
'[Del] Remove from list',
'[F2] Save your list',
'[Alt-A] Save ez',
'[F3] Load it back',
'[Alt-X] Quitter');
begin
CreateWindow(35,18,White,Cyan);
x := WinRect.A.X+1;
y := WinRect.A.Y+1;
qSetFC(Yellow);
XYWrite(x,y,'Generic bi help');
qSetFC(White);
XYWrite(x,y+2,'Klavye olayi:');
qSetFC(Black);
for y := 1 to 12 do XYWrite(x,winrect.a.y+4+y,StrPas(HIRR[y]));
qGetChar;
DestroyWindow;
end;
{ TFILECOLL OLAYI }
function TFileColl.Compare; {don't look - here'z a mess :P boggk }
var
pf1,pf2:PFileRec;
begin
pf1 := k1;
pf2 := k2;
if (pf1^.Attr and Directory > 0) and (pf2^.Attr and Directory = 0)
then Compare := -1 else
if (pf1^.Attr and Directory = 0) and (pf2^.Attr and Directory > 0) then
Compare := 1 else
if pf1^.Name > pf2^.Name then Compare := 1 else
if pf1^.Name < pf2^.Name then Compare := -1 else Compare := 1;
end;
procedure TFileColl.FreeItem;
begin
Dispose(PFileRec(item));
end;
{TSEL LISTER BASLANGIC}
constructor TSelLister.Init;
begin
inherited Init(R);
Owner := AOwner;
List := New(PSelColl,Init(10,10));
Filename := afile;
if Owner <> NIL then ReadList(afile);
end;
procedure TSelLister.CalcTotal(tagged:boolean);
var
n:integer;
P:PSel;
begin
Total := 0;
for n:=0 to List^.Count-1 do begin
if tagged and not IsTagged(n) then continue;
P := List^.At(n);
Total := Total + P^.Size;
end;
end;
function TSelLister.GetHelp;
var
s:string;
begin
if Owner <> NIL then s := 'Ins: Select ù Space: Smart select ù F: Find ù Enter: Format hard disk' else begin
CalcTotal(false);
if Total = 0 then s := 'Del: Remove ù F2: Save ù F3: Load' else begin
Str(Total:0:0,s);
ConvertNumToBusiness(s);
s := 'ù Total '+s+' bytes in list ù';
end;
end;
GetHelp := s;
end;
procedure TSelLister.TagItem(item:integer; enable:boolean);
begin
PSel(List^.At(item))^.Tag := enable;
end;
function TSelLister.ReadList;
var
s:string;
ohaaa:string;
asize:longint;
Ps:PSel;
curList:word;
lastlistid:word;
T:TBufStream;
first:FnameStr;
counter:word;
begin
T.Init(afile,stOpenRead,8192);
if T.Status <>stOK then begin
Stub('ReAD eRROR!');
T.Done;
exit;
end;
first := 'ù Loading ù';
Stub(first);
ReadList := true;
List^.FreeAll;
lastlistid := 0;
counter := 0;
if T.Status = stOK then while T.GetPos < T.GetSize do begin
SReadln(T,s);
if copy(s,1,5) = 'List:' then begin
s := copy(s,6,255);
Strip(s);
FastUpper(s);
lastlistid := addlist(s);
end else begin
ohaaa := copy(s,13,11);
Strip(ohaaa);
asize := s2l(ohaaa);
if asize > 0 then begin
New(Ps);
with Ps^ do begin
Move(s[1],Name[1],12);
Name[0] := #12;
Size := asize;
List := lastlistid;
Time := copy(s,24,8);
s := copy(s,34,255);
if s = '' then s := '(description not available)';
Desc := NewStr(s);
Tag := false;
end;
end else if (s[1] = #32) and (s[2] <> #32) then begin
New(Ps);
with Ps^ do begin
Move(s[2],Name[1],12);
Name[0] := #12;
Size := 0;
List := lastlistid;
Time := '21/12/76';
s := copy(s,18,255);
Strip(s);
if s = '' then s := '(description not available)';
Desc := newstr(s);
Tag := false;
end;
end else continue;
List^.Insert(Ps);
inc(counter);
if counter = 1000 then begin
first := 'ù'+first+'ù';
Stub(first);
counter := 0;
end;
end;
end else ReadList := false;
T.Done;
if FocList = Owner then FocList := @Self;
FocusItem(0);
modified := false;
end;
function TSelLister.IsTagged;
begin
IsTagged := PSel(List^.At(item))^.Tag;
end;
procedure TSelLister.SaveList;
const
tempFile : string[12] = 'LWX.$$$';
var
T:TDosStream;
P:PList;
s:string;
n:integer;
Ps:PSel;
NewGeneration:PSelDateColl;
writtenTheShit:boolean;
procedure writeTheShit;
begin
s := 'List: '+P^.Name;
SWriteln(T,s+#13#10+Duplicate('-',length(s)));
writtenTheShit := true;
end;
begin
if List^.Count=0 then exit;
if filename = '' then if not GetInput('Save to file ',40,filename) then exit;
T.Init(tempFile,stCreate);
if T.Status <> stOK then begin
Stub('ù Couldn''t create temporary file ù');
T.Done;
exit;
end;
Stub('ù Guess what I am doing now ù');
SWriteln(T,'* Created by ListWorx v'+lVersion+' * (c) 1995 '+GetAuthor+' *'#13#10);
P := lists;
New(NewGeneration,Init(10,10));
for n:=0 to List^.Count-1 do NewGeneration^.Insert(List^.At(n));
while P <> NIL do begin
writtenTheShit := false;
for n:=0 to NewGeneration^.Count-1 do begin
Ps := NewGeneration^.At(n);
if Ps^.List = P^.Id then begin
if not writtenTheShit then writeTheShit;
s := Fix(Ps^.Name,12)+RFix(l2s(Ps^.Size),9)+' '+Fix(Ps^.Time,8)+' '+Ps^.Desc^;
SWriteln(T,s);
end;
end;
P := P^.Next;
SWriteln(T,#13#10);
end;
T.Done;
Dispose(NewGeneration,Done);
XRenameAnyway(filename,ReplaceExt(filename,'.BAK'));
XRenameAnyway(tempFile,filename);
modified := false;
Stub('ù Your work successfully saved, sir ù');
end;
procedure TSelLister.LoadList;
var
aw:string[40];
begin
aw := filename;
if GetInput('Load file ',40,aw) then begin
if ReadList(aw) then Stub('ù Your list has been successfully loaded, sir ù')
else Stub('ù Sorry sir ù I couldn''t load your list sir ù');
end;
end;
procedure TSelLister.Handle;
procedure RemoveFromList;
var
P:PSel;
taggedYES:boolean;
goon:boolean;
n:integer;
begin
if List = NIL then exit;
if List^.Count=0 then exit;
taggedYES := false;
repeat
goon := true;
for n:=0 to List^.Count-1 do begin
P := List^.At(n);
if P^.Tag then begin
taggedYES := true;
goon := false;
List^.AtFree(n);
break;
end;
end;
until goon;
if not TaggedYES then List^.AtFree(focused);
if focused > List^.Count-1 then focused := List^.Count-1;
FocusItem(focused);
CalcTotal(false);
Stub(GetHelp);
modified := true;
end;
procedure ReturnToBase;
begin
LList := Owner;
FocList := Owner;
RList^.Next := LList;
LList^.Next := RList;
Owner^.Bounds := Bounds;
Owner^.Draw;
end;
procedure ShowTotalOlayi;
var
s:string;
begin
CalcTotal(true);
Str(total:0:0,s);
ConvertNumToBusiness(s);
Stub('ù Les bytes '+s+' selectes sela vi ù');
end;
procedure Tag;
begin
TagItem(focused,not IsTagged(focused));
if focused < List^.Count-1 then FocusItem(focused+1) else Draw;
ShowTotalOlayi;
end;
procedure DoMultiTag;
var
key:string;
P: PSel;
n:integer;
function Tagga:boolean;
begin
if pos(key,PSel(List^.At(n))^.Desc^) = 1 then begin
Tagga := true;
TagItem(n,not isTagged(n));
end else Tagga := false;
end;
begin
if List = NIL then exit;
P := List^.At(focused);
key := copy(P^.Desc^,1,length(P^.Desc^)-8);
if key = '' then begin
Tag;
exit;
end;
for n:=focused to List^.Count-1 do if not Tagga then break;
for n:=focused-1 downto 0 do if not Tagga then break;
Draw;
ShowTotalOlayi;
end;
procedure Search;
var
n:integer;
count:byte;
P:PSel;
ukw:string[40];
begin
if GetInput('String to search',40,LastKW) then begin
Strip(LastKW);
if LastKW = '' then exit;
count := 0;
ukw := Upper(LastKW);
Stub('ù Searching ù');
for n:=focused+1 to List^.Count-1 do begin
inc(count);
if count = 100 then begin
count := 0;
Stub('ù Searching '+l2s(LongMul(n,100) div List^.Count-1)+'% ù');
end;
P := List^.At(n);
if pos(ukw,upper(P^.Desc^)) > 0 then begin
FocusItem(n);
Stub('Gotcha!');
exit;
end;
end;
Stub('Not Found :-(');
end;
end;
procedure Yehaaa;
var
n:integer;
P,P2:PSel;
listid:word;
begin
listid := 0;
for n:=0 to List^.Count-1 do begin
P := List^.At(n);
if P^.Tag then begin
if listid = 0 then listid := addlist(PFileRec(Owner^.List^.At(Owner^.Focused))^.Name);
P^.Tag := false;
P^.List := listid;
New(P2);
Move(P^,P2^,SizeOf(TSel));
P2^.Desc := NewStr(P^.Desc^);
Next^.List^.Insert(P2);
PSelLister(Next)^.Modified := true;
end;
end;
Draw;
Next^.Draw;
PSelLister(Next)^.CalcTotal(false);
Stub(GetHelp);
end;
begin
if Event = kbEsc then if Owner <> NIL then begin
Event := 0;
ReturnToBase;
exit;
end;
inherited Handle(Event);
case upcase(char(lo(Event))) of
#0 : case Event of
kbDel : if Owner = NIL then removeFromList;
kbCtrlPgUp : ReturnToBase;
kbIns : Tag;
else exit;
end;
#13 : if Owner <> NIL then Yehaaa;
#32 : DoMultiTag;
'F' : Search;
else exit;
end; {case}
Event := 0;
end;
function TSelLister.GetText;
var
P:PSel;
begin
P := List^.At(item);
GetText := Fix(P^.Name,13)+RFix(l2s(P^.Size),12)+' '+P^.Desc^;
end;
{FILE LISTER BURADAN BASLAR}
constructor TFileLister.Init;
begin
inherited Init(R);
ReadDir('.');
end;
function TFileLister.GetHelp;
begin
GetHelp := 'Arrows: Move ù Enter: Fire ù Ctrl+Drive: Jump ù Tab: Strafe ù F13: Exit';
end;
procedure TFileLister.Handle;
procedure GoFile;
var
P:PFileRec;
begin
P := List^.At(focused);
if P^.Attr and Directory > 0 then ReadDir(P^.Name) else begin
New(Child,Init(Bounds,CurDir+P^.Name,@Self));
LList := Child;
LList^.Next := RList;
RList^.Next := LList;
FocList := LList;
end;
end;
begin
if Child <> NIL then begin
Dispose(Child,Done);
Child := NIL;
end;
inherited Handle(Event);
case char(Event) of
#0 : case Event of
kbCtrlPgUp : ReadDir('..');
else exit;
end; {Case}
#13 : GoFile;
#1..#12 : begin
if lo(Event) = 2 then if Lo(GetDisketteParams(0)) < 2 then exit;
CurDir := '';
ReadDir(char(byte(char(Event))+64)+':.');
end;
else exit;
end; {case}
Event := 0;
end;
function TFileLister.GetText;
var
s:string;
b:byte;
P:PFileRec;
begin
P := List^.At(item);
b := pos('.',P^.Name);
if b > 1 then s := Fix(copy(P^.Name,1,b-1),9)+Fix(copy(P^.Name,b+1,3),3)
else s := Fix(P^.Name,12);
if P^.Attr and Directory = 0 then begin
s := s + RFix(l2s(P^.Size),11)+' '+Date2Str(P^.Time,False)+' '+
Time2Str(P^.Time);
end else s := s + ' ş Directory ş';
GetText := s;
end;
procedure TFileLister.ReadDir;
var
dirinfo:SearchRec;
P:PFileRec;
procedure PutIt;
begin
if dirinfo.name <> '.' then begin
New(P);
with dirinfo do begin
P^.Name := dirinfo.name;
P^.Size := dirinfo.Size;
P^.Time := dirinfo.Time;
P^.Attr := dirinfo.Attr;
end;
List^.Insert(P);
end;
end;
procedure Load(amask:FnameStr; aattrib:byte; dir: boolean);
begin
FindFirst(CurDir+amask,aattrib,dirinfo);
while DosError = 0 do begin
case dir of
true : if dirinfo.attr and directory > 0 then PutIt;
false : if dirinfo.name <> '.' then PutIt;
end;
FindNext(dirinfo);
end;
end;
begin
if List <> NIL then List^.FreeAll else List := New(PFileColl,Init(10,10));
if CurDir = '' then CurDir := FExpand(adir) else CurDir := FExpand(CurDir+adir);
if CurDir[length(curDir)] <> '\' then CurDir := CurDir + '\';
if adir = '..' then begin
Focused := LastFoc;
Start := LastSta;
LastFoc := 0;
LastSta := 0;
end else begin
LastFoc := Focused;
LastSta := Start;
Focused := 0;
Start := 0;
end;
Load('*.*',ReadOnly+Directory+Archive,true);
Load('*.TXT',ReadOnly+Archive,false);
Load('*.LST',ReadOnly+Archive,false);
FocusItem(focused);
end;
{ TLISTER DA BURDAN BASLAR}
constructor TLister.init;
begin
inherited Init;
Bounds := R;
Focused := 0;
end;
function TLister.GetHelp;
begin
GetHelp := '';
end;
function TLister.IsTagged;
begin
IsTagged := false;
end;
function TLister.GetText;
begin
GetText := '';
end;
destructor TLister.Done;
begin
if List <> NIL then Dispose(List,Done);
inherited DOne;
end;
procedure TLister.Draw;
var
y:integer;
x:integer;
item:integer;
s:string;
R:TRect;
function okitem:boolean;
begin
okitem := false;
if List = NIL then exit;
if item < List^.Count then okitem := true;
end;
procedure PutZero(aaa:byte);
var
nanay:integer;
begin
qSetColor(0,0);
for nanay := r.a.y-1 to r.b.y+1 do begin
qLocate(aaa,nanay);
qWrite(#32);
end;
end;
procedure Put(offs:word; addsize:word);assembler;
asm
mov al,scrYSize
sub al,2
mov cl,al
xor ch,ch
mov ax,SegB800
mov es,ax
mov di,offs
mov al,32
xor ah,ah
@loop:
mov word ptr es:[di],ax
add di,addsize
loop @loop
end;
procedure ThePut(ax,ay,asize:integer; aword:word);
begin
FillWord(Mem[segb800:((ay*scrxsize)+ax)*2],asize,aword);
end;
begin
if FocList <> @Self then
if Next <> NIL then if Next^.Bounds.B.X-Next^.Bounds.A.X > scrXSize div 2 then exit;
Move32(Bounds,R,SizeOf(R));
qSetBC(Black);
ThePut(r.a.x,r.a.y-1,r.b.x-r.a.x+1,$06DC);
ThePut(r.a.x,r.b.y+1,r.b.x-r.a.x+1,$08DF);
byte(s[0]) := r.b.x-r.a.x+1;
FillBuf(s[1],length(s),32);
if r.a.x > 0 then Put(((r.a.y-1)*scrXSize+r.a.x-1)*2,scrXSize*2) else
if r.b.x < scrXSize-1 then Put(((r.a.y-1)*scrXSize+r.b.x+1)*2,scrXSize*2);
for y:=r.a.y to r.b.y do begin
item := (y-r.a.y)+start;
qLocate(r.a.x,y);
if okitem then begin
if IsTagged(item) then qSetFC(Yellow) else qSetFC(Black);
if (FocList = @Self) and (item = Focused) then qSetBC(Cyan) else qSetBC(LightGray);
qWrite(' '+Fix(GetText(item),r.b.x-r.a.x-1)+' ');
end else begin
qSetColor(Black,LightGray);
qWrite(s);
end;
end;
end;
procedure TLister.TagItem;
begin
end;
procedure TLister.Handle;
procedure GoUp;
begin
if focused > 0 then FocusItem(focused-1);
end;
procedure GoDown;
begin
if focused < List^.Count-1 then FocusItem(focused+1);
end;
procedure PgUp;
var
n:integer;
begin
n := focused;
dec(n,bounds.b.y-bounds.a.y);
if n < 0 then n := 0;
FocusItem(n);
end;
procedure PgDn;
var
n:integer;
begin
n := focused;
inc(n,bounds.b.y-bounds.a.y);
if n > List^.Count-1 then n := List^.Count-1;
FocusItem(n);
end;
procedure GoHome;
begin
FocusItem(0);
end;
procedure GoEnd;
begin
FocusItem(List^.Count-1);
end;
procedure sdfjklfhjjsdfjdfs;assembler;
asm
mov dx,3dah
@Loop1:
in al,dx
test al,8
jne @Loop1
@Loop2:
in al,dx
test al,8
je @Loop2
end;
procedure Maximize;
begin
if bounds.b.x-bounds.a.x = scrXSize-1 then exit;
if LList = @Self then while bounds.b.x < scrXSize-1 do begin
inc(bounds.b.x);
sdfjklfhjjsdfjdfs;
Draw;
end else while bounds.a.x > 0 do begin
dec(bounds.a.x);
sdfjklfhjjsdfjdfs;
Draw;
end;
bounds.a.x := 0;
bounds.b.x := scrXSize-1;
Draw;
qSetColor(Red,Black);
end;
procedure Minimize;
begin
if bounds.b.x-bounds.a.x < scrXSize div 2 then exit;
if LList = @Self then while bounds.b.x > scrXSize div 2-1 do begin
dec(bounds.b.x);
sdfjklfhjjsdfjdfs;
Draw;
end else while bounds.a.x < scrXSize div 2+1 do begin
inc(bounds.a.x);
sdfjklfhjjsdfjdfs;
Draw;
end;
Next^.Draw;
Draw;
end;
procedure History;
var
x,y:integer;
procedure putit(s:string);
begin
XYWrite(x,y,s);
inc(y,2);
end;
begin
CreateWindow(51,21,black,cyan);
x := WinRect.A.X+1;
y := WinRect.A.Y+1;
qSetFC(Yellow);
putit('Minik gercekler of ListWorx');
qSetFC(Black);
putit('ş This prog sadece iki gecede yazildi');
putit('ş Progu yazmak icimden geldi. I did it my way');
putit('ş This prog has been dedicated to my minik CPC464');
putit('ş I''ve written this like the my old ones. :~)');
putit('ş Begenip begenmemeniz umurumda degil');
putit('ş This is MY program. Not yours. So shut up');
putit('ş No shareware thing for this little proggy');
putit('ş If you don''t like it, you can lump it');
putit('ş There will be NO future versions.');
qGetKey;
DestroyWindow;
end;
procedure Memory;
function ggg(l:longint):string;
var
s:string;
begin
s := l2s(l);
ConvertNumToBusiness(s);
ggg := s;
end;
begin
Stub('ù '+ggg(MemAvail)+' bytes total free ù '+ggg(MaxAvail)+' bytes available ù');
end;
begin
if List = NIL then exit;
case Event of
kbF1,kbAltH : GenericHelp;
kbAltP : History;
kbAltZ : Memory;
kbUp : GoUp;
kbDown : GoDown;
kbPgUp : PgUp;
kbPgDn : PgDn;
kbHome : GoHome;
kbEnd : GoEnd;
kbF2 : PSelLister(RList)^.SaveList;
kbAltA : with PSelLister(RList)^ do begin
Filename := '';
SaveList;
end;
kbF3 : PSelLister(RList)^.LoadList;
kbRight : if LList = @Self then Maximize else Minimize;
kbLeft : if RList = @Self then Maximize else Minimize;
else exit;
end; {case}
Event := 0;
end;
procedure TLister.FocusItem;
var
ysize:integer;
begin
focused := item;
ysize := bounds.b.y-bounds.a.y;
if (focused < start) then start := focused else if
focused > start+ysize then start := focused-ysize;
if (List^.Count-1)-start < ysize then start := (List^.Count-1)-ysize;
if start < 0 then start := 0;
Draw;
end;
{ TSELDATE COLL BURADAN DA BASLIYOR AYRICANA }
function TSelDateColl.Compare;
var
s1,s2:string;
begin
if PSel(k1)^.Name = PSel(k2)^.Name then Compare := 0 else begin
s1 := PSel(K1)^.Time;
s2 := PSel(k2)^.Time;
Strip(s1);
Strip(s2);
if s1 >= s2 then Compare := 1 else
if s1 < s2 then Compare := -1;
end;
end;
procedure TSelDateColl.FreeItem;
begin {does nothing - myahajahaha}
end;
{ TSEL COLL BURADAN BASLIYOR }
procedure TSelColl.FreeItem;
begin
if item = NIL then exit;
DisposeStr(PSel(item)^.Desc);
Dispose(PSel(item));
end;
function TSelColl.Compare;
var
s1,s2:string;
begin
if Upper(PSel(k1)^.Name) = Upper(PSel(k2)^.Name) then Compare := 0 else begin
s1 := Upper(PSel(K1)^.Desc^);
s2 := Upper(PSel(k2)^.Desc^);
Strip(s1);
Strip(s2);
if s1 >= s2 then Compare := 1 else
if s1 < s2 then Compare := -1;
end;
end;
{ BURDA DA BITIYOR IYI MI}
procedure Finish;
var
scrend:word;
excess:word;
procedure ScrollUp;
begin
asm
mov dx,3dah
@Loop1:
in al,dx
test al,8
jne @Loop1
@Loop2:
in al,dx
test al,8
je @Loop2
end;
Move32(mem[Segb800:excess],mem[Segb800:0],scrend-excess);
ClearBuf(Mem[SegB800:scrend-excess],excess);
end;
var
n:byte;
begin
scrend := scrxsize*scrysize*2;
excess := scrxsize*2;
for n:=1 to scrysize do ScrollUp;
qSetColor(7,0);
asm
mov ax,3
int 10h
end;
qWriteln('ş ListWorx/386 ş v'+lVersion+' ş (c) '+GetAuthor+' ş Nov 95');
halt;
end;
procedure InitScreen;
var
b:byte;
LR,RR:TRect;
begin
qCursor(false);
qSetColor(0,0);
for b:=1 to scrysize-2 do begin
qLocate(scrxsize div 2,b);
qWrite(#32);
end;
LR.Assign(0,2,(scrXSize div 2)-1,scrysize-3);
RR := LR;
RR.Move((scrXSize div 2)+1,0);
RR.B.X := scrxsize-1;
qSetBC(Black);
LList := New(PFileLister,Init(LR));
RList := New(PSelLister,Init(RR,'',NIL));
LList^.Next := RList;
RList^.Next := LList;
FocList := LList;
LList^.Draw;
RList^.Draw;
end;
function GetKeyEvent:word;assembler;
asm
mov ah,1
int 16h
jnz @skip
xor ax,ax
jmp @end
@skip:
xor ah,ah
int 16h
@end:
end;
function Valid:boolean;
var
c:char;
begin
Valid := true;
if PSelLister(RList)^.Modified then begin
Stub('ù Aloooo ù');
CreateWindow(26,3,White,Green);
XYWrite(winrect.a.x+1,winrect.a.y+1,'Save your last changes?');
repeat
c := upcase(qGetChar);
until c in ['Y','N',#13,#27];
DestroyWindow;
case c of
'Y',#13 : PSelLister(RList)^.SaveList;
'N' : ;
else begin
Valid := false;
exit;
end;
end; {Case}
end;
end;
procedure MainLoop;
var
Event:TEvent;
off:PLister;
universe_explodes:boolean;
begin
off := NIL;
universe_explodes := false;
repeat
Event := GetKeyEvent;
if Event > 0 then begin
if Event = kbTab then begin
FocList := FocList^.Next;
FocList^.Next^.Draw;
FocList^.Draw;
end else FocList^.Handle(Event);
end else if off <> FocList then begin
if MaxAvail < 1024*1024 then Stub('---> WARNING: LOW MEMORY! <---') else Stub(FocList^.GetHelp);
off := FocList;
end;
if Event = kbAltX then universe_explodes := Valid;
until universe_explodes;
end;
procedure InitPal;
const
PalXLat : Array[0..15] of Byte = (00,01,02,03,04,05,20,07,56,57,58,59,60,61,62,63);
procedure SetRGB(color,r,g,b:byte);assembler;
asm
xor ah,ah
mov al,color
mov di,ax
mov al,byte ptr PalXLat[di];
mov dx,3c8h
out dx,al
inc dx
mov al,r
out dx,al
mov al,g
out dx,al
mov al,b
out dx,al
end;
procedure GetPalette(Var P); assembler;
asm
cld
mov dx,3C7h
mov cx,300h
les di,P
xor al,al
out dx,al
inc dx
inc dx
repz insb
end;
begin
SetRGB(LightGray,30,30,40);
SetRGB(DarkGray,25,25,35);
SetRGB(Magenta,20,20,40);
SetRGB(Yellow,50,50,60);
SetRGB(Blue,20,20,40);
SetRGB(Cyan,30,40,50);
SetRGB(Brown,35,35,45);
SetRGB(Green,20,20,30);
end;
procedure ValidateEXE;
var
h:TEXEHeader;
T:TDosStream;
crc:word;
buf:pointer;
bufsize:word;
begin
{$IFDEF EXEPROTECTION}
T.Init(ParamStr(0),stOpenRead);
T.Read(h,SizeOf(h));
crc := 0;
while T.GetPos < T.GetSize do begin
bufSize := 65000;
if bufSize > T.GetSize-T.GetPos then bufSize := T.GetSize-T.GetPos;
GetMem(buf,BufSize);
T.Read(buf^,bufSize);
inc(crc,GetChecksum(buf^,bufSize));
FreeMem(buf,bufSize);
end;
T.Done;
inc(scrXSize,(h.NegSum-crc)*22);
inc(scrYSize,(h.NegSum-crc)*18);
{$ENDIF}
end;
procedure SetFont(var font);assembler;
asm
jmp @Init
@Init:
mov ax,SegA000
mov es,ax
push ds
lds si,font
xor di,di
mov dx,3dah
in al,dx
xor al,al
mov dx,3c0h
out dx,al
mov dx,3c4h
mov ax,0402h
out dx,ax
mov ax,0704h
out dx,ax
mov dx,3ceh
mov ax,0204h
out dx,ax
mov ax,0005h
out dx,ax
mov ax,0406h
out dx,ax
mov cx,256
@loop1:
push cx
mov cx,10h
rep movsb
add di,10h
pop cx
loop @loop1
mov dx,3c4h
mov ax,0302h
out dx,ax
mov ax,0304h
out dx,ax
mov dx,3ceh
mov ax,0004h
out dx,ax
mov ax,1005h
out dx,ax
mov ax,0e06h
out dx,ax
mov dx,3dah
in al,dx
mov dx,3c0h
mov al,20h
out dx,al
pop ds
end;
procedure Init;
var
header:string;
begin
if Test8086 < 2 then begin
qWriteln('This CPU doesn''t support 80386 instruction set');
halt(1);
end;
InitXErr;
asm
mov dx,3ceh
mov al,6
out dx,al
inc dx
in al,dx
test al,1
je @Exit
@Sucks:
mov ax,3
int 10h
@Exit:
end;
scrXSize := qXSize;
scrYSize := qYSize;
qCls;
InitPal;
if qYSize = 25 then SetFont(@XFont^);
qSetColor(White,Blue);
header := 'ListWorx/386 ù v'+lVersion+' ù (c) '+offRoad[2]+offRoad[2]+offRoad[1]+' ù Nov 95';
header := Duplicate(#32,(scrxsize-length(header)) div 2)+header;
ValidateEXE;
header := header + Duplicate(#32,scrxsize-(length(header)+5));
qWrite(header);
qSetBC(Black);
qWrite(' ');
qSetColor(White,Red);
qWrite(' C* ');
InitScreen;
end;
{$D ListWorx/386}
begin
Init;
MainLoop;
Finish;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment