dc 24/02/06 Ma fille de 5 ans a découvert dans un magazine (D*sn*y princesse) les mots cachés. Ils sont très simples : un mot par ligne et plus de lignes que de mots !
J'ai voulu lui en faire, en augmentant la difficulté : la grille est carrée et de dimension la dimension du plus grand mot, on peut placer indifféremment sur ligne ou sur colonne à l'endroit ou à l'envers
Appuyer sur le bouton droit de la souris crée une image eps prête à imprimer.
le code en fichier [1] et le fichier liste.txt [2] contenant les mots à trouver
Code actualisé le 26/02/06
package require Tk
proc posInit {x y} {
global pos
set pos(x) $x
set pos(y) $y
}
proc traceSelection {x y} {
global pos
.c delete selection
.c create line $pos(x) $pos(y) $x $y -width 3 -fill red -tags selection
}
proc posFin {x y} {
global pos
.c delete selection
set listeId [.c find overlapping $pos(x) $pos(y) $x $y]
foreach id $listeId {
set lestags [.c gettags $id]
lappend tag [lindex $lestags 1]
}
set tag [lsort [join $tag]]
set exttag "[lindex $tag 0] [lindex $tag end]"
trouveSolution $exttag
}
proc trouveSolution {valeur} {
global soluce
set tabcomplet [array get soluce]
set res [lsearch -exact $tabcomplet $valeur]
if {$res!=-1} {
set mot [lindex $tabcomplet [expr {$res-1}]]
foreach {tag1 tag2} $valeur break
regexp {x([0-9]+)y([0-9]+)} [.c gettags $tag1] -> x0 y0
regexp {x([0-9]+)y([0-9]+)} [.c gettags $tag2] -> x1 y1
.c create line $x0 $y0 $x1 $y1 -width 3 -fill green
.c itemconfigure $mot -fill green
unset soluce($mot)
}
if {[array names soluce]==""} {
stopScore
}
}
proc stopScore {} {
global t0
set t1 [clock seconds]
tk_messageBox -message "solution trouv\u00E9e en
[clock format [expr {$t1-$t0}] -format "%M minutes et %S secondes"]" -icon info
}
proc listeDecMots {liste} {
foreach mot $liste {
lappend lmot [list $mot [string length $mot]]
}
foreach {mot long} [join [lsort -decreasing -integer -index 1 $lmot]] {
lappend listeDec $mot
}
return $listeDec
}
proc longMaxMots {liste} {
return [string length [lindex [listeDecMots $liste] 0]]
}
proc enversEndroit {mot} {
set e [expr {int(rand()*2)}]
if {$e==1} {return $mot}
set tom ""
for {set i 0} {$i<[string length $mot]} {incr i} {
append tom [string index $mot end-$i]
}
return $tom
}
proc initGrille {} {
global m taille
for {set i 0} {$i<$taille} {incr i} {
for {set j 0} {$j<$taille} {incr j} {
set m($i,$j) " "
}
}
}
proc montreGrilleConsole {} {
global m taille
for {set i 0} {$i<$taille} {incr i} {
for {set j 0} {$j<$taille} {incr j} {
if {$m($i,$j)!=" "} {
puts -nonewline "$m($i,$j) "
} else {
puts -nonewline "* "
}
}
puts \n
}
}
proc afficheGrilleTk {} {
pack [canvas .c -bg white] -expand 1 -fill both
bind .c <1> "posInit %x %y"
bind .c <B1-Motion> "traceSelection %x %y"
bind .c <B1-ButtonRelease> "posFin %x %y"
bind .c <3> ".c postscript -file motcache.eps"
global m taille
for {set i 0} {$i<$taille} {incr i} {
for {set j 0} {$j<$taille} {incr j} {
set x [expr {($j+1)*27}];set y [expr {($i+1)*27}]
set id [.c create text $x $y \
-text $m($i,$j) \
-font "courier 24 bold" -tags grille]
.c addtag $i,$j withtag $id
.c addtag x${x}y${y} withtag $id
}
}
}
proc afficheTk {liste} {
foreach {x0 y0 x1 y1} [.c bbox grille] break
set n 0
set offset 25
foreach mot $liste {
incr n
#.c create rectangle [expr {$x1+$offset}] [expr {$offset*$n}]\
[expr {$x1+10}] [expr {$offset*$n+20}] -tags $mot
.c create text [expr {$x1+2*$offset}] [expr {$offset*$n}]\
-text $mot -font "helevtica 24" -anchor w -tags $mot
}
}
proc completeGrille {} {
global m taille
set alphabet "\u00E0 \u00E2 \u00E9 \u00E8 \u00EA \u00EE \u00EF \
\u00F4 \u00F9 a b c d e f g h i j k l m n o p q r s t u v w x y z"
for {set i 0} {$i<$taille} {incr i} {
for {set j 0} {$j<$taille} {incr j} {
if {$m($i,$j)==" "} {
set hasard [expr {int(rand()*[llength $alphabet])}]
set car [lindex $alphabet $hasard]
set m($i,$j) [encoding convertto [encoding system] $car]
}
}
}
}
proc adapteFenetre {} {
update
foreach {x0 y0 x1 y1} [.c bbox all] break
set x1 [expr {$x1+27}];set y1 [expr {$y1+27}]
wm geometry . ${x1}x$y1
}
proc listePositionPossible {mot orient numero} {
global m taille
# contenu de la ligne
set ligne ""
for {set i 0} {$i<$taille} {incr i} {
if {[string equal $orient horizontal]} {
append ligne $m($numero,$i)
} else {
append ligne $m($i,$numero)
}
}
# calcul des poss partir de longueurs
set lmot [string length $mot]
set posMax [expr {$taille-$lmot}]
for {set k 0} {$k<=$posMax} {incr k} {
lappend listPoss $k
}
# 1er cas : rien dans la ligne !
if {[string equal $ligne [string repeat " " $taille]]} {
return $listPoss
}
# 2e cas : on compare les chanes dans les tous
# les possibilits listes
set listePoss ""
foreach i $listPoss {
set chaine [string repeat " " $i]
append chaine $mot[string repeat " " [expr {$taille-$lmot-$i}]]
set valide 1
for {set k 0} {$k<$taille} {incr k} {
if {[string index $ligne $k]==" " \
|| [string index $chaine $k]==" " \
|| [string index $ligne $k]==[string index $chaine $k]} {
continue
} else {
set valide 0
break
}
}
if {$valide==1} {lappend listePoss $i}
}
return $listePoss
}
proc marqueMot {mot orient numero indice} {
global m
if {[string equal $orient "horizontal"]} {
for {set j 0} {$j<[string length $mot]} {incr j} {
set m($numero,[expr {$indice+$j}]) [string index $mot $j]
}
} else {
for {set i 0} {$i<[string length $mot]} {incr i} {
set car [string index $mot $i]
set encodeUniP [format %04.4X [scan $car %c]]
set encodeUni [encoding convertfrom [encoding system] \\u$encodeUniP]
eval set m([expr {$indice+$i}],$numero) $encodeUni
}
}
}
proc placeMot {mot orient listeN} {
set listepossibilites ""
while {$listepossibilites==""&&[llength $listeN]>0} {
set llisteN [llength $listeN]
#puts $llisteN
set ranghasard [expr {int(rand()*$llisteN)}]
#puts $ranghasard
set numero [lindex $listeN $ranghasard]
set listeN [lreplace $listeN $ranghasard $ranghasard]
set listepossibilites [eval listePositionPossible $mot $orient $numero]
}
return [list $numero $listepossibilites]
}
proc ajouteSoluce {mot orient numero indice} {
global soluce
set lmot [string length $mot]
set debut $indice
set fin [expr {$debut+$lmot-1}]
if {[string equal $orient "horizontal"]} {
set soluce($mot) [lsort "${numero},$debut ${numero},$fin"]
} else {
set soluce($mot) [lsort "${debut},$numero ${fin},$numero"]
}
}
proc moteur2 {liste} {
global taille
set taille [longMaxMots $liste]
initGrille
set listeOrient {horizontal vertical}
for {set k 0} {$k<$taille} {incr k} {
lappend listeNumeros $k
}
foreach mot [listeDecMots $liste] {
set motom [enversEndroit $mot]
set listeN $listeNumeros
set h [expr {int(rand()*2)}]
set orient [lindex $listeOrient $h]
foreach {numero lp} [placeMot $motom $orient $listeN] break
# aucune place disponible dans cette orientation !
if {$lp==""} {
set orient [lindex $listeOrient [expr {($h+1)%2}]]
foreach {numero lp} [placeMot $motom $orient $listeN] break
if {$lp==""} {return 0}
}
# sinon, on choisit une des possibilits !
set ranghasard [expr {int(rand()*[llength $lp])}]
set indice [lindex $lp $ranghasard]
marqueMot $motom $orient $numero $indice
ajouteSoluce $mot $orient $numero $indice
}
return 1
}
proc genereGrille {liste} {
global soluce
while {[moteur2 $liste]==0} {
}
completeGrille
afficheGrilleTk
afficheTk $liste
adapteFenetre
}
set f [open liste.txt]
fconfigure $f -encoding [encoding system]
set contenu [read $f]
close $f
eval $contenu
wm iconify .
tk_messageBox -message "Appuyer sur le bouton droit de la souris pour g\u00E9n\u00E9rer\
un fichier motcache.eps\n
Appuyer sur le bouton gauche pour trouver les mots." -icon info
wm deiconify .
set t0 [clock seconds]
genereGrille $listela liste est alors a créée dans un fichier liste.txt contenant seulement par exemple :
set liste {belle bête gaston rose château prince princesse miroir zip samovar}ulis, 2006-02-25. Sur ma machine, on ne voit pas la différence gras/non gras et les caractères accentués ne correspondent pas à ce qui est affiché (j'ai du les enlever). En tout cas, la liste est facile à changer et c'est idéal pour un jeune enfant.
dc l'interface est à refaire. Quant aux caractères accentués, j'avais remarqué cela aussi avec un fichier composé sous emacs en utf-8, j'ai finalement enregistré le fichier en le codant en iso-8859-1 et là plus de problème. Je suppose que je pourrai directement utiliser les caractères unicode correspondant à ces caractères. Je vais voir cela.
Voilà, le code est actualisé (et plus rapide) et gère normalement les caractères accentués...à tester néanmoins.
dmc . 28/2/2007 -- La sélection verticale ne fonctionne pas sur ma machine. 3/3/07 : Excuses, l'erreur est de ma part, c'est le pointage des lettres de départ ou de fin qui est en cause, il suffit d'un pixel de trop pour sélectionner une lettre de plus sans s'en apercevoir.