program clear (input, output, disk);

  {**************************************************************}
  {                                                              }
  { Copyright (c) 1987            Bob Schor                      }
  {                               Eye and Ear Hospital           }
  {                               230 Lothrop Street             }
  {                               Pittsburgh, PA   15213         }
  {                                                              }
  { All rights reserved.  May not be copied without this notice. }
  {                                                              }
  {**************************************************************}

  { program to clear out unused disk space (makes later browsing easier }

  { Version 7.2 -- first incarnation }
  { Version 7.2 -- several patterns available }
  { Version 7.3 -- allow big disks, check for file size = -1 }

CONST
  version = 'CLEAR     Version 7.3';

CONST
  namesize = 20;      { standard character length for file names }
  disksize = 512;
  maxfilesize = 177777B;
TYPE
  unsigned = 0 .. 177777B;
  natural = 0 .. maxint;
  nameindextype = 1 .. namesize;
  enameindextype = 0 .. namesize;   { extended type, can return 0 }
  nametype = PACKED ARRAY [nameindextype] OF char;
  diskblocktype = PACKED ARRAY [1 .. disksize] OF char;
  disktype = FILE OF diskblocktype;
  openstatus = (success, failure);
  readorwritetype = (toread, towrite);
  answerset = SET OF char;
VAR
  diskblock : diskblocktype;
  disk : disktype;
  filenumber : natural;
  filesize : unsigned;
  device : nametype;

  PROCEDURE timestamp (VAR day, month, year,
		       hour, min, sec : natural); EXTERNAL;

  FUNCTION legalanswer (possibleanswers : answerset) : char;

  VAR
    answer : char;

    FUNCTION uppercase (letter : char) : char;

     BEGIN   { uppercase }
       IF ('a' <= letter) AND (letter <= 'z')
	THEN uppercase := chr(ord(letter) - ord('a') + ord('A'))
	ELSE uppercase := letter
     END;

    PROCEDURE informoferror;

    VAR
      answer : char;
      commabelongshere : boolean;

     BEGIN   { informoferror }
       write ('Error -- legal answers are ');
       IF ' ' IN possibleanswers
	THEN
	 BEGIN
	   write ('[space]');
	   commabelongshere := true
	 END
	ELSE commabelongshere := false;
       FOR answer := succ(' ') TO 'Z' DO
       IF answer IN possibleanswers
	THEN
	 BEGIN
	   IF commabelongshere
	    THEN write (', ');
	   commabelongshere := true;
	   write (answer:1)
	 END;
       write (' :  ')
     END;

   BEGIN  { legalanswer }
      REPEAT
       IF eoln
	THEN
	 BEGIN
	   readln;
	   answer := ' '
	 END
	ELSE readln (answer);
       answer := uppercase(answer);
       IF NOT (answer IN possibleanswers)
	THEN informoferror
      UNTIL answer IN possibleanswers;
     legalanswer := answer
   END;

  FUNCTION answerisyes : boolean;

   BEGIN   { answerisyes }
     answerisyes := legalanswer (['Y', 'N', ' ']) = 'Y'
   END;

  PROCEDURE makefilespec (devicename, filename, extension,
			  flagname : nametype; VAR filespec : nametype);

  VAR
    nameindex : enameindextype;

    FUNCTION namelength (name : nametype) : enameindextype;

      { returns the number of consecutive non-blank characters in "name" }

      FUNCTION nmln (length : nameindextype) : enameindextype;

	{ inner recursive function, does all the work }

       BEGIN   { nmln }
	 IF name[length] = ' '
	  THEN nmln := pred(length)
	  ELSE
	  IF length = namesize
	   THEN nmln := namesize
	   ELSE nmln := nmln (succ(length))
       END;

     BEGIN   { namelength }
       namelength := nmln (1)
     END;

    PROCEDURE append (before : char; name : nametype; after : char);

      PROCEDURE add (character : char);

	{ side effects -- changes nameindex, filespec }

       BEGIN   { add }
	 nameindex := succ(nameindex);
	 filespec[nameindex] := character
       END;

      PROCEDURE testadd (separator : char);

       BEGIN   { testadd }
	 IF (name[1] <> ' ') AND (separator <> ' ')
	  THEN
	  IF nameindex = 0
	   THEN add (separator)
	   ELSE
	   IF filespec[nameindex] <> separator
	    THEN add (separator)
       END;

      PROCEDURE app (index : nameindextype);

       BEGIN   { app }
	 IF name[index] <> ' '
	  THEN
	   BEGIN
	     add (name[index]);
	     IF index < namesize
	      THEN app (succ(index))
	   END
       END;

     BEGIN   { append }
       testadd (before);
       IF name[1] = before
	THEN app (2)
	ELSE app (1);
       testadd (after)
     END;

    PROCEDURE blankout;

     BEGIN   { blankout }
       WHILE nameindex <> namesize DO
	BEGIN
	  nameindex := succ(nameindex);
	  filespec[nameindex] := ' '
	END
     END;

   BEGIN   { makefilespec }
     nameindex := 0;
     append (' ', devicename, ':');
     append (' ', filename, ' ');
     append ('.', extension, ' ');
     append ('/', flagname, ' ');
     blankout
   END;

  PROCEDURE initialize;

    PROCEDURE cleardiskblock;

    VAR
      day, month, year,
      hour, min, sec : natural;

    VAR
      count : 1 .. disksize;

      FUNCTION numeral (singledigit : natural) : char;

       BEGIN   { numeral }
	 numeral := chr (ord('0') + (singledigit MOD 10))
       END;

      FUNCTION monthchar (month, index : natural) : char;

      VAR
	word : PACKED ARRAY [1 .. 3] OF char;

       BEGIN   { monthchar }
	 CASE month OF
	   1  : word := 'Jan';
	   2  : word := 'Feb';
	   3  : word := 'Mar';
	   4  : word := 'Apr';
	   5  : word := 'May';
	   6  : word := 'Jun';
	   7  : word := 'Jul';
	   8  : word := 'Aug';
	   9  : word := 'Sep';
	   10 : word := 'Oct';
	   11 : word := 'Nov';
	   12 : word := 'Dec';
	  END;
	 monthchar := word[index]
       END;

     BEGIN   { cleardiskblock }
       timestamp (day, month, year, hour, min, sec);
       writeln;
       writeln ('Choose from following patterns -- ');
       writeln ('   Z    Fill with all nulls [default]');
       writeln ('   E    Fill with lower-case e');
       writeln ('   D    Fill with date/time pattern');
       writeln;
       write ('Which pattern do you want?  ');
       CASE legalanswer (['Z', 'E', 'D', ' ']) OF
	 'Z',
	 ' ' : FOR count := 1 TO disksize DO diskblock[count] := chr(0);
	 'E' : FOR count := 1 TO disksize DO diskblock[count] := 'e';
	 'D' : FOR count := 1 TO disksize DO
	 CASE (count MOD 16) OF
	   1  : diskblock[count] := numeral (day DIV 10);
	   2  : diskblock[count] := numeral (day MOD 10);
	   3  : diskblock[count] := ' ';
	   4  : diskblock[count] := monthchar (month, 1);
	   5  : diskblock[count] := monthchar (month, 2);
	   6  : diskblock[count] := monthchar (month, 3);
	   7  : diskblock[count] := ' ';
	   8  : diskblock[count] := numeral ((year MOD 100) DIV 10);
	   9  : diskblock[count] := numeral ((year MOD 100) MOD 10);
	   10 : diskblock[count] := ' ';
	   11 : diskblock[count] := numeral (hour DIV 10);
	   12 : diskblock[count] := numeral (hour MOD 10);
	   13 : diskblock[count] := ':';
	   14 : diskblock[count] := numeral (min DIV 10);
	   15 : diskblock[count] := numeral (min MOD 10);
	   0 :  diskblock[count] := ' '
	  END
	END
     END;

   BEGIN   { initialize }
     writeln;
     writeln (version);
     writeln;
     writeln ('Clear blank areas of disk');
     writeln;
     write ('What device do you wish to clear?  ');
     readln (device);
     cleardiskblock;
     filenumber := 1
   END;

  FUNCTION attempttoopen (readorwrite : readorwritetype;
			  number : natural; VAR size : unsigned) : openstatus;

  CONST
    filename = 'TEMPCL              ';
    flag = '                    ';
  VAR
    tempsize : integer;
    extension : nametype;
    filespec : nametype;

    PROCEDURE encode (number : natural; VAR extension : nametype);

      PROCEDURE e (number : natural; index : nameindextype);

       BEGIN   { e }
	 IF index > 3
	  THEN
	   BEGIN
	      REPEAT
	       extension[index] := ' ';
	       index := pred(index)
	      UNTIL index = 3;
	     e (number, index)
	   END
	  ELSE
	   BEGIN
	     extension[index] := chr (ord('0') + number MOD 10);
	     IF index > 1
	      THEN e (number DIV 10, pred(index))
	   END
       END;

     BEGIN   { encode }
       e (number, namesize)
     END;

   BEGIN   { attempttoopen }
     encode (number, extension);
     makefilespec (device, filename, extension, flag, filespec);
     tempsize := maxfilesize;
     CASE readorwrite OF
       toread  : reset (disk, filespec, '  ', tempsize);
       towrite : rewrite (disk, filespec, '  ', tempsize)
      END;
     size := tempsize;
     IF (size = 0) OR (size = maxfilesize)
      THEN attempttoopen := failure
      ELSE attempttoopen := success
   END;

  PROCEDURE clearout (size : unsigned);

   BEGIN   { clearout }
      REPEAT
       disk^ := diskblock;
       put (disk);
       size := pred(size)
      UNTIL size = 0;
     close (disk)
   END;

  PROCEDURE getridof (filenumber : natural);

  VAR
    count : natural;

   BEGIN   { getridof }
     FOR count := 1 TO filenumber DO
     CASE attempttoopen (toread, count, filesize) OF
       success : delete (disk);
       failure : writeln ('Oops -- file # ', count:1, ' doesn''t exist.')
      END
   END;

 BEGIN   { clear }
   initialize;
   WHILE attempttoopen (towrite, filenumber, filesize) = success DO
    BEGIN
      clearout (filesize);
      filenumber := succ(filenumber)
    END;
   getridof (pred(filenumber))
 END.