home *** CD-ROM | disk | FTP | other *** search
/ ftp.wwiv.com / ftp.wwiv.com.zip / ftp.wwiv.com / pub / EVENTS / WWIVGIRL.ZIP / GIRL.PAS < prev   
Pascal/Delphi Source File  |  1990-03-01  |  11KB  |  475 lines
  1. Program girlrate(input,output);
  2. {$V-} {$C-}
  3. {$G1}{$P1}
  4.  
  5. CONST strlen=160;
  6. TYPE str=string[strlen];
  7.     regs=record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer; end;
  8. var
  9.   Temp : char;
  10.   Temp2: string[2];
  11.   Result    : Integer;
  12.   Name : String[32];
  13.   Age  : Integer;
  14.   Rt   : Integer;
  15.     incom,okansi,cs,so,hangup:boolean;
  16.     rp:regs;
  17.  
  18. procedure checkhangup;
  19. begin
  20. end;
  21.  
  22. procedure getkey(var c:char); forward;
  23.  
  24. procedure prompt(i:str); forward;
  25.  
  26. procedure ansic(c:integer);
  27. var i:str;
  28. begin
  29.   if (c=1) or (c=0) then
  30.     c:=0
  31.   else
  32.     if (c=2) then
  33.       c:=7
  34.     else
  35.       c:=c-2;
  36.   i:=#3+chr(ord('0')+c);
  37.   prompt(i);
  38. end;
  39.  
  40. procedure prompt;
  41. var c:integer; cc:char;
  42. begin
  43.   if (not hangup) then
  44.     for c:=1 to length(i) do begin
  45.       if (i[c]=#10) then
  46.         ansic(0);
  47.       write(i[c]);
  48.     end;
  49. end;
  50.  
  51. procedure print(i:str);
  52. begin
  53.   prompt(i+chr(13)+chr(10))
  54. end;
  55.  
  56. function cstr(i:integer):str;
  57. var c:str;
  58. begin
  59.   str(i,c); cstr:=c;
  60. end;
  61.  
  62. procedure nl;
  63. begin
  64.   prompt(chr(13)+chr(10))
  65. end;
  66.  
  67. procedure prt(i:str);
  68. begin
  69.   ansic(4); prompt(i); ansic(0);
  70. end;
  71.  
  72. function empty:boolean;
  73. begin
  74.   rp.ax:=$0b00;
  75.   msdos(rp);
  76.   if (rp.ax and $00ff)=$00 then
  77.     empty:=true
  78.   else
  79.     empty:=false;
  80. end;
  81.  
  82. procedure getkey;
  83. begin
  84.     rp.ax:=$0800;
  85.     msdos(rp);
  86.     c:=chr(rp.ax and $00ff);
  87. end;
  88.  
  89. procedure cls;
  90. begin
  91.   write(chr(12));
  92. end;
  93.  
  94. function yn:boolean;
  95. var c:char;
  96. begin
  97.   if not hangup then begin
  98.     ansic(3);
  99.     repeat
  100.       getkey(c);
  101.       c:=upcase(c);
  102.     until (c='Y') or (c='N') or (c=chr(13)) or hangup;
  103.     if c='Y' then begin print('Yes'); yn:=true; end else begin print('No'); yn:=false; end;
  104.     if hangup then yn:=false;
  105.   end;
  106. end;
  107.  
  108. procedure input1(var i:str; ml:integer; tf:boolean);
  109. var cp:integer;
  110.     c:char;
  111.     r:real;
  112. begin
  113.  checkhangup;
  114.  if not hangup then begin
  115.   cp:=1;
  116.   repeat
  117.     getkey(c);
  118.     if not tf then c:=upcase(c);
  119.     if (c>=' ') and (c<chr(127)) then
  120.       if cp<=ml then begin
  121.       i[cp]:=c;
  122.       cp:=cp+1;
  123.       write(c);
  124.     end else else case ord(c) of
  125.       8:if cp>1 then begin
  126.                c:=chr(8);
  127.                write(#8#32#8);
  128.                cp:=cp-1;
  129.              end;
  130.       21,24:while cp<>1 do begin
  131.                cp:=cp-1;
  132.                write(#8#32#8);
  133.              end;
  134.     end;
  135.   until (c=#13) or (c=#14) or hangup;
  136.   i[0]:=chr(cp-1);
  137.   nl;
  138.  end;
  139. end;
  140.  
  141. procedure input(var i:str; ml:integer);
  142. begin
  143.   input1(i,ml,false);
  144. end;
  145.  
  146. procedure inputl(var i:str; ml:integer);
  147. begin
  148.   input1(i,ml,true);
  149. end;
  150.  
  151. procedure onek(var c:char; ch:str);
  152. begin
  153.   repeat
  154.     getkey(c);
  155.     c:=upcase(c);
  156.   until (pos(c,ch)>0) or hangup;
  157.   if hangup then c:=ch[1];
  158.   print(''+c);
  159. end;
  160.  
  161.  
  162.  procedure wkey(var abort,next:boolean);
  163.  var cc:char;
  164.  begin
  165.     while not (empty or hangup or abort) do begin
  166.       getkey(cc);
  167.       if (cc=' ') or (cc=chr(3)) or (cc=chr(24)) or (cc=chr(11)) then
  168.         abort:=true;
  169.       if (cc=chr(14)) then begin abort:=true; next:=true; end;
  170.       if (cc=chr(19)) or (cc='P') or (cc='p') then begin
  171.         getkey(cc);
  172.       end;
  173.     end;
  174.  end;
  175.  
  176. procedure printa1(i:str; var abort,next:boolean);
  177. var c:integer;
  178. begin
  179.  checkhangup;
  180.  if not hangup then begin
  181.   abort:=false; next:=false; c:=1;
  182.   if not empty then wkey(abort,next);
  183.   while (not abort) and (c-1<length(i)) and (not hangup) do begin
  184.     checkhangup;
  185.     if i[c]=#3 then
  186.       if i[c+1] in [#0..#8] then
  187.         if okansi then
  188.           ansic(ord(i[c+1]));
  189.     if not empty then wkey(abort,next);
  190.     if i[c]=#3 then
  191.       c:=c+1
  192.     else
  193.       write(i[c]);
  194.     c:=c+1;
  195.   end;
  196.  end else abort:=true;
  197. end;
  198.  
  199. procedure printa(i:str; var abort,next:boolean);
  200. var s:str; p,op,rp,rop,nca:integer; crend:boolean;
  201. begin
  202.   abort:=false;
  203.   crend:=(i[length(i)]=#1) and (i[length(i)-1]<>#3);
  204.   if crend then i:=copy(i,1,length(i)-1);
  205.   wkey(abort,next);
  206.   if i='' then nl;
  207.   while (i<>'') and (not abort) and (not hangup) do begin
  208.     rp:=0; nca:=80-wherex-1; p:=0;
  209.     while (rp<nca) and (p<length(i)) do begin
  210.       if i[p+1]=#8 then rp:=rp-1 else
  211.         if i[p+1]=#3 then
  212.           p:=p+1
  213.         else
  214.           if (i[p+1]<>#10) then rp:=rp+1;
  215.       p:=p+1;
  216.     end;
  217.     op:=p; rop:=rp;
  218.     if (rp>=nca) and (p<length(i)) then begin
  219.       while ((not (i[p] in [' ',#8,#10])) or (i[p-1]=#3)) and (p>1) do begin
  220.         rp:=rp-1; p:=p-1;
  221.       end;
  222.       if p=1 then
  223.         if not (i[1] in [' ',#8,#10]) then begin rp:=rp-1; p:=p-1; end;
  224.     end;
  225.     if abs(rop-rp)>=(80 div 2) then p:=op;
  226.     s:=copy(i,1,p); delete(i,1,p);
  227.     if (s[length(s)]=' ') then s[0]:=pred(s[0]);
  228.     printa1(s,abort,next);
  229.     if ((i='') and crend) or (i<>'') or abort then
  230.       nl
  231.     else
  232.       printa1(' ',abort,next);
  233.   end;
  234. end;
  235.  
  236. procedure printacr(i:str; var abort,next:boolean);
  237. begin
  238.  if not abort then
  239.   if i[length(i)]=#1 then
  240.     printa(i,abort,next)
  241.   else
  242.     printa(i+#1,abort,next);
  243. end;
  244.  
  245. procedure pfl(fn:str; var abort:boolean; cr:boolean);
  246. var fil:text;
  247.     i:str;
  248.     next:boolean;
  249. begin
  250.     if not hangup then begin
  251.       assign(fil,fn);
  252.       {$I-} reset(fil); {$I+}
  253.       if ioresult<>0 then print('File not found.') else begin
  254.         abort:=false;
  255.         while not eof(fil) and (not abort) and (not hangup) do begin
  256.           readln(fil,i);
  257.           if cr then
  258.             printacr(i,abort,next)
  259.           else
  260.             printa(i,abort,next);
  261.         end;
  262.         close(fil);
  263.       end;
  264.       nl;nl;
  265.     end;
  266. end;
  267.  
  268. procedure printfile(fn:str);
  269. var abort:boolean;
  270. begin
  271.   pfl(fn,abort,true);
  272. end;
  273.  
  274. procedure iport;
  275. begin
  276.   hangup:=false;
  277. end;
  278.  
  279. procedure topscr;
  280. begin
  281. end;
  282.  
  283.  
  284. procedure start;
  285. var r2:integer;
  286.   begin
  287.   print('Welcome to CompuRate! The computerized woman rating service!');
  288.   print ('Converted to Pascal by Firebird');
  289.   print ('Debugged by Brian Hanson');
  290.   print ('Re-written by Wizard of Aahs 1@7100');
  291.   prt('Name of your girl >');Input(name,32);
  292.   prt('Age >');Input(temp2,2);Val(temp2,age,result);nl;
  293.   r2:=r2+1; Rt := 0;
  294.   end;
  295.  
  296. Procedure q1;
  297. var r2:integer;
  298. begin rt:=0;
  299. nl; print('How is her face?');nl;
  300. print('0>  Full of zits, chubby, craters');
  301. print('1>  A face only a mother could love');
  302. print('2>  Major wart residing on nose');
  303. print('3>  No warts, zits, but lots of black spots');
  304. print('4>  Zits, few black spots');
  305. print('5>  Couple zits, rare black spots');
  306. print('6>  Couple zits, no black spots');
  307. print('7>  Seamly face, rare zit');
  308. print('8>  Beautiful face, very rare zits');
  309. print('9>  Perfect face');nl;
  310. prt('Number > ');OneK(temp,'1234567890');Val(Temp,R2,Result);r2:=r2+1;
  311. rt:=rt+r2;end;
  312.  
  313. Procedure q2;
  314. var r2:integer;
  315. begin cls;print('How is her hair?');nl;
  316. print('0>  What?! That beehive?! Hair?!');
  317. print('1>  What hair? Chorme-dome we call her..');
  318. print('2>  Looks like a worn brillo pad');
  319. print('3>  Too much mousse and hairspray');
  320. print('4>  Too much mousse');
  321. print('5>  Too much hairspray');
  322. print('6>  Stringy, but decent');
  323. print('7>  Perm of some sort, bodywave');
  324. print('8>  Beautifully cared for');
  325. print('9>  Beyond words in perfectness...');nl;
  326. prt('Number > ');OneK(temp,'1234567890');Val(Temp,R2,Result);r2:=r2+1;
  327. rt:=rt+r2;end;
  328.  
  329. procedure q3;
  330. var r2:integer;
  331. begin cls;print('How is her skin?');nl;
  332. print('** Some may not be valid for black women **');
  333. print('0>  White as a ghost');
  334. print('1>  Flappy, flimsy, like my 103 yr old grandmother');
  335. print('2>  Wrinkled like a Shar-pai dog..');
  336. print('3>  Are those hives or some sort of rash?');
  337. print('4>  Blubber');
  338. print('5>  Slightly tanned, but sorta blah..');
  339. print('6>  Tanned, but ok');
  340. print('7>  Not bad..');
  341. print('8>  Typical skin');
  342. print('9>  Perfect!');nl;
  343. prt('Number > ');OneK(temp,'1234567890');Val(Temp,R2,Result);r2:=r2+1;
  344. rt:=rt+r2;end;
  345.  
  346. procedure q4;
  347. var r2:integer;
  348. begin cls;print('And now, how are her legs?');nl;
  349. print('0>  Scabby, flabby, and hairy <canadian?>');
  350. print('1>  Looks like it went through battle');
  351. print('2>  Got some sort of dots or whatever on it');
  352. print('3>  Bristle Mania');
  353. print('4>  THUNDER THIGHS!!!!');
  354. print('5>  Scabs and cuts');
  355. print('6>  Wears stockings but only god knows whats underneath');
  356. print('7>  Eh...');
  357. print('8>  Nice..');
  358. print('9>  Perfect!');nl;
  359. prt('Number > ');OneK(temp,'1234567890');Val(Temp,R2,Result);r2:=r2+1;
  360. rt:=rt+r2;end;
  361.  
  362. procedure q5;
  363. var r2:integer;
  364. begin cls;print('Ok.. how is her ass?');nl;
  365. print('0>  Blub blub blub blub');
  366. print('1>  Round and fat <yuk!>');
  367. print('2>  I dont think she wipes...');
  368. print('3>  Ok, but smells');
  369. print('4>  I think she got hemmorroids');
  370. print('5>  Small, but ok');
  371. print('6>  It''s ok');
  372. print('7>  Veerrrryy Nice!!');
  373. print('8>  NNNggghhh!!!');
  374. print('9>  Perfect!!!');nl;
  375. prt('Number > ');OneK(temp,'1234567890');Val(Temp,R2,Result);r2:=r2+1;
  376. rt:=rt+r2;end;
  377.  
  378. procedure q6;
  379. var r2:integer;
  380. begin cls;print('How are her tits?');nl;
  381. print('0>  What tits?');
  382. print('1>  Mosquito bites');
  383. print('2>  Peas on end');
  384. print('3>  Not even begun to form..');
  385. print('4>  You can tell she has kids');
  386. print('5>  Lemons');
  387. print('6>  Oranges');
  388. print('7>  Decent sized');
  389. print('8>  Bigger than normal');
  390. print('9>  More than a handfull <2 handfulls that is..>');nl;
  391. prt('Number > ');OneK(temp,'1234567890');Val(Temp,R2,Result);r2:=r2+1;
  392. rt:=rt+r2;end;
  393.  
  394. procedure q7;
  395. var r2:integer;
  396. begin cls;
  397.     print('How is her figure?');nl;
  398.     print('0>  Well, if you like balloons, ok..');
  399.     print('1>  Looks like a whale');
  400.     print('2>  No figure');
  401.     print('3>  Round. Plump. Perfect for roasting.');
  402.     print('4>  A little chubby, but ok');
  403.     print('5>  Skinny as hell. SuperStick.');
  404.     print('6>  Some parts good, some parts bad');
  405.     print('7>  Ok...');
  406.     print('8>  Humina');
  407.     print('9>  NNNggghhh!!!');nl;
  408.     prt('Number > ');
  409.     OneK(temp,'1234567890');
  410.     Val(Temp,R2,Result);r2:=r2+1;rt:=rt+r2; end;
  411.  
  412. procedure q8;
  413. var r2:integer;
  414. begin cls;
  415.     print('How is her voice?'); nl;
  416.     print('1>  Terrible');
  417.     print('2>  Crackly');
  418.     print('3>  Ehh..');
  419.     print('4>  Ok..');
  420.     print('5>  Very sexy!');nl;
  421.     prt('Number > ');
  422.     OneK(temp,'12345');
  423.     Val(Temp,R2,Result);
  424.   rt:=rt+(r2*2);
  425. end;
  426.  
  427. procedure q9;
  428. var r2:integer;
  429. begin cls;
  430.     print('What is your relationship with her?');nl;
  431.     print('1>  Stranger');
  432.     print('2>  Sister');
  433.     print('3>  Co-worker');
  434.     print('4>  Girlfriend');
  435.     print('5>  Wife');nl;
  436.     prt('Number > ');
  437.     OneK(temp,'12345');
  438.     Val(Temp,R2,Result);
  439.   rt:=rt+(r2*2);
  440. end;
  441.  
  442. procedure q10;
  443. var r2:integer;
  444. begin cls;
  445.     print('When you see her, do you...'); nl;
  446.     print('1>  Turn away and yak on the ground');
  447.     print('2>  Look for a little, but then yak');
  448.     print('3>  Just look');
  449.     print('4>  Look and daydream');
  450.     print('5>  Cream your jeans');nl;
  451.     prt('Number > ');
  452.     OneK(temp,'12345');
  453.     Val(Temp,R2,Result);
  454.   rt:=rt+(r2*2);
  455. end;
  456.  
  457. Procedure finish;
  458. begin
  459.   nl;
  460.   print('Name > '+name);
  461.   print('Age  > '+cstr(age));
  462.   print('Rate > '+cstr(rt)+'%');
  463. end;
  464.  
  465. procedure return;
  466. begin
  467. print('Now returning to Gamers! BBS...');
  468. end;
  469.  
  470. Begin
  471.   iport;
  472.   checkhangup;
  473.   if hangup then return;
  474.   start;q1;q2;q3;q4;q5;q6;q7;q8;q9;q10;finish;return;
  475. End.