home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
mbug
/
mbug017.arc
/
SCNLOCK1.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1979-12-31
|
10KB
|
434 lines
PROGRAM SCNLOCK2;
CONST
password ='MASTER1';
VAR
source : FILE ;
SourceName,
oldname,
Name,
word : STRING[14];
buffer : ARRAY[1..128] OF byte;
ch : char;
dirname : ARRAY[1..12] OF char;
dir : ARRAY[1..100] OF STRING[12];
c,i,x,y : integer;
lastline : integer;
dirno : integer;
quit : boolean;
lockbyte : byte;
PROCEDURE printdir;
VAR
i,j,count : integer;
BEGIN
clrscr;
count := 1;
write(' E..UP, X..DOWN, S..LEFT, D..RIGHT, V..VIEW,');
writeln(' N..NEW SCORE BOARD, Q..QUIT');
writeln;
Writeln(' Directory of Screen files');
writeln(' * = R/O . = R/W ');
Write('-----------------------------------------------------------------');
Writeln('--------');
FOR i := 1 TO dirno DO
BEGIN
write(dir[i]);
IF ((Count MOD 5) = 0)
THEN BEGIN
Writeln;
lastline := lastline + 1;
END
ELSE Write(' | ');
Count := Count+1;
END;
IF (Count MOD 5) <> 1
THEN Writeln;
Write('-----------------------------------------------------------------');
Writeln('--------');
END;
PROCEDURE printnewdir;
BEGIN
gotoxy(x,y);
lowvideo;
write(dir[c]);
normvideo;
END;
PROCEDURE printolddir;
BEGIN
gotoxy(x,y);
write(dir[c]);
END;
PROCEDURE Pdir; {DriveCode: Byte}
CONST
Set_DMA : Integer = 26;
Search_First : Integer = 17;
Search_Next : Integer = 18;
Get_Current_Drive : Integer = 25;
Select_Drive : Integer = 14;
VAR
Error, Count, Loop : Integer;
Drive : Byte;
FCB : ARRAY[0..25] OF Byte absolute $005C;
DMA : ARRAY[0..255] OF Byte; { default buffer }
PROCEDURE Initialise2;
BEGIN {Initialise}
lastline := 0;
Count := 1;
Error := Bdos(Set_DMA, Addr(DMA));
FOR Loop := 1 TO 8 DO
FCB[Loop] := Ord('?');
FCB[9] := ord('S');
FCB[10] := ord('C');
FCB[11] := ord('N');
FOR Loop := 12 TO 25 DO
FCB[Loop] := 0;
FOR loop := 1 TO 100 DO { There should not be more than 100 *.scn's}
BEGIN
dirname := ' ';
dir[i] := dirname;
END;
END; {Initialise}
PROCEDURE Dump(Int: Integer);
VAR
Hex_Char: Byte;
Dot: Char;
BEGIN
IF Mem[Int+10] < $80
THEN
BEGIN
dirno := dirno +1;
IF Mem[Int+9] > $7F
THEN Dot := '*'
ELSE Dot := '.';
FOR Loop := 1 TO 11 DO
BEGIN
Hex_Char := Mem[Int+Loop] AND $7F;
IF Loop > 8
THEN BEGIN
dirname[9] := dot;
dirname[loop+1] := (chr(hex_char));
END
ELSE BEGIN
dirname[loop] := (chr(hex_char));
END;
END;
dir[dirno] := dirname;
END;
END;
BEGIN { PDIR - main program body }
Initialise2;
Drive := FCB[0]-1;
IF Drive = $FF
THEN
BEGIN
Drive := Bdos(Get_Current_Drive);
Bdos(Select_Drive,Drive);
END;
Error := Bdos(Search_First,Addr(FCB));
IF Error <> $FF
THEN
BEGIN
dirno := 0;
Dump(Addr(DMA)+Error*32);
END; { if }
REPEAT
Error := Bdos(Search_Next);
IF Error <> $FF
THEN
Dump(Addr(DMA)+Error*32)
UNTIL Error=$FF;
END; { PDIR }
PROCEDURE getbuffer;
BEGIN
name := ' ';
sourcename := '';
i := 0;
name := dir[c];
REPEAT
i := i + 1;
IF name[i] <> ' '
THEN BEGIN
sourcename := sourcename + name[i];
END;
UNTIL i=8;
sourcename := sourcename + '.SCN';
IF oldname <> sourcename
THEN BEGIN
assign(Source,SourceName);
reset(Source);
blockread(source,buffer,1);
oldname := sourcename;
lockbyte := buffer[128];
END;
END;
PROCEDURE New_score_board;
VAR
i,j,k,l : integer;
ch : char;
BEGIN
getbuffer;
gotoxy(15,20);
IF lockbyte <> 0
THEN
write(' Sorry ')
ELSE
write('New Score Board for ');
lowvideo;
write(dir[c]);
normvideo;
IF lockbyte <> 0
THEN BEGIN
write(' is locked.');
delay(3000);
END
ELSE BEGIN
write('. Are you sure? Y/N ');
REPEAT
read(kbd,ch);
UNTIL upcase(ch) IN ['Y','N'];
IF upcase(ch) = 'Y'
THEN BEGIN
gotoxy(30,22);
writeln('Making New Score Board.');
i := 2;
FOR j := 1 TO 10 DO
BEGIN
FOR k := 1 TO 9 DO
BEGIN
buffer[i] := 88;
i := i +1;
END;
FOR l := 1 TO 3 DO
BEGIN
buffer[i] := 0;
i := i + 1;
END;
END;
reset(source);
blockwrite(source,buffer,1);
close(source);
END;
END;
gotoxy(1,20);
delline;
delline;
delline;
END;
PROCEDURE Display_scoreboard;
VAR
i,j,k,l : integer;
score,screens : integer;
BEGIN
clrscr;
i := 2;
FOR j := 1 TO 10 DO
BEGIN
gotoxy(34,1);
writeln('S C O R E B O A R D');
gotoxy(30,5);
writeln(' NAME SCORE SCREENS');
gotoxy(30,j+5);
FOR k := 1 TO 9 DO
BEGIN
write(chr(buffer[i]));
i := i+1;
END;
score := buffer[i]+(buffer[i+1]*256);
screens := buffer[i+2];
writeln(' ',score:5,'0 ',screens:3);
i := i+3;
END;
END;
PROCEDURE viewfile;
BEGIN
getbuffer;
display_scoreboard;
gotoxy(30,3);
lowvideo;
write(dir[c]);
normvideo;
IF buffer[128] <> 0
THEN BEGIN
write(' was LOCKED by ');
CASE lockbyte OF
187 : writeln('Gregory');
204 : writeln('Robert');
255 : writeln('Dad');
END;
END
ELSE BEGIN
writeln(' is UNLOCKED');
END;
writeln;
gotoxy(25,21);
write('Would you like the file REVERSED Y/N ');
REPEAT
read(kbd,ch);
ch := upcase(ch);
UNTIL ch IN ['Y','N'];
write(ch);
IF ch = 'Y'
THEN BEGIN
writeln('es');
IF lockbyte <> 0
THEN BEGIN
gotoxy(30,22);
writeln('Unlocking ',dir[c]);
buffer[128] := 0;
END
ELSE BEGIN
gotoxy(27,22);
write('Who''s file do you want to lock? G/R/D ');
REPEAT
read(kbd,ch);
ch := upcase(ch);
UNTIL ch IN ['G','R','D'];
gotoxy(30,23);
write('Locking ',dir[c],' to ');
CASE ch OF
'R' : BEGIN
buffer[128] := 204;
writeln('Robert');
END;
'G' : BEGIN
buffer[128] := 187;
writeln('Gregory');
END;
'D' : BEGIN
buffer[128] := 255;
writeln('Dad');
END;
END;
END;
lockbyte := buffer[128];
reset(source);
blockwrite(source,buffer,1);
close(source);
END
ELSE
BEGIN
writeln('o');
END;
printdir;
Printnewdir;
END;
PROCEDURE up;
BEGIN
IF c-5 >= 1
THEN BEGIN
y := y -1;
c := c -5;
END
ELSE write(chr(7));
END;
PROCEDURE down;
BEGIN
IF c+5 <= dirno
THEN BEGIN
y := y + 1;
c := c + 5;
END
ELSE write(chr(7));
END;
PROCEDURE left;
BEGIN
IF c-1 >= 1
THEN BEGIN
x := x - 15;
IF x < 1
THEN BEGIN
x := 61;
y := y -1;
END;
c := c - 1;
END
ELSE write(chr(7));
END;
PROCEDURE right;
BEGIN
IF c+1 <= dirno
THEN BEGIN
x := x + 15;
IF x > 65
THEN BEGIN
x := 1;
y := y +1;
END;
c := c + 1;
END
ELSE write(chr(7));
END;
PROCEDURE getkey;
BEGIN
read(kbd,ch);
ch := upcase(ch);
printolddir;
CASE ch OF
'E' : up;
'X' : down;
'S' : left;
'D' : right;
'V' : viewfile;
'N' : new_score_board;
'Q' : quit := true;
ELSE write(chr(7));
END;
printnewdir;
END;
PROCEDURE getpassword;
BEGIN
word := ' ';
i := 0;
gotoxy(30,12);
write('Password .. ');
REPEAT
i := i + 1;
read(kbd,ch);
IF ch <> chr(13)
THEN BEGIN
write('x');
word[i] := upcase(ch);
END;
UNTIL ch = chr(13);
END;
BEGIN
quit := false;
clrscr;
getpassword;
if word = password then begin
clrscr;
c := 1;
x := 1;
y := 6;
oldname := '';
pdir;
printdir;
REPEAT;
printnewdir;
getkey;
UNTIL quit;
end;
clrscr;
END.