02-02-2026, 03:44 PM
I've installed a rudimentary "solve" button that becomes available when all cards are face up, though ideally the waste pile should either be cleared or in some semblance of numerical order before using it. I'm going to do some head scratching on an animation for that function. You can also {s}ave a hand in progress and {l}oad it later.
Code: (Select All)
OPTION _EXPLICIT
$COLOR:32
_TITLE "Quiet Solitaire"
TYPE V2 ' Position (x, y) Vector <x, y> pair
x AS INTEGER
y AS INTEGER
END TYPE
TYPE region
ul AS V2 ' upper left position
lr AS V2 ' lower right position
END TYPE
TYPE card
in AS INTEGER ' index of card
rk AS INTEGER ' rank of card (A,2,3,4,5,6,7,8,9,10,J,Q,K) sequential from 1 to 13
st AS INTEGER ' suit of card (2-5) black even, red odd
im AS LONG ' image handle of card
fc AS _BYTE ' facing of card (up=true, down=false)
END TYPE
DIM SHARED Main&
Main& = _NEWIMAGE(680, 540, 32)
SCREEN Main&
DO: LOOP UNTIL _SCREENEXISTS
_SCREENMOVE 5, 5
DIM SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
DIM AS INTEGER tog
tog = 0
DIM SHARED deck(52) AS card ' The Deck
DIM SHARED transfer AS INTEGER ' stack movement flag
DIM SHARED fromPile AS INTEGER ' stack moved from
REDIM SHARED pick%(13) ' moving array
'card stacks
DIM SHARED stack(12, 52) AS INTEGER ' first dimenstion=stack pointer second dimension=index array
'stack 0 = draw pile "Stock"
'stack 1 = drawn pile "Waste"
'stacks 2-5 = ace pile clubs - hearts - spades - diamonds "foundation"
DIM SHARED suitname$(2 TO 5)
suitname$(2) = "Clubs"
suitname$(3) = "Hearts"
suitname$(4) = "Spades"
suitname$(5) = "Diamonds"
'stacks 6-12 = 7 build piles "Tableau"
$EMBED:'./Cards.png','Carddeck'
DIM CardDeck&
CardDeck& = _LOADIMAGE(_EMBEDDED$("Carddeck"), 32, "memory")
IF CardDeck& = -1 THEN PRINT "Cards.png failed to load, bye!": END
DIM rank%, suit%
DIM AS INTEGER SW, SH, SPRow, SPCol, Peektop
rank% = 1: suit% = 1
SW = 72: SH = 96: SPRow = 13: SPCol = 4: Peektop = 18
CONST back = 10 ' display offset for face down cards in build stacks
CONST face = 24 ' display offset for face up cards in build stacks
CONST TRUE = -1
CONST FALSE = 0
' cards 72 x 96 3x4
deck(0).im = _NEWIMAGE(72, 96, 32) ' create card back image
_PUTIMAGE , CardDeck&, deck(0).im, (13 * SW, 0 * SH)-STEP(SW, SH) 'put card back sprite in image handle
'original sprite order: clubs spades hearts diamonds swap spades and hearts to align even/odd suit numbering to red/black
DIM x%, sheetx%, sheety%
suit% = 2
FOR x% = 1 TO 52
deck(x%).in = x%
deck(x%).rk = rank%
deck(x%).st = suit% '
deck(x%).im = _NEWIMAGE(72, 96, 32)
deck(x%).fc = 0
sheetx% = ((x% - 1) MOD SPRow) * SW
SELECT CASE x%
CASE 1 TO 13 ' Clubs suit=1
sheety% = 0 '
CASE 14 TO 26 ' Spades to Hearts suit=2
sheety% = 2 * SH
CASE 27 TO 39 ' Hearts to Spades suit=3
sheety% = SH
CASE 40 TO 52 ' Diamonds suit=4
sheety% = 3 * SH
END SELECT
_PUTIMAGE , CardDeck&, deck(x%).im, (sheetx%, sheety%)-STEP(SW, SH)
rank% = rank% + 1 ' Ace to King ascending
IF x% MOD 13 = 0 THEN
suit% = suit% + 1
rank% = 1
END IF
NEXT x%
'PLAY LAYOUT REGIONS
DIM mp AS V2
DIM SHARED tpstk(12) AS region
DIM SHARED sbut AS region
'Set_Stacks scrw%, scrh%
DIM xset%, yset%
xset% = 10: yset% = 10
tpstk(0).ul.x = xset%: tpstk(0).ul.y = yset%: tpstk(0).lr.x = SW + xset%: tpstk(0).lr.y = SH + yset% 'draw stack
xset% = xset% + 10 + SW
tpstk(1).ul.x = xset%: tpstk(1).ul.y = yset%: tpstk(1).lr.x = SW + xset%: tpstk(1).lr.y = SH + yset% 'discard stack
xset% = xset% + 3 * SW
tpstk(2).ul.x = xset%: tpstk(2).ul.y = yset%: tpstk(2).lr.x = SW + xset%: tpstk(2).lr.y = SH + yset% 'clubs stack
xset% = xset% + 10 + SW
tpstk(3).ul.x = xset%: tpstk(3).ul.y = yset%: tpstk(3).lr.x = SW + xset%: tpstk(3).lr.y = SH + yset% 'hearts stack
xset% = xset% + 10 + SW
tpstk(4).ul.x = xset%: tpstk(4).ul.y = yset%: tpstk(4).lr.x = SW + xset%: tpstk(4).lr.y = SH + yset% 'spades stack
xset% = xset% + 10 + SW
tpstk(5).ul.x = xset%: tpstk(5).ul.y = yset%: tpstk(5).lr.x = SW + xset%: tpstk(5).lr.y = SH + yset% 'diamonds stack
xset% = 10: yset% = yset% + SH + 50
tpstk(6).ul.x = xset%: tpstk(6).ul.y = yset%: tpstk(6).lr.x = xset% + SW: tpstk(6).lr.y = _HEIGHT - 1 'build 1 stack
xset% = xset% + 20 + SW
tpstk(7).ul.x = xset%: tpstk(7).ul.y = yset%: tpstk(7).lr.x = xset% + SW: tpstk(7).lr.y = _HEIGHT - 1 'build 2 stack
xset% = xset% + 20 + SW
tpstk(8).ul.x = xset%: tpstk(8).ul.y = yset%: tpstk(8).lr.x = xset% + SW: tpstk(8).lr.y = _HEIGHT - 1 'build 3 stack
xset% = xset% + 20 + SW
tpstk(9).ul.x = xset%: tpstk(9).ul.y = yset%: tpstk(9).lr.x = xset% + SW: tpstk(9).lr.y = _HEIGHT - 1 'build 4 stack
xset% = xset% + 20 + SW
tpstk(10).ul.x = xset%: tpstk(10).ul.y = yset%: tpstk(10).lr.x = xset% + SW: tpstk(10).lr.y = _HEIGHT - 1 'build 5 stack
xset% = xset% + 20 + SW
tpstk(11).ul.x = xset%: tpstk(11).ul.y = yset%: tpstk(11).lr.x = xset% + SW: tpstk(11).lr.y = _HEIGHT - 1 'build 6 stack
xset% = xset% + 20 + SW
tpstk(12).ul.x = xset%: tpstk(12).ul.y = yset%: tpstk(12).lr.x = xset% + SW: tpstk(12).lr.y = _HEIGHT - 1 'build 7 stack
sbut.ul.x = SW * 2 + 30: sbut.ul.y = 10: sbut.lr.x = sbut.ul.x + SW: sbut.lr.y = sbut.ul.y + (SH \ 4)
DIM SHARED A(52) AS INTEGER
FOR x% = 1 TO 52: A(x%) = x%: NEXT x%
Initialize
Card_Refresh
DIM dn%, k$, in%, ms
dn% = 0
DO
DO
k$ = INKEY$
IF k$ = CHR$(27) THEN in% = -1: dn% = -1
IF k$ = CHR$(116) THEN tog = NOT tog: in% = -1 'Cheating Easter egg
IF k$ = CHR$(108) THEN 'load
Load_Hand
Card_Refresh
END IF
IF k$ = CHR$(115) THEN 'save
Save_Hand
END IF
IF k$ = CHR$(100) THEN
Initialize
in% = -1
END IF
ms = MBS%
mp.x = _MOUSEX: mp.y = _MOUSEY
IF ms AND 1 THEN
Clear_MB 1
'Mouse_LeftII mp
Mouse_Left mp
in% = -1
END IF
IF ms AND 2 THEN
Clear_MB 2
Mouse_Right mp
in% = -1
END IF
_LIMIT 30
LOOP UNTIL in%
in% = 0
IF tog THEN
Card_List
ELSE
Card_Refresh
END IF
'IF UpCheck% THEN
' 'all cards up, put up a solve button
'END IF
IF Victory_Check% THEN
_PRINTSTRING (_WIDTH / 2 - 32, _HEIGHT / 2), "Winner!"
END IF
_DISPLAY
LOOP UNTIL dn%
END
'---------------------------------------------------------------
SUB Analyze_Stack (down AS INTEGER, up AS INTEGER, index AS INTEGER)
DIM x%
down = 0
up = 0
x% = 0
DO UNTIL stack(index, x%) = 0
SELECT CASE deck(stack(index, x%)).fc
CASE TRUE: up = up + 1 ' count face up
CASE FALSE: down = down + 1 ' count face down
END SELECT
x% = x% + 1
LOOP
END SUB 'Analyze_Stack
'---------------------------------------------------------------
SUB Box_Region (b AS region, c AS LONG, t AS INTEGER)
DIM x%
FOR x% = 0 TO t - 1
LINE (b.ul.x + x%, b.ul.y + x%)-(b.lr.x - x%, b.lr.y - x%), c, B
NEXT x%
END SUB 'Box_Region
'---------------------------------------------------------------debugging and cheating Easter egg
SUB Card_List
DIM bld%, ace%, dn%, up%, y%, r%, num$, suit$
DIM AS INTEGER ypos
CLS
FOR ace% = 2 TO 5
ypos = 0: r% = 0
Box_Region tpstk(ace%), Red, 1
Analyze_Stack dn%, up%, ace%
IF up% > 0 THEN
FOR y% = 1 TO up%
num$ = Rank_Name$(deck(stack(ace%, r%)))
suit$ = Suit_Name$(deck(stack(ace%, r%)))
_PRINTSTRING (tpstk(ace%).ul.x, ypos), LEFT$(num$, 4) + LEFT$(suit$, 4)
ypos = ypos + 16 ' increment ypos by back constant
r% = r% + 1
NEXT y%
END IF
NEXT ace%
FOR bld% = 6 TO 12
r% = 0
ypos = tpstk(bld%).ul.y
Box_Region tpstk(bld%), &HFFFF0000, 1
Analyze_Stack dn%, up%, bld%
'place any face down cards
IF dn% > 0 THEN
FOR y% = 1 TO dn%
COLOR &HFFFF0000
num$ = Rank_Name$(deck(stack(bld%, r%)))
suit$ = Suit_Name$(deck(stack(bld%, r%)))
_PRINTSTRING (tpstk(bld%).ul.x, ypos), LEFT$(num$, 4) + LEFT$(suit$, 4)
ypos = ypos + 16 ' increment ypos by back constant
r% = r% + 1
NEXT y%
END IF
'place any face up cards
IF up% > 0 THEN
FOR y% = 1 TO up%
COLOR &HFFFFFFFF
num$ = Rank_Name$(deck(stack(bld%, r%)))
suit$ = Suit_Name$(deck(stack(bld%, r%)))
_PRINTSTRING (tpstk(bld%).ul.x, ypos), LEFT$(num$, 4) + LEFT$(suit$, 4)
ypos = ypos + 16 ' increment ypos by face constant
r% = r% + 1
NEXT y%
END IF
NEXT bld%
Box_Region tpstk(0), &HFFFF0000, 1
Analyze_Stack dn%, up%, 0
FOR y% = 0 TO dn% - 1
_PRINTSTRING (5, _HEIGHT - (20 + y% * 16)), Rank_Name$(deck(stack(0, y%))) + " of " + Suit_Name$(deck(stack(0, y%)))
NEXT y%
Analyze_Stack dn%, up%, 1
FOR y% = 0 TO up% - 1
_PRINTSTRING (200, _HEIGHT - (20 + y% * 16)), Rank_Name$(deck(stack(1, y%))) + " of " + Suit_Name$(deck(stack(1, y%)))
NEXT y%
END SUB 'Card_List
'---------------------------------------------------------------
SUB Card_Refresh
DIM AS INTEGER ypos
DIM x%, y%, r%, trash%, ace%, bld%, up%, dn%
DIM img&, mc&, q&, px&
DIM AS V2 mid
DIM m AS _MEM
CLS , Green
IF UpCheck% THEN
'set a flag to reveal the solve button
Box_Region sbut, Red, 3
Mid_Region mid, sbut
_PRINTSTRING (mid.x - 20, mid.y - 8), "Solve"
END IF
IF stack(0, 0) <> 0 THEN '..................................Stock Stack
trash% = Image_Region(tpstk(0), deck(0).im, Main&, "c", "c")
ELSE
Box_Region tpstk(0), &HFFFF0000, 1
END IF
IF stack(1, 0) <> 0 THEN '..................................Waste Stack
x% = 0
DO UNTIL stack(1, x% + 1) = 0
x% = x% + 1
LOOP
'Analyze_Stack dn%, up%, 1
IF transfer AND fromPile = 1 THEN
'negative
img& = _COPYIMAGE(deck(stack(1, x%)).im)
m = _MEMIMAGE(img&)
mc& = 0
DO
_MEMGET m, m.OFFSET + mc& * 4, px&
q& = Negative&(px&)
_MEMPUT m, m.OFFSET + mc& * 4, q&
mc& = mc& + 1
LOOP UNTIL mc& * 4 = m.SIZE - 4
_PUTIMAGE (tpstk(1).ul.x, tpstk(1).ul.y), img&
_MEMFREE m
ELSE
trash% = Image_Region(tpstk(1), deck(stack(1, x%)).im, Main&, "c", "c")
END IF
ELSE
Box_Region tpstk(1), &HFFFF0000, 1
END IF
'STACK 2 - 5
FOR ace% = 2 TO 5 '.........................................Foundation Stacks
IF stack(ace%, 0) <> 0 THEN
'show the topmost
Analyze_Stack dn%, up%, ace%
IF up% + dn% > 0 THEN
trash% = Image_Region(tpstk(ace%), deck(stack(ace%, up% + dn% - 1)).im, Main&, "c", "c")
END IF
ELSE
DIM tc AS V2
Box_Region tpstk(ace%), &HFFFF0000, 1
Mid_Region tc, tpstk(ace%)
_PRINTSTRING (tc.x - _SHL(LEN(suitname$(ace%)), 2), tc.y - 8), suitname$(ace%)
END IF
NEXT ace%
FOR bld% = 6 TO 12 '........................................Tableau Stacks
r% = 0
ypos = tpstk(bld%).ul.y
Analyze_Stack dn%, up%, bld%
'place any face down cards
IF dn% > 0 THEN
FOR y% = 1 TO dn%
_PUTIMAGE (tpstk(bld%).ul.x, ypos), deck(0).im 'place card back
ypos = ypos + back ' increment ypos by back constant
r% = r% + 1
NEXT y%
END IF
'place any face up cards
IF up% > 0 THEN
FOR y% = 1 TO up%
_PUTIMAGE (tpstk(bld%).ul.x, ypos), deck(stack(bld%, r%)).im 'place card face
IF transfer AND bld% = fromPile THEN
img& = _COPYIMAGE(deck(stack(bld%, r%)).im)
m = _MEMIMAGE(img&)
mc& = 0
DO
_MEMGET m, m.OFFSET + mc& * 4, px&
q& = Negative&(px&)
_MEMPUT m, m.OFFSET + mc& * 4, q&
mc& = mc& + 1
LOOP UNTIL mc& * 4 = m.SIZE - 4
_PUTIMAGE (tpstk(bld%).ul.x, ypos), img&
_MEMFREE m
END IF
ypos = ypos + face ' increment ypos by face constant
r% = r% + 1
NEXT y%
END IF
NEXT bld%
_PRINTMODE _KEEPBACKGROUND
_PRINTSTRING (5, _HEIGHT - 17), "d = deal l = load s = save esc = quit"
END SUB 'Card_Refresh
'---------------------------------------------------------------
'Description
'Clear the mousebutton queue - only releases when button released
SUB Clear_MB (var AS INTEGER)
DO UNTIL NOT _MOUSEBUTTON(var)
_LIMIT 30
WHILE _MOUSEINPUT: WEND
LOOP
END SUB 'Clear_MB
'---------------------------------------------------------------
SUB Deal
DIM x%, r%, dr%, st%
DO
FOR st% = 6 TO 12
IF st% - 6 - r% < 0 THEN
stack(st%, r%) = 0 ' put a zero where no card on the deal
ELSE
x% = x% + 1 ' index for next card
stack(st%, r%) = A(x%) ' place card x% on stack st% and rank r%
deck(A(x%)).fc = _IIF(st% - 6 - r% = 0, -1, 0) 'face up first card of the stack rank
END IF
NEXT st%
r% = r% + 1
LOOP UNTIL r% = 7
DO ' put the rest in the draw
x% = x% + 1
deck(A(x%)).fc = 0
stack(0, dr%) = A(x%)
dr% = dr% + 1
LOOP UNTIL x% = 52
DO
stack(0, dr%) = 0
dr% = dr% + 1
LOOP UNTIL dr% = 53
transfer = 0
END SUB 'Deal
'---------------------------------------------------------------
FUNCTION Go% (from AS INTEGER, tto AS INTEGER)
IF deck(from).rk = deck(tto).rk - 1 THEN ' if from card is one less than to card
IF deck(from).st MOD 2 <> deck(tto).st MOD 2 THEN ' if suit color alternates
Go% = TRUE
ELSE
Go% = FALSE
END IF
ELSE
Go% = FALSE
END IF
END FUNCTION 'Go%
'---------------------------------------------------------------
FUNCTION Image_Region (r AS region, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
DIM AS INTEGER xs, ys, xp, yp, xl, yl ' ready for OPTION EXPLICIT programs
xp = r.ul.x: yp = r.ul.y: xl = r.lr.x: yl = r.lr.y ' isolate sent parameters from any changes
DIM AS SINGLE rt, xrt, yrt
xrt = (xl - xp) / _WIDTH(i) ' width of area divided by width of image
yrt = (yl - yp) / _HEIGHT(i) ' height of area divided by height of image
rt = _IIF(xrt < yrt, xrt, yrt) ' pick the smaller of the two ratios to fit area
xs = _WIDTH(i) * rt ' final image size ratio in x
ys = _HEIGHT(i) * rt ' final image size ratio in y
xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
xl = xp + xs
yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
yl = yp + ys
_PUTIMAGE (xp, yp)-(xl, yl), i, d
Image_Region = rt
END FUNCTION 'Image_Region
'---------------------------------------------------------------
SUB Initialize
DIM st%, sl%
FOR st% = 0 TO 12
FOR sl% = 0 TO 52
stack(st%, sl%) = 0
NEXT sl%
NEXT st%
Shuffle A()
Deal
END SUB 'Initialize
'---------------------------------------------------------------
FUNCTION InRange% (var##, ll##, ul##)
InRange% = _CLAMP(var##, ll##, ul##) = var##
END FUNCTION 'InRange4%
'---------------------------------------------------------------
FUNCTION InRegion% (p AS V2, r AS region)
InRegion% = -(InRange%(p.x, r.ul.x, r.lr.x) * InRange%(p.y, r.ul.y, r.lr.y)) 'in region? T/F
END FUNCTION 'InRegion%
'---------------------------------------------------------------
' Description:
' Polls state of mouse wheel and buttons and allows drag operations.
' Author: Steve McNeill
FUNCTION MBS% 'Mouse Button Status
DIM AS INTEGER tempMBS, BD
STATIC StartTimer AS _FLOAT
STATIC ButtonDown AS INTEGER
STATIC ClickCount AS INTEGER
CONST ClickLimit## = 0.2 'Less than 1/4th of a second to down, up a key to count as a CLICK.
' Down longer counts as a HOLD event.
SHARED Mouse_StartX, Mouse_StartY, Mouse_EndX, Mouse_EndY
WHILE _MOUSEINPUT 'Remark out this block, if mouse main input/clear is going to be handled manually in main program.
SELECT CASE SGN(_MOUSEWHEEL)
CASE 1: tempMBS = tempMBS OR 512
CASE -1: tempMBS = tempMBS OR 1024
END SELECT
WEND
IF _MOUSEBUTTON(1) THEN tempMBS = tempMBS OR 1
IF _MOUSEBUTTON(2) THEN tempMBS = tempMBS OR 2
IF _MOUSEBUTTON(3) THEN tempMBS = tempMBS OR 4
IF StartTimer = 0 THEN
IF _MOUSEBUTTON(1) THEN 'If a button is pressed, start the timer to see what it does (click or hold)
ButtonDown = 1: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(2) THEN
ButtonDown = 2: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
ELSEIF _MOUSEBUTTON(3) THEN
ButtonDown = 3: StartTimer = TIMER(0.01)
Mouse_StartX = _MOUSEX: Mouse_StartY = _MOUSEY
END IF
ELSE
BD = ButtonDown MOD 3
IF BD = 0 THEN BD = 3
IF TIMER(0.01) - StartTimer <= ClickLimit THEN 'Button was down, then up, within time limit. It's a click
IF _MOUSEBUTTON(BD) = 0 THEN tempMBS = 4 * 2 ^ ButtonDown: ButtonDown = 0: StartTimer = 0
ELSE
IF _MOUSEBUTTON(BD) = 0 THEN 'hold event has now ended
tempMBS = 0: ButtonDown = 0: StartTimer = 0
Mouse_EndX = _MOUSEX: Mouse_EndY = _MOUSEY
ELSE 'We've now started the hold event
tempMBS = tempMBS OR 32 * 2 ^ ButtonDown
END IF
END IF
END IF
MBS% = tempMBS
END FUNCTION 'MBS%
'---------------------------------------------------------------
SUB Mid_Region (re AS V2, send AS region)
' ³ ÀÄ region sent to find mid point of
' ÀÄ (x, y) point returned
re.x = _SHR(send.lr.x - send.ul.x, 1) + send.ul.x
re.y = _SHR(send.lr.y - send.ul.y, 1) + send.ul.y
END SUB 'Mid_Region
'---------------------------------------------------------------
SUB Mouse_Left (ms AS V2)
DIM x%, a%, t%, d%, u%, df%, uf%, i%, ran%, m%, f%, flg%
FOR x% = 0 TO 12
IF InRegion(ms, tpstk(x%)) THEN EXIT FOR
NEXT x%
SELECT CASE x%
CASE 0 ' STOCK STACK REGION
IF transfer THEN transfer = NOT transfer
IF stack(0, 0) = 0 THEN ' reset from waste stack back to stock stack when empty
Analyze_Stack d%, u%, 1
RANDOMIZE TIMER
FOR m% = 0 TO d% + u% - 1
ran% = INT(RND * (d% + u%))
SWAP stack(1, m%), stack(1, ran%)
NEXT m%
DO
Push Pop(1), 0, -1
LOOP UNTIL stack(1, 0) = 0
ELSE ' draw card from stock stack and place on top of waste stack
Push Pop(0), 1, -1
END IF
CASE 1 ' WASTE STACK REGION
transfer = NOT transfer
fromPile = x%
CASE 2 TO 5 ' FOUNDATION STACK REGIONS
CASE 6 TO 12 ' TABLEAU STACK REGIONS
Analyze_Stack d%, u%, x% '
transfer = NOT transfer
IF u% <> 0 THEN ' if face up cards are present in the stack
IF transfer THEN ' Are we in a potential transfer move?
fromPile = x% ' Yes. Assign fromPile, but do nothing until the next column click
ELSE ' No. Complete the transfer from the previously chosen fromPile
IF x% = fromPile THEN
fromPile = 0
ELSE
Analyze_Stack df%, uf%, fromPile
IF fromPile = 1 THEN
IF Go%(stack(1, df% + uf% - 1), stack(x%, d% + u% - 1)) THEN
Push Pop(1), x%, 0
END IF
EXIT SUB ' a simple waste to tableau, one card transfer. Our job is done here.
END IF
GOSUB grab_face_ups
FOR t% = 0 TO UBOUND(pick%)
IF Go%(pick%(t%), stack(x%, d% + u% - 1 + i%)) THEN 'does pick card go on top tableau card?
i% = i% + 1
stack(x%, d% + u% - 1 + i%) = pick%(t%) 'Yes increment counter i% and transfer the element
END IF
NEXT t%
IF i% > 0 THEN ' subscript error trap. Don't pass a zero stack to Pop function
DO
a% = Pop(fromPile) ' Pump & Dump from stack of those cards accepted by move
i% = i% - 1 ' pop only as many as were moved
LOOP UNTIL i% = 0
END IF
END IF
END IF
ELSE ' no face up cards are present in the stack
IF d% = 0 THEN ' no face down cards are present in the stack
Analyze_Stack df%, uf%, fromPile
IF fromPile = 1 THEN
'IF NOT tranfer is to skip out of subscript error of clicking an empty tableau
IF NOT transfer THEN
IF deck(stack(fromPile, df% + uf% - 1)).rk = 13 THEN 'only a king should go on an empty stack SUBSCRIPT ERROR
Push Pop(1), x%, 0
END IF
END IF
ELSE
IF df% + uf% <= 0 THEN EXIT SUB ' no card to move, leave before subscript error
GOSUB grab_face_ups
IF deck(pick%(0)).rk = 13 THEN ' if first card is a king. SUBSCRIPT OUT OF RANGE ERROR WHEN EMPTY
FOR t% = 0 TO UBOUND(pick%)
stack(x%, d% + u% + t%) = pick%(t%)
stack(fromPile, df% + t%) = 0 ' empty from stack elements
NEXT t%
fromPile = 0
END IF
END IF
ELSE
transfer = NOT transfer
IF d% > 0 THEN ' if there are face down cards,
deck(stack(x%, d% - 1)).fc = -1 ' flip the last card in the stack
END IF
END IF
END IF ' end: face up cards present in stack test
END SELECT
IF InRegion%(ms, sbut) THEN
IF UpCheck% THEN
DO
flg% = FALSE
FOR a% = 1 TO 12
SELECT CASE a%
CASE 2 TO 5
_CONTINUE
CASE ELSE
Analyze_Stack d%, u%, a%
IF d% + u% = 0 THEN _CONTINUE
flg% = TRUE
f% = deck(stack(a%, d% + u% - 1)).st
Analyze_Stack df%, uf%, f%
IF deck(stack(a%, d% + u% - 1)).rk - 1 = deck(stack(f%, df% + uf% - 1)).rk THEN
Push Pop(a%), f%, 0
END IF
END SELECT
NEXT a%
LOOP UNTIL NOT flg%
END IF
END IF
EXIT SUB
grab_face_ups:
REDIM pick%(uf% - 1)
FOR a% = 0 TO uf% - 1
pick%(a%) = stack(fromPile, df% + a%) 'put all face up cards in frompile into pick array
NEXT a%
RETURN
END SUB 'Mouse_Left
'---------------------------------------------------------------
SUB Mouse_Right (ms AS V2)
DIM x%, d%, u%, rd%, ru%, pt%, t%, a%, tabl%, solve%
FOR x% = 0 TO 12
IF InRegion(ms, tpstk(x%)) THEN EXIT FOR
NEXT x%
SELECT CASE x%
CASE 1, 6 TO 12
IF stack(0, 0) = 0 AND stack(1, 0) = 0 THEN ' when stock and waste piles are empty
solve% = TRUE
FOR a% = 1 TO 52
IF deck(a%).fc = FALSE THEN solve% = FALSE 'if any card not face up, we aren't solved yet
NEXT a%
IF solve% THEN
FOR a% = 2 TO 5
Analyze_Stack d%, u%, a%
FOR tabl% = 6 TO 12
Analyze_Stack rd%, ru%, tabl%
IF rd% + ru% > 0 THEN
IF deck(stack(tabl%, rd% + ru% - 1)).st = a% THEN 'If suit matches
IF deck(stack(tabl%, rd% + ru% - 1)).rk = deck(stack(a%, d% + u%)).rk + 1 THEN
Push Pop(tabl%), a%, 0
'animation here?
'
END IF
END IF
END IF
NEXT tabl%
NEXT a%
END IF
END IF
Analyze_Stack d%, u%, x% ' determine the suit of the last card in stack x%
IF d% + u% > 0 THEN ' trap for subscript error
t% = d% + u% - 1
IF deck(stack(x%, t%)).fc = FALSE THEN EXIT SUB 'do not transfer a face down card
pt% = deck(stack(x%, t%)).st ' create a pointer to the appropriate suit stack 2-5
Analyze_Stack rd%, ru%, pt% ' poll state of pointer stack
IF deck(stack(x%, t%)).rk = ru% + 1 THEN ' if that card is .rk+1 equal to last card in the suit stack
stack(pt%, ru%) = stack(x%, t%) ' transfer to that suit stack
stack(x%, t%) = 0 ' erase from x% stack
END IF
deck(stack(pt%, ru%)).fc = TRUE
END IF
END SELECT
END SUB 'Mouse_Right
'---------------------------------------------------------------
FUNCTION Negative& (var AS LONG)
Negative& = _RGBA32(255 - _RED32(var), 255 - _GREEN32(var), 255 - _BLUE32(var), _ALPHA32(var))
END FUNCTION 'Negative&
'---------------------------------------------------------------
FUNCTION Pop (stk AS INTEGER)
DIM dn%, up%
Analyze_Stack dn%, up%, stk
Pop = stack(stk, dn% + up% - 1) ' return topmost array value, accounting for 0 element
stack(stk, dn% + up% - 1) = 0 ' clear topmost array element
END FUNCTION 'Pop
'---------------------------------------------------------------
SUB Push (var AS INTEGER, stk AS INTEGER, flip AS INTEGER)
DIM dn%, up%
Analyze_Stack dn%, up%, stk
stack(stk, dn% + up%) = var ' push value to next array element
IF flip THEN deck(var).fc = NOT deck(var).fc ' turn over card if flip = TRUE
END SUB 'Push
'---------------------------------------------------------------
SUB Shuffle (arr() AS INTEGER)
DIM i%, ran%
RANDOMIZE TIMER
FOR i% = 1 TO 52
ran% = INT(RND * 52) + 1
SWAP arr(i%), arr(ran%)
NEXT i%
END SUB 'Shuffle
'---------------------------------------------------------------
FUNCTION Rank_Name$ (var AS card)
SELECT CASE var.rk
CASE 1: Rank_Name$ = "Ace"
CASE 2: Rank_Name$ = "Two"
CASE 3: Rank_Name$ = "Three"
CASE 4: Rank_Name$ = "Four"
CASE 5: Rank_Name$ = "Five"
CASE 6: Rank_Name$ = "Six"
CASE 7: Rank_Name$ = "Seven"
CASE 8: Rank_Name$ = "Eight"
CASE 9: Rank_Name$ = "Nine"
CASE 10: Rank_Name$ = "Ten"
CASE 11: Rank_Name$ = "Jack"
CASE 12: Rank_Name$ = "Queen"
CASE 13: Rank_Name$ = "King"
END SELECT
END FUNCTION 'Rank_Name$
'---------------------------------------------------------------
FUNCTION Suit_Name$ (var AS card)
SELECT CASE var.st
CASE 2: Suit_Name$ = "Clubs"
CASE 3: Suit_Name$ = "Hearts"
CASE 4: Suit_Name$ = "Spades"
CASE 5: Suit_Name$ = "Diamonds"
END SELECT
END FUNCTION 'Suit_Name
'---------------------------------------------------------------
FUNCTION Victory_Check%
DIM x%
Victory_Check% = TRUE
FOR x% = 2 TO 5
IF stack(x%, 12) = 0 THEN
Victory_Check% = FALSE
ELSE
IF deck(stack(x%, 12)).rk MOD 13 <> 0 THEN Victory_Check% = FALSE
END IF
NEXT x%
END FUNCTION 'Victory_Check
'--------------------------------------------------------------- under development for eventual fullscreen version
SUB Set_Stacks (w AS INTEGER, h AS INTEGER)
DIM x10%, y10%, x20%, y20%
x10% = 10 * (w / _WIDTH(Main&)): y10% = 10
x20% = 20 * (w / _WIDTH(Main&))
'tpstk(0).ul.x = x10%: tpstk(0).ul.y = y10%: tpstk(0).lr.x = SW + x10%: tpstk(0).lr.y = SH + y10% 'draw stack
'x10% = x10% + 10 + SW
'tpstk(1).ul.x = x10%: tpstk(1).ul.y = y10%: tpstk(1).lr.x = SW + x10%: tpstk(1).lr.y = SH + y10% 'discard stack
'x10% = x10% + 3 * SW
'tpstk(2).ul.x = x10%: tpstk(2).ul.y = y10%: tpstk(2).lr.x = SW + x10%: tpstk(2).lr.y = SH + y10% 'clubs stack
'x10% = x10% + 10 + SW
'tpstk(3).ul.x = x10%: tpstk(3).ul.y = y10%: tpstk(3).lr.x = SW + x10%: tpstk(3).lr.y = SH + y10% 'hearts stack
'x10% = x10% + 10 + SW
'tpstk(4).ul.x = x10%: tpstk(4).ul.y = y10%: tpstk(4).lr.x = SW + x10%: tpstk(4).lr.y = SH + y10% 'spades stack
'x10% = x10% + 10 + SW
'tpstk(5).ul.x = x10%: tpstk(5).ul.y = y10%: tpstk(5).lr.x = SW + x10%: tpstk(5).lr.y = SH + y10% 'diamonds stack
'x10% = 10: y10% = y10% + SH + 50
'tpstk(6).ul.x = x10%: tpstk(6).ul.y = y10%: tpstk(6).lr.x = x10% + SW: tpstk(6).lr.y = _HEIGHT - 1 'build 1 stack
'x10% = x10% + 20 + SW
'tpstk(7).ul.x = x10%: tpstk(7).ul.y = y10%: tpstk(7).lr.x = x10% + SW: tpstk(7).lr.y = _HEIGHT - 1 'build 2 stack
'x10% = x10% + 20 + SW
'tpstk(8).ul.x = x10%: tpstk(8).ul.y = y10%: tpstk(8).lr.x = x10% + SW: tpstk(8).lr.y = _HEIGHT - 1 'build 3 stack
'x10% = x10% + 20 + SW
'tpstk(9).ul.x = x10%: tpstk(9).ul.y = y10%: tpstk(9).lr.x = x10% + SW: tpstk(9).lr.y = _HEIGHT - 1 'build 4 stack
'x10% = x10% + 20 + SW
'tpstk(10).ul.x = x10%: tpstk(10).ul.y = y10%: tpstk(10).lr.x = x10% + SW: tpstk(10).lr.y = _HEIGHT - 1 'build 5 stack
'x10% = x10% + 20 + SW
'tpstk(11).ul.x = x10%: tpstk(11).ul.y = y10%: tpstk(11).lr.x = x10% + SW: tpstk(11).lr.y = _HEIGHT - 1 'build 6 stack
'x10% = x10% + 20 + SW
'tpstk(12).ul.x = x10%: tpstk(12).ul.y = y10%: tpstk(12).lr.x = x10% + SW: tpstk(12).lr.y = _HEIGHT - 1 'build 7 stack
END SUB 'Set_Stacks
'---------------------------------------------------------------
FUNCTION UpCheck%
DIM x%, s%
s% = TRUE
FOR x% = 1 TO 52
IF deck(x%).fc = FALSE THEN s% = FALSE: EXIT FOR
NEXT x%
UpCheck% = s%
END FUNCTION 'UpCheck%
'---------------------------------------------------------------
SUB Save_Hand
DIM f&
DIM x%, s%, c%
f& = FREEFILE
OPEN "hand.bin" FOR BINARY AS f&
FOR x% = 1 TO 52
PUT f&, , deck(x%)
NEXT x%
FOR s% = 0 TO 12
FOR c% = 0 TO 52
PUT f&, , stack(s%, c%)
NEXT c%
NEXT s%
CLOSE f&
END SUB 'Save_Hand
'---------------------------------------------------------------
SUB Load_Hand
DIM f&
DIM x%, s%, c%
f& = FREEFILE
IF _FILEEXISTS("hand.bin") THEN
OPEN "hand.bin" FOR BINARY AS f&
FOR x% = 1 TO 52
GET f&, , deck(x%)
NEXT x%
FOR s% = 0 TO 12
FOR c% = 0 TO 52
GET f&, , stack(s%, c%)
NEXT c%
NEXT s%
CLOSE f&
END IF
END SUB 'Load_Hand
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
sha_na_na_na_na_na_na_na_na_na: