c---
c---   Blackjack 
c---
c---
c---   Warning
c---   =======
c---   Official black jack program. This program is to be used for
c---   recreational purpose only. The authors assume no responsibility
c---   for any misuse of this program.
c---
c---   Programmers:
c---                     Jim Sauer & Kris Lakshmanan
c---                     Chemical Engineering Department
c---                     Ohio State University
c---                     140 W 19 Avenue
c---                     Columbus, OH 43210
c---
c---   Hardware requirement:   VT100 (advanced video is optional)
c---
c---   Program notes:
c---   ==============
c---   This is a one player game against the house. Modifications to
c---   handle multiple players and multiple card decks are being
c---   considered. If any of the users make changes to this program
c---   the authors would like to know about it.
c---
c---   Cards are drawn at random through a random number
c---   generator. After 40 cards are dealt the deck is reshuffled.
c---   The rules are essentially the same as in casinos except that
c---   tied score is counted as a tie. Upto six cards could be drawn
c---   by the better.
c---
c---   The program keeps track of vital statistics using ISAM database.
c---   Changes are required in the open statement in subroutine stat_open
c---   for disk and directory reference. The users are identified by
c---   their usernames to avoid the possibility of double identification.
c---
c---   Subroutines required:
c---   =====================
c---    All but one subroutine are included below the main program, 
c---    The missing one is subroutine USERNAMES, which is coded in
c---    macro32. The routine is included in the directory.
c---
c---    The routine CHECKUSER checks for user group UIC for authorized
c---    group access. We had this check so that only graduate, faculty
c---    and staff accounts could join the club. The routine is very
c---    similar to the one above, except it gets the UIC numbers. 
c---    It exits if users are of unauthorized group.
c---
	include '($libclidef)'			
	include 'black.prm'			!common block parameters
	integer pcard
	character*20 cardi(10),cardj(10),card,ans,buried,hors,horss
	character*80 message, mess(10)
	character*2 bell
	parameter(bell=char(07)//char(07))
	common num_card
	mess(1)='black jack, you win 15.'
	mess(2)='black jack, I win 15.'
	mess(3)='we both have black jack, we tie.'
	mess(4)='21 or less in five cards, you win 20.'
	mess(5)='you busted, I win 10.'
	mess(6)='I busted, you win 10.'
	mess(7)='I must stick, you win 10.'
	mess(8)='I win 10.'
	mess(9)='we tie'
	mess(10)='21 or less in six cards, you win 30.'

c---	
c---	optional subroutine call to check for authorized user
c---    group UIC. This is a nice feature to enable only
c---    graduate students to play the game. (disable if needed)
c---
	call checkuser			! check for valid users

	call lib$erase_page(1,1)
	call lib$put_screen(' ChE Black Jack (why aren''t you working
	1 on your research?) ',1,8,2)

	call checkname			! get username

	call lib$put_screen('Do you need directions (Y or N)? ',3,1)
	read(5,1000)ans
	if(ans.eq.'y' .or. ans.eq.'Y')then
	call lib$erase_page(2,1)
	call lib$set_cursor(3,1)
	type *,'  Standard Black Jack rules:  the dealer must hit if 16 or'
	type *,'less and must stick if 17 or greater.  The scoring is as'
	type *,'follows.'
	type *,' '
	type *,' 10 for win, -10 for lose, 0 for tie'
	type *,' 15 for win by Black Jack, -15 for lose by Black Jack'
	type *,' 20 for less than 21 in five cards'
	type *,' 30 for less than 21 in six cards'
	type *,' '
	type *,'<RETURN> to play '
	read(5,1000)ans
	call lib$erase_page(2,1)
	endif

	call stat_show

	call lib$put_screen('How much money can you afford to lose
	1 ($200 maximum please)?',3,1)
35	call lib$erase_line(3,62)
	call lib$set_cursor(3,62)
	read(5,*,err=35)score
	if(score.lt.0)goto 35

	if(score.gt.200)then			!set betting limit of $200
	call lib$erase_page(1,1)
	call lib$put_screen(' You''re too rich for my blood!! ',3,10,6)
	call lib$set_cursor(23,1)
	stop ' '
	endif

c---
c---	Disable Control_Y to take care of exit once the game has started.
c---    Club rules are the game should be played till the deck is
c---    reshuffled. Control_Y input is taken as a hit.
c---
	iostat=lib$disable_ctrl(lib$m_cli_ctrly,)
	call ctrlc_exit

	sscore=score
	call lib$erase_page(2,1)
	
	z=secnds(0.0)
	i=int(z)
	y=ran(i)
c
c	set time to zero
c
	call timestart

c---new deck of cards
60	kdeal=1
	call deal(i,kdeal,kkcard,pcard,card,kkace)
	if(pcard.eq.11)goto 60
	call lib$put_screen('The cards have been shuffled and the top
	1 card which is buried is the',3,3)
	call lib$put_screen(card,4,3)
	kdeal=0
	num_card=0


c---start new hand

40	do m=6,22
	call lib$erase_line(m,1)
	enddo
	call lib$put_screen('  NEW HAND  ',6,30)
	call lib$put_screen('--dealer--',8,10)
	call lib$put_screen('--you--',8,51)

c	call lib$set_cursor(23,1)

	do kkk=1,10
	cardi(kkk)=' '
	cardj(kkk)=' '
	enddo
	itotal=0
	jtotal=0
	iace=0
	jace=0
	ijack=0
	istick=0
	message=' '
	hors= ' '
	numi=0
	numj=0
	iscore=0

c---deal cards

14	numi=numi+1
	call deal(i,kdeal,icard,pcard,card,iace)
	cardi(numi)=card
	itotal=itotal+pcard
	call ace(itotal,iace)
	if(numi.gt.2)goto 67

15	numj=numj+1
	call deal(i,kdeal,jcard,pcard,card,jace)
	cardj(numj)=card
	jtotal=jtotal+pcard
	call ace(jtotal,jace)

	if(numj.lt.2)goto 14

C---messages if black jack

	if(numj.eq.2)then

		if(itotal.eq.21)then
		message=mess(1)
		iscore=15
		endif
			if(jtotal.eq.21)then
			message=mess(2)
			iscore=-15
			endif
	
	if(itotal.eq.21 .and. jtotal.eq.21)then
	message=mess(3)
	iscore=0
	endif

	if(message.ne.' ')ijack=1

	endif

c---message if player busts
	
67			if(itotal.ge.22)then
			message=mess(5)
			iscore=-10
			endif


c---show cards

	kmax=jmax0(numi,numj)

	buried='**down**'
	call lib$erase_line(9,1)
	call lib$put_screen(buried,9,10)
	call lib$put_screen(cardi(1),9,50)

	do n=2,kmax
	nn=n+8
	call lib$put_screen(cardj(n),nn,10)
	call lib$put_screen(cardi(n),nn,50)
	enddo

	if(ijack.eq.1)goto 63
	if(message.eq.mess(5))goto 64

c---ask for hit or stick

		if(istick.eq.0) then
	call lib$erase_line(20,1)
	call lib$put_screen('Hit or Stick (H or S)? ',19,3)
	read(5,1000)hors
	if(hors.eq.'s' .or. hors.eq.'S') istick=1
	call lib$erase_line(19,1)
	call lib$erase_line(3,1)
	call lib$erase_line(4,1)
	call lib$erase_line(6,1)
		endif


c---five cards and 21 or under
	if(numi.eq.5 .and. istick.eq.1)then
	message=mess(4)
	iscore=20
	endif

c---six cards and 21 or under
	if(numi.eq.6)then
	message=mess(10)
	iscore=30
	endif

	if(iscore.eq.20 .or. iscore.eq.30)goto 64

	if(istick.eq.0)goto 14

	if(jtotal.ge.22)then
	message=mess(6)
	iscore=10
	endif

	do mm=1,4
	if(jtotal.ge.17 .and. jace.gt.0
	1 .and. jtotal.lt.itotal)then
	jtotal=jtotal-10
	jace=jace-1
	endif
	enddo

	if(jtotal.ge.17 .and. jtotal.le.21 .and. jtotal.lt.itotal)
	1	then
	message=mess(7)
	iscore=10
	endif

	if(jtotal.ge.17 .and. jtotal.le.21 .and. jtotal.gt.itotal)
	1	then
	message=mess(8)
	iscore=-10
	endif

	if(jtotal.ge.17 .and. jtotal.le.21 .and. jtotal.eq.itotal)
	1	message=mess(9)

	if(message.eq.' ')goto 15

63	if(message.ne.mess(1))then
	call lib$erase_line(9,1)
	call lib$put_screen(cardj(1),9,10)
	call lib$put_screen(cardi(1),9,50)
	endif

	if(ijack.eq.1)	call lib$put_output(bell)

64	if(iscore.gt.0)then
	call lib$erase_line(8,1)
	call lib$put_screen(' --dealer-- ',8,9)
	call lib$put_screen(' --you-- ',8,50,6)
	else if (iscore.lt.0)then
	call lib$erase_line(8,1)
	call lib$put_screen(' --dealer-- ',8,9,6)
	call lib$put_screen(' --you-- ',8,50)
	else
	call lib$erase_line(8,1)
	call lib$put_screen(' --dealer-- ',8,9,6)
	call lib$put_screen(' --you-- ',8,50,6)
	endif
	
	call lib$set_cursor(23,1)
	write(6,3500) sscore
3500	format('+',t58,i5)
	call lib$set_cursor(24,1)
	score=score+iscore
	write(6,3600) score
3600	format('+',t57,i5)
	call lib$put_screen('starting amount: $',23,40)
	call lib$put_screen('present amount: $',24,40)
	
	call lib$erase_line(19,1)
	message=' '//message
	call count (message,num)
	call lib$put_screen(message(1:num+1),20,1,2)

	if(score.le.0)then
	call lib$erase_line(24,1)	
	call lib$put_screen(' ********** YOU''RE BROKE *********** ',24,
	1 32,6)
	call timestop(sec)
	call stat_end(sec)
	call stat_show
	call lib$set_scroll(1,24)
	iostat=lib$enable_ctrl(lib$m_cli_ctrly,)
	stop ' '
	endif

	call lib$put_screen('<RETURN> to continue ',20,num+3)

	read(5,1000)ans
	
	if(num_card.le.40)goto 40

	call lib$put_screen('Do you want to continue (Y or N)? ',22,1)
	read(5,1000)ans
	call lib$erase_line(22,1)

	if(ans.eq.'n' .or. ans.eq. 'N') then
	call lib$erase_page(2,1)
		if(score.gt.sscore)then
	call lib$put_screen(' You were lucky this time ',2,24,4)
	else
	call lib$put_screen(' Thanks for your contribution ',2,22,4)
	endif

	call timestop(sec)
	call stat_end(sec)
	call stat_show
	call lib$set_scroll(1,24)
	iostat=lib$enable_ctrl(lib$m_cli_ctrly,)

	stop ' '
	endif

	goto 60

1000	format(a)
2000	format(t20,20a,10x,20a)
3000	format(t2,a)
	end
	

	subroutine ace(ktotal,kace)
		do ii=1,4
			if(ktotal.ge.22 .and. kace.ge.1) then
			kace=kace-1
			ktotal=ktotal-10
			endif
		enddo
	return
	end

	subroutine deal(i,kdeal,kcard,pcard,card,kace)
	integer pcard
	character card*20
	common num_card
	dimension krepeat(52)

	num_card=num_card+1

c---shuffle the cards
		if(kdeal.eq.1) then
		do init=1,52
		krepeat(init)=0
		enddo
		endif




10	y=RAN(i)
	vcard=y*52.

		do kcard=1,52
			if(vcard.le.float(kcard))then

c---do not pick a card that has already been picked
				do kk=1,kcard
				if(krepeat(kk).eq.kcard)goto 10
				enddo
			krepeat(kcard)=kcard
			call match(kcard,pcard,card,kace)
			return
			endif
		enddo
	end


	subroutine match(kcard,pcard,card,kace)
	integer pcard
	character*20 card

	if(kcard.ge.40)then
	card='spades'
	kkcard=kcard-39
		else if(kcard.ge.27)then
		card='hearts'
		kkcard=kcard-26
			else if(kcard.ge.14)then
			card='diamonds'
			kkcard=kcard-13
				else 
				card='clubs'
				kkcard=kcard
	endif

		if(kkcard.eq.13)then
		card='king '//card
		pcard=10
	else if(kkcard.eq.12)then
	card='queen '//card
	pcard=10
		else if(kkcard.eq.11)then
		card='jack '//card
		pcard=10
	else if(kkcard.eq.10)then
	card='10 '//card
	pcard=10
		else if(kkcard.eq.9)then
		card='9 '//card
		pcard=9
	else if(kkcard.eq.8)then
	card='8 '//card
	pcard=8
		else if(kkcard.eq.7)then
		card='7 '//card
		pcard=7
	else if(kkcard.eq.6)then
	card='6 '//card
	pcard=6
		else if(kkcard.eq.5)then
		card='5 '//card
		pcard=5
	else if(kkcard.eq.4)then
	card='4 '//card
	pcard=4
		else if(kkcard.eq.3)then
		card='3 '//card
		pcard=3
	else if(kkcard.eq.2)then
	card='2 '//card
	pcard=2
		else if(kkcard.eq.1)then
		card='ace '//card
		pcard=11
		kace=kace+1
	endif

	return
	end

	subroutine checkname
	include 'black.prm'
c
c	subroutine to check for new user
c
c	get username from $GETJPI
c
	call usernames(-1,%ref(uname))
c
c	check for new user
c
	call stat_open
	read(unit=23,keyeq=uname,keyid=0,err=10)
	1 username,tms_play,tot_hrs,tot_bets,tot_loss
	call stat_close
	return
c
c	add new user to statistics file
c
10	tms_play=0
	tot_hrs=0.0
	tot_bets=0
	tot_loss=0
	write(unit=23)uname,tms_play,tot_hrs,tot_bets,tot_loss
	iflag=1
	call stat_close
	return
	end	

	subroutine stat_open
	character fname*(*)
	include 'black.prm'
c
c	subroutine to open statistics file. Make necessary
c       changes in the disk name and directory assignments.
c
	parameter (fname='che1:[games]black.bin')
	open(unit=23,file=fname,status='unknown',shared,
	1    organization='indexed',recordtype='variable',
	2    form='unformatted',access='keyed',recl=40,
	3    key=(1:12:character))
c
	iopen=1
	return
	end

	subroutine stat_close
	include 'black.prm'
c
c	subroutine to close the statistics file
c
	close(unit=23)
	iopen=0
	return
	end


	subroutine stat_end(sec)
c
c	subroutine to update statistics
c
	include 'black.prm'
c
	call stat_open
	read(unit=23,keyeq=uname,keyid=0,err=99)
	1    username,tms_play,tot_hrs,tot_bets,tot_loss
c
c	update stats
c
	elps_time = sec/3600.
	tot_hrs = tot_hrs + elps_time
	tms_play = tms_play + 1
	tot_bets = tot_bets + sscore
	tot_loss = tot_loss + (score - sscore)
c
	rewrite(unit=23)
	1    username,tms_play,tot_hrs,tot_bets,tot_loss
	call stat_close
	
c
99	return
	end	


	subroutine stat_show
c
c	subroutine to display statistics
c
	include 'black.prm'
	character*1 ans
c
	call lib$put_screen
	1 ('Do you want to display the statistics (Y or N)? ',21,1)
	read(5,10)ans
10	format(a)
	if(ans.eq.'y' .or. ans.eq.'Y')then
c
	call lib$erase_page(2,1)
	call lib$put_screen(' Username ',3,1,2)
	call lib$put_screen(' Games Played ',3,14,2)
	call lib$put_screen(' Hrs. Played ',3,29,2)
	call lib$put_screen(' Total Bets ',3,43,2)
	call lib$put_screen(' Total Winnings ',3,56,2)
	call lib$set_scroll(4,24)

	call stat_open
	call lib$set_cursor(4,1)
20	read(unit=23,end=99)
	1 username,tms_play,tot_hrs,tot_bets,tot_loss
c
	write(6,25)username,tms_play,tot_hrs,tot_bets,tot_loss
	goto 20
c
25	format(1x,a,t13,i10,t29,f10.2,t43,i10,t58,i10)
c
99	type *,'<RETURN> '
	read(5,1000)ans
	call lib$erase_page(2,1)
	else
	call lib$erase_line(21,1)
	endif
c
1000	format(a)
	return
	end

	subroutine timestart
	common/timer/t1
	t1=secnds(0.0)
	return
	end
	subroutine timestop(sec)
	common/timer/t1
	sec=secnds(t1)
	return
	end

	subroutine ctrlc_exit
c
	integer*4 tt_chan,sys$qiow,sys$assign,ctrlc_ctrly
	external ctrlc_msg
	include '($IODEF)'
	parameter (ctrlc_ctrly=io$m_ctrlcast+io$m_ctrlyast)
c
	istat=sys$assign('tt',tt_chan,,)
	istat=sys$qiow(,%val(tt_chan),%val(io$_setmode.or.ctrlc_ctrly),
	1              ,,,ctrlc_msg,,%val(3),,,)
	return
	end

	subroutine ctrlc_msg
	call ctrlc_exit
	return
	end