SPECIAL.PAS

   1 {//-------------------------------------------------------------------------}
   2 {/*                                                                         }
   3 {Copyright (C) 1990, 2009 - Apogee Software, Ltd.                           }
   4 {                                                                           }
   5 {This file is part of Supernova.  Supernova is free software; you can       }
   6 {redistribute it and/or modify it under the terms of the GNU General Public }
   7 {License as published by the Free Software Foundation; either version 2     }
   8 {of the License, or (at your option) any later version.                     }
   9 {                                                                           }
  10 {This program is distributed in the hope that it will be useful,            }
  11 {but WITHOUT ANY WARRANTY; without even the implied warranty of             }
  12 {MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                       }
  13 {                                                                           }
  14 {See the GNU General Public License for more details.                       }
  15 {                                                                           }
  16 {You should have received a copy of the GNU General Public License          }
  17 {along with this program; if not, write to the Free Software                }
  18 {Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.}
  19 {                                                                           }
  20 {Original Source: 1990 Scott Miller                                         }
  21 {Prepared for public release: 03/19/09 - Joe Siegler, Apogee Software, Ltd. }
  22 {*/                                                                         }
  23 {//-------------------------------------------------------------------------}
  24 program
  25   Special_Responce_Writer;
  26
  27          {This program WRITES and READS from the two text files:
  28     'special1' and 'special2'.  If a description exceeds 240 letters (Max),
  29        then the file 'special2' is used.  Otherwise 'special2' = ''.}
  30                {This program has the line edit feature!}
  31 const
  32   Max = 240;
  33
  34 type
  35   DescriptionLength = string[Max];
  36   OneChar = string[1];
  37
  38 var
  39   Special1, Special2 : file of descriptionlength;
  40   Position,Counter,Start,Stop : integer;
  41   Text1, Text2 : descriptionlength;
  42   Answer : char;
  43   Letter : onechar;
  44   List   : boolean;
  45
  46 procedure Diskwrite(text1,text2: Descriptionlength; pointer: integer);
  47   begin
  48     seek(special1,pointer); seek(special2,pointer);
  49     WRITE(special1,text1); WRITE(special2,text2);
  50     writeln('Special responce ',pointer,
  51             ' is written!  Size = ',filesize(special1));
  52     close(special1); close(special2);
  53   end; {End of Diskwrite.}
  54
  55 procedure Diskread(start,stop: integer);
  56 var
  57 counter : integer;
  58 text1, text2 : descriptionlength;
  59   begin
  60    assign(special1,'special1'); assign(special2,'special2');
  61    reset(special1); reset(special2);
  62    seek(special1,start); seek(special2,start);
  63     for counter:= start to stop do
  64       begin
  65         highvideo;
  66         READ(special1,text1); READ(special2,text2);
  67         if list then
  68           begin
  69             writeln(lst,'Special # ',counter);
  70             writeln(lst,text1,text2);
  71           end
  72         else
  73           begin
  74             writeln('Here is special responce # ',counter);
  75             lowvideo;
  76             writeln(text1,text2);
  77             highvideo;
  78           end;
  79       end;
  80     close(special1); close(special2);
  81     write('The file contains ',filesize(special1),' special responces.');
  82   end;  {End of Diskread.}
  83
  84 procedure Beep;
  85 begin
  86  if(length(text1)in[70,150,230])or(length(text2)in[70,150,230])then write(^g);
  87 end;
  88
  89 BEGIN
  90 repeat          {Main loop.}
  91   text1:='';
  92   text2:='';
  93
  94 writeln;
  95 writeln('Do you want to R)ead or W)rite?');
  96 read(kbd,answer);
  97 if upcase(answer) <> 'R' then       {Write to 'Special' files.}
  98     begin
  99       writeln;writeln;
 100       assign(special1,'special1'); assign(special2,'special2');
 101       writeln('Now RESETing Special files.');
 102             RESET(special1); RESET(special2);
 103       writeln;
 104       writeln('Input a string not more than ',2*Max,' characters.',
 105               '  ''\''-Ends string.');
 106       lowvideo;
 107         repeat
 108           read(trm,letter);
 109           if letter = ^h then
 110             begin
 111               write(^h,' ',^h);
 112               delete(text1,length(text1),2);
 113             end;
 114           beep;
 115           if (letter <> '\') and (letter <> ^h) then text1:=text1+letter
 116         until (length(text1)=Max) or (letter='\');
 117         writeln;
 118         if letter = '\' then
 119           begin
 120             highvideo;
 121             writeln('Total of ',length(text1),' characters.');
 122             text2:='';
 123           end
 124         else
 125           begin
 126             writeln;
 127             highvideo;
 128             writeln('String #1 is full!  Now writing to string #2.',^g);
 129             lowvideo;
 130               repeat
 131                 read(trm,letter);
 132                 if letter = ^h then
 133                   begin
 134                     write(^h,' ',^h);
 135                     delete(text2,length(text2),2);
 136                   end;
 137                 beep;
 138                 if (letter <> '\') and (letter <> ^h) then text2:=text2+letter
 139               until (length(text2)=Max) or (letter='\');
 140             writeln; highvideo;
 141             writeln('Total description length = ',
 142                      length(text1)+length(text2),' characters.');
 143           end;
 144       writeln('Now WRITING string to disk.');
 145       writeln('  At what position?  (Next open is # ',filesize(special1),')');
 146       readln(position);
 147       Diskwrite(text1,text2,position);
 148     end
 149 else                      {Read from 'Rooms'.}
 150   begin
 151     writeln;writeln;
 152     writeln('To the S)creen or the P)rinter?');
 153     read(kbd,answer);
 154     if(upcase(answer)='P')then List:=True else List:=False;
 155     assign(special1,'special1');
 156     reset(special1);
 157     writeln('Filesize = ',filesize(special1),
 158             '  (From 0 to ',filesize(special1)-1,')');
 159     close(special1);
 160     writeln('Enter starting position:');
 161     readln(start);
 162     if(start > filesize(special1)-5)then stop:=(filesize(special1)-1) else
 163       begin
 164         writeln('Enter final position:');
 165         readln(stop);
 166       end;
 167     Diskread(start,stop);
 168   end;  {End of else clause.}
 169 writeln;writeln('Another special responce?  Y)es or N)o');
 170 read(kbd,answer);
 171 until upcase(answer) = 'N';     {End of Main loop.}
 172 writeln; writeln(^g,'You are now out of the program.')
 173 END.
 174
 175
 176 \1a