proc shuffleText string { set res "" foreach part [regexp -inline -all {[-A-Za-z]+|[^A-Za-z]} $string] { if {[regexp {[A-Za-z-]} $part] && [string length $part]>3} { set part [shuffleWord $part] } append res $part } set res } proc shuffleWord string { set list [split $string ""] join [concat [lindex $list 0] [shuffle6 [lrange $list 1 end-1]] [lindex $list end]] "" } proc shuffle6 { list } { set n [llength $list] for { set i 1 } { $i < $n } { incr i } { set j [expr { int( rand() * $n ) }] set temp [lindex $list $i] lset list $i [lindex $list $j] lset list $j $temp } return $list }#----- Testing:
% shuffleText $aboutAcidncrog to a sduty of Cabmgidre Unreisvity, the order of lrteets iidsne a wrod deos not mtetar mcuh for rdiietbaaly, as long as the fisrt and last letetrs of the word are correct. Here is Tcl cdoe to test this:#------- Incredible! I've tried it in french... and it's true! JPTjcw - To make it shuffle more, i.e. retry if there was no effect, change the line
set part [shuffleWord $part]to
while {[set mix [shuffleWord $part]] eq $part} {} set part $mix#------- [daveg] - Nedes mroe wrok: The above change isn't good with words like good...
RS 2003-09-22: removed redundant grouping in regexp
Stu - It's fun, but the Cambridge study does not exist. [1]
FW: shuffleText could be simplified further (in part by using my break_text from Bag of Algorithms) as:
proc shuffleText2 string { set res "" foreach {word punc} [break_text $string] { append res [shuffleWord $word] $punc } return $res }
See also Can you read this?.