123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556 |
- { Softporn Adventure, include file # 2 }
- function locase( c : char ) : char;
- (*===============================*)
- begin
- case c of
- 'A'..'Z': c := chr( ord(c) + $20 );
- '�': c := '†';
- 'Ž': c := '„';
- '™': c := '”';
- end;
- locase := c;
- end;
- procedure read_key ( var ch : char; cset : set_of_char );
- (*=====================================================*)
- var ch_up : char;
- begin
- repeat
- read( kbd, ch );
- ch_up := upcase(ch);
- if ch_up in cset then
- writeln( ch )
- else
- write(#7);
- until ch_up in cset;
- ch := ch_up;
- end; { Read key }
- procedure write_long_messg( messg_no : integer );
- (*=============================================*)
- const EOL = #$0D;
- NULL = #0;
- var i, j : integer;
- c : char;
- begin
- seek( messg_file, messg_no-1 );
- read( messg_file, messg_rec );
- for i:=1 to recsize-1 do
- begin
- c := messg_rec[i];
- if c=EOL then
- writeln
- else if c>=' ' then
- begin
- write(pred(c));
- if messg_no in [39,58,69] then
- delay(150);
- end;
- end; { for i=1 to recsize-1 do }
- end; { Write long messg }
- procedure write_long_message( messg_no : integer );
- (*===============================================*)
- begin
- writeln;
- write_long_messg( messg_no );
- end; { Write long message }
- procedure write_message( message : messg_string );
- (*==============================================*)
- begin
- writeln;
- writeln(message);
- end;
- procedure wait_for_space;
- (*=====================*)
- var c : char;
- begin
- write(' Press <SPACE> to continue ');
- repeat
- read(kbd,c);
- if c<>' ' then write(#7);
- until c=' ';
- end;
- procedure cursor_to_bottom;
- (*=======================*)
- begin
- gotoXY(1,bottom_line);
- end;
- procedure cursor_next_to_bottom;
- (*============================*)
- begin
- gotoXY(1,bottom_line-1);
- end;
- procedure give_help;
- (*================*)
- var message : integer;
- begin
- clrscr;
- writeln;
- writeln;
- for message:=70 to 72 do
- write_long_messg( message );
- writeln;
- wait_for_space;
- clrscr;
- cursor_to_bottom;
- end;
- procedure look_graffiti;
- (*====================*)
- var message : integer;
- begin
- clrscr;
- for message:=59 to 62 do
- begin
- write_long_messg( message );
- end;
- wait_for_space;
- clrscr;
- cursor_to_bottom;
- end; { Look graffiti }
- procedure purgatory;
- (*================*)
- var choice, door : integer;
- c : char;
- begin
- delay(700);
- door := 0;
- repeat
- if door=0 then
- write_long_message( 65 )
- else
- begin
- writeln;
- writeln('You''re still here!');
- writeln;
- end;
- write('Choose your door: 1, 2 or 3?? ');
- read_key( c, ['1'..'3'] );
- choice := ord(c) - ord('0');
- door := ( random(3) + choice ) mod 3;
- game_position.game_ended := door=1;
- until door<>2;
- end; { Purgatory }
- procedure bum_tells_story;
- (*======================*)
- var i,j : integer;
- begin
- writeln;
- writeln('He looks at me and starts to speak:');
- delay(400);
- write_long_message( 39 );
- writeln;
- delay(300);
- for i:=0 to 128 do
- begin
- for j:=1 to i do
- write(' ');
- writeln('Like I did!!');
- end;
- for i:=1 to 5 do
- writeln;
- delay(500);
- writeln('He throws up and gives me back the bottle of wine.');
- writeln;
- end; { Bum tells story }
- procedure watch_TV ( var TV_channel : integer );
- (*============================================*)
- var ch : char;
- begin
- repeat
- write('Which channel? (1-9) ');
- read_key( ch, ['1'..'9'] );
- TV_channel := ord(ch) - ord('0');
- write_long_message( 40 + TV_channel );
- writeln;
- write('Change the channel? (y/n) ');
- read_key( ch, ['Y','N'] );
- until ch='N';
- end; { Watch TV }
- procedure wine_in_taxi;
- (*===================*)
- begin
- write_long_message( 58 );
- delay(500);
- writeln;
- write('What shall I do? ');
- delay(1000);
- writeln;
- writeln;
- writeln('The idiot cab driver backs over me and kills me!!!!!!');
- purgatory;
- end; { Wine in taxi }
- procedure stab_someone;
- (*===================*)
- begin
- writeln;
- writeln('OK - warmonger!');
- delay(1000);
- writeln('Parry!!');
- delay(500);
- writeln('Thrust!!!');
- delay(1000);
- writeln('I just got myself!!');
- purgatory;
- end; { Stab }
- procedure falling_down;
- (*===================*)
- var i : integer;
- begin
- for i:=1 to 50 do
- writeln('Aaaaaeeeeeiiiiiiii!!!!!!!!');
- delay(300);
- writeln('Splaaatttttt!!!!!');
- if game_position.verb<>jump then
- begin
- delay(500);
- writeln;
- writeln('I should have used safety rope!!!!!!!!');
- end;
- purgatory;
- end; { Falling down }
- procedure play_slot( var money : integer );
- (*=======================================*)
- const slot : array[0..4] of char = ( '!', '#', '*', '$', '^' );
- slot_figs = 5;
- var answer : char;
- i, x1, x2, x3 : integer;
- begin
- writeln;
- writeln('This will cost $100 each time');
- repeat
- randomize;
- write('You have $',money,'00. Would you like to play? (y/n) ');
- read_key( answer, ['Y','N'] );
- if answer='Y' then
- begin
- for i:=1 to 30 do
- begin
- x1 := random(slot_figs);
- x2 := random(slot_figs);
- x3 := random(slot_figs);
- delay(30);
- write( #13, slot[x1]:1, slot[x2]:5, slot[x3]:5 );
- end;
- writeln;
- if (x1=x2) and (x2=x3) then
- begin
- writeln('Triples!!!!!! You win $1500');
- money := money + 15;
- end
- else if (x1=x2) or (x2=x3) or (x3=x1) then
- begin
- writeln('A pair! You win $300');
- money := money + 3;
- end
- else
- begin
- writeln('You lose!');
- money := money - 1;
- end;
- end;
- until (money<1) or (answer='N');
- writeln;
- if money<1 then
- begin
- writeln('I''m broke!!! -- that means death!!!!!!!');
- purgatory;
- end;
- end; { Play slot }
- procedure play_21( var money : integer );
- (*=====================================*)
- const card_name : array[1..13] of string[7]
- = ( 'an Ace', 'a 2', 'a 3', 'a 4', 'a 5', 'a 6', 'a 7',
- 'an 8', 'a 9', 'a 10', 'a Jack', 'a Queen', 'a King' );
- delay_21 = 400;
- var answer : char;
- dollars, code, mi, md, yd, ym, ad, am, a, y, z, ac, i : integer;
- answer_ok, game_over : boolean;
- dollar_string, doll_00 : string[20];
- card : string[7];
- procedure deal_card;
- (*----------------*)
- begin
- z := random(13) + 1;
- y := 0;
- ac := 0;
- card := card_name[z];
- if z>10 then z := 10;
- if z=1 then z := 11;
- if z>9 then y := 1;
- if z=11 then ac := 1;
- end;
- procedure check;
- (*------------*)
- begin
- if (md>21) and (ad>0) then
- begin
- ad := ad - 1;
- md := md - 10;
- end;
- delay(delay_21);
- writeln('The dealer has ',md);
- if md<17 then
- a := 6
- else if (md>21) or (mi>md) then
- begin
- delay(delay_21);
- writeln('You win!!');
- money := money + dollars;
- game_over := true;
- end
- else if mi<md then
- begin
- delay(delay_21);
- writeln('You lose!');
- money := money - dollars;
- game_over := true;
- end
- else {if mi=md then}
- begin
- delay(delay_21);
- writeln('Tie!');
- game_over := true;
- end;
- end;
- procedure check_hit;
- (*----------------*)
- begin
- if (mi>21) and (am>0) then
- begin
- am := am - 1;
- mi := mi - 10;
- end;
- delay(delay_21);
- writeln('Your total is ',mi,'.');
- if mi>21 then
- begin
- delay(delay_21);
- writeln('Busted!');
- money := money - dollars;
- game_over := true;
- end
- else if (ym=2) and (mi=21) then
- begin
- delay(delay_21);
- writeln('You''ve got a ***BLACKJACK***');
- money := money + dollars + dollars;
- game_over := true;
- end
- else if (yd=2) and (md=21) then
- begin
- delay(delay_21);
- writeln('The dealer has a ***BLACKJACK***');
- money := money - dollars;
- game_over := true;
- end
- else
- begin
- delay(delay_21);
- write('Would you like a hit? (y/n) ');
- read_key( answer, ['Y','N']);
- if answer='N' then check;
- end;
- end;
- begin
- writeln;
- repeat
- randomize;
- mi := 0;
- md := 0;
- yd := 0;
- ym := 0;
- ad := 0;
- am := 0;
- repeat
- answer_ok := false;
- write('You have $',money,'00. How many dollars would you like to bet? ');
- readln(dollar_string);
- repeat
- i := pos( ' ', dollar_string);
- if i>0 then delete( dollar_string, i, 1 );
- until i=0;
- i := length(dollar_string);
- if i>2 then
- begin
- doll_00 := copy( dollar_string, i-1, 2 );
- delete( dollar_string, i-1, 2 );
- end
- else
- begin
- doll_00 := dollar_string;
- dollar_string := '';
- end;
- val( doll_00, dollars, code );
- if code=0 then val( dollar_string, dollars, code );
- if (code<>0) or (dollars<=0) then
- writeln('Huh?')
- else if doll_00 <> '00' then
- writeln('$100 increments only!!')
- else if dollars > money then
- writeln('You don''t have that much!!!')
- else
- answer_ok := true;
- until answer_ok;
- a := 1;
- game_over := false;
- repeat
- deal_card;
- delay(delay_21);
- case a of
- 1,3 : begin
- mi := mi + z;
- writeln('You''re dealt ',card);
- ym := ym + y;
- am := am + ac;
- a := a + 1;
- end;
- 2 : begin
- md := md + z;
- writeln('The dealer gets a card down');
- yd := yd + y;
- ad := ad + ac;
- a := a + 1;
- end;
- 4 : begin
- md := md + z;
- writeln('The dealer gets ',card);
- a := 5;
- ad := ad + ac;
- yd := yd + y;
- check_hit;
- end;
- 5 : begin
- mi := mi + z;
- writeln('You get ',card);
- am := am + ac;
- check_hit;
- end;
- 6 : begin
- md := md + z;
- writeln('The dealer gets ',card);
- ad := ad + ac;
- check;
- end;
- end;
- until game_over;
- if money<1 then
- begin
- writeln('You''re out of money!!! So long!!!!!!!!!!');
- purgatory;
- end
- else
- begin
- write('Play again?? (y/n) ');
- read_key( answer, ['Y','N'] );
- end;
- until (answer='N') or (money<1);
- end; { Play 21 }
- procedure buy_rubber;
- (*=================*)
- var answer : char;
- i : integer;
- begin
- with game_position do
- begin
- rubber_lubricated := 'non-lubricated';
- rubber_ribbed := 'non-ribbed';
- writeln;
- writeln('The man leans over the counter and whispers:');
- write('What color? '); readln(rubber_color);
- for i:=1 to length(rubber_color) do
- rubber_color[i] := locase(rubber_color[i]);
- write('And for a flavor? '); readln(rubber_flavor);
- for i:=1 to length(rubber_flavor) do
- rubber_flavor[i] := locase(rubber_flavor[i]);
- write('Lubricated or not? (y/n) ');
- read_key( answer, ['Y','N'] );
- if answer='Y' then delete( rubber_lubricated, 1, 4 );
- write('Ribbed? (y/n) ');
- read_key( answer, ['Y','N'] );
- if answer='Y' then delete( rubber_ribbed, 1, 4 );
- writeln('He yells -- This pervert just bought a ',rubber_color,', ');
- writeln(rubber_flavor,'-flavored, ',rubber_lubricated,', ',
- rubber_ribbed,' rubber!!!!');
- writeln('A lady walks by and looks at me in disgust!!!!');
- writeln;
- end;
- end; { Buy rubber }
- procedure OK;
- (*=========*)
- begin
- write_message('OK');
- end;
- procedure _open( var object_open : boolean );
- (*=========================================*)
- begin
- if object_open then
- write_message('It''s already open!!')
- else
- begin
- OK;
- object_open := true;
- end;
- end;
- procedure _close( var object_open : boolean );
- (*=========================================*)
- begin
- if not object_open then
- write_message('It''s already closed!!')
- else
- begin
- OK;
- object_open := false;
- end;
- end;
|