22
$\begingroup$

I was just reading the Wikipedia page on Typoglycemia:

... readers can understand the meaning of words in a sentence even when the interior letters of each word are scrambled ...

and wanted to know how that text can be produced with Mathematica.

My code is given below, but it does not check if the first or last character is not a letter.

How would you solve this?

text = "In a publication of New Scientist you could randomise all the \
letters,keeping the first two and last two the same,and readability \
would hardly be affected.My analysis did not come to much because the \
theory at the time was for shape and sequence recognition.Saberi's \
work suggests we may have some powerful parallel processors at \
work.The reason for this is surely that identifying content by \
parallel processing speeds up recognition.We only need the first and \
last two letters to spot changes in meaning.";

words = StringSplit[text];
randomWords = Array[0 &, Length[words]];
numWords = Length[randomWords];

getRandomWord[x_] := Module[
   {word = x},
   wordLength = Length[word];
   firstLetter = StringTake[word, 1];
   lastLetter = StringTake[word, -1];
   restString = StringTake[word, {2, wordLength - 2}];
   randomLetters = RandomSample[StringPartition[restString, 1]];
   result = StringJoin[firstLetter, randomLetters, lastLetter]
   ];

Table[
  word = words[[count]];
  wordLength = StringLength[word];
  If[wordLength < 3, randomWords[[count]] = word, 
   randomWords[[count]] = getRandomWord[word]],
  {count, 1, numWords}
  ];

randomText = StringRiffle[randomWords]

"In a pbilcituaon of New Snscetiit you could ridnomsae all the \
liteepsr,eknetg the fisrt two and last two the sa,anmed rteiaiadbly \
wluod hladry be adMf.etecfy ayaisnls did not cmoe to much bacusee the \
torhey at the tmie was for spahe and snquecee rbgtnSi.oeein'iocars \
work sugtgess we may hvae some pewfroul parealll prrsocoses at \
whrkT.oe rosean for this is srluey that iydeintfnig cenotnt by \
pleaalrl piernocssg spdees up rongiecWt.ione olny need the first and \
lsat two letters to spot chgeans in mgaenin."
$\endgroup$
2
  • 9
    $\begingroup$ "Typoglycemia"--what a revolting term. I think "spellicopter" would have been infinitely better. Or "jumble jet". Well, it has as much to do with air travel as it does with glucose homeostasis, doesn't it? $\endgroup$ Feb 28, 2016 at 17:43
  • 2
    $\begingroup$ @Oleksandr It was probably a reference to the slurred speech that can happen with hypoglycemia. $\endgroup$
    – Mr.Wizard
    Feb 28, 2016 at 23:58

3 Answers 3

17
$\begingroup$

My attempt:

SeedRandom[42];
StringReplace[text, 
              a : (Repeated[LetterCharacter, {5, ∞}]) :> 
              StringJoin[Take[#, 2], RandomSample[#[[3 ;; -3]]],
                         Take[#, -2]] &[Characters[a]]]
   "In a puciibltaon of New Scieintst you could radmonise all the \
    letters,keiepng the first two and last two the same,and reabdaiilty \
    would hardly be affected.My anlaysis did not come to much beaucse the \
    theory at the time was for shape and seqneuce recgotniion.Saebri's \
    work sueggsts we may have some pofewrul palrlael prsoecosrs at \
    work.The reason for this is surely that ideyfniitng content by \
    parallel prisesocng speeds up regioticnon.We only need the first and \
    last two letters to spot chnages in meaning."
$\endgroup$
2
  • $\begingroup$ I think this is a better approach. I am not sure why StringSplit came to mind first. $\endgroup$
    – Mr.Wizard
    Feb 28, 2016 at 16:02
  • $\begingroup$ Thanks, short and does it as it should ... I vote for your solution. See also comment to Mr. Wizard. $\endgroup$
    – mrz
    Mar 2, 2016 at 11:51
13
$\begingroup$
scramble[s_String /; StringLength[s] > 5] :=
  #[[;; 2]] <> RandomSample @ #[[3 ;; -3]] <> #[[-2 ;;]] & @ Characters @ s

scramble[else_] := else

MapAt[scramble, StringSplit[text, WordBoundary], ;; ;; 2] // StringJoin

"In a puilicbaton of New Scniteist you could raniodmse all the leettrs,kepeing the first two and last two the same,and reiialbadty would hadrly be afeftced.My anlyasis did not come to much beaucse the thoery at the time was for shape and seueqnce regiitnocon.Saberi's work sugegsts we may have some powrfeul paarllel prsoseocrs at work.The reason for this is suerly that idnytifeing conetnt by pallarel proissecng speeds up reigncitoon.We only need the first and last two letters to spot chngaes in meianng."

  1. This assumes that your text starts with a letter.

  2. I went with the first two and last two characters being fixed, as described in the text.


Update: after seeing J. M.'s answer I suppose I could better have written:

StringReplace[text, x : LetterCharacter .. :> scramble[x]]
$\endgroup$
1
  • $\begingroup$ I am more than impressed. Your solution and also the code of J. M. and Dr. belisarius demonstrate how extremely powerful and probably unbeatable Mathematica is. Thanks a lot to all of you. $\endgroup$
    – mrz
    Feb 29, 2016 at 17:57
10
$\begingroup$

As a regular expression:

SeedRandom[42];
regex = RegularExpression["\\b([[:alpha:]]{2})([[:alpha:]]+)([[:alpha:]]{2})\\b"];

StringReplace[text, regex :> StringJoin["$1", RandomSample@Characters@"$2", "$3"]  

"In a puiabtlicon of New Sceitinst you could raondimse all the letetrs,keeping the first two and last two the same,and reaailidbty would hardly be afcfteed.My anayslis did not come to much because the theory at the time was for shape and seeqnuce recgitinoon.Saberi's work suseggts we may have some pofwreul paallrel proseocsrs at work.The resaon for this is suerly that idieniyftng content by parlalel preioscsng speeds up regoticnion.We only need the first and last two leettrs to spot chgnaes in meaning."

Generalizing to "fix" the first and last n characters is trivial:

regex@n_ := ToString@StringForm[
                     "\\b([[:alpha:]]{`1`})([[:alpha:]]+)([[:alpha:]]{`1`})\\b", n];
StringReplace[text, RegularExpression@regex@2 :> 
                               StringJoin["$1", RandomSample@Characters@"$2", "$3"]]

For those not acquainted with regexes, here is a breakdown:

wordBoundary = "\\b";
twoLetters   = "([[:alpha:]]{2})";
oneOrMore    = "([[:alpha:]]+)";
regex        = wordBoundary ~~ twoLetters ~~ oneOrMore  ~~ twoLetters ~~ wordBoundary;

Please note that further generalization to "a string with minimum length m, keeping the first and last n chars fixed is also straightforward using the repetition pattern {min,}:

regex[m_, n_] := 
 ToString@StringForm["\\b([[:alpha:]]{`1`})([[:alpha:]]{`2`,})([[:alpha:]]{`1`})\\b", 
    n, m - 2 n] /; m > 2 n
StringReplace[text, RegularExpression@regex[5, 1] :> 
              StringJoin["$1", RandomSample@Characters@"$2", "$3"]]

"In a piulcotaibn of New Ssitneict you colud rndsaomie all the lterets,kepnieg the fisrt two and last two the same,and redbialtaiy wuold hadrly be aefecftd.My anilyass did not come to much bsceuae the tehory at the time was for sahpe and snecquee rcntieooign.Saebri's work setgguss we may have some puwfroel pelarlal pscorseors at work.The rosaen for this is seulry that iyindnietfg cntoent by parlelal prniesscog seepds up reigooncitn.We only need the first and last two lerttes to spot caegnhs in meniang."

$\endgroup$
5
  • 2
    $\begingroup$ (+1) Actually RegularExpression["\\b([[:alpha:]])([[:alpha:]]{3,})([[:alpha:]])\\b"] does work in version 9.0.1. Probably you simply forgot to wrap it by RegularExpression... But RegularExpression["\\b([[:alpha:]]{2})([[:alpha:]]+)([[:alpha:]]{2})\\b"] is more correct: it fixes first two and last two characters, not one. $\endgroup$ Feb 29, 2016 at 7:35
  • $\begingroup$ @AlexeyPopkov You're right! Thanks! Gong to edit $\endgroup$ Feb 29, 2016 at 17:13
  • $\begingroup$ Great solution ... can you recommend some documentation for reading about RegularExpressions? $\endgroup$
    – mrz
    Feb 29, 2016 at 18:04
  • 1
    $\begingroup$ @mrz better by trying it. Enter \b([[:alpha:]]{2})([[:alpha:]]+)([[:alpha:]]{2})\b here regex101.com $\endgroup$ Feb 29, 2016 at 18:17
  • $\begingroup$ This is wonderful ... Thanks $\endgroup$
    – mrz
    Mar 1, 2016 at 11:56

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.