CP/M/CPM_CDROM.iso/mbug/mbug013.arc/ANIMAL.PAS

Pascal/Delphi Source File | 1979-12-31 | 10KB | 363 lines

program ANIMAL;

{               Version for Turbo Pascal
   Developed, with major modifications, by Bob Burt from
  a Pascal/Z source written for the Pascal/Z Users Group
     (Volume 26) by Roy Allen of Mill Valley, CA.

   Note that the Turbo version compiles to a 14k .COM file,
  compared with 26k for the Pascal/Z version.  Additionally,
   the Turbo version allows a LISTing of the known animals,
    and will print out the data file format and contents.

  This is a useful demonstration program to assist newcomers
   to Turbo Pascal to learn how to structure and manipulate
                     data files.                              }

const
  inviter   = 'Would you like to play the animal guessing game';
  insulted  = 'Well, exCUUUUSE ME! !  So you don''t want to play, huh?';
  start1    = 'You think of an animal, and I''ll try to guess what it is';
  start2    = 'When you''re ready to begin, press <RETURN>';
  askagain  = 'Would you like to play another round';
  want_list = 'Do you want a list of the animals I now know';
  see_file  = 'Do you want to see how the file is constructed';
  continue  = 'Press any key to continue';
  vowels    : set of char = ['A','E','I','O','U','a','e','i','o','u'];
  shiftup   : integer = -32; { ord('A') - ord(a') }
type
  string128 = string[128];
  string24  = string[24];
  animal_record = record
                    name_or_question : string128;
                    yes_node,no_node : integer
                  end;
var
  animal_data : file of animal_record;
  animal_rec  : animal_record;
  count,animal_count : integer;
  answer : integer;
  OK,play_game,match,found : boolean;
  ch : char;
  query : string128;
  old_animal : string24;

{$I getyes.fun}
{$I explain.pro}

procedure guessing; forward;

procedure starter_file;
begin
  assign(animal_data,'animal.dat');
  {$I-} reset(animal_data) {$I+};
  OK := (ioresult = 0);
  if not OK then
    begin
      rewrite(animal_data);
      seek(animal_data,0);
      with animal_rec do
      begin
        name_or_question := 'Does it live in the water';
        yes_node := 1; no_node := 2
      end;
      write(animal_data,animal_rec);
      seek(animal_data,1);
      with animal_rec do
      begin
        name_or_question := 'octopus';
        yes_node := 0; no_node := 0;
      end;
      write(animal_data,animal_rec);
      seek(animal_data,2);
      with animal_rec do
      begin
        name_or_question := 'moose';
        yes_node := 0; no_node := 0;
      end;
      write(animal_data,animal_rec)
    end; {if not OK}
    close(animal_data)
end; {procedure starter_file}

procedure extract_file;
begin
  animal_count := 0;
  writeln;
  assign(animal_data,'animal.dat');
  reset(animal_data);
  for count := 0 to filesize(animal_data) - 1 do
    begin
      seek(animal_data,count);
      read(animal_data,animal_rec);
      with animal_rec do
      begin
        write('Animal Record No.',count,' contains :');
        writeln(name_or_question,' Nodes : ',yes_node,',',no_node);
        if yes_node = 0 then animal_count := animal_count + 1
      end; {with}
    end; {for count}
    writeln;
    writeln('Total number of animals I know is : ',animal_count);
    close(animal_data)
end; {procedure extract_file}

procedure list_animals;
var
  x,y : integer;
begin
  y := 2;
  animal_count := 0;
  clrscr;
  writeln('Animals I know :');
  assign(animal_data,'animal.dat');
  reset(animal_data);
  for count := 0 to filesize(animal_data) - 1 do
    begin
      seek(animal_data,count);
      read(animal_data,animal_rec);
      with animal_rec do
        if yes_node = 0 then
        begin
          if (animal_count mod 6 = 0)
            then begin
                   x := -12; y := y + 1;
                 end;
          x := x + 13;
          gotoxy(x,y);
          write(name_or_question);
          animal_count := animal_count + 1
        end {if}
    end; {for count}
    close(animal_data);
    writeln; writeln;
    writeln('Thus I know a total of ',animal_count,' animals')
end; {procedure list_animals}

procedure animal_total;
begin
  animal_count := 0;
  assign(animal_data,'animal.dat');
  reset(animal_data);
  for count := 0 to filesize(animal_data) - 1 do
  begin
    seek(animal_data,count);
    read(animal_data,animal_rec);
    with animal_rec do
      if yes_node = 0 then
        animal_count := animal_count + 1
  end; {for count}
  close(animal_data)
end; {procedure animal_total}

function voweler(noun : string24) : string24;
var
  holder : string24;
begin
  if noun[1] in vowels
    then holder := ' an '
    else holder := ' a ';
    voweler := holder + noun
end; {voweler function}

procedure right_guess;
const
  boast = 'How about that - - - I WON!';
begin
  writeln;
  writeln(^G,boast);
  delay(2000);
  close(animal_data)
end; {procedure right_guess}

procedure depun(var dtext : string24);
begin
  repeat
    if (dtext[length(dtext)] = '.')
    or (dtext[length(dtext)] = ',')
    or (dtext[length(dtext)] = '!')
    or (dtext[length(dtext)] = '?')
    or (dtext[length(dtext)] = ' ') then
      dtext := copy(dtext,1,length(dtext)-1)
  until (dtext[length(dtext)] in ['a'..'z'])
     or (dtext[length(dtext)] in ['A'..'Z'])
end; {procedure depun}

procedure lower(var dtext : string24);
var
 i : integer;
 letter : char;
 sloppy : boolean;
begin
  sloppy := true;
  for i := 1 to 4 do
    if i <= length(dtext)
      then if dtext[i] in ['a'..'z']
        then sloppy := false;
  if sloppy
    then for i := 1 to length(dtext) do
      begin
        letter := dtext[i];
        if ((letter >= 'A') and (letter <= 'Z'))
          then dtext[i] := chr(ord(letter) - shiftup)
      end
end; {procedure lower}

procedure markout(var btext : string24);
begin
  while btext[1] = ' ' do
    btext := copy(btext,2,length(btext));
  if  (btext[1] = 'a')
  and (btext[2] = ' ') then
    btext := copy(btext,3,length(btext));
  if  (btext[1] = 'a')
  and (btext[2] = 'n')
  and (btext[3] = ' ') then
    btext := copy(btext,4,length(btext));
  while btext[1] = ' ' do
    btext := copy(btext,2,length(btext))
end; {procedure markout}

procedure learning;
const
  puzzled  = 'Really?  What sort of animal is it then?';
  humbler  = 'Oh!  I didn''t know about';
  request1 = 'I''d like to know more about animals.';
  request2 = 'What''s a yes-or-know question';
  request3 = 'to discriminate between';
  clarify1 = 'Which answer to that question would mean';
  clarify2 = ' - yes or no';
  thanks   = 'Thank you!  Now I know ';
var
  yes_answer : boolean;
  holder : string24;

begin {procedure learning}
  writeln(puzzled);
  readln(holder);
  depun(holder);
  lower(holder);
  markout(holder);
  writeln(humbler,voweler(holder),'.');
  writeln(request1);
  writeln(request2);
  write(request3,voweler(holder),' and');
  writeln(voweler(animal_rec.name_or_question),'?');
  readln(query);
  write(clarify1,voweler(holder));
  write(clarify2);
  old_animal := animal_rec.name_or_question;
  yes_answer := getyes;
  seek(animal_data,answer);
  with animal_rec do
    begin
      name_or_question := query;
      if yes_answer
      then begin
             yes_node := filesize(animal_data);
             no_node  := filesize(animal_data) + 1
           end
      else begin
             yes_node := filesize(animal_data) + 1;
             no_node  := filesize(animal_data)
           end
    end; {with animal_rec}
  write(animal_data,animal_rec);
  seek(animal_data,filesize(animal_data));
  with animal_rec do
    begin
      name_or_question := holder;
      yes_node := 0; no_node := 0
    end; {with animal_rec}
  write(animal_data,animal_rec);
  seek(animal_data,filesize(animal_data)); {new filesize after write}
  with animal_rec do
    begin
      name_or_question := old_animal;
      yes_node := 0; no_node := 0
    end; {with animal_rec}
  write(animal_data,animal_rec);
  close(animal_data);
  animal_total;
  write(thanks,animal_count:1,' animals')
end; {procedure learning}

procedure animal_guess;
begin
  found := false;
  seek(animal_data,answer);
  read(animal_data,animal_rec);
  write('Is it',voweler(animal_rec.name_or_question));
  OK := getyes;
  if OK
    then begin
           found := true;
           right_guess
         end;
  if (not found) and (not OK)
    then begin
           found := true;
           learning
         end
end; {procedure animal_guess}

procedure next_node;
begin
  seek(animal_data,answer);
  read(animal_data,animal_rec);
  with animal_rec do
    begin
      write(name_or_question);
      OK := getyes;
      if OK then answer := yes_node;
      if not OK then answer := no_node
    end;
  guessing
end; {procedure next_node}

procedure guessing;
begin
  seek(animal_data,answer);
  read(animal_data,animal_rec);
  if animal_rec.yes_node = 0
    then animal_guess
    else next_node
end; {procedure guessing}

begin {program animal}
  clrscr; starter_file;
  animal_total; explain;
  write(inviter);
  play_game := getyes;
  if not play_game then
    begin
      writeln; writeln(insulted)
    end; {if not play_game}
  while play_game do
    begin {while play_game}
      clrscr; answer := 0;
      writeln(start1); writeln(start2);
      readln(ch);
      assign(animal_data,'animal.dat');
      reset(animal_data);
      guessing; writeln;
      write(askagain); play_game := getyes
    end; {while play_game}
  writeln; write(want_list);
  OK := getyes;
  if OK then
    begin
      list_animals; writeln;
      write(continue); repeat until keypressed;
    end; {if OK}
  writeln; write(see_file);
  OK := getyes;
  if OK then
    begin
      clrscr; extract_file;
      write(continue); repeat until keypressed;
    end; {if OK}
  writeln; writeln('Okay!  Goodbye!')
end. {program animal}