aUCBLogo Demos and Tests / mastermind
; [Mastermind game] by Brian Harvey
load "buttons.lg
load "streams.lg
to mastermind [:numsquares_ 4] [:dup_ok false] [:mysecret true]
; Mastermind game program.
; Program is controlled by mouse clicks or keystrokes.
(splitScreen 0.9)
setLabelSize [20 30]
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 seth 90 label "WIN!
ct print (sentence [I win in] :numguesses "turns.)
make "winloop true
action_loop
]
]
]
]
ss setsc "white
cs ct setpc "black 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]
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]
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 5 [setsc 4 updateGraph setsc 0 updateGraph]
type [Click or type anything to restart.]
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_ [pr [now] output (list ")] ; Can't happen (would mean :num>count :word).
output flatten stream_map ~
`[[letter] stream_map `[word ,:letter ?]
perms remonce :letter ,:word_ ,[:num-1]] ~
:word_
;destreamed version
output map_se
[[letter] map [word :letter ?]
perms remonce :letter :word_ :num-1]
:word_
;my simple test version without streams and map is not very nice
;but works with aUCBLogo
;and was fine for testing until I got the above code working.
local [x l i1 i2 i3 i4 i5 i6]
x=int last word_
l=[]
case num
[ [2
for [i1 1 x]
[ for [i2 1 x]
[ if i1 != i2
[ push "l (word i1 i2)
]
]
]
]
[3
for [i1 1 x]
[ for [i2 1 x]
[ if i1 != i2
[ for [i3 1 x]
[ if (and i1 != i3 i2 != i3)
[ push "l (word i1 i2 i3)
]
]
]
]
]
]
[4
for [i1 1 x]
[ for [i2 1 x]
[ if i1 != i2
[ for [i3 1 x]
[ if (and i1 != i3 i2 != i3)
[ for [i4 1 x]
[ if (and i1 != i4 i2 != i4 i3 != i4)
[ push "l (word i1 i2 i3 i4)
]
]
]
]
]
]
]
]
[5
for [i1 1 x]
[ for [i2 1 x]
[ if i1 != i2
[ for [i3 1 x]
[ if (and i1 != i3 i2 != i3)
[ for [i4 1 x]
[ if (and i1 != i4 i2 != i4 i3 != i4)
[ for [i5 1 x]
[ if (and i1 != i5 i2 != i5 i3 != i5 i4 != i5)
[ push "l (word i1 i2 i3 i4 i5)
]
]
]
]
]
]
]
]
]
]
[6
for [i1 1 x]
[ for [i2 1 x]
[ if i1 != i2
[ for [i3 1 x]
[ if (and i1 != i3 i2 != i3)
[ for [i4 1 x]
[ if (and i1 != i4 i2 != i4 i3 != i4)
[ for [i5 1 x]
[ if (and i1 != i5 i2 != i5 i3 != i5 i4 != i5)
[ for [i6 1 x]
[ if (and i1 != i6 i2 != i6 i3 != i6 i4 != i6 i5 != i6)
[ push "l (word i1 i2 i3 i4 i5 i6)
]
]
]
]
]
]
]
]
]
]
]
]
[else []
]
]
output l
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?
wait 0
make "exact_ true
end
to askinexact
ct type "How many INEXACT matches?
wait 0
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
ct setSC 0
init_buttons
ifelse :mysecret
[ colorchart 6 "ROYGBV [4 14 6 2 1 13] 150
setbutton [-250 -30] [45 25] [clear] false 0 "erase "DEL
][ numchart 0 150
]
setbutton [-240 -60] [25 25] [if not :winloop [guess]] true 0 "OK "RET
setbutton [-250 -90] [45 25] [throw "master] false 0 [new game] "N
setbutton [-250 -120] [45 25] [throw "quit] false 0 "quit "Q
setbutton [-260 -170] [70 35] [make "mysecret true throw "master]
:mysecret 0 [I guess] []
setbutton [-260 -210] [70 35] [make "mysecret false throw "master]
(not :mysecret) 0 [Logo guess] []
center_caption [-260 206] [65 29] [Number of colors:]
numsquares -170 2 6
center_caption [0 206] [65 29] [Duplicates allowed:]
setbutton [80 210] [25 25] [make "dup_ok true throw "master]
:dup_ok 0 "yes []
setbutton [110 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 -240 :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 -240 :ycor_) [25 25] ~
`[if not :winloop [getnum ,:num]] false 0 :num :num
numchart :num+1 :ycor_-30
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 (-180 + (first :start) + 220*: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
; Wait for any key or mouse click, then return, ignoring which/where.
wait 0
if mousebuttons != 0 [while [mousebuttons != 0] [] 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] [40] 12
setpc 7 seth 90 label :num
type :num setcursor :cursor_
wait 0
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]
setfc :colornumber
fillRect [0 0][25 25]
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]
setfc 0
fillRect [0 0][25 25]
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 seth 90 label "WIN!
print (sentence [You win in] :numguesses "turns.)
] [
move [15 12]
setpc 7 seth 90 label exact :secret :guess_
move [40 12]
setpc 7 seth 90 label inexact :secret :guess_
newguess
]
end