memory.ws3
#
# short intro
#
# game "memory": the player is supposed N pairs of pictures with the
# least possible amount of tries. We thus keep track of:
# s the current status of the pictures
# 0 backside up
# 1 front up
# 2 permanently open
# i the array of pictures used for this game
# (varies with each reshufflement)
# l the current level (translates into N)
# h which pictures have been "hit", ie selected by the player
# r the refresh rate
#
# the application needs to
# * reshuffle --> generate new i
# * find matching --> check/modify status
# * change level --> keep track of l and reshuffle
# * show help text
# * change refresh rate
# * keep track of best player
#
# turn logging on
#web::logfilter add memory.-debug
#web::logdest add memory.-debug file [file join / tmp websh memory.log]
# config: map level number to X-Y dimensions
set _levels(1) [list 1 2]
set _levels(2) [list 1 4]
set _levels(3) [list 2 5]
set _levels(4) [list 3 6]
set _levels(5) [list 4 7]
set _levels(6) [list 5 8]
set _levels(7) [list 6 9]
# setup file context
web::filecontext mctx -path /tmp/websh/%s.ctx
if {![file exists /tmp/websh/memory.ctx]} {
catch {
# make sure context directory exists
# (note: in a production environment you make sure that this exists
# at install time. You don't want to create that directory with every request)
file mkdir /tmp/websh
# hack ot make the filecontext work
close [open /tmp/websh/memory.ctx w]
}
}
# formatLink -- helper function to generate hrefs
proc formatLink {url {show ""}} {
if {$show == ""} { set show $url }
return "<a href=\"$url\">$show</a>"
}
# putLink -- helper function to output links
proc putLink {url {show ""}} {
web::put [formatLink $url $show]
}
# putLinkHtmlified -- helper function to output links
proc putLinkHtmlified {url show} {
web::put [formatLink $url [web::htmlify $show]]
}
# commandList -- add "commands" line to HTML page
proc commandList {} {
web::put "<tt>"
putLinkHtmlified [web::cmdurl decrementLevel] "<"
web::put " | "
putLinkHtmlified [web::cmdurl incrementLevel] ">"
web::put " | "
putLinkHtmlified [web::cmdurl reset] "x"
web::put " | "
putLinkHtmlified [web::cmdurl new] new
web::put " | "
putLinkHtmlified [web::cmdurl help] "?"
web::put " | "
putLinkHtmlified [web::cmdurl incrRefreshTime] "+"
web::put " | "
putLinkHtmlified [web::cmdurl decrRefreshTime] "-"
# load hall of fame
mctx::init memory
# get the lowest number of tries for this level from the session context
# why do I use web::cmdurlcfg here instead of web::param ?
# I do not want to bother about the level when I generate a URL
# using web::cmdurl - I keep it in the static parameters (managed
# by web::cmdurlcfg).
set best [mctx::cget hof([web::cmdurlcfg l]) "n/a"]
web::put " (level: [web::cmdurlcfg l], [web::cmdurlcfg c] tries, best: $best)"
web::put "</tt>\n"
web::put "<br>\n"
}
# page -- helper function to produce an HTML page
proc page {title code} {
# HTML header stuff
web::put "
<html>
<head>
<title>$title</title>
</head>
<body bgcolor=\"#ffffff\">
"
web::put "<br>\n"
# depends on the caller
uplevel 1 $code
# add list of commands
web::put "<hr>\n"
commandList
# footer and end-of-HTML
web::put "
<hr><font size=\"-2\"><tt>
[web::config version]</tt></font><br>
</BODY>
</HTML>
"
}
# table -- helper function to output a HTML table
proc table {code} {
web::put {<table border="0" cellspacing="0" cellpadding="0">}
web::put "\n"
uplevel 1 $code
web::put "\n</table>\n"
}
# tablerow --
proc tablerow {code {bgcolor {}}} {
if {[string length $bgcolor] } {
web::put "<tr bgcolor=\"$bgcolor\">\n"
} else {
web::put "<tr>\n"
}
uplevel 1 $code
web::put "\n</tr>\n"
}
# tablecell --
proc tablecell {code} {
web::put "<td>\n"
uplevel 1 $code
web::put "\n</td>\n"
}
# image --
proc image {gif} {
set res "<img src=\"/websh/images/memory/$gif\" width=\"50\" height=\"50\" vspace=\"0\" hspace=\"0\""
append res "border=\"1\" ALIGN=\"middle\">"
return $res
}
# validateImg -- check current game status
proc validateImg {vImg vStatus} {
global _levels
upvar $vImg img
upvar $vStatus status
# no images - this calls for a new game. Reshuffle.
if { [string length $img] < 2} {
# reset try counter
web::cmdurlcfg -set c 0
# get current level
set tmp $_levels([web::cmdurlcfg l])
# reshuffle (number of images depends on level)
set numImg [expr ([lindex $tmp 0] * [lindex $tmp 1]) / 2]
for {set i 0} {$i < $numImg} {incr i} {
set timg [format %2.2d $i]
# for this image, generate two random numbers which will
# determine the position of the image in the game
while {1} {
set r1 [expr rand()]
if { ![info exists shuffle($r1)] } { break }
}
while {1} {
set r2 [expr rand()]
if { ![info exists shuffle($r2)] } { break }
}
set shuffle($r1) $timg
set shuffle($r2) $timg
}
# compile string which describes game outline
set img ""
foreach tmp [array names shuffle] {
append img $shuffle($tmp)
}
# and set status of every image to "closed"
set status [string repeat "0" [expr {$numImg * 2}]]
}
}
# listOpen -- helper function to list currently open pictures
proc listOpen {vStatus {val 1}} {
upvar $vStatus status
set i 0
set res ""
foreach tmp [split $status ""] {
if { $tmp == $val } {lappend res $i}
incr i
}
return $res
}
# countOpen -- helper to count all pictures that have a given status
proc countOpen {vStatus {val 1}} {
upvar $vStatus status
set res [listOpen status $val]
return [llength $res]
}
# doMatch -- helper to decide if two selected images match
proc doMatch {vImg vOpens} {
upvar $vImg img
upvar $vOpens opens
set img1 [getImageFromArray img [lindex $opens 0]]
set img2 [getImageFromArray img [lindex $opens 1]]
if {[string equal $img1 $img2]} {
set res [list 1]
lappend res [lindex $opens 0]
lappend res [lindex $opens 1]
} else {
set res [list 0]
lappend res [lindex $opens 0]
lappend res [lindex $opens 1]
}
return $res
}
# getImageFromArray -- helper to extract two letters from string
proc getImageFromArray {vImg pos} {
upvar $vImg img
return [string range $img [expr {$pos * 2}] [expr {$pos * 2 + 1}]]
}
# getStat -- helper to pick status for a given picture
proc getStat {vStatus pos} {
upvar $vStatus status
return [string index $status $pos]
}
# setStat -- set status
proc setStat {vStatus pos {new 0}} {
upvar $vStatus status
set res [string range $status 0 [expr $pos - 1]]
set res $res$new
set res $res[string range \
$status [expr {$pos + 1}] [string length $status]]
set status $res
}
# toggleStat -- toggle status: switch 0->1 or 1->0, but keep 2 at 2
proc toggleStat {vStatus pos} {
upvar $vStatus status
set cur [getStat status $pos]
if {$cur == 0} {
setStat status $pos 1
} elseif { $cur == 2 } {
setStat status $pos 2
} else {
setStat status $pos 0
}
}
# findMatching -- see if the user did find two matching images
proc findMatching {vImg vStatus} {
upvar $vImg img
upvar $vStatus status
# in case only one is open, we prevent closing it again
set tmp [listOpen status 1]
set onlyone -1
if { [llength $tmp] == 1 } {
set onlyone [lindex $tmp 0]
}
# which ones are selected ?
set hitlst [web::param h]
foreach tmp $hitlst {
# if it is not the single one that is already open, flip it
if {$tmp != $onlyone} {
toggleStat status $tmp
}
}
# now, how many are open, really ?
set opens [listOpen status]
set Nopen [llength $opens]
# more than two open ? (no tricks !)
if { $Nopen > 2 } {
foreach tmp $opens {
setStat status $tmp 0
}
} elseif { $Nopen == 2 } {
# get current try counter (or 0 if not set) ...
set tmp [web::cmdurlcfg c 0]
# ... and increment it and store it back as static parameter
web::cmdurlcfg -set c [incr tmp]
# do the two selected pictures match ?
set tmp [doMatch img opens]
if { [lindex $tmp 0] == 1 } {
# yes, open permanently
setStat status [lindex $tmp 1] 2
setStat status [lindex $tmp 2] 2
} else {
# no. use the refresh feature
set opens [listOpen status]
# add img and status as static parameters
# (ensure that we have status and img in the URL)
web::cmdurlcfg -set s $status
web::cmdurlcfg -set i $img
# for refresh: simulate clicks on the two open pictures
# that will close them
set tmp [web::cmdurl "" [list h [lindex $opens 0] h [lindex $opens 1]]]
# add the HTTP "refresh" header, using the parameter r for the
# refresh time (using 2 sec as default)
web::response -set Refresh "[web::cmdurlcfg r 2];URL=$tmp"
}
}
# add img and status as static parameters
# (ensure that we have status and img in the URL)
web::cmdurlcfg -set s $status
web::cmdurlcfg -set i $img
}
# display table with memory
proc showMemory {} {
global _levels
global _cache
# get current status from URL
set status [web::param s]
# get current game outline from URL
set img [web::param i]
# asses status of game
validateImg img status
# do we have any matching images ?
findMatching img status
# no more closed ? --> game over --> perhaps we need to update hof
if { [countOpen status 0] == 0} {
mctx::init memory
set best [mctx::cget hof([web::cmdurlcfg l]) -1]
if { ($best == -1) ||
([web::cmdurlcfg c] < $best) } {
mctx::cset hof([web::cmdurlcfg l]) [web::cmdurlcfg c]
mctx::commit
}
}
# get X-Y dimension for game outline from level
set tmp $_levels([web::cmdurlcfg l 5])
set numX [lindex $tmp 0]
set numY [lindex $tmp 1]
# output HTML page
page "memory game" {
# output HTML table
table {
# table rows
for {set i 0} {$i < $numX} {incr i} {
tablerow {
for {set j 0} {$j < $numY} {incr j} {
set tmpCnt [expr {$i * $numY + $j}]
set timg [getImageFromArray img $tmpCnt]
set curImgStat [getStat status $tmpCnt]
# table cells
tablecell {
if {$curImgStat == 0} {
# show backside
#
# actually, it is a link back to the CGI app,
# recursion of some sort.
#
# from parameter h, showMemory will know which
# picture the player did select
putLink [web::cmdurl "" h $tmpCnt] \
[image back.gif]
} elseif {$curImgStat == 2} {
# two matching found - no link any more, just the image
web::put [image $timg.jpg]
} else {
# show front side
putLink [web::cmdurl "" h $tmpCnt] \
[image $timg.jpg]
}
}
}
}
}
}
}
}
# web::command help -- display help text
web::command help {
page "memory game - help text" {
web::put "<tt>"
web::put "Memory -- find the matching images."
web::put "<p>"
web::put "You can see the hidden image by clicking on its back side. "
web::put "When you have found two matching images, they will remain open "
web::put "from then on. If two images do not match, they will be "
web::put "closed again."
web::put "<p>"
web::put "If the images close again too quickly on your system, "
web::put "you can make the images stay open longer with the "
web::put ""+" command ("-" to close them "
web::put "more quickly)."
web::put "<p>"
web::put ""new" shuffels the images again. "
web::put ""×" restarts the game from the beginning."
web::put "</tt><p>"
}
}
# web::command decrementLevel -- reduce level and show game
web::command decrementLevel {
# I do not want to have to bother about the level when I generate
# URLs using web::cmdurl. So, I put level to the static parameters
# and let web::dispatch track it.
# That's why web::cmdurlcfg is used here, instead of web::param.
set level [web::cmdurlcfg l 5]
if {$level > 1} {incr level -1}
web::cmdurlcfg -set l $level
# changing the level implies resetting the game
web::param -set i ""
showMemory
}
# web::command incrementLevel -- increase level and show game
web::command incrementLevel {
set level [web::cmdurlcfg l 5]
if {$level < 7} {incr level}
web::cmdurlcfg -set l $level
# changing the level implies resetting the game
web::param -set i ""
showMemory
}
# web::command incrRefreshTime -- increase refresh time
web::command incrRefreshTime {
set r [web::cmdurlcfg r 2]
if {$r < 30} {incr r 2}
web::cmdurlcfg -set r $r
showMemory
}
# web::command decrRefreshTime -- decrease refresh time
web::command decrRefreshTime {
set r [web::cmdurlcfg r 2]
if {$r > 2} {incr r -2}
web::cmdurlcfg -set r $r
showMemory
}
# web::command new -- new game on the same level (reshuffle)
web::command new {
web::param -set i ""
showMemory
}
# web::command reset -- back to the defaults
web::command reset {
web::param -set i ""
web::cmdurlcfg -set l 5
showMemory
}
# web::command default -- if nothing is specified, use this one
web::command default {
showMemory
}
# web::dispatch -- decide which command to call
#
# here, we use the tracking feature of dispatch. Whenever dispatch
# finds a parameter from the -track list, it copies it over to the
# static parameters
#
# also, we use -hook to execute code just before web::dispatch will
# call the web::command command. Here, we set the default level to 5
# if it is not yet known.
web::dispatch -track [list l c r] -hook {web::cmdurlcfg -set l [web::cmdurlcfg l 5]}
# cleanup context after the request (prevent session crosstalk)
mctx::delete
Generated by GNU enscript 1.6.3.