ADPARSER.PAS

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