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 $liste
la 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.