src/ROOMRITE.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 3     }\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, see https://gnu.org/licenses or write to: }\r
  18 {  Free Software Foundation, Inc.                                           }\r
  19 {  51 Franklin Street, Fifth Floor                                          }\r
  20 {  Boston, MA 02110-1301                                                    }\r
  21 {  USA                                                                      }\r
  22 {                                                                           }\r
  23 {Original Source: 1990 Scott Miller                                         }\r
  24 {Prepared for public release: 03/19/09 - Joe Siegler, Apogee Software, Ltd. }\r
  25 {*/                                                                         }\r
  26 {//-------------------------------------------------------------------------}\r
  27 {$c-}\r
  28 const\r
  29   Max = 234;\r
  30 \r
  31 type\r
  32   MaxLength = string[Max];\r
  33   OneChar   = string[1];\r
  34 \r
  35 var\r
  36   R1, R2            : file of MaxLength;\r
  37   Position,Counter,\r
  38   Start,Stop,x      : integer;\r
  39   Text1, Text2      : MaxLength;\r
  40   Answer            : char;\r
  41   Letter            : OneChar;\r
  42   List              : boolean;\r
  43 \r
  44 procedure Diskwrite(text1,text2: MaxLength; pointer: integer);\r
  45   begin\r
  46     seek(R1,pointer); seek(R2,pointer);\r
  47     WRITE(R1,text1); WRITE(R2,text2);\r
  48     writeln('ROOM decription ',pointer,\r
  49             ' is written!  Size = ',filesize(R1));\r
  50     close(R1); close(R2);\r
  51   end; {End of Diskwrite.}\r
  52 \r
  53 procedure Diskread(start,stop: integer);\r
  54 var\r
  55 counter : integer;\r
  56 text1, text2 : MaxLength;\r
  57   begin\r
  58    assign(R1,'R1');assign(R2,'R2');\r
  59    reset(R1); reset(R2);\r
  60    seek(R1,start); seek(R2,start);\r
  61     for counter:= start to stop do\r
  62       begin\r
  63         highvideo;\r
  64         READ(R1,text1); READ(R2,text2);\r
  65         if list then\r
  66           begin\r
  67             writeln(lst,'Discription # ',counter);\r
  68             writeln(lst,text1,text2);\r
  69           end\r
  70         else\r
  71           begin\r
  72             writeln('Here is ROOM description # ',counter);\r
  73             lowvideo;\r
  74             writeln(text1,text2);\r
  75             highvideo;\r
  76           end;\r
  77       end;\r
  78     close(R1); close(R2);\r
  79     write('The file contains ',filesize(R1),' ROOM descriptions.');\r
  80   end;  {End of Diskread.}\r
  81 \r
  82 procedure Beep;\r
  83 begin\r
  84  if(length(text1)in[68,146,224])or(length(text2)in[68,146,224])then\r
  85   begin sound(99);delay(50);nosound;end;\r
  86 end;\r
  87 \r
  88 BEGIN\r
  89 nosound;\r
  90 window(2,1,79,25);\r
  91 repeat          {Main loop.}\r
  92   text1:='';\r
  93   text2:='';\r
  94 \r
  95 writeln;\r
  96 writeln('Do you want to R)ead, W)rite or Q)uit?');\r
  97 read(kbd,answer);\r
  98 if upcase(answer) = 'Q' then begin writeln('FINISHED');halt;end;\r
  99 if upcase(answer) <> 'R' then       {Write to 'ROOMS'.}\r
 100     begin\r
 101       writeln;writeln;\r
 102       assign(R1,'R1'); assign(R2,'R2');\r
 103       textcolor(9);writeln('Now RESETing ROOM files.');highvideo;\r
 104             RESET(R1); RESET(R2);\r
 105       writeln;\r
 106       writeln('Input a string not more than ',2*Max,' characters.',\r
 107               '  ''\''-Ends string.');\r
 108       x:=wherey;if(x>17)then x:=18;for stop:=1 to 7 do writeln;gotoxy(1,x);\r
 109       lowvideo;\r
 110         repeat\r
 111           read(trm,letter);\r
 112           if letter = ^h then\r
 113             begin\r
 114               if(wherex=1)then\r
 115                begin window(2,1,80,25);gotoxy(79,wherey-1)end;\r
 116               write(^h,' ',^h);\r
 117               delete(text1,length(text1),2);\r
 118               window(2,1,79,25);\r
 119             end;\r
 120           beep;\r
 121           if (letter <> '\') and (letter <> ^h) then text1:=text1+letter\r
 122         until (length(text1)=Max) or (letter='\');\r
 123         if letter = '\' then\r
 124           begin\r
 125             writeln;\r
 126             highvideo;\r
 127             writeln('Total of ',length(text1),' characters.');\r
 128             text2:='';\r
 129           end\r
 130         else\r
 131           begin\r
 132               repeat\r
 133                 textcolor(11);\r
 134                 read(trm,letter);\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(text2,length(text2),2);\r
 141                    window(2,1,79,25);\r
 142                   end;\r
 143                 beep;\r
 144                 if (letter <> '\') and (letter <> ^h) then text2:=text2+letter\r
 145               until (length(text2)=Max) or (letter='\');\r
 146             writeln; highvideo;\r
 147             writeln('Total description length = ',\r
 148                      length(text1)+length(text2),' characters.');\r
 149           end;\r
 150       writeln('Now WRITING string to disk.');\r
 151       writeln('  At what position?  (Next open is # ',filesize(R1),')');\r
 152       textcolor(12);position:=position+1;readln(position);highvideo;\r
 153       Diskwrite(text1,text2,position);\r
 154     end\r
 155 else                      {Read from 'ROOMS'.}\r
 156   begin\r
 157     writeln;writeln;\r
 158     writeln('To the S)creen or the P)rinter');\r
 159     read(kbd,answer);\r
 160     if(upcase(answer)='P')then List:=True else List:=False;\r
 161     assign(R1,'R1');\r
 162     reset(R1);\r
 163     writeln('Filesize = ',filesize(R1),\r
 164             '  (From 0 to ',filesize(R1)-1,')');\r
 165     close(R1);\r
 166     writeln('Enter starting position:');\r
 167     textcolor(12);readln(start);highvideo;\r
 168     if(start > filesize(R1)-5)then stop:=(filesize(R1)-1) else\r
 169       begin\r
 170         writeln('Enter final position:');\r
 171         textcolor(12);readln(stop);highvideo;\r
 172       end;\r
 173     Diskread(start,stop);\r
 174   end;  {End of else clause.}\r
 175 until false;     {End of Main loop.}\r
 176 END.\r
 177 \r
 178 \r
 179 \1a\r