path: root/js/games/nluqo.github.io/~bh/downloads/csls-programs/solitaire

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