ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/PASCAL/DOORDR50.ZIP/JUNGLE.PAS

Pascal/Delphi Source File | 1992-02-02 | 11.8 KB | 487 lines

uses doordriv,crt,ddscott;

{ EXAMPLE DOOR: The Jungle!                                               }
{               By Scott Baker                                            }
{                                                                         }
{      One of my friends wanted me to whip this thing up, but I never     }
{ finished it. So here it is! Basically, this door operates as a type     }
{ of "Never Ending Story". Users continually add on to the end of a       }
{ large "tablet"  which contains all of the dialog.                       }
{      The program is not quite finished - there are some maintenance     }
{ options that are really necessary (such as purging the table of old     }
{ data), but there isn't much work left.                                  }
{      Also, if you do use any of this code in your own program, I        }
{ that you credit my name.                                                }

{$V-}

const
 numusers=100;
type
 setuprec=record
           numstr: word;
           minwords,
           maxwords,
           minpunct,
           maxpunct,
           mincaps,
           maxcaps,
           minpro,
           maxpro: word;
           minpass: word;
          end;

 userrec=record
          realname: string[35];
          alias: string[35];
          scrsize: word;

          totalcaps: longint;
          totalpunct: longint;
          totalpro: longint;
          totalwords: longint;
          totallines: longint;
          totalposts: longint;
         end;

const
 setup: setuprec= (numstr: 5000;
                   minwords: 3;
                   maxwords: 10;
                   minpunct: 1;
                   maxpunct: 10;
                   mincaps: 2;
                   maxcaps: 20;
                   minpro: 0;
                   maxpro: 3;
                   minpass: 3);

type
 sttypetype=(Authorident,thetext);
 strrec=record
         sttype: sttypetype;
         numlines: word;
         str: string[80];
        end;
var
 strfile: file of strrec;                 {File to hold the tablet          }
 header: strrec;                          {"header" for the tablet          }

 numuserlines: word;                      {Number of lines user has typed in}
 userlines: array[1..500] of string[80];  {Holds users typing for session   }

 user: userrec;                           {Current user record              }
 userfile: file of userrec;               {File to hold user records        }
 usernum: word;                           {Record number of user            }

 exitsave: pointer;                       {for exit procedure               }

procedure AddStr(s: string);
var
 st:strrec;
begin;
 inc(header.numlines);
 st.sttype:=thetext;
 st.str:=s;
 seek(strfile,header.numlines);
 write(strfile,st);
end;

procedure openfiles;
var
 s: strrec;
 a: integer;
begin;
 assign(strfile,'TEXT.DAT');
 {$I-}
 reset(strfile);
 {$I+}
 if ioresult<>0 then begin;
  rewrite(strfile);
  header.sttype:=authorident;
  header.str:='';
  header.numlines:=1;
  s.sttype:=authorident;
  s.str:='Introduction';
  for a:=1 to setup.numstr do write(strfile,s);
  reset(strfile);

  Addstr('Welcome to ... The Jungle!');
  Addstr('(c) 1991 Scott Baker & Michael Crosson.');
  addstr('');
  addstr('The world''s best free-format message system! Where it doesn''t matter how');
  addstr('you post, where you post, just that you post! ');

  seek(strfile,0);
  write(strfile,header);
 end;
 reset(strfile);
 read(strfile,header);

 assign(userfile,'JNGLUSER.DAT');
 {$I-}
 reset(userfile);
 {$I+}
 if ioresult<>0 then begin;
  rewrite(userfile);
  fillchar(user,sizeof(user),0);
  for a:=1 to numusers+1 do write(userfile,user);
 end;
 reset(userfile);
end;

{$F+}
procedure myexit;
begin;
 if usernum<>0 then begin;
  seek(userfile,usernum);
  write(userfile,user);
 end;
 close(userfile);
 close(strfile);
 exitproc:=exitsave;
end;
{$F-}

procedure login;
var
 a,b,c: integer;
 u: userrec;
 s: string;
begin;
 swriteln('Welcome to The Jungle!');
 swriteln('');
 swriteln('Standby, finding your place in the jungle!');
 b:=0;
 c:=0;
 for a:=1 to numusers do begin;
  seek(userfile,a);
  read(userfile,u);
  if u.realname=stu(user_first_name+' '+user_last_name) then b:=a;
  if (u.realname='') and (c=0) then c:=a;
 end;
 swriteln('');
 if (b=0) and (c=0) then begin;
  swriteln('Sorry, the jungle is kind of crowded right now. Maybe some other time!');
  halt;
 end;
 usernum:=b;
 if (b=0) then begin;
  usernum:=c;
  fillchar(user,sizeof(user),0);
  user.realname:=stu(user_first_name+' '+user_last_name);
  swriteln('Looks like this is your first visit to the jungle! First, let me ask you');
  swriteln('a few questions....');
  swriteln('');
  repeat;
   swrite('What would you like as an alias? ');
   sread(user.alias);
   swrite(namestr(user.alias)+', Correct (Y/N) ? ');
   sread_char(ch);
   ch:=upcase(ch);
  until ch='Y';
  swriteln('');
  repeat;
   swrite('How many screen lines do you have (15-50) ? ');
   sread(s);
   val(s,user.scrsize,a);
   swrite(wva(user.scrsize)+', Right (Y/N) ? ');
   sread_char(ch);
   ch:=upcase(ch);
  until ch='Y';
  swriteln('');
 end;
end;

procedure ListFrom(n: word);
var
 a: integer;
 s: strrec;
 s2,s3: string;
begin;
 if n>header.numlines then n:=header.numlines;
 for a:=n to header.numlines do begin;
  seek(strfile,a);
  read(strfile,s);
  if s.sttype=authorident then begin;
   swriteln('');
   set_Foreground(lightgray);
   set_background(1);
   s3:='|||||||||||||||||||||||';
   s2:=' Line: '+wva(a)+' ';
   move(s2[1],s3[8],length(s2));
   swrite(s3);
   set_background(0);
   swriteln('');
   swriteln('');
  end else begin;
   set_foreground(lightgray);
   swriteln(s.str);
  end;
 end;
end;

procedure adduser(s: string);
begin;
 inc(numuserlines);
 userlines[numuserlines]:=s;
end;

procedure listuser;
var
 a: integer;
begin;
 set_foreground(lightred);
 swriteln('Your Text:');
 set_foreground(white);
 for a:=1 to numuserlines do swriteln(userlines[a]);
end;

procedure DispBar(s: string; min,max,v: word; var pass: word);
var
 a: integer;
 s2: string;
begin;
 set_foreground(cyan);
 swrite(s);
 set_foreground(white);
 str(v:3,s2);
 swrite(s2+'  ');
 for a:=0 to 30 do begin;
  if a<=v then set_background(cyan) else set_background(blue);
  if a=min then begin;
   set_foreground(lightred);
   swrite('|');
  end else if a=max then begin;
   set_foreground(lightred);
   swrite('|');
  end else swrite(' ');
 end;
 set_foreground(7);
 set_background(0);
 swrite('  ');
 if (v>=min) and (v<=max) then begin;
  set_Foreground(0);
  set_background(green);
  swrite('[PASS]');
  inc(pass);
 end else begin;
  set_foreground(0);
  set_background(red);
  swrite('[FAIL]');
 end;
 set_foreground(7);
 set_background(0);
 swriteln('');
end;

procedure DoBars(lines,words,punct,caps,pro: longint; var pass: word);
begin;
 pass:=0;
 DispBar('Words Per Line          : ',setup.minwords,setup.maxwords,words div lines,pass);
 swriteln('');
 DispBar('Punctuation Per Line    : ',setup.minpunct,setup.maxpunct,punct div lines,pass);
 swriteln('');
 dispbar('Capitol Letters Per Line: ',setup.mincaps,setup.maxcaps,caps div lines,pass);
 swriteln('');
 dispbar('Profanity               : ',setup.minpro,setup.maxpro,pro div lines,pass);
end;

procedure checkusertext;
const
 pchars= [':'..'@','['..'`','!'..'/'];
var
 caps: word;
 words: word;
 punct: word;
 pro: word;
 found: boolean;
 a,b: integer;
 lastspace: boolean;
 pros: array[1..255] of string[30];
 numpros: word;
 s2: string;
 f: text;
 pass: word;
begin;
 if numuserlines=0 then exit;
 sclrscr;
 set_foreground(lightgray);
 swriteln('Standby, Testing your text for content:');
 swriteln('');
 if exist('JUNGBAD.TXT') then begin;
  assign(f,'JUNGBAD.TXT');
  reset(f);
  numpros:=0;
  while not eof(F) do begin;
   inc(numpros);
   readln(f,pros[numpros]);
   if length(pros[numpros])<2 then dec(numpros);
  end;
  close(F);
 end else numpros:=0;
 caps:=0;
 words:=0;
 punct:=0;
 pro:=0;
 for a:=1 to numuserlines do begin;
  inc(words);
  lastspace:=true;
  swrite(#13+'Line: '+wva(a));
  delay(125);
  for b:=1 to length(userlines[a]) do begin;
   if userlines[a][b] in pchars then inc(punct);
   if userlines[a][b] in ['A'..'Z'] then inc(caps);
   if (userlines[a][b] in pchars) or (userlines[a][b] = ' ') then begin;
    if not lastspace then inc(words);
    lastspace:=true;
   end else lastspace:=false;
  end;
  s2:=userlines[a];
  repeat;
   found:=false;
   for b:=1 to numpros do if pos(stu(pros[b]),stu(s2))<>0 then begin;
    found:=true;
    inc(pro);
    delete(s2,pos(stu(pros[b]),stu(s2)),length(pros[b]));
   end;
  until found=false;
 end;
 while wherex>1 do swrite(#8' '#8);
 set_foreground(7);
 set_background(1);
 swrite('[-- User text analysis --]');
 set_foreground(7);
 set_Background(0);
 swriteln('');
 swriteln('');
 dobars(numuserlines,words,punct,caps,pro,pass);
 swriteln('');
 if pass<setup.minpass then begin;
  set_Foreground(lightred);
  swriteln('You did not pass enough tests! Your writing has been discarded!');
  numuserlines:=0;
 end else begin;
  set_Foreground(lightgreen);
  swriteln('You passed! Your writing is saved.');
  user.totalwords:=user.totalwords+words;
  user.totalpunct:=user.totalpunct+punct;
  user.totalcaps:=user.totalcaps+caps;
  user.totalpro:=user.totalpro+pro;
  user.totallines:=user.totallines+numuserlines;
 end;
end;

procedure ShowHistory;
var
 pass: word;
begin;
 swriteln('');
 swriteln('Your posting history:');
 swriteln('');
 if user.totallines=0 then begin;
  swriteln('You have no posting history!');
  exit;
 end;
 dobars(user.totallines,user.totalwords,user.totalpunct,user.totalcaps,user.totalpro,pass);
end;

procedure wreadln(var thestr,wwrap: string);
var
 s,s2: string[162];
 a,b,c: integer;
 ch: char;
 done: boolean;
begin;
 done:=false;
 if thestr<>'' then swrite(thestr);
 wwrap:='';
 repeat;
  sread_char(ch);
  if (ch=#8) and (length(thestr)>0) then begin;
   swrite(#8+' '+#8);
   delete(thestr,length(thestr),1);
  end;
  if not (ch in [#$0d,#$08]) then begin;
   thestr:=thestr+ch;
   swrite(ch);
  end;
  if length(thestr)>72 then begin;
   c:=0;
   for b:=1 to length(thestr) do if thestr[b]=' ' then c:=b;
   s:='';
   if c>60 then begin;
    for b:=c+1 to length(thestr) do begin;
     s:=s+thestr[b];
     swrite(#8+' '+#8);
    end;
    for b:=c to length(thestr) do delete(thestr,length(thestr),1);
   end;
   wwrap:=s;
   done:=true;
  end;
 until (ch=#13) or (done);
 swriteln('');
end;

procedure mainloop;
var
 s: string;
 a,b: integer;
 done: boolean;
 wwrap: string;
begin;
 done:=false;
 wwrap:='';
 repeat;
  set_foreground(lightcyan);
  swrite('> ');
  set_foreground(white);
  s:=wwrap;
  wreadln(s,wwrap);
  set_foreground(lightgray);
  if stu(s)='H' then showhistory;
  val(s,a,b);
  if a<>0 then begin;
   listfrom(a);
   swriteln('');
   listuser;
   swriteln('');
  end else if (stu(s)='Q') or (stu(s)='O') or (stu(s)='QUIT') or (stu(s)='EXIT') then begin;
   done:=true;
  end else if stu(s)<>'H' then adduser(s);
 until done;
 checkusertext;
end;

procedure savefiles;
var
 a: integer;
 s: strrec;
begin;
 if numuserlines<>0 then begin;
  s.sttype:=authorident;
  s.str:=stu(user_first_name+' '+user_last_name);
  inc(header.numlines);
  seek(strfile,header.numlines);
  write(strfile,s);
 end;
 for a:=1 to numuserlines do addstr(userlines[a]);
 seek(strfile,0);
 write(strfile,header);
end;

begin;
 initdoordriver('DOORDRIV.CTL');
 morechk:=false;
 progname:='The Jungle!';
 numuserlines:=0;
 usernum:=0;
 openfiles;
 exitsave:=exitproc;
 exitproc:=@myexit;
 login;
 mainloop;
 savefiles;
 delay(1000);
end.