src/ADPARSER.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, 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 {*****************************************************************************}\r
  25 {*                                 ADPARSER                                  *}\r
  26 {*                             by Scott Miller                               *}\r
  27 {*      This include file to Adgame contains the word parser commands.       *}\r
  28 {*                          Copyright 1984 Pending                           *}\r
  29 {*****************************************************************************}\r
  30 \r
  31 \r
  32 procedure  RR(RoomNum : integer);\r
  33     begin FlagSA:='s';\r
  34       seek(rooms1,RoomNum);seek(rooms2,RoomNum);\r
  35       READ(rooms1,text1);READ(rooms2,text2);\r
  36       writeln(text1,text2);\r
  37     end; {of RoomRead}\r
  38 \r
  39 \r
  40 procedure  RS(RoomNum : integer);\r
  41    begin\r
  42      FlagSA:='s';\r
  43      seek(Special1,RoomNum);seek(Special2,RoomNum);\r
  44      READ(Special1,text1);READ(Special2,text2);\r
  45      writeln(text1,text2);\r
  46    end;  {of SpecialRead}\r
  47 \r
  48 procedure RL(RoomNum : integer);\r
  49    var text1 : str80;\r
  50    begin\r
  51      FlagSA:='s';\r
  52      seek(Line1,RoomNum);\r
  53      READ(Line1,text1);\r
  54      writeln(text1);\r
  55    end;  {of LineRead}\r
  56 \r
  57 \r
  58 procedure Format(var input : Str80);\r
  59  procedure D(A:str14; B: Byte);\r
  60   begin while pos(A,input)<>0 do delete(input,pos(A,input),B) end;\r
  61    begin input:=input+' '; insert(' ',input,1);\r
  62     d(' of ',3); d(' go ',3); d('''',1); d('"',1); d(',',1);\r
  63     d(' a ',2); d('?',1);  d('!',1); d(';',1); d('#',1);\r
  64     d(' the ',4); d('fly ',4); d('drive ',6); d('run ',4);\r
  65     d('walk ',5); d('travel ',7); d('please ',7); d('room ',5);\r
  66     d('crawl se',6); d('crawl nw',6); d('steer ',6); d('crawl n ',6);\r
  67     d('crawl s ',6); d('crawl e',6); d('crawl w',6); d('that ',5);\r
  68     d('first ',6); d('second ',7); d('number ',7);\r
  69     d('this ',5); d('game ',5); d('i want to ',10); d(' my ',3); d('big ',4);\r
  70     d('those ',6); d('them ',5); d('broken ',7); d('large ',6);\r
  71     d('huge ',5); d('small ',6); d('tiny ',5);d('little ',7); d('within ',4);\r
  72     d('yes ',3); d('no ',2); d('wade ',4); d('swim ',4);\r
  73     while pos('examine ',input)>0 do delete(input,pos('examine ',input)+2,5);\r
  74     while pos('into ',input)>0 do delete(input,pos('into ',input)+2,2);\r
  75     while pos('. ',input)>0 do delete(input,pos('. ',input)+1,1);\r
  76     while pos('inside ',input)>0 do delete(input,pos('inside ',input)+2,4);\r
  77     d(' .',1); d('  ',1); d('..',1);\r
  78     if(input[1]='.')then delete(input,1,1);\r
  79     while(length(input)>0)and(input[1]=' ')do delete(input,1,1);\r
  80     while(length(input)>0)and(input[length(input)]=' ')do\r
  81      delete(input,length(input),1);\r
  82     if(input='')or(input[1]='.')then writeln('Whoops!')\r
  83    end;  {of Format}\r
  84 \r
  85 \r
  86 procedure Chop(var input : Str80);\r
  87    var Word : Str80;\r
  88        j, l : integer;\r
  89    begin\r
  90      if length(input) >0 then\r
  91        begin\r
  92          input:=input+' ';\r
  93          j:=1;\r
  94          repeat\r
  95            Word:='';\r
  96            while(input[j]<>' ')and(input[j]<>'.')do begin\r
  97              Word:=Word+input[j];\r
  98              j:=j+1\r
  99            end;\r
 100            if length(Word) >7 then\r
 101              begin\r
 102                l:=pos(Word,input);\r
 103                j:=j+(7-length(Word));\r
 104                delete(input,l,length(Word));\r
 105                delete(Word,8,120);\r
 106                insert(Word,input,l)\r
 107              end;\r
 108            j:=j+1;\r
 109          until (j-1)=length(input);\r
 110          delete(input,length(input),1)\r
 111        end\r
 112    end;  {of Chop}\r
 113 \r
 114 \r
 115 procedure LowerCase(var input : Str80);\r
 116     var j:byte;\r
 117    begin\r
 118      if length(input) > 0 then\r
 119       for j:=1 to length(input) do\r
 120        if(input[j] in ['A'..'Z'])then\r
 121         input[j]:=chr(ord(input[j])+32)\r
 122    end;   {of LowerCase}\r
 123 \r
 124 \r
 125 procedure FindVerb (var input:Str80;var Word:Str14;var Verb:integer);\r
 126    var j, k, r : integer;\r
 127    begin\r
 128    j:=1;\r
 129    input:=input+' ';\r
 130    Word:='';\r
 131    while input[j]<>' ' do begin\r
 132      Word:=Word+input[j];\r
 133      j:=j+1\r
 134    end;\r
 135    if length(Word+' ')<length(input)then begin\r
 136      Word:=Word+' '; j:=j+1;\r
 137      while input[j]<>' ' do begin\r
 138        Word:=Word+input[j];\r
 139        j:=j+1\r
 140      end\r
 141    end;\r
 142 \r
 143    Verb:=Null;\r
 144    for r:= 0 to VMax do\r
 145      begin\r
 146        k:=0;\r
 147        repeat\r
 148          k:=k+1;\r
 149          if v[r,k]=Word then\r
 150            Verb:=r;\r
 151        until (v[r,k]=Q)or(k=5)\r
 152      end;\r
 153 \r
 154    if(pos(' ',Word)<>0)and(Verb=Null)then\r
 155      begin\r
 156        delete(Word,pos(' ',Word),8);\r
 157        for r:=0 to VMax do\r
 158          begin\r
 159            k:=0;\r
 160            repeat\r
 161              k:=k+1;\r
 162              if v[r,k]=Word then\r
 163                Verb:=r;\r
 164            until (v[r,k]=Q)or(k=5)\r
 165          end\r
 166      end;\r
 167      delete(input,length(input),1);\r
 168      if Verb<>Null then delete(input,1,length(Word));\r
 169      if input[1]=' 'then delete(input,1,1)\r
 170    end;  {of FindVerb}\r
 171 \r
 172 \r
 173 procedure FindNoun(var input:Str80;var Word:Str14;var Noun:integer);\r
 174    var j, k, t  : integer;\r
 175    begin\r
 176    j:=1;\r
 177    input:=input+' ';\r
 178    Word:='';\r
 179    while input[j]<>' ' do begin\r
 180      Word:=Word+input[j];\r
 181      j:=j+1\r
 182    end;\r
 183    if length(Word+' ')<length(input)then begin\r
 184      Word:=Word+' ';j:=j+1;\r
 185      while input[j]<>' ' do begin\r
 186        Word:=Word+input[j];\r
 187        j:=j+1\r
 188      end\r
 189    end;\r
 190 \r
 191    Noun:=Null;\r
 192    for t:=0 to NMax do\r
 193      begin\r
 194        k:=0;\r
 195        repeat\r
 196          k:=k+1;\r
 197          if n[t,k]=Word then\r
 198            Noun:=t;\r
 199        until (n[t,k]=Q)or(k=5)\r
 200      end;\r
 201 \r
 202    if(pos(' ',Word)<>0)and(Noun=Null)then\r
 203      begin\r
 204        delete(Word,pos(' ',Word),8);\r
 205        for t:=0 to NMax do\r
 206          begin\r
 207            k:=0;\r
 208            repeat\r
 209              k:=k+1;\r
 210              if n[t,k]=Word then\r
 211                Noun:=t;\r
 212            until (n[t,k]=Q)or(k=5)\r
 213          end\r
 214      end;\r
 215      delete(input,length(input),1);\r
 216      if Noun<>Null then delete(input,1,length(Word));\r
 217      if input[1]=' 'then delete(input,1,1)\r
 218    end;  {of FindNoun}\r
 219 \r
 220 \r
 221 procedure FindSep(var input : Str80; var h : Str14);\r
 222    var j  : integer;\r
 223    begin\r
 224      input:=input+' ';\r
 225      j:=1;\r
 226      h:='';\r
 227      while input[j]<>' ' do begin\r
 228        h:=h+input[j];\r
 229        j:=j+1\r
 230      end;\r
 231      if pos(' '+h+' ',' crawl on at to in off with within into '+\r
 232             ' above against through beside behind around across '+\r
 233             ' inside from by under using near over onto down ') >0 then\r
 234        begin\r
 235          delete(input,length(input),1);\r
 236          delete(input,1,length(h));\r
 237          if input[1]=' ' then delete(input,1,1);\r
 238          if(h='on')or(h='around')or(h='above')or(h='over')or(h='onto')\r
 239            then h:='to';\r
 240          if(h='inside')or(h='within')or(h='through')or(h='into')or(h='down')\r
 241            then h:='in';\r
 242          if(h='using')then h:='with';\r
 243          if(h='beside')or(h='by')then h:='near';\r
 244          if(h='against')then h:='at';\r
 245          if(h='across')then h:='over'\r
 246        end\r
 247      else\r
 248        begin\r
 249          h:='s';\r
 250          delete(input,length(input),1)\r
 251        end\r
 252    end;  {of FindSep}\r
 253 \r
 254 \r
 255 procedure Check(var SepWord : Str14);\r
 256    var j  : integer;\r
 257    begin\r
 258    Verb:=Null; Noun:=Null; Noun2:=Null; DialNum:=Null; Flag:='?';\r
 259    SepWord:='s';\r
 260    if length(input)>0then\r
 261     begin\r
 262      FindVerb(input,Word,Verb);\r
 263      if Verb<>Null then\r
 264       if(length(input)>0)and not(Verb in [31,53,63])then\r
 265        begin\r
 266         FindNoun(input,Word,Noun);\r
 267         If(Noun<>Null)then LastNoun:=n[noun,1];\r
 268         if Noun<>Null then\r
 269          if(Verb in[0,8,9,21,36,6,7,15,17,32,26])and(length(input)=0)then\r
 270           begin\r
 271            Flag:='g';\r
 272            if(Verb in[36,15])then Verb:=9\r
 273           end\r
 274          else\r
 275          if(Verb in[0,8,21,36,37,29,9,39,6,15,7,17,32,26,40])then\r
 276           if length(input)>0 then\r
 277            begin\r
 278             if(Verb=9)then Verb:=29 else ;\r
 279             FindSep(input,SepWord);\r
 280             if SepWord<>'s' then\r
 281              if length(input)>0 then\r
 282               if Verb=39 then\r
 283                begin\r
 284                 val(input,DialNum,j);\r
 285                 Flag:='g'\r
 286                end\r
 287               else\r
 288                begin\r
 289                 FindNoun(input,Word,Noun2);\r
 290                 if Noun2<>Null then\r
 291                  if length(input)>0 then\r
 292                   Flag:='r'\r
 293                  else\r
 294                   Flag:='g'\r
 295                 else\r
 296                  begin\r
 297                   FindVerb(input,Word,Verb);\r
 298                    if Verb=Null then Flag:='n'\r
 299                    else Flag:='b'\r
 300                  end\r
 301                end\r
 302              else\r
 303               if(Verb=39)and((SepWord='to')or(SepWord='off'))then\r
 304                Flag:='g' else Flag:='e'\r
 305             else\r
 306              Flag:='r'\r
 307            end\r
 308           else\r
 309            Flag:='s'\r
 310          else\r
 311           if length(input)>0 then\r
 312            begin FindVerb(input,Word,j);if j<>Null then Flag:='b' else\r
 313            begin FindSep(input,SepWord);if SepWord<>'s' then Flag:='b' else\r
 314            begin FindNoun(input,Word,j);if j<>Null then Flag:='h' end end;\r
 315             if Flag='?' then Flag:='v'\r
 316            end\r
 317           else\r
 318            Flag:='g'\r
 319         else\r
 320          begin\r
 321           FindVerb(input,Word,Verb);\r
 322            if Verb=Null then Flag:='n'\r
 323            else Flag:='b'\r
 324          end\r
 325        end\r
 326       else\r
 327        if Verb in OneWordCommands then Flag:='g'\r
 328        else Flag:='m'\r
 329      else\r
 330       begin\r
 331        FindNoun(input,Word,Noun2);\r
 332         If Noun2=Null then Flag:='v'\r
 333         else Flag:='a'\r
 334       end\r
 335     end;\r
 336    case flag of\r
 337    'v','n':if pos(' '+Word+' ',' crawl on at to in off with within into '+\r
 338                   ' above against through beside behind around down '+\r
 339                   ' inside by under using near over onto top below '+\r
 340                   ' from away want across ')>0 then begin\r
 341              write('The word ''',Word);RL(393)end\r
 342            else writeln('I don''t understand the word ''',Word,'.''');\r
 343      'b'  :begin\r
 344             if pos(' ',Word)>0 then delete(Word,pos(' ',Word),9);\r
 345             writeln('You can''t use the word ''',Word,''' here.')\r
 346            end;\r
 347      's'  :RL(129);\r
 348      'r'  :RL(130);\r
 349      'e'  :RL(131);\r
 350      'm'  :RL(132);\r
 351      'a'  :RL(316);\r
 352      'h'  :begin write(Word);RL(392)end\r
 353    end;\r
 354    Skip:=True;\r
 355    if flag<>'g' then begin Attack:=False;Line:='';Skip:=False end\r
 356   end;  {of Check}\r
 357 \r
 358 {***************************** END OF ADPARSER ******************************}\r
 359 \1a\r