src/SPECIAL.PAS

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