src/SPECIAL.PAS

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