{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 16384,0,0}
program vtg2;
{ $define arabic}
{$define Fiedel}
Uses Objects,Drivers,Dos,NewCRT,Strings;
var
TextAttr:Byte;
sstr,filename:PathStr;
Timer: word absolute $40:$6c;
type
tPage=array[0..$3ff] of byte; {40*24+10+14 = 1 KByte}
int=integer;
void=int;
numstr=array[0..3] of char; {von wegen Hexzahlen}
const
OldButtons:word=0;
INDIZES=2048;
{$ifdef Fiedel}
MAGIC=$e6e8d4d6;
INDEXPP=249; {Indexeinträge pro führender Index-Seite}
{$else}
MAGIC=$f3e8d4d6;
INDEXPP=255;
{$endif}
{MAGIC=Longint('fhTV') or $80808080; Intelnotation}
type
tView=object (tRect)
procedure MouseHide;
procedure WriteBuf(x,y,br,h:Integer; Buf:Pointer);
end;
procedure tView.MouseHide; assembler;
asm
les bx,[self]
mov al,es:[bx]
dec al
mov ah,8
mul ah
mov cx,ax
mov al,es:[bx+2]
dec al
mov ah,FONTH
mul ah
mov dx,ax
mov al,es:[bx+4]
inc al
mov ah,8
mul ah
mov si,ax
mov al,es:[bx+6]
inc al
mov ah,FONTH
mul ah
mov di,ax
mov ax,10h
int 33h
end;
procedure tView.WriteBuf;
var Zeile,Spalte:Int;
ch:Char; attr:Byte;
begin
for Zeile:=y to y+h-1 do
for Spalte:=x to x+br-1 do begin
ch:=Char(Buf^); Inc(Word(Buf));
attr:=Byte(Buf^); Inc(Word(Buf));
WriteChar(ch,attr,Spalte,Zeile);
end;
end;
type
tVPage=object (tView)
procedure DisplayPage(var Page:tPage;FlagPar:Byte);
function videotreffer(var Page:tPage; var i:int; var event:tevent):boolean;
end;
tButton=object (tView)
Schrift: String;
hot:Char;
constructor Init(s:String;x,y:Byte;hotkey:char);
function Treffer(Event:tEvent):Boolean;
destructor done;
end;
var
i,j,k: int;
p: pointer;
posx,posy,farb: byte;
Event:tEvent;
ch:char;
constructor tButton.Init;
var
i,j:byte;
buf:array[0..39] of word;
begin
Assign(x,y,x+1+CStrLen(s),y+2);
MouseHide;
WriteChar('┌',$f0,a.x,a.y);
WriteChar('┐',$f0,b.x,a.y);
WriteChar('└',$f0,a.x,b.y);
WriteChar('┘',$f0,b.x,b.y);
WriteChar('│',$f0,a.x,a.y+1);
WriteChar('│',$f0,b.x,a.y+1);
for i:=a.x+1 to b.x-1 do begin
WriteChar('─',$f0,i,a.y);
WriteChar('─',$f0,i,b.y);
end;
MoveCStr(buf,s,$f4f0);
WriteBuf(a.x+1,a.y+1,CStrLen(s),1,@buf);
{ WrStr(s,$f0,a.x+1,a.y+1);
WriteChar(hotkey,$f4,xa+pos(hotkey,s),ya+1);}
hot:=hotkey;
showmouse;
end;
destructor tButton.Done;
var
i,j:byte;
s:string;
begin
MouseHide;
s:='';
for i:=a.x to b.x do s:=s+' ';
for i:=a.y to b.y do
WrStr(s,$71,a.x,i);
ShowMouse;
end;
var
button1,button2,button3,button4,buttonU,buttonS:tButton;
buttonplus,buttonminus,buttonnext,ButtonRight,ButtonDouble:tButton;
subpagelist:string[80];
VPage:tVPage;
const
maxhist=9;
historystack: array[0..maxhist] of word=
($100,$100,$100,$100,$100,$100,$100,$100,$100,$100);
procedure puthistory(w:word);
var
i:integer;
begin
for i:=0 to maxhist-1 do historystack[i]:=historystack[i+1];
historystack[maxhist]:=w;
end;
function gethistory:word;
var
i:integer;
begin
gethistory:=historystack[MAXHIST];
for i:=maxhist-1 downto 0 do historystack[i+1]:=historystack[i];
historystack[0]:=$100;
end;
function BCD2Hex(B:Byte):Byte;
begin
BCD2Hex:=(B shr 4)*10 + (B and $f);
end;
function Hex2BCD(B:Byte):Byte;
begin
Hex2BCD:=(B div 10) shl 4 + (B mod 10);
end;
function tButton.Treffer;
var
i,j:Byte;
begin
case Event.What of
evKeyDown:
if UpCase(Event.CharCode)=UpCase(Hot) then begin
Event.What:=0; Treffer:=true; exit;
end;
evMouseDown:
if Contains(Event.Where) then begin
Event.What:=0; Treffer:=true; exit;
end;
end;
treffer:=false;
end;
const
pfad:pathstr='';
Type
pLine=^tLine;
tLine=array[0..39] of byte;
pPage=^tPage;
tIdx=record
pag,sub:word;
end;
var
vtf: TDosStream;
Index: array[0..INDIZES] of tIdx;
IndexCnt: word;
var
Page:tPage;
function CctChr(grafikflag:boolean; code:byte):char;
begin
CctChr:= Chr(Code);
if Code<$20 then cctchr:=' ' else
if grafikflag then begin
case code of
$20..$3f:cctchr:=Chr(code-$20);
$60..$7f:cctchr:=Chr(code+$40);
end {case}
end {grafikflag}
end;{cctchr}
procedure DisplayLine(p:pointer;x,y:Byte;var FlagPar:byte); {FlagPar-Rückgabe}
const
flashtime:boolean=true;
colormap:array[0..7]of byte=(0,$c,$a,$e,9,$d,$b,$f);
var
spalte,byteein,byteold:byte;
FlagReg:Byte;
{0:blinkflag,1:dblheigth (Flag Doppelte Höhe),
2:inbox (Flag für innerhalb einer Box), 3:shift (z.Z. nicht benutzt),
4:secret (Textfreigabe durch Quiztaste), 5:separated (gebrochene Grafik),
6:holdgrafix (bei Farbwechsel Wdh. letzte Grafik), 7:grafikflag (Grafikmode)}
{FlagPar:
0:blinkbit, 1:Zeilen ohne Blinken ignorieren,
2:Mix-Betrieb, 3:??,
4:Quiz-Bit, 5:Zeilen ohne Quiz ignorieren,
6:Doppelte Höhe vorhanden (intern), 7:Doppelte Höhe verboten (=ignorieren)}
procedure PutCctChr(ByteEin:byte);
begin
PutMode:=0;
if (FlagPar and $4 >0) and (FlagReg and $4 =0) then begin
PutMode:= $10; {transparent}
end;
PutMode:= PutMode or FlagReg and 2;
if (PutMode and 2 =0) then Inc(PutMode);
if (FlagReg and $80 >0) then
case (ByteEin and not $40) of
$20..$3f: PutMode:=PutMode or (FlagReg and $20);
end;
{$ifdef arabic}
WriteChar(Char(ByteEin),7,spalte+x,y);
{$else}
if ((FlagReg and 1 =0) or (FlagPar and 1 >0)) {Blinkbit}
and ((FlagReg and $10 =0) or (FlagPar and $10 >0)) then begin {Secret-Bit}
if (FlagReg and $80 >0) then
case ByteEin of
$20..$3f:ByteEin:=ByteEin-$20;
$60..$7f:ByteEin:=ByteEin+$40;
end {case}
end else ByteEin:=$20;
WriteChar(Char(ByteEin),TextAttr,spalte+x,y);
{$endif}
if (FlagPar and $40 >0) and (FlagReg and 2 =0) then {Doppelte Höhe}
WriteChar(' ',TextAttr,spalte+x,y+1); {Zeile darunter auch}
end; {PutCCTChr}
function SContains(p:pointer;b:byte):boolean; assembler;
asm
cld
les di,p
mov al,b
mov cx,40
repne scasb
mov al,false
jnz @@e
mov al,true
@@e:
end;
begin
{Notwendigkeit des Redraws feststellen}
if (FlagPar and $22 =0) or
((FlagPar and 2 >0) and Scontains(p,8)) or
((FlagPar and $20 >0) and Scontains(p,24)) then begin
CurFont:=@norm8x10;
PutMode:=1;
if (FlagPar and 4 >0) then
Wrstr('▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒',$71,x,y);
if (FlagPar and $80 =0) and (Scontains(p,13)) then begin
FlagPar:=FlagPar or $40; {Doppelte Höhe vorhanden}
if (FlagPar and 4 >0) then
Wrstr('▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒',$71,x,y+1);
end;
CurFont:=@tele8x10;
TextAttr:=$f; {Weiß auf Schwarz}
FlagReg:=0; {alle Flags aus}
for Spalte:=0 to 39 do begin
byteein:=byte(p^); Inc(Word(p));
case ByteEin of
28:TextAttr:=TextAttr and $f; {Hintergrund schwarz}
29:TextAttr:=TextAttr and $f or ((TextAttr shl 4) and $f0);
{Nibble doppeln}
end;
if (ByteEin<$20) then begin
if (FlagReg and $c0 =$c0) and {HoldGrafix und GrafikFlag}
((ByteOld and not $40 >=$20) and (ByteOld and not $40 <$40))
then PutCCTChr(ByteOld)
else PutCCTChr({$ifdef arabic} ByteEin {$else}$20{$endif});
end else begin
PutCCTChr(ByteEin);
ByteOld:=ByteEin;
end;
case ByteEin of
0..7,16..23: TextAttr:=TextAttr and $f0 or ColorMap[ByteEin and 7];
end;
if (ByteEin<$20) then
FlagReg:= FlagReg and not $10; {Secret aus}
case ByteEin of
0..7:FlagReg:= FlagReg and not $80;{Grafikflag aus}
{$ifndef arabic}
8: FlagReg:= FlagReg or 1; {Blinken ein}
9: FlagReg:= FlagReg and not 1; {Blinken aus}
10: FlagReg:= FlagReg and not 4; {InBox aus}
11: FlagReg:= FlagReg or 4; {InBox ein}
12: FlagReg:= FlagReg and not 2; {DoubleHeigth aus}
13: if (FlagPar and $80 =0) then {wenn nicht verboten}
FlagReg:= FlagReg or 2; {DoubleHeigth ein}
14: FlagReg:= FlagReg and not 8; {Shift aus (später verwendet)}
15: FlagReg:= FlagReg or 8; {Shift ein (später verwendet)}
16..23: FlagReg:= FlagReg or $80; {Grafikflag ein}
24: FlagReg:= FlagReg or $10; {Secret ein}
25: FlagReg:= FlagReg and not $20;{separated aus}
26: FlagReg:= FlagReg or $20; {separated ein}
30: FlagReg:= FlagReg or $40; {holdgrafix ein}
31: FlagReg:= FlagReg and not $40;{holdgrafix aus}
{$endif}
end; {case}
end; {1 Zeile}
if (FlagPar and 4 =0) then begin
writechar(' ',0,x+40,y);
if (FlagPar and $40 >0) then
writechar(' ',0,x+40,y+1);
end;
end; {if}
end;
const FlagPar:Byte=$01;
type
tHeader=record
Pag,Sub,C:Word;
HamErrs:Byte
end;
function FormatS(const fs:string;p4,p3,p2,p1:LongInt): string; assembler;
asm
les si,@result; push es; push si
les si,fs; push es; push si
lea si,p1; push ss; push si
call FormatStr
end;
function PagStr(I:tHeader):String;
var
s: string[5]; {Vorgabe-String}
begin
s:='%x'; if I.Sub<>0 then s:='%x/%x';
if I.Pag<$100 then I.Pag:=I.Pag+$800;
PagStr:=FormatS(s,0,0,I.Sub,I.Pag);
end;
procedure tVPage.DisplayPage(var Page:tPage;FlagPar:byte);
{ Gibt eine Teletextseite (seitenr) aus dem PC-RAM am Bildschirm aus }
var
Zeile: Byte;
Header: tHeader;
SaveHeader: tHeader absolute Page;
FlagSave: Byte;
NewHeader: String[7];
begin
FlagSave:=FlagPar and $80;
Header:=SaveHeader;
NewHeader:=FormatS('%c%03x/%02x',
0,Header.Sub and $ff,Header.Pag,Page[25*40+11]+Ord('P'));
if NewHeader[1]='0' then NewHeader[2]:='8';
System.Move(NewHeader[1],SaveHeader,7);
MouseHide;
FlagPar:=FlagPar and not $c0;
if (Header.C and $60)<>0 then
FlagPar:=FlagPar or 4; {Untertitel oder Schlagzeile}
for Zeile:=0 to {$ifdef arabic} 25 {$else} 24 {$endif} do begin
if FlagSave=0 then FlagPar:=FlagPar and not $80;
if (Zeile=0) or (Zeile=24) then
FlagPar:=FlagPar or $80;
if (FlagPar and $40 =0) then
DisplayLine(@Page[Zeile*40],a.x,a.y+Zeile,FlagPar)
else
FlagPar:=FlagPar and not $40;
end;
ShowMouse;
PutMode:=1;
SaveHeader:=Header;
end; {DisplayPage}
function tVPage.videotreffer(var Page:tPage; var i:int; var event:tevent):boolean;
var
Envir:array[0..4] of byte; {5 Zeichen}
j,k:int;
begin
if (Event.What=evMouseDown) and
Contains(Event.Where) then begin
System.Move(Page[(Event.Where.y-a.y)*40+(Event.Where.x-a.x)-2],Envir,sizeof(Envir));
for j:=0 to 2 do if (Envir[j]>=$30) and (Envir[j]<$3a) then break;
i:=0;
for k:=j to j+2 do begin
i:= i shl 4;
if (Envir[k]<$30) or (Envir[k]>=$3a) then begin
videotreffer:=false; exit; end;
i:=i + Envir[k] and $f;
end;
Event.What:=0; VideoTreffer:=true;
end else
Videotreffer:=false; {nicht mal Rechteck getroffen}
end;
const
flashcount:word=0;
lookingfor:boolean=false;
procedure Idle;
var
c:char;
var Idx:tIdx;
found:boolean;
{ var Page:tPage;}
begin
if Timer-FlashCount > (FlagPar and 1)*24+8 then begin
FlashCount:=Timer;
FlagPar:=FlagPar xor 1; {Toggeln Blinkzustand}
VPage.DisplayPage(Page,FlagPar or 2);
end;
end;
procedure readall;
var
{ Page: tPage;}
idx: tIdx;
found: boolean;
i: int;
begin
IndexCnt:=LongDiv(vtf.GetSize,sizeof(TPage));
if IndexCnt>INDIZES then RunError;
if (IndexCnt >0) then
for i:=0 to IndexCnt-1 do begin
vtf.Seek(LongMul(i,sizeof(TPage)));
vtf.Read(Index[i],sizeof(TIdx));
Write(i:5,#13);
end;
writeln;
end;
procedure ReadNewIndex; {Routine zum Einlesen eines New-Format-VT-Files}
{Die Kennung sei bereits vorher gecheckt!}
var
i,i1: int;
ph: int absolute page;
begin
IndexCnt:=LongDiv(vtf.GetSize,sizeof(TPage));
{Dateilänge:=Seitenzahl + (Seitenzahl+248) div INDEXPP, oder andersherum:}
{Seitenzahl:=Dateilänge - (Dateilänge+249) div (INDEXPP+1)}
if IndexCnt>INDIZES then RunError; {Zuviele Indizes}
i:=(IndexCnt+INDEXPP) div (INDEXPP+1); {Reservierte Seiten am Beginn}
for i1:=0 to i-1 do
Longint(Index[i1]):=MAGIC;
while i<IndexCnt do begin
vtf.Read(Page,sizeof(TPage)); {Eine Seite mit Indizes lesen}
if ph>=0 then RunError; {Bit15 muß gesetzt sein, auch bei künftigen Änderungen!}
i1:=IndexCnt-i; if i1>INDEXPP then i1:=INDEXPP; {Differenz, aber höchstens 255}
Move(Page[4],Index[i],sizeof(tIdx)*i1); {Indizes kopieren}
Inc(i,i1); {gleich ein Ruck weiter}
end {while};
end;
procedure ReadIn; {Videotext-Index einlesen, alte und neue Form}
var
ph: Longint absolute page;
begin
vtf.Read(Page,sizeof(TPage)); {Erste Seite einlesen}
vtf.Seek(0); {Dateizeiger zurücksetzen}
if ph=MAGIC then ReadNewIndex
else begin
writeln('Bitte warten, Datei ',filename,' wird eingelesen...');
readall;
end;
end;
{----------------------------------------------------}
procedure printtele(const FName:PathStr; const Page:tPage);
var
s1:array[0..40] of char;
f:text;
spalte,zeile,
byteein :byte;
grafikflag :boolean; { Flag ob Grafik ein/aus }
function cctchr(b:byte):char;
begin
case b of
$00..$1f: b:=$20; {Alle Steuerzeichen zu Space machen}
end;
if grafikflag then
case b of
$20..$3f,$60..$7f: b:=byte('░'); {Alle Grafikzeichen zu Füllern machen}
end;
case b of
$40: b:=byte(''); {gültig für deutsche Seite (4) und Codepage 437}
$5b: b:=byte('Ä');
$5c: b:=byte('Ö');
$5d: b:=byte('Ü');
$60: b:=byte('°');
$7b: b:=byte('ä');
$7c: b:=byte('ö');
$7d: b:=byte('ü');
$7e: b:=byte('ß');
end;
if (Zeile=0) and (Spalte<7) then
CctChr:=' ' else
cctchr:=Chr(b);
end;
begin
assign(f,FName); {$i-}Append(f);{$i+}
if IOResult<>0 then Rewrite(f);
s1[40]:=#0;
for Zeile:=0 to 24 do begin
grafikflag:=FALSE;
for spalte:=0 to 39 do begin
byteein:=Page[Zeile*40+Spalte];
case byteein of
0..7: grafikflag:=FALSE;
16..23: grafikflag:=TRUE;
end;
s1[Spalte]:=cctchr(byteein);
end;
writeln(f,s1);
end;
writeln(f); {Leerzeile}
close(f);
end; { printtele }
procedure GetEvent(var E:tEvent);
begin
repeat
GetKeyEvent(E);
if E.What=0 then GetMouseEvent(E);
if E.What=0 then Idle
else asm
mov ax,3
int 33h
mov ax,dx
mov bl,FONTH
div bl
mov ah,0
les di,E
mov [di+6],ax
end;
until E.What<>0;
end;
var speicher,pagenr,seitenr :word;
weiter :boolean;
attralt :byte;
sel,ok :integer;
procedure main;
(*
Function Ja_Nein(x,y:integer):Boolean;
var
ch:char;
BEGIN
{gotoxy(x,y);} write('<J>a oder <N>ein');
runerror;
repeat
ch:=readkey;
if ch in ['j','J'] then begin Ja_Nein:=true;EXIT;end;
if ch in ['n','N'] then begin Ja_Nein:=false;EXIT;end;
until false;
END;{ ja,nein }
*)
Procedure zahl_aus(hilfstr:String);
Begin
WrStr(copy('###',1,3-Length(HilfStr)),$f2,57,4);
WrStr(Hilfstr,$f2,57+3-Length(HilfStr),4);
End;
var pagelast,z: integer;
ch:Char;
MiniStr: String[3]; {3 Zeichen für Seite}
NextFlag: boolean;
Function NeueSeite:integer; {liefert 0 bei Extra-Funktionen}
var
xy :integer;
okay,z :integer;
hilfstring :string;
BEGIN
hilfstring:='';
repeat
GetEvent(Event);
ch:=Upcase(Event.charcode);
if ((Event.What=evKeyDown) and (Ch='Z')) or
((Event.What=evMouseDown) and
(Event.Buttons=mbRightButton)) then begin
NeueSeite:=GetHistory; exit;
end;
if buttonPlus.treffer(Event) then begin
{Such Minimum größer als pagelast}
xy:=MAXINT;
for j:=0 to IndexCnt-1 do
if Index[j].Pag<$800 then begin
z:=Index[j].Pag; if z<=PageLast then z:=z+$800; {Zyklisch machen!}
if xy>z then xy:=z;
end;
puthistory(pagelast);
NeueSeite:=xy; exit;
end;
if buttonMinus.treffer(Event) then begin
{Such Maximum kleiner als pagelast}
xy:=-MAXINT;
for j:=0 to IndexCnt-1 do
if Index[j].Pag<$800 then begin
z:=Index[j].Pag; if z>=PageLast then z:=z-$800;
{Zyklisch machen! Negative Zahlen stören nicht!}
if xy<z then xy:=z;
end;
PutHistory(PageLast);
NeueSeite:=xy; exit;
end;
if buttonNext.treffer(Event) then begin
{Such Maximum größer als pagelast}
NeueSeite:=pagelast; exit;
end;
if ButtonRight.Treffer(Event) then begin
NextFlag:=true;
NeueSeite:=pagelast; exit;
end;
if button3.treffer(Event) then begin
FlagPar:= FlagPar xor $10;
Ch:=' '; if FlagPar and $10 <>0 then Ch:='√';
CurFont:=@Norm8x10;
WriteChar(Ch,$f2,68,21);
VPage.DisplayPage(Page,FlagPar or $20);
end;
if button2.treffer(Event) then begin
FlagPar:= FlagPar xor $4;
Ch:=' '; if FlagPar and $4 <>0 then Ch:='√';
CurFont:=@Norm8x10;
WriteChar(Ch,$f2,60,18);
VPage.DisplayPage(Page,FlagPar);
end;
if buttonDouble.treffer(Event) then begin
FlagPar:= FlagPar xor $80;
Ch:=' '; if FlagPar and $80 =0 then Ch:='√';
CurFont:=@Norm8x10;
WriteChar(Ch,$f2,65,24);
VPage.DisplayPage(Page,FlagPar);
end;
if button1.treffer(Event) then begin
WrStr('Dateiname: ',$f2,0,0);
MemW[$40:$50]:=11;
readln(hilfstring);
if hilfstring<>'' then begin
printtele(hilfstring,Page);
WrStr(hilfstring+' geschrieben.',$f2,44,32);
end else
WrStr('NICHT geschrieben! ',$f4,44,32);
end;{drucken}
if button4.treffer(Event) then ch:=#27;
if buttonS.treffer(Event) then begin
hilfstring:=''; zahl_aus(hilfstring); end;
if VPage.VideoTreffer(Page,xy,Event) then ch:=#12;
case ch of
'0'..'9','A'..'F':
begin
if length(hilfstring) < 3 then begin
hilfstring:=hilfstring+ch;
zahl_aus(hilfstring);
end;
if length(hilfstring)=3 then begin
val('$'+hilfstring,xy,okay);
If (okay=0) then begin
puthistory(pagelast);
neueseite:=xy; exit;
end;
end;
End;{ Ziffern }
#13: begin
if length(hilfstring)=0 then begin
neueseite:=pagelast; exit;
end;
val('$'+hilfstring,xy,okay);
If (okay=0) then begin
puthistory(pagelast);
neueseite:=xy; exit;
end;
End;{ ENTER }
#12: If (xy>=$100) and (xy<$900) then begin
puthistory(pagelast);
neueseite:=xy; exit;
end;
#8: begin
If (length(hilfstring)>0) then begin
delete(hilfstring,length(hilfstring),1);
zahl_aus(hilfstring);
End;
end;{ Backspace }
#27: begin
neueseite:=0; weiter:=true; exit;
end;{ ESC }
end;{ case }
until false;
end;{ neueseite }
var
found: boolean;
Header: tHeader absolute Page;
function inctomax(k,m:int):int;
begin
inc(k); if k>=m then k:=0;
inctomax:=k;
end;
procedure seektonext;
begin
for j:=1 to 80 do begin
inc(k); if k>80 then k:=1;
if subpagelist[k]='X' then break;
end;
end;
BEGIN
VPage.Assign(2,4,42,28);
pagenr:=$100;
pagelast:=0;
repeat
{ GetEvent(Event);}
found:=true;
if pagenr=pagelast then seektonext;
if (Nextflag and (k<3)) then begin
pagenr:=MAXINT;
for j:=0 to IndexCnt-1 do
if Index[j].Pag<$800 then begin
z:=Index[j].Pag; if z<=PageLast then z:=z+$800; {Zyklisch machen!}
if pagenr>z then pagenr:=z;
end;
puthistory(pagelast);
pagenr:=pagenr and $7ff;
end;
if (pagenr<>pagelast) then begin
found:=false;
subpagelist:=' ';
{leermachen!}
for j:=0 to IndexCnt-1 do begin
if Index[j].pag=pagenr then
if Index[j].sub<$80 then begin
found:=true;
subpagelist[BCD2Hex(Index[j].sub)+1]:='X'; {Kreuzchen setzen}
end;
end;
if found then begin
WrStr(SubPageList,$71,0,0);
k:=0;
SeekToNext;
end else begin
write(#7);
WrStr('Seite nicht vorhanden!',$f4,44,32);
end;
end;
if found then begin
for j:=0 to IndexCnt-1 do begin
if (Index[j].pag=pagenr) and (Index[j].sub=Hex2BCD(k-1)) then break;
end;
vtf.Seek(LongMul(j,sizeof(TPage)));
vtf.Read(Page,sizeof(TPage));
WrStr(PagStr(Header)+' ',$f1,44,32);
Zahl_Aus(FormatS('%03x',0,0,0,Header.Pag));
WrStr(FormatS('%04x',0,0,0,Header.Sub),$f2,62,9);
VPage.DisplayPage(Page,FlagPar);
end;
pagelast:=pagenr;
NextFlag:=FALSE;
pagenr:=neueseite and $7ff; {Hohe Zahlen weg!}
until weiter;
end {main};
procedure checkintegrity;
var
i,j:word;
p,s:word;
begin
writeln('Teste Integrität...');
for j:=0 to IndexCnt-1 do begin
p:=Index[j].pag;
s:=Index[j].sub;
if p and $8000 =0 then begin
for i:=j+1 to IndexCnt-1 do begin
if (p=Index[i].pag) and (s=Index[i].sub) then
writeln(FormatS('Inkonsistent: Index %d zu Index %d, Videoseite %x/%x',s,p,i,j));
end; {for}
end; {if}
end; {for}
end; {proc}
var
stat:byte;
n:NameStr;
e:ExtStr;
fi:file;
bytesread:word;
const
DeleteOnExit: boolean=false;
begin
FileMode:=0;
sstr:=ParamStr(1); {$V-}
FSplit(FExpand(sstr),FileName,n,e);
if n='' then begin
writeln('Dateiname angeben!');
exit;
end;
FileName:=FileName+n;
if e='.VTZ' then begin
SwapVectors;
WriteLn('Packe aus mit PKUNZIP...');
Exec(FSearch('pkunzip.exe',GetEnv('PATH')),
' -o '+FileName+'.vtz '+GetEnv('TEMP')+'\');
SwapVectors;
if DosError<>0 then begin
WriteLn('Fehler ',DosError,' beim Ausführen von PKUNZIP.EXE (nicht im Pfad?)');
exit;
end;
if DosExitCode<>0 then begin
WriteLn('Fehler ',DosExitCode,' beim Auspacken (Rückgabewert von PKUNZIP)');
exit;
end;
FileName:=GetEnv('TEMP')+'\'+n; {Name zusammensetzen}
e:=''; {Eine VT-Datei müßte nun vorhanden sein}
DeleteOnExit:=true; {.VT-Datei löschen bei Programmende}
end;
IndexCnt:=0;
Assign(fi,FileName+'.VTI'); {$i-}Reset(fi,4);{$i+}
if IOResult=0 then begin
blockread(fi,Index,INDIZES,IndexCnt);
end;
if e='' then e:='.VT';
FileName:=FileName+e;
vtf.Init(FileName,stOpenRead);
case vtf.ErrorInfo of
0: if IndexCnt=0 then ReadIn;
2: begin
writeln('Datei ',fileName,' nicht gefunden!');
exit;
end;
3: begin
writeln('Pfad zu ',fileName,' nicht gefunden!');
exit;
end;
5: begin
writeln('Zugriff zu ',fileName,' verweigert!');
exit;
end;
else begin
writeln('DOS-Fehler beim Öffnen der Datei ',fileName,'!');
exit;
end;
end;
if IndexCnt=0 then ReadIn; {Index so oder so einlesen}
if ParamCount >=2 then checkintegrity;
asm xor bx,bx; mov ax,$168B; int $2F end; {DOS-Box in Vollbild schalten}
InitVideo;
SetM10;
ScreenMode:=$10; {damit das Rückschalten klappt}
WrStr (' ■ Wenn SAA programmieren so leicht wäre... ',$70,0,0);
for k:=1 to maxy-1 do
Wrstr('▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒',$71,0,k);
WrStr (' Rechte Maustaste=Zurück! ■ Neue Version - unterstützt gepackte .VTZ-Dateien ',$70,0,maxy);
WriteChar('Z',$74,18,maxy);
buttonS.init('~S~eite xxx',50,3,'S');
buttonU.init('~U~nterseite yyyy',50,8,'U');
button1.init('~P~: ASCII-Ausgabe',50,13,'P');
button2.init('~M~ix-Bild ',50,17,'M');
button3.init('~V~erborgener Text ',50,20,'V');
buttonDouble.init('~D~oppelte Höhe ~√~',50,23,'D');
button4.init('E~x~it',50,28,'x');
buttonplus.init(' ~+~ ',25,30,'+');
buttonminus.init(' ~-~ ',5,30,'-');
buttonnext.init(' ~N~ ',15,30,'N');
buttonRight.init(' ~>~ ',35,30,' ');
WrStr('Datenbasis: '+FileName,$70,44,33);
curfont:=@tele8x10;
InitEvents;
main;
DoneEvents;
DoneVideo;
if DeleteOnExit then asm
mov bl,byte [filename]
xor bh,bh
mov byte [filename+1+bx],0
lea dx,filename[1]
mov ah,$41
int 21h {Nun Datei wieder aufräumen}
end;
WriteLn('Ich hoffe, das Programm war nicht GANZ so schlimm...');
end.
| Detected encoding: OEM (CP437) | 1
|
|
|