Mots cachés

 

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.