YOUR JOYFUL MEMBERSHIP CREDENTIALS HAVE NOT BEEN IDENTIFIED. PLEASE ENTER YOUR CREDENTIALS OR JOIN OUR JOYFUL COMMUNITY.
ENTER YOUR JOYFUL MEMBER CREDENTIALS REQUEST ACCESS TO OUR JOYFUL COMMUNITY


JB: LARGE PRINT Game of 21
10-01-2017, 01:28 AM
Post: #1
 (Print Post)
This game is not exactly like BlackJack and even though JB has GUI not much was used except Large Font and some color:
Code Snippet: [Select]
'LARGE PRINT 21 GAME.txt for JB (B+=MGA) 2017-10-01
' from: 21 new start.txt for JB [B+=MGA] 2016-03-25
' with LARGE PRINT mod inspired by Don Johnson problem post

global xmax, ymax  'these two you can easily reset to your needs
'set these to screen width = xmax, screen height = ymax, that you want

xmax = 1000 : ymax = 700  '<<<<<< set this as you need or from plug-in notes

global cellW, cellH
'do not mess with cellW and cellH globals for printing
cellW = 14 'pixels wide for characters
cellH = 28 'pixels high for characters

global maxRow, maxCol
'and then these are calclated from above globals
maxCol = int(xmax / cellW)  'these control printing characters
maxRow = int(ymax / cellH)

global lastC, lastR 'for loc8 (locate), pl (print a line), lp (locate and print)
lastC = 1 : lastR = 1

'key events update globals with latest info
global inkee$, h$

h$ = "#gr"

nomainwin

WindowWidth = xmax + 8
WindowHeight = ymax + 32
UpperLeftX = (DisplayWidth-WindowWidth) / 2
UpperLeftY = (DisplayHeight-WindowHeight) / 2

open "         LARGE PRINT GAME OF 21" for graphics_nsb_nf as #gr '<, == change for plug in modules
#gr "trapclose quit"

'fonts that don't work arial, tahoma, verdana
'fonts that work
'#gr "font courier_new 10 20"
'#gr "font consolas 10 20"
#gr "font dejavu_sans_mono ";cellW;" ";cellH

'#gr "home"                  '< check drawing area
'#gr "posxy w2 h2"           '<<<<<<<<<<<<<<<<<<
'notice "Screen Drawing Check";chr$(13);"Size:" + chr$(13) + "Width (w2*2) = ";w2*2;",  Height (h2*2) = ";h2*2

#gr "setfocus"
#gr "when characterInput charIn"
#gr "down"

'=================================================== plug-in main modules here

DIM Deck(52), Player$(11)
'prep deck for shuffles
FOR i = 1 TO 52
   Deck(i) = i
NEXT

GLOBAL deckindex, playerindex, points, ace, playertotal, pointsrisk
points = 100

DO
   call getReady
   call getPointsRisk
   call drawcard
   call drawcard
   call playhand
   call dealer
LOOP UNTIL points = 0
call clear 0, 0, 0
#gr "color white"
call cp 10, "Game Over"
call pause 2500
call quit h$

SUB getReady
   ' shuffle deck before each round with simple and tested routine
   FOR i = 52 TO 2 step -1
       r = INT(RND(1) * i) + 1
       t = Deck(i)
       Deck(i) = Deck(r)
       Deck(r) = t
   NEXT
   ' restart these for next round
   DIM Player$(11)
   playerindex = 1 : deckindex = 1
   playertotal = 0 : pointsrisk = 0 : ace = 0
END SUB

SUB getPointsRisk
   call clear 0, rnd(0) * 100 + 155, rnd(0)*100 + 155
   call cp 4, "You have ";str$(points);" points available to risk:"
   call loc8 18, 8
   call inp " (0 = quit)  Enter point risk > ", pointsrisk$
   pointsrisk = val(pointsrisk$)
   IF pointsrisk <= 0  THEN
       call cp 10, "OK, goodbye"
       call pause 2500
       call quit h$
   ELSE
       IF pointsrisk > points THEN pointsrisk = points
   END IF
END SUB

SUB drawcard
   value = Deck(deckindex) mod 13
   IF value = 1 THEN
       IF ace = 0 OR ace = 1 THEN
           IF playertotal < 11 THEN ace = 11 ELSE ace = 1
           playertotal = playertotal + ace
       ELSE
           playertotal = playertotal + 1
       END IF
   ELSE
       IF value > 1 AND value < 10 THEN
           playertotal = playertotal + value
       ELSE
           playertotal = playertotal + 10
       END IF
   END IF
   IF playertotal > 21 AND ace = 11 THEN playertotal = playertotal - 10 : ace = 1
   Player$(playerindex) = Cardname$(value)
   deckindex = deckindex + 1 : playerindex = playerindex + 1
END SUB

SUB playhand
   g = rnd(0) * 100 + 155 : b = rnd(0) * 100 + 155
   WHILE 1
       call clear 0, g, b
       call cp 2, "TWENTYONE";"     Points: ";str$(points);"    risking ";str$(pointsrisk)
       s$ = "Player's cards: "
       FOR i=1 TO playerindex-1
           s$ = s$ + " " + Player$(i)
       NEXT
       call cp 6, s$
       call cp 8, "Card total at present is " + str$(playertotal)
       if playertotal >= 21 then exit while
       s$ = "Enter 1 for another card, 2 to stay "
       IF ace = 11 and playertotal <> 21 THEN s$ = s$ + "or 3 to change ace value to one "
       call cp 10, s$
       DO
           call loc8 35, 12
           call inp "", choice$
           choice = val(choice$)
       LOOP UNTIL choice = 1 OR choice = 2 OR (choice = 3 AND ace = 11)
       IF choice = 1 THEN
           CALL drawcard
       ELSE
           IF ace = 11 AND choice = 3 THEN
               playertotal = playertotal - 10 : ace = 1
           ELSE
               EXIT WHILE
           END IF
       END IF
   WEND
END SUB

SUB dealer
   s$ = "Dealer's cards: "
   if playertotal < 22 then enough = playertotal else enough = 12
   WHILE dealtotal <= enough
       s$ = s$ + " " + Cardname$(Deck(deckindex))
       dcard = Deck(deckindex) MOD 13
       deckindex = deckindex + 1
       IF dcard = 1 THEN 'deal with ace
           IF dealtotal < 11 THEN  'go for or make 21
               dealtotal = dealtotal + 11 : dealace = 11
           ELSE
               dealtotal = dealtotal + 1
           END IF
       ELSE
           IF dcard > 1 AND dcard < 10 THEN
               dealtotal = dealtotal + dcard
           ELSE
               dealtotal = dealtotal + 10
           END IF
       END IF
       IF dealtotal > 21 AND dealace = 11 THEN
           dealtotal = dealtotal - 10
           dealace = 1
       END IF
   wend
   call cp 16, s$
   call cp 18, "The dealer has a total of " +str$(dealtotal) + "."
   IF (playertotal > dealtotal AND playertotal <= 21) OR (playertotal <= 21 AND dealtotal > 21) THEN
       points = points + pointsrisk
       call cp 21, "You won " + str$(pointsrisk) + " points!"
   ELSE
       IF (dealtotal > playertotal AND dealtotal <= 21) OR (playertotal > 21 AND dealtotal <= 21) THEN
           points = points - pointsrisk
           call cp 21, "You lost " + str$(pointsrisk) + " points."
       ELSE
           call cp 21, "You tied."
       END IF
   END IF
   call loc8 23, 24
   call inp "Press enter to continue... ", temp$
END SUB

FUNCTION Cardname$(avalue)
   SELECT CASE avalue mod 13
   CASE 1
       cn$ = "Ace"
   CASE 11
       cn$ = "Jack"
   CASE 12
       cn$ = "Queen"
   CASE 0
       cn$ = "King"
   CASE 2, 3, 4, 5, 6, 7, 8, 9,10
       cn$ = str$(avalue mod 13)
   END SELECT
   Cardname$ = cn$
END FUNCTION


wait ' end plug-in section ==========================
'========================== subset of DE procedures

sub charIn hdl$, c$
   inkee$ = c$
end sub

sub quit hdl$
   timer 0
   close #gr
   end
end sub

sub clear r, g, b 'clear screen to new RGB color and set backcolor
' and set up so pl (print line) will start at line 1, cell column 1)
   #gr "fill ";r;" ";g;" ";b
   #gr "backcolor ";r;" ";g;" ";b
   lastC = 1 : lastR = 1
end sub

sub loc8 x, y   'locate xColumnCell, yRowCell for printing
   if 0 < x and x < maxCol + 1 and 0 < y and y < maxRow + 1 then
       lastC = x
       lastR = y
   end if
end sub

sub pl mess$ 'print line (feed)
   startR = lastR
   for i = 1 to len(mess$)
       scan
       call lp lastC, lastR, mid$(mess$, i, 1)
       if lastR <> startR then exit for
   next
   lastC = 1
   lastR = startR + 1
   if lastR > maxRow then lastR = maxRow 'yuck!
end sub

sub lp x, y, mess$ 'locate x, y : print mess$ lp = locate and print
   'if locate = x col and y row then and top left corner locates as 1, 1
   c = x - 1: r = y
   if 0 < x and x < maxCol + 1 and 0 < y and y < maxRow + 1 then
       #gr "place ";c * cellW;" ";r * cellH - 4
       #gr "|";mess$
       lastC = x + len(mess$)
       if lastC > maxCol then lastC = 1 : lastR = lastR + 1
       if lastR > maxRow then lastR = maxRow 'yuck!
   end if
end sub

sub cp y,cpText$ 'cp Center Print on line y the cpText$
   call lp int((maxCol - len(cpText$))/2 + 1.5), y, cpText$
   lastC = 1 : lastR = y + 1
end sub

sub inp prmpt$, byref var$   'input
'prints prompt at lastC, lastR and leaves lastC = 1 lastR = pRow + 1

   inkee$ = "" 'clear last key (new fix for DE5)
   call lp lastC, lastR, prmpt$;"{"
   'this will update lastR and lastC to the starting point of input variable
   pRow = lastR : pCol = lastC 'save these for redrawing var
   call lp pCol, pRow, "}"
   OK$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz"
   OK$ = OK$+ chr$(8)+ chr$(27) + chr$(13) + "1234567890!@#$%^&*()_-+={}[]|\:;'<,>.?/"
   do
       scan
       if instr(OK$, inkee$) then
           if inkee$ = Chr$(8) then
               if t$ <> "" then
                   if Len(t$)=1 then t$="" else t$=Left$(t$,Len(t$)-1)
               end if
           else
               if inkee$=Chr$(13) or inkee$=Chr$(27) then
                   'new D5, I was expecting nothing in return for my esc
                   if inkee$ = chr$(27) then t$ = ""
                   exit do
               else
                   t$=t$;inkee$
               end if
           end if
           call lp pCol, pRow, t$;"} "
           inkee$ = ""
       end if
   loop until done
   var$ = t$
   lastC = 1 : lastR = pRow + 1
end sub

sub at xPix, yPix, char$  'print a string at pixel x, y This pin point locating.
   #gr "place ";xPix;" ";yPix
   #gr "|";char$
end sub

sub pause mil   'tsh version has scan built-in
   t0 = time$("ms")
   while time$("ms") < t0 + mil : scan : wend
end sub


Attached File(s) Image(s)
   

For a bad joke 
http://www.laughfactory.com/jokes/joke-of-the-day 
worse than Pete's Big Grin
Find all posts by this user
Like Post
The following 1 user Likes bplus's post:
easylangs (10-01-2017)



Forum Jump:


User(s) browsing this thread: 1 Guest(s)




QB64 Member Project - Kings Valley verion one
QB64 Member Project - Quarto
QB64 Member Project - Kobolts Monopoly
QB64 Member Project - Color Rotating Text
QB64 Member Project - Spiro Roses
QB64 Member Project - Algeria Weather
QB64 Member Project - Blokus
QB64 Member Project - Input
QB64 Member Project - Bowditch curve
QB64 Member Project - Isolation
QB64 Member Project - Pivet version one
QB64 Member Project - Foursight
QB64 Member Project - Qubic
QB64 Member Project - Kings Vallery version two
QB64 Member Project - Inside Moves
QB64 Member Project - Othello
QB64 Member Project - Martin Fractals version two
QB64 Member Project - Sabotage
QB64 Member Project - Score 4
QB64 Member Project - MAPTRIANGLE
QB64 Member Project - Martin Fractals version one
QB64 Member Project - Rubix's Magic
QB64 Member Project - Rotating Background
QB64 Member Project - Splatter
QB64 Member Project - Overboard
QB64 Member Project - Amazon
QB64 Member Project - Swirl
QB64 Member Project - Color Triangles
QB64 Member Project - Exit
QB64 Member Project - STxAxTIC 3D World
QB64 Member Project - Touche
QB64 Member Project - Spinning Color Wheel
QB64 Member Project - OpenGL Triangles
QB64 Member Project - Martin Fractals version three
QB64 Member Project - Line Thickness
QB64 Member Project - ARB Checkers
QB64 Member Project - Kings Court
QB64 Member Project - Full Color LED Sign
QB64 Member Project - RGB Color Wheel
QB64 Member Project - 9 Board
QB64 Member Project - Martin Fractals version four
QB64 Member Project - Red Scrolling LED Sign
QB64 Member Project - Basic Dithering
QB64 Member Project - Connect Four
QB64 Member Project - Dakapo
QB64 Member Project - Pivot version two
QB64 Member Project - Dreamy Clock
QB64 Member Project - Domain
QB64 Member Project - Point Blank