src/ROOMRITE.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 Beyond The Titanic. Beyond The Titanic is free        }\r
  28 {software; you can redistribute it and/or modify it under the terms of the  }\r
  29 {GNU General Public License as published by the Free Software Foundation;   }\r
  30 {either version 3 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, but WITHOUT}\r
  33 {ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or      }\r
  34 {FITNESS FOR A PARTICULAR PURPOSE.                                          }\r
  35 {                                                                           }\r
  36 {Copyright (C) 1990, 2009 - Apogee Software, Ltd.                           }\r
  37 {                                                                           }\r
  38 {This file is part of Supernova.  Supernova is free software; you can       }\r
  39 {redistribute it and/or modify it under the terms of the GNU General Public }\r
  40 {License as published by the Free Software Foundation; either version 3     }\r
  41 {of the License, or (at your option) any later version.                     }\r
  42 {                                                                           }\r
  43 {This program is distributed in the hope that it will be useful,            }\r
  44 {but WITHOUT ANY WARRANTY; without even the implied warranty of             }\r
  45 {MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                       }\r
  46 {                                                                           }\r
  47 {See the GNU General Public License for more details.                       }\r
  48 {                                                                           }\r
  49 {You should have received a copy of the GNU General Public License          }\r
  50 {along with this program; if not, write to the Free Software                }\r
  51 {Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.}\r
  52 {                                                                           }\r
  53 {Original Source: 1990 Scott Miller                                         }\r
  54 {Prepared for public release: 03/19/09 - Joe Siegler, Apogee Software, Ltd. }\r
  55 {*/                                                                         }\r
  56 {//-------------------------------------------------------------------------}\r
  57 program\r
  58   Room_Write;\r
  59 \r
  60     {This program WRITES and READS from the two text files: 'rooms1' and\r
  61      'rooms2'.  If a description exceeds 240 letters (Max), then the file\r
  62                'rooms2' is used.  Otherwise 'rooms2' = ''.}\r
  63                  {This program has the line edit feature!}\r
  64 \r
  65 uses Crt, Printer;\r
  66 \r
  67 const\r
  68   Max = 240;\r
  69 \r
  70 type\r
  71   DescriptionLength = string[Max];\r
  72   ManyChar = string[1];\r
  73 \r
  74 var\r
  75   Rooms1, Rooms2 : file of descriptionlength;\r
  76   Position,Counter,Start,Stop : integer;\r
  77   Text1, Text2 : descriptionlength;\r
  78   Answer : char;\r
  79   Letter : manychar;\r
  80   List   : boolean;\r
  81 \r
  82 procedure Diskwrite(text1,text2: Descriptionlength; pointer: integer);\r
  83   begin\r
  84     seek(rooms1,pointer); seek(rooms2,pointer);\r
  85     WRITE(rooms1,text1); WRITE(rooms2,text2);\r
  86     writeln('Room description ',pointer,\r
  87             ' is written!  Size = ',filesize(rooms1));\r
  88     close(rooms1); close(rooms2);\r
  89   end; {End of Diskwrite.}\r
  90 \r
  91 procedure Diskread(start,stop: integer);\r
  92 var\r
  93 counter : integer;\r
  94 text1, text2 : descriptionlength;\r
  95   begin\r
  96    assign(rooms1,'ROOMS1');\r
  97    assign(rooms2,'ROOMS2');\r
  98    reset(rooms1);\r
  99    reset(rooms2);\r
 100    seek(rooms1,start);\r
 101    seek(rooms2,start);\r
 102     for counter:= start to stop do\r
 103       begin\r
 104         highvideo;\r
 105         READ(rooms1,text1); READ(rooms2,text2);\r
 106         if list then\r
 107           begin\r
 108             writeln(lst,'Description # ',counter);\r
 109             writeln(lst,text1,text2);\r
 110           end\r
 111         else\r
 112           begin\r
 113             writeln('Here is room description # ',counter);\r
 114             lowvideo;\r
 115             writeln(text1,text2);\r
 116             highvideo;\r
 117           end;\r
 118       end;\r
 119     write('The file contains ',FileSize(rooms1),' room descriptions.');\r
 120     close(rooms1); close(rooms2);\r
 121   end;  {End of Diskread.}\r
 122 \r
 123 procedure Beep;\r
 124 begin\r
 125  if(length(text1)in[70,150,230])or(length(text2)in[70,150,230])then write(^g);\r
 126 end;\r
 127 \r
 128 BEGIN\r
 129 repeat          {Main loop.}\r
 130   text1:='';\r
 131   text2:='';\r
 132 \r
 133 writeln;\r
 134 writeln('Do you want to R)ead or W)rite?');\r
 135 readln(answer);\r
 136 if upcase(answer) <> 'R' then       {Write to 'Rooms'.}\r
 137     begin\r
 138       writeln;writeln;\r
 139       assign(rooms1,'ROOMS1'); assign(rooms2,'ROOMS2');\r
 140       writeln('Now RESETing room files.');\r
 141             RESET(rooms1); RESET(rooms2);\r
 142       writeln;\r
 143       writeln('Input a string not more than ',2*Max,' characters.',\r
 144               '  ''\''-Ends string.');\r
 145       lowvideo;\r
 146         repeat\r
 147           letter := ReadKey;\r
 148           write(letter);\r
 149           if letter = ^h then\r
 150             begin\r
 151               write(' ', ^h);\r
 152               delete(text1,length(text1),1);\r
 153 \r
 154             end;\r
 155           beep;\r
 156           if (letter <> '\') and (letter <> ^h) then text1:=text1+letter;\r
 157         until (length(text1)=Max) or (letter='\');\r
 158         writeln;\r
 159         if letter = '\' then\r
 160           begin\r
 161             highvideo;\r
 162             writeln('Total of ',length(text1),' characters.');\r
 163             text2:='';\r
 164           end\r
 165         else\r
 166           begin\r
 167             writeln;\r
 168             highvideo;\r
 169             writeln('String #1 is full!  Now writing to string #2.',^g);\r
 170             lowvideo;\r
 171               repeat\r
 172                 letter := ReadKey;\r
 173                 write(letter);\r
 174                 if letter = ^h then\r
 175                   begin\r
 176                     write(' ',^h);\r
 177                     delete(text2,length(text2),1);\r
 178                   end;\r
 179                 beep;\r
 180                 if (letter <> '\') and (letter <> ^h) then text2:=text2+letter\r
 181               until (length(text2)=Max) or (letter='\');\r
 182             writeln; highvideo;\r
 183             writeln('Total description length = ',\r
 184                      length(text1)+length(text2),' characters.');\r
 185           end;\r
 186       writeln('Now WRITING string to disk.');\r
 187       writeln('  At what position?  (Next open is # ',filesize(rooms1),')');\r
 188       readln(position);\r
 189       Diskwrite(text1,text2,position);\r
 190     end\r
 191 else                      {Read from 'Rooms'.}\r
 192   begin\r
 193     writeln;writeln;\r
 194     writeln('To the S)creen or the P)rinter');\r
 195     readln(answer);\r
 196     if(upcase(answer)='P')then List:=True else List:=False;\r
 197     assign(rooms1,'ROOMS1');\r
 198     reset(rooms1);\r
 199     writeln('Filesize = ',filesize(rooms1),\r
 200             '  (From 0 to ',filesize(rooms1)-1,')');\r
 201     // close(rooms1);\r
 202     writeln('Enter starting position:');\r
 203     readln(start);\r
 204     writeln('Evo filesize rooms1: ');\r
 205     writeln(filesize(rooms1));\r
 206 \r
 207     if(start > filesize(rooms1)-5)then stop:=(filesize(rooms1)-1) else\r
 208       begin\r
 209         writeln('Enter final position:');\r
 210         readln(stop);\r
 211       end;\r
 212     Diskread(start,stop);\r
 213   end;  {End of else clause.}\r
 214 writeln;\r
 215 writeln('Another room description?  Y)es or N)o');\r
 216 read(answer);\r
 217 until upcase(answer) = 'N';     {End of Main loop.}\r
 218 writeln; writeln(^g,'You are now out of the program.')\r
 219 END.\r