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