Club Amiga de Montreal - CAM/CAM_CD_1.iso/files/058.lha/Solitare

AmigaBASIC Source Code | 1986-11-20 | 15.7 KB | 785 lines

CLEAR, 40960
DEFINT a-z
OPTION BASE 1
DIM deck(52),upcp(7,12),downcp(7,6),cpndx(7,2),ap(4,12) 'card pile arrays
DIM suit(21,4), cardval(21,13), card(99,52) 'card graphics arrays
DIM topdeck(2), temp(2,2), drawdeck(24), playdeck(24)
GOTO Begin

'MigaSol version 1.0
'Copyright 1986, Jon Scarpelli. All rights reserved.
'The author retains all rights to this software and
'hereby grants license for the free dissemination
'of this software product for non-commercial use only
'under the sole condition that this notice not be
'removed. The author reserves the right to revoke this
'license at any time.
'Now that that's done, this software is distributed as
'Shareware. If you find yourself using this software
'and would like to encourage both the Shareware concept
'and further development of this program, please send
'a contribution ($10 would be nice) to the author:
'        Jon Scarpelli
'        3209 Lindenwood
'        Dearborn, MI  48120
'Planned enhancements include music, rules to reduce but
'not eliminate cheating, score keeping, and an UNDO
'function. Your comments and suggestions will be
'appreciated. ENJOY THIS!

Begin:

GOSUB GetGraphics
GOSUB StartGame

LOCATE 16,3:PRINT "HELP"
LOCATE 18,3:PRINT "PLAY  "

HelpOrPlay:

WHILE MOUSE(0)<>1:WEND
x=MOUSE(3):y=MOUSE(4)

IF x>16 AND x<48 AND y>120 AND y<129 THEN
  HelpNeeded=-1
END IF

IF HelpNeeded THEN
  GOSUB PlayInstructions
  GOTO CheckMouse
ELSE
  LOCATE 16,3:PRINT "Have at it!  "
  LOCATE 18,3:PRINT "REDEAL"
  GOTO CheckMouse
END IF

CheckMouse:

WHILE MOUSE(0)<>1:WEND
x=MOUSE(3):y=MOUSE(4)

ProcessSelection:

LOCATE 2,3
PRINT "Wait..."
LOCATE 3,3
PRINT "       "
LOCATE 16,3
PRINT "             "

IF x>16 AND x<56 AND y>152 AND y<161 THEN
  IF click=frompos THEN
    Oops=-1:click=newpos
    GOTO ShowSelect
  ELSE
    LOCATE 16,3:PRINT "Too late...  "
  END IF
ELSEIF x>16 AND x<64 AND y>136 AND y<145 THEN
  redeal=-1
  GOSUB StartGame
  GOTO CheckMouse
ELSE
  click=click*-1
END IF

IF click=frompos THEN
  fromcardpile=0:fromplaypile=0
  tocardpile=0:newpile=0
END IF

GOSUB TestPile
IF UsingCardpile THEN
 IF cpndx(pile,up)>0 THEN  'up card available
  GOSUB TestUpCard    'was card picked available & get y positions
  IF validcard THEN
    IF click=frompos THEN
      fromx1=x1:fromy1=y1
      fromx2=x2:fromy2=y2
      fromcard=card:frompile=pile
      fromupndx=cpndx(pile,up)
      fromdownndx=cpndx(pile,down)
      cardstomove=fromupndx-card+1
      fromcardpile=-1
    ELSE  'click=newpos
      tocardpile=-1
      newx1=x1:newy1=y1
      newx2=x2:newy2=y2
      newcard=card:newpile=pile
      newupndx=cpndx(newpile,up)
      IF fromcardpile THEN
        GOSUB UpdateArrays
        IF OkToMove THEN
          GOSUB MoveCard
        END IF
      ELSE
        GOSUB UsePlayPile
      END IF
    END IF
  ELSE
    click=click*-1
  END IF
 ELSEIF cpndx(pile,down)>0 THEN  'down card available
       GOSUB TestDownCard
       IF validcard THEN
         IF click=frompos THEN     'turn card over
           CurrentCard=downcp(pile,1)
           PUT (x1,y1),card(1,CurrentCard),PSET
           IF cpndx(pile,down)>1 THEN
             FOR i=1 TO 5
               downcp(pile,i)=downcp(pile,i+1)
             NEXT i
           END IF
           cpndx(pile,up)=1
           cpndx(pile,down)=cpndx(pile,down)-1
           cpndx(pile,up)=1
           upcp(pile,1)=CurrentCard
           click=click*-1
         END IF
       ELSE
         click=click*-1
       END IF
     ELSE      'empty pile
       IF click=newpos THEN
         newcard=1:newpile=pile
         newy1=5:newx1=x1:newupndx=0
         IF fromcardpile THEN
           GOSUB UpdateArrays
           IF OkToMove THEN
             GOSUB MoveCard
           END IF
         ELSE
           tocardpile=-1
           GOSUB UsePlayPile
         END IF
       ELSE
         LOCATE 16,3
         PRINT "Not today... "
         click=click*-1
       END IF
     END IF
ELSEIF ace1pile OR ace2pile OR ace3pile OR ace4pile THEN
       IF click=newpos THEN
         newx1=580:newcard=1
         IF ace1pile THEN
           newpile=1:newy1=35
         ELSEIF ace2pile THEN
               newpile=2:newy1=70
         ELSEIF ace3pile THEN
               newpile=3:newy1=105
         ELSE
               newpile=4:newy1=140
         END IF

         GOSUB UpdateAceArray
         IF OkToMove THEN
           IF fromplaypile THEN
             GOSUB UsePlayPile
           ELSE
             GOSUB MoveCard
           END IF
         END IF
       END IF
     ELSEIF UsingDrawpile THEN
       GOSUB UseDrawPile
       click=newpos
     ELSEIF UsingPlaypile AND cardtoplay>0 THEN
       GOSUB UsePlayPile
     ELSE
       click=click*-1
     END IF

ShowSelect:

Oops=0

LOCATE 2,3
PRINT "Select "

LOCATE 3,3
IF click=frompos THEN
  PRINT "To...  "
ELSE
  PRINT "From..."
END IF

GOTO CheckMouse


TestPile:

  UsingCardpile=0:pile=0
  UsingDrawpile=0:UsingPlaypile=0
  ace1pile=0:ace2pile=0
  ace3pile=0:ace4pile=0
  IF y>4 AND y<161 AND x>131 AND x<549 THEN
    IF x>131 AND x<164 THEN
        pile=1:UsingCardpile=-1
        x1=132:x2=163
    ELSEIF x>195 AND x<228 THEN
        pile=2:UsingCardpile=-1
        x1=196:x2=227
    ELSEIF x>259 AND x< 292 THEN
        pile=3:UsingCardpile=-1
        x1=260:x2=291
    ELSEIF x>323 AND x<356 THEN
        pile=4:UsingCardpile=-1
        x1=324:x2=355
    ELSEIF x>387 AND x<420 THEN
        pile=5:UsingCardpile=-1
        x1=388:x2=419
    ELSEIF x>451 AND x< 484 THEN
        pile=6:UsingCardpile=-1
        x1=452:x2=483
    ELSEIF x>515 AND x<548 THEN
        pile=7:UsingCardpile=-1
        x1=516:x2=547
    ELSE
        LOCATE 16,3
        PRINT "Which pile?  "
    END IF
  ELSEIF x>19 AND x<52 AND y>39 AND y<64 THEN
        UsingPlaypile=-1
        x1=20:y1=40:x2=51:y2=63
   ELSEIF x>19 AND x<52 AND y>79 AND y<104 THEN
        UsingDrawpile=-1
   ELSEIF x>579 AND x<612 AND click=newpos THEN
      x1=580:x2=611
      IF y>34 AND y<59 THEN
        ace1pile=-1 '1st ace pile
        y1=35:y2=58
      ELSEIF y>69 AND y<94 THEN
        ace2pile=-1 '2nd ace pile, etc.
        y1=70:y2=93
      ELSEIF y>104 AND y<129 THEN
        ace3pile=-1
        y1=105:y2=128
      ELSEIF y>139 AND y<164 THEN
        ace4pile=-1
        y1=140:y2=163
      ELSE
        LOCATE 16,3
        PRINT "How's that?  "
      END IF
    ELSE
      LOCATE 16,3
      PRINT "Whuh..??     "
    END IF

RETURN

TestUpCard:

  card=0:validcard=0

  IF y>4 AND y<161 THEN card=INT((y-5)/12)+1

  IF card<=cpndx(pile,up) THEN      'pointing to top half
    validcard=-1                    'of any up card
  ELSEIF card-1=cpndx(pile,up) THEN   'pointing to bottom
        card=card-1                   'half of last up card
        validcard=-1
  ELSE
    LOCATE 16,3:PRINT "Which card?  "
  END IF

'Get y1 and y2 position

  IF validcard THEN      'card <= cpndx
    y1=5+(card-1)*12
    y2=5+(cpndx(pile,up)+1)*12
  END IF

RETURN

TestDownCard:

  card=0:validcard=0

  IF y>4 AND y<161 THEN card=INT((y-5)/12)+1

  IF card=1 OR card=2 THEN
    card=1
    y1=5
    validcard=-1
  ELSE
    LOCATE 16,3:PRINT "Come again?  "
  END IF

RETURN

UpdateArrays:

  OkToMove=0

  IF frompile<>newpile THEN
    GOSUB FromPileRedraw
    j=1
    IF newupndx>0 THEN  'cards already showing
      newy1=newy1+12    'offset so as not to cover
    END IF
    FOR i=fromcard TO fromcard+cardstomove-1
      upcp(newpile,newupndx+j)=upcp(frompile,i)
      upcp(frompile,i)=0
      j=j+1
    NEXT i
    cpndx(frompile,up)=fromupndx-cardstomove
    cpndx(newpile,up)=newupndx+cardstomove
    OkToMove=-1
  ELSE
    LOCATE 16,3
    PRINT "Nope...      "
  END IF

RETURN


UpdateAceArray:

  OkToMove=0

  IF fromcardpile THEN
    CurrentCard=upcp(frompile,fromcard)
  ELSE
    CurrentCard=playdeck(cardtoplay)
  END IF

  IF ap(newpile,1)>0 THEN 'not 1st card on pile
    IF CurrentCard=ap(newpile,1)+1 THEN  'consequtive cards
      IF fromcardpile THEN
        GOSUB FromPileRedraw
        upcp(frompile,fromcard)=0
        cpndx(frompile,up)=fromupndx-1
      END IF
      newx1=580:newcard=1
      FOR i=1 TO 11
        ap(newpile,i+1)=ap(newpile,i)
      NEXT i
      ap(newpile,1)=CurrentCard
      OkToMove=-1
    ELSE
      LOCATE 16,3
      PRINT "Can't do that"
    END IF
  ELSEIF CurrentCard=1 OR CurrentCard=14 OR CurrentCard=27 OR CurrentCard=40 THEN
        IF fromcardpile THEN
          GOSUB FromPileRedraw
          upcp(frompile,fromcard)=0
          cpndx(frompile,up)=fromupndx-1
        END IF
        newx1=580:newcard=1
        ap(newpile,1)=CurrentCard
        OkToMove=-1
      ELSE
        LOCATE 16,3
        PRINT "Can't do that"
      END IF

RETURN

FromPileRedraw:


  DrawEmptyPile=0:DrawCardBack=0

  IF fromcard=1 THEN   '1st card moving
    IF fromdownndx>0 THEN  'down cards available
      DrawCardBack=-1
    ELSE
      DrawEmptyPile=-1
    END IF
  ELSE
    CardToRedraw=upcp(frompile,fromcard-1)
  END IF

RETURN

MoveCard:

  ERASE temp
  arraysize=3+INT((16+fromx2-fromx1)/16)*(1+fromy2-fromy1)*2
  DIM temp(arraysize,2)
  GET (fromx1,fromy1)-(fromx2,fromy2),temp(1,1)  ' cards
  GET (fromx1-32,fromy1)-(fromx2-32,fromy2),temp(1,2)  'clear background
  PUT (fromx1,fromy1),temp(1,2),PSET 'clear fromcards
  'put bottom half of card left or empty pile or back of down card
  IF DrawEmptyPile THEN
    LINE (fromx1,fromy1)-(fromx1+31,fromy1+23),1,b
    DrawEmptyPile=0
  ELSEIF DrawCardBack THEN
        PATTERN ,topdeck
        COLOR 3,2
        LINE (fromx1,fromy1)-(fromx1+31,fromy1+23),,bf
        DrawCardBack=0
      ELSE
        PUT (fromx1,fromy1-12),card(1,CardToRedraw),PSET
      END IF

  PUT (newx1,newy1),temp(1,1),PSET

RETURN

UseDrawPile:

  IF click = frompos THEN
    IF cardsdealt < cardstodeal THEN
      IF cardsdealt < cardstodeal-2 THEN
        FOR i=1 TO 3
          playdeck(cardtoplay+i)=drawdeck(cardsdealt+i)
        NEXT i
        cardtoplay=cardtoplay+3
        cardsdealt=cardsdealt+3
      ELSEIF cardsdealt=cardstodeal-2 THEN
        playdeck(cardtoplay+1)=drawdeck(cardsdealt+1)
        playdeck(cardtoplay+2)=drawdeck(cardsdealt+2)
        cardtoplay=cardtoplay+2
        cardsdealt=cardsdealt+2
      ELSEIF cardsdealt=cardstodeal-1 THEN
        playdeck(cardtoplay+1)=drawdeck(cardsdealt+1)
        cardtoplay=cardtoplay+1
        cardsdealt=cardsdealt+1
      END IF
      newx1=20:newy1=40 'playpile coords
      CurrentCard=playdeck(cardtoplay) 'get current card to play
      PUT (newx1,newy1),card(1,CurrentCard),PSET 'show current card
      IF cardsdealt = cardstodeal THEN 'draw empty draw pile
        ERASE temp
        DIM temp(99,2)
        GET (60,162)-(91,185),temp(1,2) 'get empty background
        PUT (20,80),temp(1,2),PSET 'clear draw deck
        LINE (20,80)-(51,103),1,b 'draw empty pile
      END IF
    ELSE  'empty draw pile
      FOR i=1 TO cardstodeal-cardsplayed 'move play pile to draw pile
        drawdeck(i) = playdeck(i)
      NEXT i
      cardstodeal = cardstodeal-cardsplayed
      cardsplayed=0:cardtoplay=0:cardsdealt=0
      IF cardstodeal>0 THEN
        ERASE temp
        DIM temp( 99,2)
        GET (60,162)-(91,185),temp(1,2) 'get empty background
        PUT (20,40),temp(1,2),PSET 'clear play deck
        LINE (20,40)-(51,63),1,b 'draw empty pile
        PATTERN ,topdeck
        COLOR 3,2
        LINE (20,80)-(51,103),,bf
      END IF
    END IF
  END IF

RETURN

UsePlayPile:

  IF cardtoplay > 0 THEN
    IF click = frompos THEN
      fromx1=x1:fromx2=x2
      fromy1=y1:fromy2=y2
      validcard=-1:fromplaypile=-1
      fromcardpile=0
    ELSE  'click=newpos
      CurrentCard=playdeck(cardtoplay)
      cardsplayed=cardsplayed+1
      cardtoplay=cardtoplay-1
      IF cardtoplay=0 THEN
        DrawEmptyPile=-1
      ELSE
        CardToRedraw=playdeck(cardtoplay)
      END IF
      IF tocardpile THEN
        IF newupndx > 0 THEN
          newy1=newy1+12
        END IF
        upcp(newpile,newupndx+1)=CurrentCard
        cpndx(newpile,up)=newupndx+1
      END IF
      ERASE temp
      DIM temp(99,2)
      GET (fromx1,fromy1)-(fromx2,fromy2),temp(1,1)
      PUT (newx1,newy1),temp(1,1),PSET
      IF NOT DrawEmptyPile THEN
        PUT (fromx1,fromy1),card(1,CardToRedraw),PSET
      ELSE
        GET (60,162)-(91,185),temp(1,2) 'get empty background
        PUT (fromx1,fromy1),temp(1,2),PSET 'clear play deck
        LINE (fromx1,fromy1)-(fromx2,fromy2),1,b
        DrawEmptyPile=0
      END IF

      OkToMove=-1
    END IF
  END IF

RETURN

StartGame:
  up=1:down=2
  frompos=-1:newpos=1:click=newpos:redeal=0
  cardstodeal=24:cardsdealt=0:cardtoplay=0
  cardsplayed=0
  COLOR 1,0
InitArrays:
  FOR card=1 TO 52
    deck(card)=card
  NEXT card

  FOR pile=1 TO 7
    cpndx(pile,up)=1
    cpndx(pile,down)=pile-1
  NEXT pile

  FOR pile=1 TO 4
    FOR card=1 TO 12
      ap(pile,card)=0
    NEXT card
  NEXT pile

  FOR card=1 TO 24
    playdeck(card)=0
    drawdeck(card)=0
  NEXT card

  FOR pile=1 TO 7
    FOR card=1 TO 12
      upcp(pile,card)=0
    NEXT card
  NEXT pile

  FOR pile=1 TO 7
    FOR card=1 TO 6
      downcp(pile,card)=0
    NEXT card
  NEXT pile

  RANDOMIZE  TIMER
  played=1

Gencards:

  FOR i=1 TO 52
    x=INT(RND*52+1)
    SWAP deck(i),deck(x)
  NEXT i

DealCards:
  played=0
  FOR card=1 TO 7
    FOR pile = card TO 7
      played=played+1
      IF card=1 THEN
        upcp(pile,card)=deck(played)
      ELSE
        downcp(pile,card-1)=deck(played)
      END IF
    NEXT pile
  NEXT card

BuildDrawDeck:

  FOR i=29 TO 52
    j=i-28
    drawdeck(j)=deck(i)
  NEXT i

TurnPiles:
  CLS
  COLOR 1,0

  FOR pile=1 TO 7        ' card piles
    CurrentCard=upcp(pile,1)
    x=132+((pile-1)*64)
    y=5
    PUT (x,y),card(1,CurrentCard),PSET
   NEXT pile

  FOR pile=1 TO 4     ' empty ace piles
    x=580
    y=35*pile
    LINE (x,y)-(x+31,y+23),1,b
  NEXT pile

' create empty play pile and draw pile
  x=20
  y=40
  LINE (x,y)-(x+31,y+23),1,b
  x=20
  y=80
  PATTERN ,topdeck
  COLOR 3,2
  LINE (x,y)-(x+31,y+23),,bf
   x=1:y=1

  LOCATE 18,3
  PRINT "REDEAL"

  LOCATE 20,3
  PRINT "Oops!"

  LOCATE 2,3
  PRINT "Select "
  LOCATE 3,3
  PRINT "From..."

RETURN


GetGraphics:

  'load 1st 3 words of each array
  FOR i=1 TO 4
    suit (1,i)=16
    suit (2,i)=9
    suit (3,i)=2
  NEXT i

  FOR i=1 TO 13
    cardval (1,i)=16
    cardval (2,i)=9
    cardval (3,i)=2
  NEXT i

  FOR i=1 TO 52
    card (1,i)=32
    card (2,i)=24
    card (3,i)=2
  NEXT i

  FOR j=1 TO 4
    FOR i=4 TO 12
      READ suit(i,j)
    NEXT i
  NEXT j

  FOR j=13 TO 1 STEP -1
    FOR i=4 TO 12
      READ  cardval(i,j)
    NEXT i
  NEXT j


  READ topdeck(1):READ topdeck(2)

  k=1
  PRINT "Please wait while I print a new deck for you..."
  FOR  i=1 TO 4
    FOR j=1 TO 13
      LINE (16,59)-(47,82),1,bf
      PUT (16,60),cardval(1,j)
      PUT (32,60),suit(1,i)
      IF i=1 OR i=3 THEN suitcolor=2 :ELSE suitcolor=3
      PAINT (40,64),suitcolor,1
      IF j <> 10 AND j <> 13 THEN PAINT (24,60),suitcolor,1
        IF j=10 THEN PAINT (24,60),suitcolor,1: PAINT (18,60),suitcolor,1
        IF j=13 THEN PAINT (20,60),suitcolor,1
        GET (16,59)-(47,82),card(1,k)
      k=k+1
    NEXT j
  NEXT i
RETURN

PlayInstructions:

  LOCATE 5,38:PRINT "CARD PILES"
  LOCATE 6,9:PRINT "PLAY"
  LOCATE 6,67:PRINT "ACES"
  LOCATE 11,9:PRINT "DRAW"
  LOCATE 16,3:PRINT "    "
  LOCATE 18,3:PRINT "PLAY"
  COLOR 1,0
  LOCATE 7,15
  PRINT "1 Cards are moved (3 at a time) from the draw pile"
  LOCATE 8,15
  PRINT "  to the play pile by clicking once on the draw pile."
  LOCATE 9,15
  PRINT "2 A checkered design indicates that a card is face"
  LOCATE 10,15
  PRINT "  down on the pile, ready for play. Down cards are"
  LOCATE 11,15
  PRINT "  turned up by clicking once on the down card."
  LOCATE 12,15
  PRINT "3 Cards are moved from the play pile and card piles to"
  LOCATE 13,15
  PRINT "  the card piles and ace piles by clicking once on the"
  LOCATE 14,15
  PRINT "  card to be moved (Select From) and then clicking once"
  LOCATE 15,15
  PRINT "  on the card position to move to (Select To)."
  LOCATE 16,15
  PRINT "4 One-click the empty draw pile to recycle the play pile."
  LOCATE 17,15
  PRINT "5 Watch the Select box. It tells you what action is "
  LOCATE 18,15
  PRINT "  expected. If you click on a card and see no response in"
  LOCATE 19,15
  PRINT "  the Select box, wait one full second, then click on the"
  LOCATE 20,15
  PRINT "  card indicated in the Select box."
  LOCATE 21,15
  PRINT "6 Oops! will change Select To... to Select From..."
  LOCATE 22,15
  PRINT "7 This game will allow you to cheat and win.   Good luck."
  COLOR 3,2
  HelpNeeded=0:redeal=-1
RETURN

'club data
DATA &h0180,&h07e0,&h07e0,&h03c0
DATA &h1ff8,&h3ffc,&h3ffc,&h1db8,&h0180
'heart data
DATA &h0e38,&h1f7c,&h1ffc,&h1ffc
DATA &h1ffc,&h0ff8,&h07f0,&h01c0,&h0080
'spade data
DATA &h0180,&h03c0,&h07e0,&h0ff0
DATA &h1ff8,&h1ff8,&h1db8,&h0180,&h0180
'diamond data
DATA &h0380,&h07c0,&h0fe0,&h3ff8
DATA &h7ffc,&h3ff8,&h0fe0,&h07c0,&h0380
'king data
DATA &h1c38,&h0c30,&h0c60,&h0ce0
DATA &h0fc0,&h0c60,&h0c70,&h0c30,&h1c38
'queen data
DATA &h07c0,&h1c70,&h3838,&h3838
DATA &h3838,&h39b8,&h39b8,&h1cfc,&h07ce
'jack data
DATA &h07f8,&h00e0,&h00e0,&h00e0
DATA &h00e0,&h00e0,&h38e0,&h38e0,&h1fc0
'10 data
DATA &h31fc,&h738e,&h7306,&h3306
DATA &h3306,&h3306,&h3306,&h338e,&h79fc
'9 data
DATA &h07f0,&h0e38,&h0e38,&h0e38
DATA &h07f8,&h0038,&h0e38,&h0770,&h03e0
'8 data
DATA &h07f0,&h1e3c,&h1c1c,&h1e3c
DATA &h07f0,&h1e3c,&h1c1c,&h1e3c,&h07f0
'7 data
DATA &h1ffc,&h1c1c,&h0038,&h0070
DATA &h00e0,&h01c0,&h0380,&h0380,&h0380
'6 data
DATA &h07e0,&h0e00,&h1c00,&h1c00
DATA &h1ff0,&h1c38,&h1c38,&h0e38,&h07f0
'5 data
DATA &h1ff0,&h1c00,&h1c00,&h1ff0
DATA &h0038,&h001c,&h1c1c,&h0e38,&h07f0
'4 data
DATA &h00f8,&h01f8,&h03b8,&h0738
DATA &h0e38,&h1c38,&h1ffc,&h0038,&h0038
'3 data
DATA &h1ffc,&h001c,&h0038,&h03f0
DATA &h0038,&h001c,&h301c,&h1838,&h0ff0
'2 data
DATA &h0ff8,&h1e1c,&h1c1c,&h003c
DATA &h07f8,&h1f00,&h1c00,&h1c00,&h1ff8
'ace data
DATA &h01c0,&h03e0,&h0770,&h0e38
DATA &h1c1c,&h1ffc,&h1c1c,&h1c1c,&h1c1c

'topdeck data
DATA &hf0f0,&h0f0f