|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 20480 (0x5000)
Types: TextFile
Names: »KATALOG.PAS«
└─⟦27a1d1812⟧ Bits:30002681 RC-Katalog over EDB-bøger og programmer
└─⟦this⟧ »KATALOG.PAS«
program katalog;
type regs = record
ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;
end;
produkt=record
opl: array(.1..10.) of string(.30.);
nr:integer;
mark:array(.1..7.) of boolean;
end;
prodptr=^produkt;
streng = string(.30.);
var i,j,m,n,p,sortnummer,nummer,antallinier,antalpost,niveau:integer;
post:produkt;
postptr:array(.1..410.) of prodptr;
f:file of produkt;
g:file of string(.255.);
typer:array(.0..9.) of string(.10.);
aktive,maskemgd:array(.1..7.) of integer;
maske,listetekst:array(.1..7.) of string(.30.);
ch,check:char;
udvid,med,pr:boolean;
u,e:text;
tom:string(.20.);
st:string(.3.);
reg:regs;
procedure L_detach;
begin
reg.cx:=$9f;
swint(224,reg);
end;
function L_cattach:integer;
begin
reg.cx:=$a1;
swint(224,reg);
L_cattach:=reg.ax;
end;
procedure printer;
begin
close(u);
if pr then
begin
assign(u,'con:');
L_detach;
end
else
if L_cattach<>$0 then
begin
writeln(clrhom);
gotoxy(10,10);write('PRINTER OPTAGET AF ANDEN PROCES. IKKE TILORDNET. ');
gotoxy(1,23);write(rvson,' TRYK RETUR ',rvsoff);
pr:=not pr;
assign(u,'con:');
read(ch);
end
else
assign(u,'lst:');
rewrite(u);
pr:=not pr;
end;
function findvaerdi(s:streng):integer;
var i,v,p:integer;
begin
i:=0;
repeat
repeat
i:=i+1;
until (s(.i.) in (.'0'..'9'.)) or (i=len(s));
val(copy(s,i,len(s)-i),v,p);
if p<>0 then
findvaerdi:=v
else
findvaerdi:=0;
until (p=0) or (v>9);
end;
procedure strquicksort(v:integer);
var gloplys:string(.30.);
gammel,w:integer;
procedure sort(v,l,r:integer);
var i,j:integer;
x,w:prodptr;
begin
i:=l;
j:=r;
x:=postptr(.(l+r) div 2.);
repeat
while postptr(.i.)^.opl(.v.)<x^.opl(.v.) do i:=i+1;
while x^.opl(.v.)<postptr(.j.)^.opl(.v.) do j:=j-1;
if i<=j then
begin
w:=postptr(.i.);
postptr(.i.):=postptr(.j.);
postptr(.j.):=w;
i:=i+1;
j:=j-1;
end;
until i>j;
if l<j then sort(v,l,j);
if i<r then sort(v,i,r);
end;
begin
sort(v,1,antalpost);
w:=1;
gloplys:=postptr(.1.)^.opl(.v.);
gammel:=1;
repeat
w:=w+1;
if postptr(.w.)^.opl(.v.)<>gloplys then
begin
sort(1,gammel,w-1);
gammel:=w;
gloplys:=postptr(.w.)^.opl(.v.);
end;
until w=antalpost;
sort(1,gammel,w);
end;
procedure nrquicksort(v:integer);
var gloplys:integer;
gammel,w:integer;
procedure sort(v,l,r:integer);
var i,j:integer;
x,w:prodptr;
begin
i:=l;
j:=r;
x:=postptr(.(l+r) div 2.);
repeat
while findvaerdi(postptr(.i.)^.opl(.v.))<findvaerdi(x^.opl(.v.)) do i:=i+1;
while findvaerdi(x^.opl(.v.))<findvaerdi(postptr(.j.)^.opl(.v.)) do j:=j-1;
if i<=j then
begin
w:=postptr(.i.);
postptr(.i.):=postptr(.j.);
postptr(.j.):=w;
i:=i+1;
j:=j-1;
end;
until i>j;
if l<j then sort(v,l,j);
if i<r then sort(v,i,r);
end;
begin
write(clrhom);
gotoxy(5,10);
write('ET ØJEBLIK - LISTE SORTERES EFTER ',RVSON,' PRIS ',RVSOFF,' (LANGSOM)');
sort(v,1,antalpost);
w:=1;
gloplys:=findvaerdi(postptr(.1.)^.opl(.v.));
gammel:=1;
repeat
w:=w+1;
if findvaerdi(postptr(.w.)^.opl(.v.))<>gloplys then
begin
sort(1,gammel,w-1);
gammel:=w;
gloplys:=findvaerdi(postptr(.w.)^.opl(.v.));
end;
until w=antalpost;
sort(1,gammel,w);
end;
procedure quicksort(v:integer);
begin
if v=4 then
nrquicksort(v)
else
strquicksort(v);
end;
procedure init;
begin
typer(.0.):='retur ';
typer(.1.):='TITEL ';
typer(.2.):='FORF. ';
typer(.3.):='FORLAG ';
typer(.4.):='PRIS ';
typer(.5.):='TLF ';
typer(.6.):='FAG ';
typer(.7.):='KLAS. ';
typer(.8.):='BOG/SW ';
typer(.9.):='SPROG ';
tom:=' ';
for i:=2 to 7 do aktive(.i.):=0;
for i:=1 to 7 do listetekst(.i.):='';
udvid:=false;
pr:=true;
printer;
niveau:=1;
sortnummer:=0;
maske(.1.):='';
end;
procedure indlaes;
begin
assign(f,'katdata.dat');
reset(f);
i:=0;
while not eof(f) do
begin
i:=i+1;
read(f,post);
allocate(postptr(.i.),340);
postptr(.i.)^:=post;
end;
antalpost:=i;
aktive(.1.):=i;
close(f);
end;
procedure maskeliste;
var typelist:array(.1..410.) of string(.30.);
k:integer;
begin
write(clrhom);
gotoxy(10,10);
write('ET ØJEBLIK ');
for j:=1 to 410 do typelist(.j.):='';
if nummer<>sortnummer then quicksort(nummer);
writeln;
k:=0;
for j:=1 to antalpost do
begin
med:=false;
n:=0;
if postptr(.j.)^.mark(.niveau-1.) then
begin
repeat
n:=n+1;
if postptr(.j.)^.opl(.nummer.)=typelist(.n.) then
med:=true;
until (med) or (n>=k);
if not med then
begin
k:=k+1;
typelist(.k.):=postptr(.j.)^.opl(.nummer.);
end;
end;
end;
write(clrhom);
for n:=1 to k do
begin
if ((n mod 40)=1) and(n<>1) then
begin
gotoxy(1,23);write(rvson,'TRYK RETUR FOR DE NÆSTE :',rvsoff);
read(ch);
write(clrhom);
end;
if not(odd((n-1) div 20)) then
gotoxy(1,((n-1) mod 20)+1)
else
gotoxy(41,((n-1) mod 20)+1);
writeln(n,' : ',typelist(.n.));
end;
gotoxy(1,23);write(rvson,'Indtast nummeret på ønskede maske, RETUR hvis ingen : ',rvsoff);
repeat
gotoxy(54,23);write(clreos);
read(st);
val(st,n,p);
until (p=0) ;
if (n=0) or (st='') then
begin
check:='O';
if not udvid then niveau:=niveau-1;
end
else
maske(.niveau.):=typelist(.n.);
if nummer<>sortnummer then quicksort(sortnummer);
end;
function igraenser(s:streng;min,max:integer):boolean;
var v:integer;
begin
v:=findvaerdi(s);
if (min<v) and (v<max) then igraenser:=true else igraenser:=false;
end;
procedure prisgruppe;
var tal:string(.5.);
min,max:integer;
begin
repeat
write(clrhom);
gotoxy(10,12);write('1) Op til en vis maksimal pris');
gotoxy(10,13);write('2) Mellem en øvre og en nedre grænse');
gotoxy(10,14);write('3) Fra en vis mindstepris og opefter');
gotoxy(10,10);write('Angiv type af prisområde ');
read(e,ch);
until ch in (.'1','2','3'.);
case ch of
'1':begin
min:=0;
gotoxy(10,18);
write('Maksimal pris : ');
read(max);
str(max,tal);
maske(.niveau.):='max '+tal;
end;
'2':begin gotoxy(10,18);write('Minimal pris : ');read(min);
gotoxy(10,20);write('Maksimal pris : ');read(max);
str(min,tal);
maske(.niveau.):=tal+' - ';
str(max,tal);
maske(.niveau.):=maske(.niveau.)+tal;
end;
'3':begin
gotoxy(10,18);
write('Minimal pris : ');
read(min);
max:=32767;
str(min,tal);
maske(.niveau.):='min '+tal;
end;
otherwise
end;
for i:=1 to antalpost do
with postptr(.i.)^ do
begin
if (mark(.niveau-1.)) and (igraenser(opl(.4.),min,max)) then
begin
if not mark(.niveau.) then aktive(.niveau.):=aktive(.niveau.)+1;
mark(.niveau.):=true
end;
end;
end;
procedure skim;
begin
check:='A';
niveau:=niveau+1;
write(clrhom);
gotoxy(10,3);
if udvid then
write(rvson,' UDVIDELSE AF DELGRUPPE : ',listetekst(.niveau.),' ',RVSOFF)
else
write(rvson,' VALG AF DELGRUPPE ',RVSOFF);
gotoxy(10,10);writeln('Vælg blandt nedenstående typer');
for i:=0 to 9 do begin gotoxy(12,11+i);writeln(i,' : ',typer(.i.));end;
gotoxy(10,23);write(rvson,'Indtast nummer : ',rvsoff);
repeat
read(e,ch);
until ch in (.'0'..'9'.);
val(ch,nummer,n);
if nummer=0 then
begin
if not udvid then niveau:=niveau-1;
end
else
begin
maskemgd(.niveau.):=nummer;
write(clrhom,RVSON,' MASKNING PÅ : ',typer(.nummer.),RVSOFF);
gotoxy(10,10);
write('Indtast maske (eller RETUR for liste over mulige ) : ');
readln(maske(.niveau.));
if maske(.niveau.)='' then
begin
if nummer=4 then
begin
writeln('Vælg mellem at få en liste, eller at angive et prisområde');
write('RETUR = liste, O = område ');
read(e,check);
if check in(.'O','o','0'.) then prisgruppe else maskeliste;
end
else
maskeliste;
end;
if not( check in (.'O','o','0'.)) then
for i:=1 to antalpost do
with postptr(.i.)^ do
begin
if (mark(.niveau-1.)) and (pos(maske(.niveau.),opl(.nummer.))<>0) then
begin
if not mark(.niveau.) then aktive(.niveau.):=aktive(.niveau.)+1;
mark(.niveau.):=true
end;
end;
listetekst(.niveau.):=listetekst(.niveau.)+'/'+copy(maske(.niveau.),1,10);
end;
end;
procedure bagud;
begin
for i:=1 to antalpost do postptr(.i.)^.mark(.niveau.):=false;
aktive(.niveau.):=0;
listetekst(.niveau.):='';
niveau:=niveau-1;
end;
procedure udskema(x:integer);forward;
procedure liste;
var stk,medtaeller,udantal:integer;
tom:string(.19.);
sidste:array(.0..410.) of 0..511;
begin
case niveau of
1,2,3,4,5:stk:=2;
6,7:stk:=3;
otherwise
end;
tom:=' ';
udantal:=0;
write(u,clrhom);
for i:=1 to niveau do
begin
writeln(u,listetekst(.i.));
end;
writeln(u,'----------------------------------------------------');
writeln(u);
i:=0;
sidste(.0.):=1;
repeat
i:=i+1;
with postptr(.i.)^ do
begin
if mark(.niveau.) then
begin
udantal:=udantal+1;
sidste(.udantal.):=i;
writeln(u,udantal,' : ',opl(.sortnummer.));
for j:=1 to 9 do
begin
med:=false;
n:=0;
repeat
n:=n+1;
if (j=maskemgd(.n.)) and (j<>4) then
begin
med:=true;
n:=niveau;
end;
until n>=niveau;
if (not med) and (j<>sortnummer) then
if j=3 then
writeln(u,tom,opl(.j.)+opl(.10.))
else
writeln(u,tom,opl(.j.));
end;
if ((udantal mod stk)=0) and (not pr) then
begin
gotoxy(1,23);
write(rvson,'RETUR = Næste, F = Forrige, S = Stop (evt for beskrivelse)',rvsoff);
read(e,ch);
if ch in (.'S','s'.) then i:=antalpost;
if (ch in (.'F','f'.)) and (udantal>=2*stk) then begin udantal:=udantal-2*stk;i:=sidste(.udantal.);end;
write(u,clrhom);
for j:=1 to niveau do
begin
writeln(u,listetekst(.j.));
end;
writeln(u,'----------------------------------------------------');
end;
end;
end;
until i=antalpost;
if not pr then
begin
if not (ch in (.'S','s'.)) then
begin
gotoxy(1,23);
write(rvson,' TRYK RETUR ',rvsoff);
read(ch);
end;
write(clrhom);
gotoxy(1,10);
write('Angiv nummer på post der ønskes beskrivelse af, RETUR hvis ingen');
read(st);
if st<>'' then
begin
val(st,i,p);
if p=0 then
begin
assign(g,'beskriv.dat');
reset(g);
medtaeller:=0;
p:=0;
repeat
p:=p+1;
if postptr(.p.)^.mark(.niveau.) then medtaeller:=medtaeller+1;
until medtaeller=i;
udskema(p);
gotoxy(7,23);
write(rvson,' Tryk RETUR',rvsoff);
read(ch);
close(g);
end;
end;
end;
end;
procedure udskema;
var beskrivelse:string(.255.);
procedure linie(x:integer);
var i:integer;
begin
write(u,' ');
case x of
1,5,6:write(u,'▶86◀');
2,3 :write(u,'▶80◀');
4,7 :write(u,'▶82◀');
otherwise
end;
for i:=1 to 35 do write(u,'▶88◀');
case x of
1:write(u,'▶8a◀');
2,7:write(u,'▶88◀');
3,6:write(u,'▶84◀');
4,5:write(u,'▶87◀');
otherwise
end;
for i:=1 to 35 do write(u,'▶88◀');
case x of
1,5,6:writeln(u,'▶85◀');
2,3 :writeln(u,'▶81◀');
4,7 :writeln(u,'▶83◀');
otherwise
end;
end;
procedure tekst(n:integer);
begin
writeln(u,copy(' ▶89◀'+typer(.n.)+postptr(.x.)^.opl(.n.)+tom+tom,1,42),
copy('▶89◀ '+typer(.n+1.)+postptr(.x.)^.opl(.n+1.)+tom+tom,1,36),'▶89◀');
end;
var k,pos,i:integer;
begin
write(clrhom);
with postptr(.x.)^ do
begin
linie(3);
tekst(1);linie(5);
writeln(u,copy(' ▶89◀'+typer(.3.)+opl(.3.)+opl(.10.)+tom+tom+tom+tom,1,78),
'▶89◀');
linie(6);
tekst(4);linie(1);
tekst(6);linie(1);
tekst(8);linie(4);
linie(2);
antallinier:=0;
write(u,' ▶89◀ ');
pos:=8;
seek(g,4*(nr));
for i:=1 to 4 do
begin
read(g,beskrivelse);
k:=0;
if len(beskrivelse)>0 then
begin
m:=0;
repeat
m:=m+1;
pos:=pos+1;
if ((beskrivelse(.m.)=chr(13)) or (pos=78)) or
(beskrivelse(.m.)=chr(10)) then
begin
while pos<79 do begin pos:=pos+1;write(u,' ');end;
write(u,'▶89◀',chr(13)+chr(10),' ▶89◀ ');
antallinier:=antallinier+1;
pos:=8;
if (beskrivelse(.m.)=chr(13)) and (m<253) then m:=m+1;
if (not pr) and (antallinier=11) then
begin
gotoxy(1,23);
write(rvson,'TRYK RETUR FOR RESTEN',rvsoff);
read(ch);
gotoxy(1,23);write(' ▶89◀ ');
gotoxy(8,23);
end;
end
else
if (m<=len(beskrivelse)) then write(u,beskrivelse(.m+k.));
until m>=len(beskrivelse);
end;
end;
while pos<78 do begin pos:=pos+1;write(u,' ');end;
writeln(u,'▶89◀');
linie(7);
end;
end;
procedure beskriv;
var taeller:integer;
sidste:array(.0..410.) of 0..511;
begin
assign(g,'beskriv.dat');
reset(g);
writeln(u,chr(12));
taeller:=0;
i:=0;
sidste(.0.):=1;
repeat
i:=i+1;
with postptr(.i.)^ do
if mark(.niveau.) then
begin
taeller:=taeller+1;
sidste(.taeller.):=i;
if (pr) and ((taeller mod 2)=1) then
begin
writeln(u,((taeller-1) div 2):40);
write(u,chr(12));
writeln(u,tom+tom+postptr(.i.)^.opl(.sortnummer.):79);
end;
udskema(i);
if not pr then
begin
gotoxy(7,23);
write(rvson,' RETUR = næste, F =Forrige, S = Stop',rvsoff);
read(e,ch);
end
else
for m:=1 to 17-antallinier do writeln(u);
writeln(u);
if ch in (.'S','s'.) then i:=antalpost;
if (ch in (.'F','f'.)) and (taeller>1) then begin taeller:=taeller-2;i:=sidste(.taeller.);end;
end;
until i=antalpost;
close(g);
end;
procedure sorter(v:integer);
begin
write(clrhom);
if v=0 then
begin
gotoxy(10,3);
write(rvson,' SORTERING ',rvsoff);
for i:=1 to 9 do begin gotoxy(10,7+i);writeln(i,' : ',typer(.i.));end;
gotoxy(10,23);write(rvson,'INDTAST NUMMER DER ØNSKES SORTERET EFTER : ',rvsoff);
repeat
read(e,ch);
until ch in(.'1'..'9'.);
v:=ord(ch)-48;
end;
if v<>sortnummer then
begin
sortnummer:=v;
write(clrhom);
gotoxy(10,10);
write('SORTERER DATA EFTER ',rvson,' ',typer(.sortnummer.),rvsoff);
quicksort(sortnummer);
end;
end;
procedure indhold;
var w,w1,w2,max:integer;
prik:string(.55.);
gloplys:string(.30.);
tryk:boolean;
side:array(.1..410.) of 0..410;
oplys:array(.0..410.) of string(.30.);
begin
prik:='.......................................................';
writeln(u,chr(12));
writeln(u);
writeln(u,' INDHOLDSFORTEGNELSE');
writeln(u);
writeln(u);
quicksort(sortnummer);
for w:=0 to 410 do oplys(.w.):=' ';
w:=0;
w1:=0;
write(clrhom);
for i:=1 to antalpost do
with postptr(.i.)^ do
begin
if mark(.niveau.) then
begin
w:=w+1;
if opl(.sortnummer.)<>gloplys then
begin
gloplys:=opl(.sortnummer.);
for w2:=1 to 30 do
if gloplys(.w2.)<>' ' then max:=w2;
writeln(u,tom,copy(copy(gloplys,1,max)+prik,1,55),((w+1) div 2));
if pr then writeln(u);
tryk:=false;
w1:=w1+1;
end;
side(.w.):=(w+1) div 2;
oplys(.w.):=opl(.1.);
gloplys:=opl(.sortnummer.);
if (not pr) and (not tryk) and (((w1 mod 20)=0) or (i=antalpost)) then
begin
tryk:=true;
gotoxy(10,23);
write(rvson,'TRYK RETUR FOR DE NÆSTE',rvsoff);
read(ch);
write(clrhom);
end
else
if (pr) and ((w1 mod 25)=0) then writeln(u,chr(12),chr(10));
end;
end;
quicksort(1);
w:=0;
if pr then
for i:=1 to antalpost do
with postptr(.i.)^ do
begin
if mark(.niveau.) then
begin
w:=w+1;
if (w mod 55)=1 then write(u,chr(12),chr(10));
w1:=0;
repeat
w1:=w1+1;
until opl(.1.)=oplys(.w1.);
gloplys:=opl(.1.);
for w2:=1 to 30 do
if gloplys(.w2.)<>' ' then max:=w2;
writeln(u,tom,copy(copy(gloplys,1,max)+prik,1,55),((w1+1) div 2));
end;
end;
quicksort(sortnummer);
end;
procedure hovedmenu;
begin
assign(e,'kbd:');
rewrite(e);
repeat
write(clrhom);
gotoxy(10,3); write('L = LISTE OVER NUVÆRENDE GRUPPE');
gotoxy(10,5); write('B = BESKRIVELSE+LISTE OVER NUVÆRENDE GRUPPE');
gotoxy(10,7); write('S = SORTERING EFTER BESTEMT POST');
gotoxy(10,9); write('D = DELGRUPPE EFTER MASKE');
gotoxy(10,11);write('U = UDVID NUVÆRENDE DELGRUPPE ',
rvson,' NIVEAU : ',niveau,' ',rvsoff);
gotoxy(10,13);write('T = TILBAGE TIL FOREGÅENDE GRUPPE');
gotoxy(10,15);write('P = PRINTER TIL ELLER FRA');
gotoxy(10,17);if pr then write('I = INDHOLDSFORTEGNELSE FOR NUVÆRENDE GRUPPE');
gotoxy(10,21);write('A = AFSLUT PROGRAMMET');
gotoxy(10,1);
if pr then write(rvson,' printer ',rvsoff) else write(rvson,' skærm ',rvsoff);
gotoxy(30,1);write(rvson,' ','ANTAL I NUVÆRENDE GRUPPE : ',aktive(.niveau.),' ',rvsoff);
gotoxy(10,23);write(rvson,' INDTAST DET ØNSKEDE : ',rvsoff);
read(e,ch);
case ch of
'L','l':liste;
'B','b':beskriv;
'S','s':sorter(0);
'D','d':skim;
'U','u':if niveau>1 then begin udvid:=true;niveau:=niveau-1;skim;udvid:=false;end;
'T','t':if niveau>1 then bagud;
'I','i':indhold;
'P','p':printer;
otherwise
end;
until ch in (.'A','a'.);
write(clrhom);
end;
begin
init;
indlaes;
sorter(1);
hovedmenu;
close(f);
close(u);
close(e);
end.
«eof»