' Solitaire Extraordinaire ' David Augros ' August 2020 ' fruit of quarantine ' written for Colour Maximite 2 ' for all the homies who had a VIC-20 in 1982 ' the code is jank; don't @ me cards=51:ranks=13:design=176 '176/177/178 are pg back$=CHR$(design)+CHR$(design) cardback=rgb(100,80,220):cardstock=rgb(white) satin=rgb(magenta):velvet=rgb(10,120,10):stc=rgb(0,70,0) hilite=rgb(blue):CX=1:CY=1:startx=10:starty=20 x=startx:y=starty:mxr=20:dx=35:dy=28:fx=155:fy=70 sy=y+fy-dy*1.3:bx=x+fx-dx*0.3:by=y+fy-2*dy CONTEXT=0:SSX=0:SSY=0:charw=36:charh=28 dim shuf(cards),rank(cards),suit(cards),colo(cards),flip(cards) dim face$(cards+3) LENGTH 5:face$(53)="**":blank$=" " dim used(cards):for i=0 to cards:used(i)=0:next i dim ronk$(ranks)=("*","A","2","3","4","5","6","7","8","9",CHR$(232),"J","Q","K") dim soot(3)=(139,140,138,137) dim tablx(mxr,7,2) '(row,col,x&y) dim tablo(7,mxr) '(col,row,card) dim tbcol(7) 'cards in each tableau column dim stak(150,1),stok(25) dim grat$(6)=("Noice!","Schw33t!","WAY2GO!","WINNER!","Awesome!","Cool!","") dim stp(3)=(0,1,0,-1) stak(0,1)=x+fx+dx*5:stak(1,1)=x+fx+dx*6 stak(139,1)=x+fx+dx*0:stak(140,1)=x+fx+dx*1 stak(138,1)=x+fx+dx*2:stak(137,1)=x+fx+dx*3 MkTblx() init() Sub init() cls:timer=0 for j=1 to 13 play sound 1,B,T,300 pause 10:play stop pause 30 next j CONTEXT=0:SSX=0:SSY=0:CX=1:CY=1 RBOX bx,by,dx*6+60,dy*15+90,12,satin,velvet RBOX bx-1,by-1,dx*6+60+2,dy*15+90+2,12,satin text stak(0,1),sy,blank$,,1,2,cardback,stc text stak(1,1),sy,back$,,1,2,cardback,cardstock text stak(139,1),sy,blank$,,1,2,cardback,stc text stak(140,1),sy,blank$,,1,2,cardback,stc text stak(138,1),sy,blank$,,1,2,cardback,stc text stak(137,1),sy,blank$,,1,2,cardback,stc MakeDeck() Shuffle() Deal() End Sub BEGIN: DO if stak(137,0)+stak(138,0)+stak(139,0)+stak(140,0)=52 then tic=3:eks=0:why=0 tm=Timer:mns=int(tm/60000):scs=int(tm/1000 mod 60) if scs<10 then pd$="0" else pd$="" grat$(6)=STR$(mns) + ":" + pd$ + STR$(scs) do CMD$=inkey$ if CMD$=CHR$(27) then init() GOTO BEGIN endif h=int(rnd*7):sfc=1:if h=6 then sfc=2 msg$=grat$(h) if (int(rnd*5)-1<0) then text rnd*MM.Hres,rnd*MM.Vres,msg$,,,sfc,rgb(rnd*255,rnd*255,rnd*255) endif line MM.Hres/2-1,MM.Vres/2-1,eks,why,1,rgb(black) if ((eks+why) mod (MM.Hres-1))=0 then tic=(tic+1) mod 4 endif eks=eks+stp((tic+1) mod 4):why=why+stp(tic) loop endif CMD$=inkey$:UI if CMD$=CHR$(27) then '[ESC] re-deal init() GOTO BEGIN endif SELECT CASE CONTEXT CASE =0: if CMD$=CHR$(129) then '[DOWN] switch CONTEXT CONTEXT=1:CY=tbcol(CX) if CY=0 then CY=1 EraseCursor endif if M <> 0 then if CMD$=CHR$(13) then '[ENTER] send P to STAX a0=ExecMove(9,0,0,0) elseif CMD$=CHR$(32) then '[SPACE] mark STOK for TAB SSX=99:SSY=99 'add markup elseif CMD$=CHR$(130) then '[LEFT] prev P from STOK P=(P-1):if P<0 then P=M-1:play tone 120,120,50 PutPile(stok(P)) elseif CMD$=CHR$(131) then '[RIGHT] next P from STOK P=(P+1) mod M if P=0 then play tone 120,120,50 PutPile(stok(P)) endif endif CASE =1: if CMD$=CHR$(13) then '[ENTER] send TAB to STAX if ExecMove(9,CX,CY,0)=1 then EraseCursor :CY=CY-1 if CY=0 then CY=1 endif elseif CMD$=CHR$(32) then '[SPACE] send STOK to TAB SELECT CASE SSX CASE =99: dsy=1-0^tbcol(CX) a0=ExecMove(CX,CY+dsy,0,0) SSX=0:SSY=0 CASE =0: SSX=CX:SSY=CY 'add markup mayhaps CASE 1 to 7: dsy=1-0^tbcol(CX) a0=ExecMove(SSX,SSY,CX,CY+dsy) SSX=0:SSY=0 END SELECT elseif CMD$=CHR$(9) then '[TAB] switch CONTEXT etc. EraseCursor :SSX=0:SSY=0:CONTEXT=0 elseif CMD$=CHR$(128) then '[UP] EraseCursor :CY=CY-1 if CY<1 then CONTEXT=0 if flip(tablo(CX,CY))=0 then CONTEXT=0 elseif CMD$=CHR$(129) then '[DOWN] EraseCursor :CY=CY+1 if CY>tbcol(CX) then CY=1 do while flip(tablo(CX,CY))=0 CY=CY+1 loop endif if flip(tablo(CX,CY))=0 then CY=tbcol(CX) elseif CMD$=CHR$(130) then '[LEFT] EraseCursor :CX=CX-1 if CX < 1 then CX=7 CY=tbcol(CX):if CY=0 then CY=1 elseif CMD$=CHR$(131) then '[RIGHT] EraseCursor :CX=(CX+1) if CX > 7 then CX=1 CY=tbcol(CX):if CY=0 then CY=1 endif END SELECT DrawBlo() LOOP Function ExecMove(Q,R,S,T) if R=0 then '1) STOK to STAX: 9(Q) if PutStk(stok(P))=1 then a0=DelStok(P):PutPile(stok(P)) elseif S=0 then '2) STOK to TAB: col(Q),row(R) if PutTab(Q,R,stok(P))=1 then CardSound():a0=DelStok(P):PutPile(stok(P)) elseif T=0 then '3) TAB to STAX: 9(Q),col(R),row(S) if PutStk(tablo(R,S))=1 then EraseCard(R,S):CleanUp(R,S) else ExecMove=0:exit function endif else '4) TAB to TAB: scol(Q),srow(R),dcol(S),drow(T) Qc=tbcol(Q) if MvTab(Q,R,S,T)=1 then CleanUp(Q,R) for yv=R+1 to Qc n0=MvTab(Q,yv,S,T-R+yv) next yv CardSound() endif endif ExecMove=1 End Function Function MvTab(sc,sr,dc,dr) src=tablo(sc,sr):dst=tablo(dc,dr-1) if rank(src)=13 then if tbcol(dc)<>0 then MvTab=Err(99):exit function else if colo(src)=colo(dst) then MvTab=Err(99):exit function if rank(src)<>rank(dst)-1 then MvTab=Err(99):exit function if flip(src) = 0 then MvTab=Err(99):exit function if flip(dst) = 0 then MvTab=Err(99):exit function if tbcol(dc) <> dr-1 then MvTab=Err(99):exit function endif text tablx(dr,dc,0),tablx(dr,dc,1),face$(src),,1,2,colo(src),cardstock text tablx(sr,sc,0),tablx(sr,sc,1),blank$,,1,2,velvet,velvet tbcol(sc)=tbcol(sc)-1:tablo(dc,dr)=src:tbcol(dc)=tbcol(dc)+1 MvTab=1 End Function Function PutTab(Xp,Yp,Card) 'rules: color diff, rank-1, face up, next empty if rank(Card)=13 then if tbcol(Xp)<>0 then PutTab=Err(99):exit function else tg=tablo(Xp,Yp-1) if colo(Card)=colo(tg) then PutTab=Err(99):exit function if rank(Card)<>rank(tg)-1 then PutTab=Err(99):exit function if flip(tg)=0 then PutTab=Err(99):exit function if tbcol(Xp)<>Yp-1 then PutTab=Err(99):exit function endif text tablx(Yp,Xp,0),tablx(Yp,Xp,1),face$(Card),,1,2,colo(Card),cardstock tablo(Xp,Yp)=Card:flip(Card)=1:tbcol(Xp)=tbcol(Xp)+1:PutTab=1 End Function Function PutStk(Card) 'rules: consecutive & suit if stak(suit(Card),0) <> rank(Card)-1 then PutStk=Err(99):exit function stak(suit(Card),0)=stak(suit(Card),0)+1 text stak(suit(Card),1),sy,face$(Card),,1,2,colo(Card),cardstock StaxSound() PutStk=1 End Function Sub PutPile(Card) if M=0 then text stak(0,1),sy,blank$,,1,2,cardback,stc text stak(1,1),sy,blank$,,1,2,cardback,stc exit sub endif if M=1 then text stak(1,1),sy,blank$,,1,2,cardback,stc endif text stak(0,1),sy,face$(Card),,1,2,colo(Card),cardstock End Sub Function DelStok(i) for dt=i to M stok(dt)=stok(dt+1) next dt M=M-1:P=P-1:if P<0 then P=0 DelStok=1 End Function Function Err(i) play tone 400,600,20 Err=0 End Function Sub EraseCard(col,row) text tablx(row,col,0),tablx(row,col,1),blank$,,1,2,velvet,velvet tbcol(col)=tbcol(col)-1 End Sub Sub FlipCard(row,col) cd=tablo(row,col) text tablx(col,row,0),tablx(col,row,1),face$(cd),,1,2,colo(cd),cardstock flip(cd)=1 End Sub Sub MakeSplotch(col) text tablx(1,col,0),tablx(1,col,1),blank$,,1,2,cardback,stc End Sub Sub UI tim=Timer:mins=int(tim/60000):secs=int(tim/1000 mod 60) if secs<10 then pad$="0" else pad$="" tstr$=STR$(mins) + ":" + pad$ + STR$(secs) text 0,0,"":?:? " ";:? tstr$ x1=530:y1=180:dx1=6:dy1=12 text x1,y1+dy1*0,CHR$(146)+"/"+CHR$(147),R,,,rgb(green):text x1+dx1,y1+dy1*0,"move cursor",L,,,rgb(red) text x1,y1+dy1*1,CHR$(149)+"/"+CHR$(148),R,,,rgb(green):text x1+dx1,y1+dy1*1,"prev/next card",L,,,rgb(red) text x1,y1+dy1*2,"SPACE",R,,,rgb(green):text x1+dx1,y1+dy1*2,"select/place card",L,,,rgb(red) text x1,y1+dy1*3,"ENTER",R,,,rgb(green):text x1+dx1,y1+dy1*3,"move to suit stack",L,,,rgb(red) text x1,y1+dy1*4,"-TAB-",R,,,rgb(green):text x1+dx1,y1+dy1*4,"jump to deck",L,,,rgb(red) text x1,y1+dy1*5,"-ESC-",R,,,rgb(green):text x1+dx1,y1+dy1*5,"new deal",L,,,rgb(red) text x1-50,y1/3,"SOLI"+CHR$(140),,,4,rgb(red),cardstock text x1-50,y1/3+4*dy1,"TAIRE",,,4,rgb(black),cardstock text x1+110,y1/3,CHR$(design),,,4,rgb(black),cardstock text x1+110,y1/3+4*dy1,CHR$(design),,,4,rgb(red),cardstock End Sub Sub CleanUp(Cz,Rz) if Rz=1 then MakeSplotch(Cz) else FlipCard(Cz,Rz-1) endif End Sub Sub DrawBlo() for cl=1 to 7 for rw=1 to tbcol(cl) cd=tablo(cl,rw) if flip(cd)=0 then fce$=back$:C0=cardback else fce$=face$(cd):C0=colo(cd) endif cs=cardstock text tablx(rw,cl,0),tablx(rw,cl,1),fce$,,1,2,C0,cs next rw next cl PutPile(stok(P)) SELECT CASE CONTEXT CASE =0: BOX stak(0,1)-2,sy-2,charw,charh,2,satin CASE =1: BOX tablx(CY,CX,0)-2,tablx(CY,CX,1)-2,charw,charh,2,satin END SELECT End Sub Sub EraseCursor BOX tablx(CY,CX,0)-2,tablx(CY,CX,1)-2,charw,charh,2,velvet BOX stak(0,1)-2,sy-2,charw,charh,2,velvet End Sub Sub Shuffle 'shuffle the deck for j=0 to cards:used(j)=0:shuf(j)=0:next j for i = 0 to cards k=0 DO a=rnd*cards mod 53 if used(a)=0 then used(a)=1 shuf(i)=a k=1 endif LOOP UNTIL k=1 next i End Sub Sub Deal 'deal the tableau and stock pile k=0:t=0:w=7 for j=1 to 7: tbcol(j)=0:next j for row=1 to 7 for col=row to 7 if k=t then flip(shuf(k))=1 t=k+w w=w-1 endif if flip(shuf(k))=0 then fce$=back$ C0=cardback else fce$=face$(shuf(k)) C0=colo(shuf(k)) endif text tablx(row,col,0),tablx(row,col,1),fce$,,1,2,C0,cardstock tablo(col,row)=shuf(k) tbcol(col)=tbcol(col)+1 k=k+1 next col next row stok(24)=-1 for i=0 to 23 stok(i)=shuf(k):flip(stok(i))=1 k=k+1 next i M=24:P=0:PutPile(stok(P)) End Sub Sub MakeDeck 'build the deck k=0 for i=0 to 3 for j=1 to ranks if i mod 2=0 then colo(k)=rgb(black) else colo(k)=rgb(red) endif face$(k)=ronk$(j)+CHR$(soot(i)) 'face flip(k)=0 'face down by default suit(k)=soot(i) 'numeric suit rank(k)=j 'rank (as int) k=k+1 next j next i stak(137,0)=0:stak(138,0)=0:stak(139,0)=0:stak(140,0)=0 End Sub Sub MkTblx 'create tablx for i=1 to mxr for j=1 to 7 tablx(i,j,0)=x+fx tablx(i,j,1)=y+fy tablo(j,i)=53 if j=7 then x=startx y=y+dy else x=x+dx endif next j next i End Sub Sub CardSound play sound 1,B,P,30:pause 5:play stop End Sub Sub StaxSound play tone 3000,5000,2 End Sub