home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG017.ARC / SCNLOCK1.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  10KB  |  434 lines
  1.  
  2. PROGRAM SCNLOCK2;
  3.  
  4. CONST
  5.   password ='MASTER1';
  6.  
  7. VAR
  8.   source     : FILE ;
  9.   SourceName,
  10.   oldname,
  11.   Name,
  12.   word       : STRING[14];
  13.   buffer     : ARRAY[1..128] OF byte;
  14.   ch         : char;
  15.   dirname    : ARRAY[1..12] OF char;
  16.   dir        : ARRAY[1..100] OF STRING[12];
  17.   c,i,x,y    : integer;
  18.   lastline   : integer;
  19.   dirno      : integer;
  20.   quit       : boolean;
  21.   lockbyte   : byte;
  22.  
  23. PROCEDURE printdir;
  24. VAR
  25.   i,j,count : integer;
  26. BEGIN
  27.   clrscr;
  28.   count := 1;
  29.   write('   E..UP, X..DOWN, S..LEFT, D..RIGHT, V..VIEW,');
  30.   writeln(' N..NEW SCORE BOARD, Q..QUIT');
  31.   writeln;
  32.   Writeln('                          Directory of Screen files');
  33.   writeln('                             * = R/O     . = R/W   ');
  34.   Write('-----------------------------------------------------------------');
  35.   Writeln('--------');
  36.   FOR i := 1 TO dirno DO
  37.     BEGIN
  38.       write(dir[i]);
  39.       IF ((Count MOD 5) = 0)
  40.         THEN BEGIN
  41.                Writeln;
  42.                lastline := lastline + 1;
  43.           END
  44.         ELSE Write(' | ');
  45.       Count := Count+1;
  46.     END;
  47.   IF (Count MOD 5) <> 1
  48.     THEN Writeln;
  49.   Write('-----------------------------------------------------------------');
  50.   Writeln('--------');
  51. END;
  52.  
  53. PROCEDURE printnewdir;
  54. BEGIN
  55.   gotoxy(x,y);
  56.   lowvideo;
  57.   write(dir[c]);
  58.   normvideo;
  59. END;
  60.  
  61. PROCEDURE printolddir;
  62. BEGIN
  63.   gotoxy(x,y);
  64.   write(dir[c]);
  65. END;
  66.  
  67. PROCEDURE Pdir; {DriveCode: Byte}
  68. CONST
  69.   Set_DMA           : Integer = 26;
  70.   Search_First      : Integer = 17;
  71.   Search_Next       : Integer = 18;
  72.   Get_Current_Drive : Integer = 25;
  73.   Select_Drive      : Integer = 14;
  74.  
  75. VAR 
  76.   Error, Count, Loop     : Integer;
  77.   Drive                  : Byte;
  78.   FCB                    : ARRAY[0..25] OF Byte absolute $005C;
  79.   DMA                    : ARRAY[0..255] OF Byte;  { default buffer      }
  80.  
  81. PROCEDURE Initialise2;
  82. BEGIN {Initialise}
  83.   lastline := 0;
  84.   Count := 1;
  85.   Error := Bdos(Set_DMA, Addr(DMA));
  86.   FOR Loop := 1 TO 8 DO
  87.     FCB[Loop] := Ord('?');
  88.   FCB[9]  := ord('S');
  89.   FCB[10] := ord('C');
  90.   FCB[11] := ord('N');
  91.   FOR Loop := 12 TO 25 DO
  92.     FCB[Loop] := 0;
  93.   FOR loop := 1 TO 100 DO { There should not be more than 100 *.scn's}
  94.     BEGIN
  95.       dirname := '            ';
  96.       dir[i] := dirname;
  97.     END;
  98. END; {Initialise}
  99.  
  100. PROCEDURE Dump(Int: Integer);
  101. VAR
  102.   Hex_Char: Byte;
  103.   Dot:      Char;
  104. BEGIN
  105.   IF Mem[Int+10] < $80
  106.     THEN
  107.       BEGIN
  108.         dirno := dirno +1;
  109.         IF Mem[Int+9] > $7F
  110.           THEN Dot := '*'
  111.           ELSE Dot := '.';
  112.         FOR Loop := 1 TO 11 DO
  113.           BEGIN
  114.             Hex_Char := Mem[Int+Loop] AND $7F;
  115.             IF Loop > 8
  116.               THEN BEGIN
  117.                      dirname[9] := dot;
  118.                      dirname[loop+1] := (chr(hex_char));
  119.                 END
  120.               ELSE BEGIN
  121.                      dirname[loop] := (chr(hex_char));
  122.                 END;
  123.           END;
  124.         dir[dirno] := dirname;
  125.       END;
  126. END;
  127.  
  128. BEGIN  { PDIR - main program body }
  129.   Initialise2;
  130.   Drive := FCB[0]-1;
  131.   IF Drive = $FF
  132.     THEN
  133.       BEGIN
  134.         Drive := Bdos(Get_Current_Drive);
  135.         Bdos(Select_Drive,Drive);
  136.       END;
  137.   Error := Bdos(Search_First,Addr(FCB));
  138.   IF Error <> $FF
  139.     THEN
  140.       BEGIN
  141.         dirno := 0;
  142.         Dump(Addr(DMA)+Error*32);
  143.       END; { if }
  144.   REPEAT
  145.     Error := Bdos(Search_Next);
  146.     IF Error <> $FF
  147.       THEN
  148.         Dump(Addr(DMA)+Error*32)
  149.   UNTIL Error=$FF;
  150. END; { PDIR }
  151.  
  152. PROCEDURE getbuffer;
  153. BEGIN
  154.   name := '              ';
  155.   sourcename := '';
  156.   i := 0;
  157.   name := dir[c];
  158.   REPEAT
  159.     i := i + 1;
  160.     IF name[i] <> ' '
  161.       THEN BEGIN
  162.              sourcename := sourcename + name[i];
  163.         END;
  164.   UNTIL i=8;
  165.   sourcename := sourcename + '.SCN';
  166.   IF oldname <> sourcename
  167.     THEN BEGIN
  168.            assign(Source,SourceName);
  169.            reset(Source);
  170.            blockread(source,buffer,1);
  171.            oldname := sourcename;
  172.            lockbyte := buffer[128];
  173.       END;
  174. END;
  175.  
  176. PROCEDURE New_score_board;
  177. VAR
  178.   i,j,k,l : integer;
  179.   ch      : char;
  180. BEGIN
  181.   getbuffer;
  182.   gotoxy(15,20);
  183.   IF lockbyte <> 0
  184.     THEN
  185.       write('    Sorry  ')
  186.     ELSE
  187.       write('New Score Board for  ');
  188.   lowvideo;
  189.   write(dir[c]);
  190.   normvideo;
  191.   IF lockbyte <> 0
  192.     THEN BEGIN
  193.            write('  is locked.');
  194.            delay(3000);
  195.       END
  196.     ELSE BEGIN
  197.            write('.  Are you sure?  Y/N ');
  198.            REPEAT
  199.              read(kbd,ch);
  200.            UNTIL upcase(ch) IN ['Y','N'];
  201.            IF upcase(ch) = 'Y'
  202.              THEN BEGIN
  203.                     gotoxy(30,22);
  204.                     writeln('Making New Score Board.');
  205.                     i := 2;
  206.                     FOR j := 1 TO 10 DO
  207.                       BEGIN
  208.                         FOR k := 1 TO 9 DO
  209.                           BEGIN
  210.                             buffer[i] := 88;
  211.                             i := i +1;
  212.                           END;
  213.                         FOR l := 1 TO 3 DO
  214.                           BEGIN
  215.                             buffer[i] := 0;
  216.                             i := i + 1;
  217.                           END;
  218.                       END;
  219.                     reset(source);
  220.                     blockwrite(source,buffer,1);
  221.                     close(source);
  222.                END;
  223.       END;
  224.   gotoxy(1,20);
  225.   delline;
  226.   delline;
  227.   delline;
  228. END;
  229.  
  230. PROCEDURE Display_scoreboard;
  231. VAR
  232.   i,j,k,l : integer;
  233.   score,screens : integer;
  234. BEGIN
  235.   clrscr;
  236.   i := 2;
  237.   FOR j := 1 TO 10 DO
  238.     BEGIN
  239.       gotoxy(34,1);
  240.       writeln('S C O R E    B O A R D');
  241.       gotoxy(30,5);
  242.       writeln('  NAME        SCORE   SCREENS');
  243.       gotoxy(30,j+5);
  244.       FOR k := 1 TO 9 DO
  245.         BEGIN
  246.           write(chr(buffer[i]));
  247.           i := i+1;
  248.         END;
  249.       score := buffer[i]+(buffer[i+1]*256);
  250.       screens := buffer[i+2];
  251.       writeln('    ',score:5,'0     ',screens:3);
  252.       i := i+3;
  253.     END;
  254. END;
  255.  
  256. PROCEDURE viewfile;
  257. BEGIN
  258.   getbuffer;
  259.   display_scoreboard;
  260.   gotoxy(30,3);
  261.   lowvideo;
  262.   write(dir[c]);
  263.   normvideo;
  264.   IF buffer[128] <> 0
  265.     THEN BEGIN
  266.            write(' was LOCKED by ');
  267.            CASE lockbyte OF
  268.              187 : writeln('Gregory');
  269.              204 : writeln('Robert');
  270.              255 : writeln('Dad');
  271.            END;
  272.       END
  273.     ELSE BEGIN
  274.            writeln(' is UNLOCKED');
  275.       END;
  276.   writeln;
  277.   gotoxy(25,21);
  278.   write('Would you like the file REVERSED  Y/N ');
  279.   REPEAT
  280.     read(kbd,ch);
  281.     ch := upcase(ch);
  282.   UNTIL ch IN  ['Y','N'];
  283.   write(ch);
  284.   IF ch = 'Y'
  285.     THEN BEGIN
  286.            writeln('es');
  287.            IF lockbyte <> 0
  288.              THEN BEGIN
  289.                     gotoxy(30,22);
  290.                     writeln('Unlocking ',dir[c]);
  291.                     buffer[128] := 0;
  292.                END
  293.              ELSE BEGIN
  294.                     gotoxy(27,22);
  295.                     write('Who''s file do you want to lock? G/R/D ');
  296.                     REPEAT
  297.                       read(kbd,ch);
  298.                       ch := upcase(ch);
  299.                     UNTIL ch IN ['G','R','D'];
  300.                     gotoxy(30,23);
  301.                     write('Locking ',dir[c],' to ');
  302.                     CASE ch OF
  303.                       'R' : BEGIN
  304.                               buffer[128] := 204;
  305.                               writeln('Robert');
  306.                             END;
  307.                       'G' : BEGIN
  308.                               buffer[128] := 187;
  309.                               writeln('Gregory');
  310.                             END;
  311.                       'D' : BEGIN
  312.                               buffer[128] := 255;
  313.                               writeln('Dad');
  314.                             END;
  315.                     END;
  316.                END;
  317.            lockbyte := buffer[128];
  318.            reset(source);
  319.            blockwrite(source,buffer,1);
  320.            close(source);
  321.       END
  322.     ELSE
  323.       BEGIN
  324.         writeln('o');
  325.       END;
  326.   printdir;
  327.   Printnewdir;
  328. END;
  329.  
  330. PROCEDURE up;
  331. BEGIN
  332.   IF c-5 >= 1
  333.     THEN BEGIN
  334.            y := y -1;
  335.            c := c -5;
  336.       END
  337.     ELSE write(chr(7));
  338. END;
  339.  
  340. PROCEDURE down;
  341. BEGIN
  342.   IF c+5 <= dirno
  343.     THEN BEGIN
  344.            y := y + 1;
  345.            c := c + 5;
  346.       END
  347.     ELSE write(chr(7));
  348. END;
  349.  
  350. PROCEDURE left;
  351. BEGIN
  352.   IF c-1 >= 1
  353.     THEN BEGIN
  354.            x := x - 15;
  355.            IF x < 1
  356.              THEN BEGIN
  357.                     x := 61;
  358.                     y := y -1;
  359.                END;
  360.            c := c - 1;
  361.       END
  362.     ELSE write(chr(7));
  363. END;
  364.  
  365. PROCEDURE right;
  366. BEGIN
  367.   IF c+1 <= dirno
  368.     THEN BEGIN
  369.            x := x + 15;
  370.            IF x > 65
  371.              THEN BEGIN
  372.                     x := 1;
  373.                     y := y +1;
  374.                END;
  375.            c := c + 1;
  376.       END
  377.     ELSE write(chr(7));
  378. END;
  379.  
  380. PROCEDURE getkey;
  381. BEGIN
  382.   read(kbd,ch);
  383.   ch := upcase(ch);
  384.   printolddir;
  385.   CASE ch OF
  386.     'E' : up;
  387.     'X' : down;
  388.     'S' : left;
  389.     'D' : right;
  390.     'V' : viewfile;
  391.     'N' : new_score_board;
  392.     'Q' : quit := true;
  393.   ELSE write(chr(7));
  394. END;
  395. printnewdir;
  396. END;
  397.  
  398. PROCEDURE getpassword;
  399. BEGIN
  400.   word := '       ';
  401.   i := 0;
  402.   gotoxy(30,12);
  403.   write('Password ..  ');
  404.   REPEAT
  405.     i := i + 1;
  406.     read(kbd,ch);
  407.     IF ch <> chr(13)
  408.       THEN BEGIN
  409.              write('x');
  410.              word[i] := upcase(ch);
  411.         END;
  412.   UNTIL ch = chr(13);
  413. END;
  414.  
  415. BEGIN
  416.   quit := false;
  417.   clrscr;
  418.   getpassword;
  419.   if word = password then begin
  420.   clrscr;
  421.   c := 1;
  422.   x := 1;
  423.   y := 6;
  424.   oldname := '';
  425.   pdir;
  426.   printdir;
  427.   REPEAT;
  428.     printnewdir;
  429.     getkey;
  430.   UNTIL quit;
  431.   end;
  432.   clrscr;
  433. END.
  434.