ASP Mystic Card Trick

				
'**************************************
' Name: ASP Mystic Card Trick
' Description:Popular web card trick, but the deck is truly shuffled on each turn.
' By: jedijedi
'
' Inputs:Select a column (pile).
'
' Returns:Three piles of seven cards.
'
' Assumes:Just call the ASP function 'funPack'.
'
' Side Effects:May include images for better effect.
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=6369&lngWId=4'for details.'**************************************

<%
' Jack Spades' Mystic Card
Response.Buffer = true 
Response.Expires = 0
randomize ' pick any number
dim iCard(52) ' poker size
sPack=Request.QueryString("fPack")
sCol=Request.QueryString("fCol")
sTurn=Request.QueryString("fTurn")
	
function funPack
	' let's go
	sOut=""
	if not sTurn="" then
		if sTurn="1" then
			' new deck & pack
			subFreshDeck
			subShuffleDeck
			subMakePack
		else
			subMakeDeck
			subShiftDeck(sCol)
			subMakePack
		end if
		sTurn=sTurn+1
	end if
	if sTurn=5 then
		' finally
		sTurn=""
		sOut=sOut & "<p>Your card must be the "
		sOut=sOut & funCard(1)
		sOut=sOut & "</p>"
		sOut=sOut & "<hr><p><a href='default.asp'>Show me again!</a></p>"
	else
		' patter selection & deal
		select case sTurn
			case ""
				sOut=sOut & "<hr><p><a href='default.asp?fTurn=1'>Let's go!</a></p>"
			case "2"
				sOut=sOut & "<p>With the deck shuffled, find a card you like and remember it.</p>"			
			case "3"
				sOut=sOut & "<p>Again, please locate your card.</p>"						
			case "4"
				sOut=sOut & "<p>And just to make sure, once more.</p>"									
		end select
		if not sTurn="" then
			sOut=sOut & funGrid(3,7)	
		end if
	end if
	funPack=sOut
end function
	
sub subFreshDeck
	' like taking the celophane off
	for i=1 to 52
		iCard(i)=i
	next
end sub
sub subShuffleDeck	
	' no flourishes mix
	for i=1 to 52
		j=int(rnd*52)+1
		k=iCard(i)
		m=iCard(j)
		iCard(i)=m
		iCard(j)=k
	next
end sub
sub subMakeDeck
	' get cards from pack string
	for i=1 to 52
		iPos=(i*2)-1
		n=mid(sPack,iPos,2)
		iCard(i)=n
	next
end sub
sub subMakePack
	' set pack in to string array
	sPack=""
	for i=1 to 52
		j=iCard(i)
		if len(j)=1 then
			sInd="0" & j
		else
			sInd=right(j,2)
		end if
		sPack=sPack & sInd
	next
end sub
sub subShiftDeck(iCol)
	' a bit of hocus pocus
	' pick up selected column
	dim iCard2(52)
	dim iSet(3)
	select case iCol
		case 1
			iSet(1)=1
			iSet(2)=2
			iSet(3)=3
		case 2
			iSet(1)=2
			iSet(2)=1
			iSet(3)=3
		case 3
			iSet(1)=3
			iSet(2)=1
			iSet(3)=2		
	end select
	for i=1 to 52
	iCard2(i)=iCard(i)
	next
	' restack from dummy deck
	j=1
	for c=1 to 3
		b=iSet(c)
		for i=b to b+18 step 3
			iCard2(j)=iCard(i)
			j=j+1
		next
	next
	for i=1 to 52
		iCard(i)=iCard2(i)
	next
end sub
function funCard(iPos)
	' reveal at postion
	iPoi=(iPos*2)-1
	sKey=mid(sPack,iPoi,2)
	iInd=1
	iKey=1
	iKey=cint(sKey)
	if iKey<14 then
		iInd2=iKey
		sSuit="<font face='Arial' color='red'>Hearts</font>"			
	elseif iKey<27 then
		iInd2=iKey-13
		sSuit="<font face='Arial' color='red'>Diamonds</font>"		
	elseif iKey<40 then
		iInd2=iKey-26
		sSuit="<font face='Arial' color='black'>Clubs</font>"		
	else
		iInd2=iKey-39
		sSuit="<font face='Arial' color='black'>Spades</font>"		
	end if
	select case iInd2
		case 1
			sIndex="Ace"
		case 2
			sIndex="Two"
		case 3
			sIndex="Three"
		case 4
			sIndex="Four"
		case 5
			sIndex="Five"
		case 6
			sIndex="Six"
		case 7
			sIndex="Seven"
		case 8
			sIndex="Eight"
		case 9
			sIndex="Nine"
		case 10
			sIndex="Ten"
		case 11
			sIndex="Jack"
		case 12
			sIndex="Queen"				
		case 13
			sIndex="King"
		case else
			sIndex="JOKER" & iInd2 & "-" & iKey
	end select
	funCard="<font face='Arial' color='navy'>" & sIndex & " of </font> " & sSuit
end function
	
function funGrid(iCols,iRows)
	' deal in rows with column taglines
	dim sTag(7)
	dim sLine(7)
	randomize
	
	if iRows*iCols >52 then exit function
	sTag(1)="In here"
	sTag(2)="Pick me"
	sTag(3)="This pile"
	sTag(4)="This one"
	sTag(5)="I see it here"
	sTag(6)="Here it is"
	sTag(7)="It's here"
	for i=1 to iCols
		n=int(rnd*7)+1
		sLine(i)=sTag(n)
	next
	k=1
	sOut=""
	sOut=sOut & "<table>" ' card mat
	sOut=sOut & "<tr>"
	for i=1 to iCols
		sOut=sOut & "<td align='center' bgcolor='DD" & hex(255-(8*i)) & "EE'>"
		sOut=sOut & "<p><font face='Arial'><a href='default.asp?fCol=" & i & "&fTurn=" & sTurn & "&fPack=" & sPack & "'>" & sLine(i) & "</a></font></p>"
		sOut=sOut & "</td>"
	next
	sOut=sOut & "</tr>"
	for i=1 to iRows
		sOut=sOut & "<tr>"
		for j=1 to iCols
			sOut=sOut & "<td align='center' bgcolor='66" & hex(255-(8*sTurn)) & hex(255-(8*j)) & "'>"
			sOut=sOut & "<p>"
			sOut=sOut & funCard(k)
			sOut=sOut & "</p>"
			sOut=sOut & "</td>"
			k=k+1
		next
		sOut=sOut & "</tr>"
	next
	sOut=sOut & "<table>"
	funGrid=sOut
end function
function funStage
	' stage effect
	sOut=""
	sOut=sOut & "<html><body>"
	sOut=sOut & "<h3><a href='mailto:jack_spades@hotmail.com'>Mystic Card</a></h3>"
	sOut=sOut & funPack & ""
	sOut=sOut & "</body></html>"
	funStage=sOut
end function
Response.Write funStage ' or funPack on your own stage freely
%>