to solitaire
print [Welcome to solitaire]
instruct
localmake "allranks [A 2 3 4 5 6 7 8 9 10 J Q K]
localmake "numranks map "ranknum :allranks
localmake "suits [H S D C]
localmake "reds [H D]
localmake "deckarray (listtoarray (crossmap "word :allranks :suits) 0)
localmake "upping "false
catch "exit [forever [onegame cleartext]]
cleartext
end
to s
solitaire
end
to onegame
print [Shuffling, please wait...]
local [card cards digit pile where]
localmake "onto []
local map [word "top ?] :suits
local cascade 9 [(sentence (word "shown #) (word "hidden #) ?)] []
localmake "ranks :allranks
localmake "numstacks 7
local map [word "num ?] :numranks
foreach :numranks [make word "num ? 4]
localmake "hand shuffle 52 :deckarray
setempty "pile
initstacks
foreach :suits [settop ? "]
redisplay
catch "endgame [forever [catch "bell [parsecmd]]]
end
;; Initialization
to instruct
print [] print [Here are the commands you can type:]
type "| | type (sentence standout "+ standout "=)
type "| | print [Deal three cards onto pile]
instruct1 "P [Play top card from pile]
instruct1 "R [Redisplay the board]
instruct1 "? [Retype these instructions]
instruct1 "card [Play that card]
instruct1 "M [Move same card again]
instruct1 "W [Play up as much as possible (Win)]
instruct1 "G [Give up (start a new game)]
instruct1 "X [Exit to Logo]
print [A card consists of a rank:]
type "| | print (sentence standout [A 2 3 4 5 6 7 8 9 10 J Q K]
"or standout "T [for 10])
print [followed by a suit:]
type "| | print standout [H S D C]
print (sentence [or followed by] standout ".
[to play all possible suits up])
print [] print [If you make a mistake, hit delete or backspace.]
print [] print [To move an entire stack,]
type "| | print [hit the shifted stack number:]
type "| | print (sentence standout [! @ # $ % ^ &] [for stacks])
type "| | print [1 2 3 4 5 6 7]
print []
end
to instruct1 :key :meaning
type "| |
type standout :key
repeat 5-count :key [type "| |]
print :meaning
end
to shuffle :len :array
if :len=0 [output arraytolist :array]
localmake "choice random :len
localmake "temp item :choice :array
setitem :choice :array (item :len-1 :array)
setitem :len-1 :array :temp
output shuffle :len-1 :array
end
to initstacks
for [num 1 7] [inithidden :num
turnup :num]
end
to inithidden :num
localmake "name hidden :num
setempty :name
repeat :num [push :name deal]
end
;; Reading and interpreting user commands
to parsecmd
if emptyp :digit [setcursor [1 22] type "| | setcursor [1 22]]
local "char
make "char uppercase readchar
if equalp :char "T [parsedigit 1 parsezero stop]
if memberp :char [1 2 3 4 5 6 7 8 9 A J Q K] [parsedigit :char stop]
if equalp :char "0 [parsezero stop]
if memberp :char :suits [play.by.name :char stop]
if equalp :char ". [allup stop]
if equalp :char "W [wingame stop]
if equalp :char "M [again stop]
if memberp :char [+ =] [hand3 stop]
if equalp :char "R [redisplay stop]
if equalp :char "? [helper stop]
if equalp :char "P [playpile stop]
if and equalp :char "|(| not emptyp :digit [cheat stop]
if and equalp :char "|)| not emptyp :digit [newstack stop]
if memberp :char [! @ # $ % ^ & * ( )] ~
[playstack :char [! @ # $ % ^ & * ( )] stop]
if memberp :char (list "| | char 8 char 127) [rubout stop]
if equalp :char "G [throw "endgame]
if equalp :char "X [throw "exit]
bell
end
to parsedigit :char
if not emptyp :digit [bell]
make "digit :char
type :digit
end
to parsezero
if not equalp :digit 1 [bell]
make "digit 10
type 0
end
to rubout
setcursor [1 22]
type "| |
setcursor [1 22]
setempty "digit
end
to bell
if not :upping [type char 7]
setempty "digit
throw "bell
end
;; Deal three cards from the hand
to hand3
if not emptyp :digit [bell]
if and emptyp :hand emptyp :pile [bell]
push "pile deal
repeat 2 [if not emptyp :hand [push "pile deal]]
dispile dishand
end
to deal
if emptyp :hand [make "hand reverse :pile setempty "pile]
if emptyp :hand [output []]
output pop "hand
end
;; Select card to play by position (pile or stack) or by name
to playpile
if emptyp :pile [bell]
if not emptyp :digit [bell]
make "card first :pile
make "where [rempile]
carddis :card
playcard
end
to playstack :which :list
if not emptyp :digit [bell]
foreach :list [if equalp :which ? [playstack1 # stop]]
end
to playstack1 :num
if greaterp :num :numstacks [bell]
if stackemptyp shown :num [bell]
make "card last thing shown :num
make "where sentence "remshown :num
carddis :card
playcard
end
to play.by.name :char
if emptyp :digit [bell]
if equalp :digit 1 [make "digit "a]
type :char
wait 0
make "card word :digit :char
setempty "digit
findcard
if not emptyp :where [playcard]
end
to findcard
if findpile [stop]
make "where findshown
if emptyp :where [bell]
end
to findpile
if emptyp :pile [output "false]
if equalp :card first :pile [make "where [rempile] output "true]
output "false
end
to findshown
for [num 1 :numstacks] ~
[if memberp :card thing shown :num [output sentence "remshown :num]]
output []
end
;; Figure out all possible places to play card, then pick one
to playcard
setempty "onto
if not coveredp [checktop]
if and not :upping ~
or (emptyp :onto) (not upsafep rank :card) ~
[checkonto]
if emptyp :onto [bell]
run :where
run first :onto
end
to coveredp
if equalp :where [rempile] [output "false]
output not equalp :card first thing shown last :where
end
to upsafep :rank
if memberp :rank [A 2] [output "true]
output equalp 0 thing word "num ((ranknum :rank)-2)
end
to checktop
if (ranknum rank :card) = 1 + (ranknum top suit :card) ~
[push "onto (list "playtop word "" suit :card)]
end
to checkonto
for [num :numstacks 1] ~
[ifelse stackemptyp shown :num
[checkempty :num]
[checkfull :num thing shown :num]]
end
to checkempty :num
if equalp rank :card "k [push "onto (list "playonto :num)]
end
to checkfull :num :stack
if equalp (redp :card) (redp first :stack) [stop]
if ((ranknum rank first :stack) = 1 + (ranknum rank :card)) ~
[push "onto (list "playonto :num)]
end
;; Play card, step 1: remove from old position
to rempile
make "cards (list (pop "pile))
dispile
end
to remshown :num
setempty "cards
remshown1 :num (count thing shown :num)
if stackemptyp shown :num [turnup :num disstack :num]
end
to remshown1 :num :length
do.until [push "cards (pop shown :num)] ~
[equalp :card first :cards]
for [i 1 [count :cards]] ~
[setcursor list (5*:num - 4) (5+:length-:i) type "| |]
end
to turnup :num
setempty shown :num
if stackemptyp hidden :num [stop]
push (shown :num) (pop hidden :num)
end
;; Play card, step 2: put in new position
to playtop :suit
localmake "var word "num ranknum rank :card
settop :suit rank :card
distop :suit
make :var (thing :var)-1
if (thing :var)=0 [make "ranks butfirst :ranks]
end
to playonto :num
localmake "row 4+count thing shown :num
localmake "col 5*:num-4
for [i 1 [count :cards]] ~
[localmake "card pop "cards
push (shown :num) :card
setcursor list :col :row+:i
carddis :card]
end
;; Update screen display
to redisplay
cleartext
for [num 1 :numstacks] [disstack :num]
foreach :suits "distop
dispile
dishand
setcursor [1 22]
setempty "digit
end
to disstack :num
setcursor list (-3 + 5 * :num) 4
type ifelse stackemptyp hidden :num ["| |] ["-]
if stackemptyp shown :num [setcursor list (-4 + 5 * :num) 5
type "| | stop]
localmake "stack (thing shown :num)
localmake "col 5*:num-4
for [i [count :stack] 1] ~
[setcursor list :col :i+4
carddis pop "stack]
end
to distop :suit
if emptyp top :suit [stop]
if equalp :suit "H [distop1 4 stop]
if equalp :suit "S [distop1 11 stop]
if equalp :suit "D [distop1 18 stop]
distop1 25
end
to distop1 :col
setcursor list :col 2
carddis word (top :suit) :suit
end
to dispile
setcursor [32 23]
ifelse emptyp :pile [type "| |] [carddis first :pile]
end
to dishand
setcursor [27 23]
type count :hand
type "| |
end
to carddis :card
ifelse memberp suit :card :reds [redtype :card] [blacktype :card]
type "| |
end
to redtype :word
type :word
end
to blacktype :word
type standout :word
end
;; Miscellaneous user commands
to again
if not emptyp :digit [bell]
if emptyp :onto [bell]
make "where list "remshown last pop "onto
if emptyp :onto [bell]
carddis :card
run :where
run first :onto
end
to helper
cleartext
instruct
print standout [type any key to continue]
ignore rc
redisplay
end
to allup
if emptyp :digit [bell]
if equalp :digit 1 [make "digit "a]
localmake "upping "true
type ". wait 0
foreach map [word :digit ?] [H S D C] ~
[catch "bell [make "card ?
findcard
if not emptyp :where [playcard]]]
setempty "digit
end
to wingame
type "W
localmake "cursor cursor
foreach :ranks [if not upsafep ? [stop]
make "digit ? ~
allup ~
setempty "digit ~
setcursor :cursor]
if equalp (map "top [H S D C]) [K K K K] ~
[ct print [you win!] wait 120 throw "endgame]
end
to newstack
localmake "num :numstacks+1
setcursor [1 22] type "| |
if not equalp :digit 9 [bell]
setempty hidden :num
setempty shown :num
make "numstacks :num
setempty "digit
end
to cheat
setcursor [1 22] type "| |
if not equalp :digit 8 [bell]
if and emptyp :hand emptyp :pile [bell]
push "pile deal
dispile
dishand
setempty "digit
end
;; Data abstraction (ranks)
to rank :card
output butlast :card
end
to ranknum :rank
if emptyp :rank [output 0]
if numberp :rank [output :rank]
if :rank = "A [output 1]
if :rank = "J [output 11]
if :rank = "Q [output 12]
if :rank = "K [output 13]
end
;; Data abstraction (suits)
to suit :card
output last :card
end
to redp :card
output memberp (suit :card) :reds
end
;; Data abstraction (tops)
to top :suit
output thing word "top :suit
end
to settop :suit :value
make (word "top :suit) :value
end
;; Data abstraction (card stacks)
to shown :num
output word "shown :num
end
to hidden :num
output word "hidden :num
end
;; Data abstraction (pushdown stacks)
to stackemptyp :name
output emptyp thing :name
end
to setempty :stack
make :stack []
end