master
; [Mastermind game]
cslsload "buttons
cslsload "streams
to master [:numsquares 4] [:dup.ok "false] [:mysecret "true]
; Mastermind game program.
; Program is controlled by mouse clicks or keystrokes.
if :LogoPlatform = "Windows [maximize.window "true]
window
if :LogoPlatform = "wxWidgets [localmake "fontsize labelsize]
localmake "colors "ROYGBV
localmake "colornums [[R 4] [O 14] [Y 6] [G 2] [B 1] [V 13]]
localmake "exact "true
local [numguesses numcolors column guess gotnum winloop permuting]
local [perms oldcount newcount guess.exact guess.inexact guess.word]
catch "quit [forever [
catch "master [
make "numguesses 0
make "numcolors 0
make "column 0
make "winloop "false
initdraw ; Clear screen, draw color palette
ifelse :mysecret [
ifelse :dup.ok ; Choose secret permutation
[make "secret (choose.dup :numsquares :colors)]
[make "secret (choose.nodup :numsquares :colors)]
newguess ; Display first guess frame
action.loop ; Read keyboard characters or mouse clicks
] [
catch "win [ ; User's secret, program has to guess.
ifelse :dup.ok [
make "permuting "false ; Lots of cases with dups okay, so
make "perms (list copies :numsquares "x)
make "newcount 0 ; find colors systematically first.
catch "perm [
for [i 1 6] [ ; Learn how many red, then orange, etc.
make "oldcount :newcount
doguess subst :i "x head :perms
make "newcount :guess.exact + :guess.inexact
make "perms flatten stream.map
`[insert ,[:newcount-:oldcount] ,:i ?] :perms
make "perms stream.filter
`[okay? ? ,:guess.exact ,:guess.inexact ,:guess.word]
:perms
check.consistency :perms
if equalp :newcount :numsquares [throw "perm]
]
check.consistency [] ; Tried all colors, user lied.
]
make "permuting "true
] [
make "perms perms "123456 :numsquares ; not :dup.ok
make "permuting equalp :numsquares 6
]
forever [ ; common portion
doguess head :perms
if equalp :numsquares :guess.exact + :guess.inexact ~
[make "permuting "true]
make "perms stream.filter
`[okay? ? ,:guess.exact ,:guess.inexact ,:guess.word]
:perms
check.consistency :perms
]
; Can't get here; either doguess finds a winner or
; check.consistency complains.
] ; We get here on throw "win from doguess.
move [15 12]
setpc 7 label "WIN!
ct print (sentence [I win in] :numguesses "turns.)
make "winloop "true
action.loop
]
]]]
cs ct setpc 7 st
end
;;; ================== LOGIC FOR MY GUESSES (USER SECRET) =================
to doguess :guessword
; Present computer's guess to user and ask about matches.
newguess ; Draw frame for guess.
make "guess.word :guessword ; Remember my colors.
foreach :guessword [apply "putguess item ? :colornums] ; Show colors.
askexact ; Ask user for exact matches.
make "gotnum "false
catch "ready [action.loop]
pu setpos [150 205] setpc 0 filled 0 [repeat 2 [fd 35 rt 90 fd 110 rt 90]]
setpc 7
ifelse :guess.exact < :numsquares [ ; Not all colors are exact.
ifelse :permuting [ ; If we know all the colors,
make "exact "false ; compute how many are inexact
getnum :numsquares-:guess.exact ; without asking.
] [
askinexact ; Otherwise, ask for inexact.
make "gotnum "false
catch "ready [action.loop]
pu setpos [150 205] setpc 0 filled 0 [repeat 2 [fd 35 rt 90 fd 110 rt 90]]
setpc 7
if :guess.exact + :guess.inexact > :numsquares ~
[check.consistency []] ; Quick error message if too many matches.
]
] [
throw "win ; All colors are exact, we win.
]
end
to subst :new :old :word
; For dups-okay guessing: Substitute the next trial color for
; all unknown squares in a partial permutation.
output map [ifelse equalp ? :old [:new] [?]] :word
end
to copies :num :letter
output cascade :num [word ? :letter] "
end
to insert :num :new :word
; For dups-okay guessing: We've learned that there are :NUM instances
; of color :NEW in the secret combination, so stick that many of them into
; a still-possible partial permutation, in every possible size=:NUM
; subset of the unknown slots.
; The result is a *stream* of possible (partial) permutations.
if :num=0 [output (list :word)] ; No slots needed, just one result.
if emptyp :word [output []] ; Not enough slots, no results!
if equalp first :word "x ; Else combine results of choosing or ~
[op flatten ; not choosing to replace into this X.
stream insert :num-1 :new word :new butfirst :word
`[(list stream.map [word "x ?] insert ,:num ",:new bf ",:word )]]
output stream.map `[word ",[first :word] ?] insert :num :new butfirst :word
end
to check.consistency :str
; If the stream of still-possible permutations is empty, then
; the user has lied to us.
if emptyp :str [ct print [Error -- inconsistent answers!]
repeat 2 [setbg 4 wait 1 setbg 0 wait 1]
type [Click or type anything to restart.] wait 0
waitforclick
throw "master]
end
to perms :word :num
; Output the stream of permutations of :NUM letters chosen from :WORD.
if :num=0 [output (list "|| )]
if emptyp :word [output []] ; Can't happen (would mean :num>count :word).
output flatten stream.map ~
`[[letter] stream.map `[word ,:letter ?]
perms remonce :letter ,:word ,[:num-1]] ~
:word
end
to okay? :perm :guess.exact :guess.inexact :guess.word
output and (equalp :guess.exact exact :perm :guess.word) ~
(equalp :guess.inexact inexact :perm :guess.word)
end
to askexact
; ct type "|How many EXACT matches? |
; pu setpos [185 210] setpc 6 label "EXACT?
localmake "caption.scrunch 1.5
setbutton [152 210] [100 25] [] "true 0 "EXACT? []
ern "caption.scrunch
make "exact "true
end
to askinexact
; ct type "|How many INEXACT matches? |
; pu setpos [185 210] setpc 6 label "INEXACT?
localmake "caption.scrunch 1.5
setbutton [152 210] [100 25] [] "true 0 "INEXACT? []
ern "caption.scrunch
make "exact "false
end
;;; ================== LOGIC FOR USER GUESSES (MY SECRET) =================
to choose.dup :number :colors
if :number = 0 [output "]
output word (pick :colors) (choose.nodup :number-1 :colors)
end
to choose.nodup :number :colors
if :number = 0 [output "]
make "color pick :colors
output word :color (choose.nodup :number-1 remonce :color :colors)
end
;;;;; ================ Used by both kinds of logic ======================
to exact :secret :guess
if empty? :secret [output 0]
output ehelp + (exact butfirst :secret butfirst :guess)
end
to ehelp
ifelse equal? (first :secret) (first :guess) [output 1] [output 0]
end
to inexact :secret :guess
output (anymatch :secret :guess) - (exact :secret :guess)
end
to anymatch :secret :guess
if empty? :secret [output 0]
if member? first :secret :guess ~
[output 1 + anymatch (butfirst :secret) (remonce first :secret :guess)]
output anymatch butfirst :secret :guess
end
to remonce :this :those
if empty? :those [output "]
if equal? :this first :those [output butfirst :those]
output word (first :those) (remonce :this butfirst :those)
end
;;;;; =================== USER INTERFACE (DRAWING) =======================
to initdraw
fs init.buttons
localmake "bigwidth ifelse :LogoPlatform = "wxWidgets [5*first :fontsize] [40]
localmake "bigbutton list :bigwidth 25
localmake "tallheight ifelse :LogoPlatform="wxWidgets [2+2*last :fontsize] [30]
localmake "tallbutton list :bigwidth :tallheight
ifelse :mysecret ~
[colorchart 6 "ROYGBV [4 14 6 2 1 13] 165
setbutton [-245 -15] :bigbutton [clear] "false 0 "erase "DEL] ~
[numchart 0 165]
setbutton pos0 [-245 -45] :bigbutton [if not :winloop [guess]] "true 0 "OK "RET
setbutton nxt :tallheight :tallbutton [throw "master] "false 0 [new game] "N
setbutton nxt 25 :bigbutton [throw "quit] "false 0 "quit "Q
ignore nxt 10
setbutton nxt :tallheight :tallbutton [make "mysecret "true throw "master] ~
:mysecret 0 [I guess] "I
setbutton nxt :tallheight :tallbutton [make "mysecret "false throw "master] ~
(not :mysecret) 0 [Logo guess] "L
caption [-245 206] [65 29] [Number |of colors:|]
numsquares -170 2 6
caption [-10 206] [65 29] [Duplicates allowed:]
ifelse :LogoPlatform = "wxWidgets [
localmake "buttonx ((first :fontsize)*10)-5
setbutton list :buttonx 210 [25 25] [make "dup.ok "true throw "master] ~
:dup.ok 0 "yes []
setbutton list :buttonx+30 210 [25 25] [make "dup.ok "false throw "master] ~
(not :dup.ok) 0 "no []
] [
setbutton [70 210] [25 25] [make "dup.ok "true throw "master] ~
:dup.ok 0 "yes []
setbutton [100 210] [25 25] [make "dup.ok "false throw "master] ~
(not :dup.ok) 0 "no []
]
end
to numsquares :xcor :num :last
if :num > :last [stop]
setbutton (list :xcor 210) [25 25] `[make "numsquares ,:num throw "master] ~
(:num = :numsquares) 0 :num []
numsquares :xcor+30 :num+1 :last
end
to colorchart :num :names :colors :ycor
if :num = 0 [stop]
setbutton (list -245 :ycor) [25 25] ~
`[putguess ",[first :names] ,[first :colors]] "false ~
(first :colors) [] (first :names)
colorchart :num-1 bf :names bf :colors :ycor-30
end
to numchart :num :ycor
if :num > :numsquares [stop]
setbutton (list -245 :ycor) [25 25] ~
`[if not :winloop [getnum ,:num]] "false 0 :num :num
numchart :num+1 :ycor-30
end
to pos0 :pos
make "controlpos :pos
output :pos
end
to nxt :height
make "controlpos list (first :controlpos) ((last :controlpos) - (:height + 5))
output :controlpos
end
to move :start
; Move the turtle to the given coordinates
; relative to the lower left corner of the first empty square
; in the current frame.
; Depends on :COLUMN (0 or 1 for >14 guesses), :NUMGUESSES, and :NUMCOLORS
; Note, since :NUMGUESSES starts at 1,
; first frame is at [-180 170] not [-180 200].
pu
setpos (list (-145 + (first :start) + 210*:column + 25*(:numcolors-1))
(200 + (last :start) - 30*(:numguesses - 14*:column)))
pd
end
; -----------------------------------------------
to newguess
; Called from MASTER for first guess frame,
; then from GUESS for later guess frames (my secret),
; or from DOGUESS (user's secret).
make "numguesses :numguesses+1
if :numguesses > 14 [make "column 1]
make "numcolors 1
move [0 0]
drawframe
make "guess "
end
to drawframe
setpc 7 seth 0
repeat :numsquares [square 25 rt 90 fd 25 lt 90]
end
to square :side
repeat 4 [fd :side rt 90]
end
;;;;; =================== USER INTERFACE (READING) =======================
to waitforclick
action.off
; Wait for any key or mouse click, then return, ignoring which/where.
if buttonp [while [buttonp] [] stop]
if keyp [ignore rc stop]
waitforclick
end
; ----------- Procedures to carry out user commands ---------------
to getnum :num [:cursor cursor]
; Called for digit key or mouse click on digit button.
make ifelse :exact ["guess.exact] ["guess.inexact] :num
move list ifelse :exact [15] [35] 12
setpc 0 filled 0 [repeat 4 [fd 20 rt 90]]
setpc 7 label :num
; type :num setcursor :cursor
make "gotnum "true
end
to putguess :colorletter :colornumber
; Called from mouse click in color palette;
; first input is a letter for :GUESS (e.g. R for red),
; second input is a Logo color number for SETPC (e.g. 4 for red).
if :numcolors < 1 [stop]
if :numcolors > :numsquares [stop]
if not :dup.ok [if member? :colorletter :guess [stop]]
make "guess word :guess :colorletter
move [0 0]
filled :colornumber [repeat 4 [fd 25 rt 90]]
make "numcolors :numcolors+1
end
to clear
; Called by clicking ERASE button
if :numcolors < 2 [stop]
make "guess butlast :guess
make "numcolors :numcolors-1
move [0 0]
filled 0 [repeat 4 [fd 25 rt 90]]
end
to guess
; Called by clicking GUESS button.
if not :mysecret [if :gotnum [ct wait 0 throw "ready] stop]
if not (:numcolors > :numsquares) [stop]
ifelse equal? :guess :secret [
move [15 12]
setpc 7 label "WIN!
print (sentence [You win in] :numguesses "turns.)
] [
move [15 12]
setpc 7 label exact :secret :guess
move [35 12]
setpc 7 label inexact :secret :guess
newguess
]
end
