Hey, that's great! I hadn't tried forcing Numerical approximation in the a and b functions, and that does make it much faster, in addition to being right!

Here is my modified version of the code I will put on Rosetta Code shortly.

piCalc[n_, precision_] := ($precision = precision; 
   4*a[n]^2)/(1 - Sum[2^(1 + k)*(a[k]^2 - b[k]^2), {k, 1, n}])
a[h_] := (a[h] = (N[#, $precision] &@a[h - 1] + b[h - 1])/2)
b[h_] := (b[h] = N[#, $precision] &@Sqrt[a[h - 1] b[h - 1]])
a[0] = 1;
b[0] = 1/Sqrt[2];

Hi Antonio,

Great! The total code for the FibonacciWord would now be:

ClearAll[FibonacciWord]
FibonacciWord[1] = "1";
FibonacciWord[2] = "0";
FibonacciWord[n_Integer?(# > 2 &)] := FibonacciWord[n] = FibonacciWord[n - 1] <> FibonacciWord[n - 2]

step["0", {_?EvenQ}] = RotationTransform[Pi/2];
step["0", {_?OddQ}] = RotationTransform[-Pi/2];
step[___] = Identity;

steps = MapIndexed[step, Characters[FibonacciWord[23]]];
dirs = ComposeList[steps, {0, 1}];
Graphics[Line[FoldList[Plus, {0, 0}, dirs]]]

Giving:

which looks exactly like the one shown in figure 1 of this article.

Antonio; as you did the 'crucial' part of the implementation, I suggest you add it to Rosettacode.

Here is a start for the Parse an IP Address task, feel free to add/modify:

testcases={"127.0.0.1","127.0.0.1:80","::1","[::1]:80","2605:2700:0:3::4713:93e3","[2605:2700:0:3::4713:93e3]:80"};
ClearAll[ParseIP]
ParseIP[str_String]:=Module[{},
 Which[
  Count[Characters[str],"."]==3,
  Print["IPV4"];
  ,
  Count[Characters[str],":"]>=2,
  Print["IPV6"];
  ,
  True,
  Print["Not sure what this is!"]
 ]
]
ParseIP/@testcases

Re: Move-to-front algorithm, for a lot of iterative algorithms it's useful to use Nest/Fold and company:

f[{output_, symList_}, next_] := Module[{index},
   index = Position[symList, next][[1, 1]] - 1;
   {output~Append~index, Prepend[Delete[symList, index + 1], next]}];

Fold[f, {{}, CharacterRange["a", "z"]}, Characters["broood"]]

Part of the usefulness is that it lets you work without having to think about how variables are changing (what some overzealous languages call "avoiding state"). In this case the incoming state of the algorithm is in the {output, symList} double passed in as the first argument to your function, and all your function has to do is figure out what the next state is, given that state and the next character in the input string. Function arguments in Mathematica are immutable precisely for this kind of thing (i.e. to make it easier to reason about your code).

A very similar method can be used to decrypt the output... I leave to others if interested.

I made a not so fast but working version of the 'Narcissistic decimal number' problem. That is: find the first 25 non-negative integers $n$, with number of digits $m$, where the sum of the digits to the power $m$ is the number itself; for example: $153 = 1 + 125 + 27 = 1^3 + 5^3 + 3^3$.

powers = {};
found = 0; number = 0; totDigits = 0;
addpower[p_] := AppendTo[powers, Power[Range[0, 9], p]];
check[number_] := With[{digits = IntegerDigits[number]},
    If[Length[digits] > totDigits, addpower[Length[digits]]; totDigits++];
    If[Total[Map[powers[[Length[digits]]][[# + 1]] &, digits]] == number, number]];
While[found < 25, If[IntegerQ[check[number]], found++; Print[number]]; number++]

This works and only calculates the powers once, but still takes 250 s. I tried another approach but have some trouble finishing it. The idea is that instead of looping over the natural numbers, this loops over combinations of integers.

sumpow[digits_, len_] := Total[Map[Power[#, len] &, digits]];
checkN[digits_] := 
    Block[{len = Length[digits], 
    numbers = Map[FromDigits[#] &, Permutations[digits]]},
    If[MemberQ[numbers, number = sumpow[digits, len]], Print[number]]];
checklist = Subsets[{0, 1, 2, 3, 4, 5, 6, 7, 8, 9}][[2;;]];
ParallelMap[checkN[#] &, checklist]

What this needs is (i) checklist also consisting of subsets with double numbers (9474 for examples is a narcissistic number) and (ii) a while loop that 'constructs' the subsets and stops after finding the 25th narcissistic number.

On the way I found that http://rosettacode.org/wiki/Combinations#Mathematica contains:

combinations[n_Integer, m_Integer]/;m>= 0:=Union[Sort /@ Permutations[Range[0, n - 1], {m}]]

While this one is shorter and seems to be an order of magnitude faster:

combinations[n_Integer, m_Integer] := Subsets[Range[0, n - 1], {m}]

I have a program for Last letter-first letter. It simply enumerates all lists of every length. The main work is done with one line of Mathematica and two short functions. On an i5 desktop it takes 65 seconds. Printing takes a few more lines. The word list is an attached file. I have not yet submitted to the web site, brute force but workable. (updated for a little more speed)

pokemon = 
  Import[FileNameJoin[{NotebookDirectory[], "pokemon.txt"}]] // 
   StringSplit;
pindex[x_] := 
  First[ToCharacterCode[x]] - First[ToCharacterCode["a"]] + 1;
pdx = {pindex[StringTake[#, 1]], pindex[StringTake[#, -1]], 
     Position[pokemon, #][[1]]} & /@ pokemon;
pslice = Table[Cases[pdx, {i, _, _}], {i, pindex["z"]}];

merge[m_, n_] := Sow[{m[[1]], n[[2]], Join[m[[3]], n[[3]]]}];
reaper[p_ ] := 
  Reap[Do[If[(n[[2]] > 0 && pslice[[n[[2]]]] != {}), 
      Do[If[Not[MemberQ[n[[3]], q[[3, 1]]]], merge[n, q]], {q, 
        pslice[[n[[2]]]]}], Null], {n, First[p]}]][[2]];

 (* heart of the processing *)
 answers = NestWhileList[reaper, {pdx}, Length[#] > 0 &][[1 ;; -2]];

(* Summary of answers *)
Print["Number of lists of each length:"];
i = 0; Print[i = i + 1, " ", Length[#[[1]]]] & /@ answers;
Print["Length of longest list is ", i, ", examples follow"];
pokemon[[answers[[i, 1, 1, 3]]]]
pokemon[[answers[[i, 1, 2, 3]]]]

Output - Number of lists of each length:

1 70

2 172

3 494

4 1288

5 3235

6 7731

7 17628

8 37629

9 75122

10 139091

11 236679

12 367405

13 516210

14 650916

15 733915

16 727566

17 621835

18 446666

19 260862

20 119908

21 40296

22 10112

23 1248

Length of longest list is 23, examples follow

{"machamp", "petilil", "landorus", "scrafty", "yamask", "kricketune", \ "emboar", "registeel", "loudred", "darmanitan", "nosepass", \ "simisear", "relicanth", "heatmor", "rufflet", "trapinch", "haxorus", \ "seaking", "girafarig", "gabite", "exeggcute", "emolga", "audino"}

{"machamp", "petilil", "landorus", "scrafty", "yamask", "kricketune", \ "emboar", "registeel", "loudred", "darmanitan", "nosepass", \ "simisear", "rufflet", "trapinch", "heatmor", "relicanth", "haxorus", \ "seaking", "girafarig", "gabite", "exeggcute", "emolga", "audino"}

Attachments:

Bump! Added code for Set Puzzle:

colors = {Red, Green, Purple};
symbols = {"0", "\[TildeTilde]", "\[Diamond]"};
numbers = {1, 2, 3};
shadings = {"\[FilledSquare]", "\[Square]", "\[DoublePrime]"};

validTripleQ[l_List] := Entropy[l] != Entropy[{1, 1, 2}];
validSetQ[cards_List] := And @@ (validTripleQ /@ Transpose[cards]);

allCards = Tuples[{colors, symbols, numbers, shadings}];

deal[{numDeal_, setNum_}] := Module[{cards, count = 0}, 
   While[count != setNum,
    cards = RandomSample[allCards, numDeal];
    count = Count[Subsets[cards, {3}], _?validSetQ]];
   cards];

Row[{Style[#2, #1], #3, #4}] & @@@ deal[{9, 4}]

Fairly lazy approach but it shows off a lot of Mathematica's power.

Mathematica is quite unusual compared to most programming languages, so it's difficult if you don't know what kinds of functions to look for in the first place. A very vague rule of thumb I would recommend is looking for functions that work in "broad strokes." And generally you should try to write things in terms of functions, because of their composability and how they are used in those "broad strokes" functions. The quintessential example here is For vs Map:

newList = Range[Length[list]];
For[i = 1, i <= Length[list], i++,
    newList[[i]] = someF[list[[i]]]]

vs

Map[someF, list]

The real key though is that you have to have the impulse to look for these things. You ain't gonna find them if you aren't looking for them!

BTW in the decoder part for the move-to-front algorithm, remember that you get the index stream through the Fold function. Here's a more explicit version to make it easier to read:

f2[{output_, symList_}, nextIndex_] := Module[{char},
   char = symList[[nextIndex + 1]];
   {output~Append~char, Prepend[Delete[symList, nextIndex + 1], char]}];

Also:

{output_, symList_} ~f2~ nextIndex_ := Module[{char}...

I wouldn't recommend this infix form for a Rosetta submission, but it could help when thinking of how to write a function for Fold. Also:

Fold["f", initial, Range[4]] // TreeForm

Note that in this tree, the left branches/subtrees are where the 'state' is coming from.

@Marcus

I just tested the algorithm by just inputting random strings and checking if the decoded is always the same as the input: It works for most cases, however for the case of:

mtf["zbmcfkukwmeogkhgkspansqgytihgwudpevgaelx"]

It spawns an error. I'm having trouble understanding the algorithm to be honest ;) Lines like:

StringDrop[symTable, {StringPosition[symTable, StringTake[string, {i}]][[1, 1]]}]

Confuse me ;-)

To make it zero-indexed we can just subtract 1 for outputting, and add 1 for inputting? Any thoughts why this error occurs?

I added the code for the Chinese remainder theorem task, which was very easy as it is a built-in function...

The built-in function seems designed to illustrate growth of beginning states. I think it would fall behind if it had to generate 47 million list entries where each entry represents a tape that grows very long . re: the bonus challenge: 5-state, 2-symbol probable Busy Beaver machine from Wikipedia

I think your method can be simplified:

ClearAll[NarcissiticQ]
NarcissiticQ[num_Integer] := Module[{dig = IntegerDigits[num], m},
  m = Length[dig];
  Total[dig^m] === num
  ]
start = AbsoluteTime[];
n = 25;
m = 0;

i = 0;
Dynamic[{i, m} // Column]
a = Reap[
   While[m < n,
    If[NarcissiticQ2[i],
     Sow[i];
     m++;
     ];
    i++;
    ]
   ];
a = a[[2, 1]]
AbsoluteTime[] - start

this takes 121 seconds on my machine.

Alternatively we can memorize (and memoize) 0..9^p and use replace instead of calculating the powers:

ClearAll[NarcissiticQ2, NarcissiticRules]
NarcissiticRules[n_] := NarcissiticRules[n] = Thread[Range[0, 9] -> Range[0, 9]^n]
NarcissiticQ2[num_Integer] := Module[{dig = IntegerDigits[num], rul},
  rul = NarcissiticRules[Length[dig]];
  Total[Replace[dig, rul, {1}]] === num
 ]

But this is slower; around 168 seconds on my machine.

Could you explain your method? It looks really complex!

I implemented the Rosetta Code/Find unimplemented tasks task.

While I look over your suggestions on the remove line from file code, here is a start for reading a configuration file. I have ran into a brick wall with the "other family" list, but I might be attacking this problem from the wrong angle.

SetDirectory@NotebookDirectory[];
p = {}; m = {};
q = Fold[DeleteCases, Import["config.txt", "Data"], {{""}, {"#"}}];
Do[If[StringFreeQ[q[[i]], {"#"}][[1]],
   AppendTo[p, q[[i]]], ""], {i, Length@q}];
name = DeleteCases[
    StringCases[Flatten[p], "FULLNAME " ~~ x__ -> x], {}][[1, 1]];
m~AppendTo~{"name", name};
favf = DeleteCases[
    StringCases[Flatten[p], "FAVOURITEFRUIT " ~~ x__ -> x], {}][[1, 
    1]];
m~AppendTo~{"favouritefruit", favf};
If[StringMatchQ[
    Flatten[StringCases[Flatten[p], ___ ~~ "NEEDSPEELING"]], 
    "NEEDSPEELING"][[1]], needspeeling = "true", 
  needspeeling = "false"];
m~AppendTo~{"needspeeling", needspeeling};
If[StringMatchQ[
    Flatten[StringCases[Flatten[p], ___ ~~ "SEEDSREMOVED"]], 
    "SEEDSREMOVED"][[1]], seedsremoved = "true", 
  seedsremoved = "false"];
m~AppendTo~{"seedsremoved", seedsremoved};
Grid[m, Frame -> All]

Adding the config file as well.

http://rosettacode.org/wiki/Read_a_configuration_file

Attachments:

Looks good to me; shall I add it?

I would have used StringReplace:

StringReplace["abcdefghijkl","d"->""]

will output:

abcefghijkl

The problem seems to arise whenever the last letter is the last of the symbol string. I am posting a fix in a very short while. Notice that the second and third "If" argument in the decoding "Do" are slightly different. I have introduced a different string of symbols in one, and forgot to change the other. I will post a fix right after I have written out this post.

The code is first deleting the symbol from the list, which reduces the string length by 1, and then it tries to prepend the same symbol which should be at position 26, however the value has been deleted and the string is only 25 symbols long, which spawns the errors. By introducing a list number 2 which is deleted from, we can prepend the value to list 2 by funneling the symbol from list 1.

The line of code you pasted removes the input letter from the symbol string, the following code would prepend to the symbol string. The reason it's so clunky is that you can't do:

symTable = "abc";
StringDrop[symTable,"b"]

But rather

symTable = "abc";
StringDrop[symTable, {2}]

This means that we have to know where the "b" occurs;

StringPosition[symTable, StringTake[string , {i}]]

Outputs a list of the start- and stop-position of the string you are looking for, of the form

{{2,2}}

For which we only need one of the numbers to ge the correct placement. We can then replace the 2 in

StringDrop[symTable, {2}]

By the following code:

StringPosition[symTable, StringTake[string , {i}]][[1,1]]

I implemented Vampire number.

I implemented Rep-string, which was quite easy in Mathematica with smart usage of the pattern-matching abilities of Mathematica.

Hi Marcus, looks great!

I think:

Print@StringJoin[{"f[", ToString[i], "]= Overflow"}]

will be (nearly) identical to:

Print["f[",i, "]= Overflow"];

It will output it using row, and you don't have to think about ToString et cetera. Of course it is not the same, but as you 'print' it anyhow, it doesn't really matter. I will add it later.

Please submit it in my place, I do not have an account and it seems you are already familiar with the submission process with regards to formatting and whatnot. I have now updated the code with your suggestion of outputting a single string, thank you for your input!

Here is my very crude and probably extremely inefficient suggestion for a word-wrap.

string = "In olden times when wishing still helped one, there lived a \
king whose daughters were all beautiful, but the youngest was so \
beautiful that the sun itself, which has seen so much, was astonished \
whenever it shone in her face.  Close by the king's castle lay a \
great dark forest, and under an old lime-tree in the forest was a \
well, and when the day was very warm, the king's child went out into \
the forest and sat down by the side of the cool fountain, and when \
she was bored she took a golden ball, and threw it up on high and \
caught it, and this ball was her favorite plaything.";

wordWrap[textWidth_, spaceWidth_, string_] :=

  Module[{start, spaceLeft, masterString},
   spaceLeft = textWidth;
   start = 1;
   masterString = {};
   Do[
    If[i + 1 > Length@StringSplit@string,
     p = StringSplit[string][[start ;; i]]; 
     AppendTo[
      masterString, {StringJoin @@ 
        Riffle[p, StringJoin@ConstantArray[" ", spaceWidth]]}],
     If[StringLength[StringSplit@string][[i + 1]] + spaceWidth > 
       spaceLeft,
      spaceLeft = textWidth - StringLength[StringSplit@string][[i]]; 
      start = i; 
      AppendTo[
       masterString, {StringJoin @@ 
         Riffle[p, StringJoin@ConstantArray[" ", spaceWidth]]}],
      spaceLeft -= StringLength[StringSplit@string][[i]]; 
      spaceLeft -= spaceWidth; 
      p = StringSplit[string][[start ;; i]]]], {i, 1, 
     Length@StringSplit@string}];
   StringJoin @@ Riffle[masterString, "\n"]
   ];

wordWrap[72, 1, string]

I've hidden the output, looks like crap in the coding preview.

Edit: Added actual dependence on the space width in the code. Edit 2: Changed output style from n discrete lines to one single string output. Edit 3: Removed a lazy "Break[]" and "Clear[p]" left behind from building the code.

I like the very short code! Thanks! great job.

Thanks for the inspiration Luis!

Hi Marcus,

I have a different approach that might be more legible, and does not hard-code variables; it creates them on-the-fly:

ClearAll[CreateVar, ImportConfig];
CreateVar[x_, y_String: "True"] := Module[{},
  If[StringFreeQ[y, ","]
   ,
   ToExpression[x <> "=" <> y]
   ,
   ToExpression[x <> "={" <> StringJoin@Riffle[StringSplit[y, ","], ","] <> "}"]
   ]
  ]
ImportConfig[configfile_String] := Module[{data},
  (*data = ImportString[configfile, "List", "Numeric" -> False];*)
  data=Import[configfile,"List","Numeric"\[Rule]False];

  data = StringTrim /@ data;
  data = Select[data, # =!= "" &];
  data = Select[data, ! StringMatchQ[#, "#" | ";" ~~ ___] &];
  data = If[! StringFreeQ[#, " "], StringSplit[#, " ", 2], {#}] & /@ data;

  CreateVar @@@ data;
 ]
ImportConfig[file]

That looks a lot better! Sorry forgot about that; filenamejoin can not be used to add an extension; that was my fault.

I modified it slightly to make it more readable and added it too! Thanks!

Here is a revised version, taking your suggestions into account.

f[document_, start_, n_] :=
 Module[{},
  SetDirectory@NotebookDirectory[];
  p = Import[document, "List"];
  If[start + n - 1 <= Length@p,
   p = Drop[p, {start, start + n - 1}];
   Export[StringJoin[FileBaseName[document], "_removed.txt"], p, 
    "List"];,
   Print["Too few lines in document. Operation aborted."]]]

I omitted the following;

FileNameJoin[{document,"_removed.txt"}]

As it tried to create a folder within testdocument.txt—which, at least in OSX, can't be done :-)

Remove lines from a file:

f[document_, start_, n_] :=
 Module[{p, q},
  SetDirectory@NotebookDirectory[];
  p = Import[StringJoin[ToString@document, ".txt"], "Data"];
  If[start + n - 1 <= Dimensions[p][[1]],
   q = Delete[p, Table[{i}, {i, start, start + n - 1}]];
   Export[StringJoin[ToString@document, "Removed.txt"], q];,
   Print["Too few lines in document. Operation aborted."]]]

Removes n lines including the designated starting line from the assigned txt file. Exports to a new file with suffix to indicate that the document has had lines removed, to not destroy the original file if the operation is run multiple times by mistake.

Sorry I also don't have access to this book. If no-one has access to it, we have to implement ourselves... Thanks for the hint! Hopefully someone has this book.