Group Abstract Group Abstract

Message Boards Message Boards

Rosetta Code Challenge & Wolfram Language

GROUPS:

Following the very nice blogpost on the: Wolfram Blog about Rosetta code, it would be very nice if we could expand---as a community---the number of solved tasks on the Rosetta code website for the Mathematica Language.

The unsolved tasks for Mathematica can be found here. The number of tasks remaining is:

  • 145 (june 4th)
  • 141 (june 5th)
  • 133 (june 6th)
  • 130 (june 7th)
  • 128 (june 14th)
  • 125 (june 17th)
  • 120 (june 21st)
  • 119 (july 4th)

Some of the tasks are very easy to implement; others are tricky and very hard (if not impossible).

Just now, I solved a couple of problems:

I hope that we can solve some more problems and quickly reduce this number. Furthermore, I hope to start a lively discussion of problem solving and algorithm implementation. As you know, the Wolfram language is very broad and supports many paradigms, so many tasks can be implemented in multiple ways. You should strive to find the most elegant solution (short code, fast run-time).

Some problems that should not be too hard to solve are:

The tasks that are not implemented can be found using:

url="http://rosettacode.org/wiki/Reports:Tasks_not_implemented_in_Mathematica";
html=Import[url,"XMLObject"];
pos=Position[html,XMLElement["div",{"class"->"mw-content-ltr","dir"->"ltr","lang"->"en"},___]];
pos=First[pos];
data=Extract[html,pos];
pos=Position[data,XMLElement["li",{},{XMLElement["a",{"shape"->"rect","href"->_,"title"->x_},{x_}]}]];
data=Extract[data,pos];
data=data[[All,-1,-1,2]];
data={"title","href"}/.#&/@%;
data[[All,2]]="http://rosettacode.org"<>#&/@data[[All,2]];
data=Hyperlink@@@data;
data//Length
data//Column

Happy solving!

P.S. If you solved a problem after reading this thread, please leave a comment :)

POSTED BY: Sander Huisman
Answer
7 months ago

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
POSTED BY: Sander Huisman
Answer
7 months ago

Here is a start for the Fibonacci word/fractal task:

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

FibonacciWord/@Range[7]//Column

giving:

1
0
01
010
01001
01001010
0100101001001

Now one should develop the 'drawing' code...

POSTED BY: Sander Huisman
Answer
7 months ago

Going by this video I added one for Huffman Coding, done in my usual potentially-too-fancy-for-its-own-good style:

huffman[s_String] := huffman[Characters[s]];
huffman[l_List] := Module[{merge, structure, rules},

(*merge front two branches. list is assumed to be sorted*)
merge[k_] := Replace[k, {{a_, aC_}, {b_, bC_}, rest___} :> {{{a, b}, aC + bC}, rest}];

structure = FixedPoint[
Composition[merge, SortBy[#, Last] &],
Tally[l]][[1, 1]];

rules = (# -> Flatten[Position[structure, #] - 1]) & /@ DeleteDuplicates[l];

{Flatten[l /. rules], rules}];

It seems to be correct.


An addendum to Sander's FibonacciWord code above:

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

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

Also in a playful programming style. I'm not certain about the correctness of this one, though.

Answer
7 months ago

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:

F23

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.

POSTED BY: Sander Huisman
Answer
7 months ago

I added the code for the Combinations and permutation task.

POSTED BY: Sander Huisman
Answer
7 months ago

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.

POSTED BY: Marcus Risanger
Answer
7 months ago

Looks great! It works pretty neatly I think. Works good, but it might be nicer if it would return a string rather than print it.

Did you add it to the Rosetta website? If you want me to do it (because you e.g. don't have an account), let me know.

POSTED BY: Sander Huisman
Answer
7 months ago

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!

POSTED BY: Marcus Risanger
Answer
7 months ago

I just added it to the website! Thanks!

POSTED BY: Sander Huisman
Answer
7 months ago

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

POSTED BY: Sander Huisman
Answer
7 months ago

hi Sander, looking at the page of the Rosetta Code I found the stable marriage problem and I remember that Stan Wagon proposes a solution to this problem in his book "Mathematica in action " third edition, but not if we have problems with Stan to post your code

POSTED BY: luis ledesma
Answer
7 months ago

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.

POSTED BY: Sander Huisman
Answer
7 months ago

Trabb Pardo-Knuth algorithm;

numbers = RandomReal[{-2, 6}, 11]

tpk[numbers_, overflowVal_] :=
Module[{revNumbers},
revNumbers = Reverse[numbers];
f[x_] := Abs[x]^0.5 + 5 x^3;
Do[If[f[i] > overflowVal,
Print@StringJoin[{"f[", ToString[i], "]= Overflow"}],
Print@StringJoin[{"f[", ToString[i], "]= ", ToString[f[i]]}]], {i,revNumbers}]]

tpk[numbers, 400]

Had to resort to discrete printings of strings, not sure how to do it otherwise. Feel free to make improvement suggestions. If you would please submit this one as well, Sander, I would appreciate that.

POSTED BY: Marcus Risanger
Answer
7 months ago

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.

POSTED BY: Sander Huisman
Answer
7 months ago

You are right, the output is virtually the same. I think your version is better as it carries only one third of the commands for printing the values and hence is more elegant.

I actually tried with a similar construction before resorting to printing strings, but it somehow displayed the value before the text strings somehow. I don't remember exactly how I formulated the command though.

Edit: I think I omitted the commas within the Print command. That doesn't work out so well apparently.

POSTED BY: Marcus Risanger
Answer
7 months ago

I replaced the Prints, and uploaded it to the website; thanks! If you forget the commas it will see it as multiplication, multiplications of a string and an number will (generally) be displayed as "numberstring". Thanks!

POSTED BY: Sander Huisman
Answer
7 months ago

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

POSTED BY: Sander Huisman
Answer
7 months ago

I implemented IBAN, quite easy to implement.

POSTED BY: Sander Huisman
Answer
7 months ago

I implemented Vampire number.

POSTED BY: Sander Huisman
Answer
7 months ago
POSTED BY: Sander Huisman
Answer
7 months ago

I implemented Zebra puzzle, which was great fun!

I used a 'sodoku kind of way' to solve it. Each house has for each kind, all the candidates. Then, by applying the rules you filter out candidates until you're left with 1 candidates per kind per house.

POSTED BY: Sander Huisman
Answer
7 months ago

I implemented Metaprogramming.

POSTED BY: Sander Huisman
Answer
7 months ago

Move-to-front algorithm:

mtf[string_] :=
Module[{word, p, q, symTable, symTable2},
p = {};
q = {};
symTable = StringJoin @@ CharacterRange["a", "z"];
Do[
If[
i == StringLength@string,
AppendTo[p,
StringPosition[symTable, StringTake[string, {i}]][[1, 1]] - 1];
symTable =
StringDrop[
symTable, {StringPosition[symTable, StringTake[string, {i}]][[1,
1]]}];
symTable = StringJoin[StringTake[string, {i}], symTable];
Print["'", string, "' encodes to: ", p],
AppendTo[p,
StringPosition[symTable, StringTake[string, {i}]][[1, 1]] - 1];
symTable =
StringDrop[
symTable, {StringPosition[symTable, StringTake[string, {i}]][[1,
1]]}];
symTable = StringJoin[StringTake[string, {i}], symTable];
]
, {i, StringLength@string}];
symTable = StringJoin @@ CharacterRange["a", "z"];
Do[
If[
j == StringLength@string,
q = StringJoin[q, StringTake[symTable, {p[[j]] + 1}]];
symTable2 =
StringDrop[
symTable, {StringPosition[symTable,
StringTake[symTable, {p[[j]] + 1}]][[1, 1]]}];
symTable =
StringJoin[StringTake[symTable, {p[[j]] + 1}], symTable2];
Print[p, " decodes to: '", q, "'"],
q = StringJoin[q, StringTake[symTable, {p[[j]] + 1}]];
symTable2 =
StringDrop[
symTable, {StringPosition[symTable,
StringTake[symTable, {p[[j]] + 1}]][[1, 1]]}];
symTable =
StringJoin[StringTake[symTable, {p[[j]] + 1}], symTable2]
]
, {j, StringLength@string}];
]

Any suggestions? Clunky code, but it gets the job done. Admittedly, I have cheated to get the problem "zero-indexed". This can apparently be done with the Notation package, but I haven't gotten a chance to look at it. Now back to my thesis!

In[347]:= Timing[mtf["broood"]]

During evaluation of In[347]:= 'broood' encodes to: {1,17,15,0,0,5}

During evaluation of In[347]:= {1,17,15,0,0,5} decodes to: 'broood'

Out[347]= {0.000612, Null}

Edit: I guess it's not a symbol table array either, it's just a string of the whole alphabet. Oh well. Edit 2: Fixed the code. Good bug-catching!

mtf["zbmcfkukwmeogkhgkspansqgytihgwudpevgaelx"]

'zbmcfkukwmeogkhgkspansqgytihgwudpevgaelx' encodes to: {25,2,13,4,7,12,21,1,23,5,10,17,12,5,13,2,2,21,19,14,19,3,20,6,25,23,20,10,4,14,15,20,12,15,24,6,14,3,23,25}

{25,2,13,4,7,12,21,1,23,5,10,17,12,5,13,2,2,21,19,14,19,3,20,6,25,23,20,10,4,14,15,20,12,15,24,6,14,3,23,25} decodes to: 'zbmcfkukwmeogkhgkspansqgytihgwudpevgaelx'
POSTED BY: Marcus Risanger
Answer
7 months ago

@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?

POSTED BY: Sander Huisman
Answer
7 months ago

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]]
POSTED BY: Marcus Risanger
Answer
7 months ago

I would have used StringReplace:

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

will output:

abcefghijkl
POSTED BY: Sander Huisman
Answer
7 months ago

Oh, that is very nice! Thanks for sharing, I need to keep my eyes out for more clever solutions instead of hard-coding some massive piece of code.

POSTED BY: Marcus Risanger
Answer
6 months ago

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.

Answer
7 months ago

Here is my suggestion for a complete algorithm, based on your encoding algorithm.

mtf[word_] :=
Module[{f, f2},
f[{output_, symList_}, next_] :=
Module[{index}, index = Position[symList, next][[1, 1]] - 1;
{output~Append~index,
Prepend[Delete[symList, index + 1], next]}];
p = Fold[f, {{}, CharacterRange["a", "z"]},
Characters[ToString[word]]][[1]];
Print["'" word, "' encodes to: ", p];
f2[{output_, symList_}, next_] :=
Module[{index}, index = symList[[next + 1]];
{output~Append~index,
Prepend[DeleteCases[symList, ToString[index]], index]}];
q = Fold[f2, {{}, CharacterRange["a", "z"]}, p][[1]];
Print[p, " decodes to: '", StringJoin@q, "'"]
]

Interestingly, I find the "old" algorithm to run a bit faster, tested with some random long string, with 1000 repetitions using AbsoluteTiming. Undoubtedly, though, this algorithm is much more elegant.

POSTED BY: Marcus Risanger
Answer
7 months ago

Looks good to me; shall I add it?

POSTED BY: Sander Huisman
Answer
6 months ago

That would be excellent!

POSTED BY: Marcus Risanger
Answer
6 months ago

I added it! Thanks!

POSTED BY: Sander Huisman
Answer
6 months ago

Well, that was pretty compact compared to my clunkstrosity! I guess it's quite obvious I am not familiar with a ton of the functions built in to Mathematica.

POSTED BY: Marcus Risanger
Answer
7 months ago

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.

Answer
6 months ago

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.

POSTED BY: Marcus Risanger
Answer
6 months ago

Here are some improvements that we should consider:

  • document_ should be document_String to make it more foolproof, same for start_ and n_ Both should have head Integer.
  • I would omit StringJoin[ToString@document, ".txt"] and just replace it by document; so the user can provide the filename directly.
  • Maybe import it as "List", so you are sure that we have each 'line' of the file as an item.
  • Dimensions[p][[1]] can be replaced by Length right?
  • Table[{i}, {i, start, start + n - 1}] could be replaced by List/@Range[start,start+n-1] BUT:
  • Delete[p, Table[{i}, {i, start, start + n - 1}]] could be replaced by Drop[p,{start,start+n-1}] directly. faster, and more concise.
  • If the import is used using List export can be exported too using List: Export[FileNameJoin[{document,"_removed.txt"}],q,"List"]
  • the variable q could be omitted: just overwrite p. (minor change of course...)

In general you should use the functions: FileNameSplit, FileNameJoin,FileNameTake,FileNameDrop, FileBaseName et cetera for combining filenames and folders. These are platform independent and should work on mac/linux/windows (the main problem is the "\" and "/" difference).

POSTED BY: Sander Huisman
Answer
6 months ago

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 :-)

POSTED BY: Marcus Risanger
Answer
6 months ago

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!

POSTED BY: Sander Huisman
Answer
6 months ago

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:
POSTED BY: Marcus Risanger
Answer
6 months ago

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]
POSTED BY: Sander Huisman
Answer
6 months ago

I added this code

POSTED BY: Sander Huisman
Answer
6 months ago

hola Sander, aqui esta mi propuesta para the Stable marriage problem, aunque es muy rustica cumple con el requisito de aplicar el algoritmo Gale/Shapley . Por favor hazle las modificaciones que cosideres necesarias, saludos y cuidate.

POSTED BY: luis ledesma
Answer
6 months ago

Hola Luis,

Muy bien code! Yo cambio el code un poco; por el legibilidad, y para hacer el code conciso. La tarea se compone dos partes: el algoritmo Gale-Shapley (incluido en la función StableMarriage) y perturbar los pares y prueba la estabilidad. Parte uno:

Quiet[Needs["Combinatorica`"]];
mals = {"abe", "bob", "col", "dan", "ed", "fred", "gav", "hal", "ian", "jon"};
fems = {"abi", "bea", "cath", "dee", "eve", "fay", "gay", "hope", "ivy", "jan"};
menstrg = {{"abi", "eve", "cath", "ivy", "jan", "dee", "fay", "bea", "hope", "gay"}, {"cath", "hope", "abi", "dee", "eve", "fay", "bea", "jan", "ivy", "gay"}, {"hope", "eve", "abi", "dee", "bea", "fay", "ivy", "gay", "cath", "jan"}, {"ivy", "fay", "dee", "gay", "hope", "eve", "jan", "bea", "cath", "abi"}, {"jan", "dee", "bea","cath", "fay", "eve", "abi", "ivy", "hope", "gay"}, {"bea", "abi", "dee", "gay", "eve", "ivy", "cath", "jan", "hope", "fay"}, {"gay", "eve", "ivy", "bea", "cath", "abi", "dee", "hope","jan", "fay"}, {"abi", "eve", "hope", "fay", "ivy", "cath", "jan", "bea", "gay", "dee"}, {"hope", "cath", "dee", "gay", "bea","abi", "fay", "ivy", "jan", "eve"}, {"abi", "fay", "jan", "gay", "eve", "bea", "dee", "cath", "ivy", "hope"}};
womstrg = {{"bob", "fred", "jon", "gav", "ian", "abe", "dan", "ed", "col", "hal"}, {"bob", "abe", "col", "fred", "gav", "dan", "ian", "ed", "jon", "hal"}, {"fred", "bob", "ed", "gav", "hal", "col", "ian", "abe", "dan", "jon"}, {"fred", "jon", "col", "abe", "ian", "hal", "gav", "dan", "bob", "ed"}, {"jon", "hal", "fred", "dan", "abe", "gav", "col", "ed", "ian", "bob"}, {"bob", "abe", "ed", "ian", "jon", "dan", "fred", "gav", "col", "hal"}, {"jon", "gav", "hal", "fred", "bob", "abe", "col", "ed", "dan", "ian"}, {"gav", "jon", "bob", "abe", "ian", "dan", "hal", "ed", "col", "fred"}, {"ian", "col", "hal", "gav", "fred", "bob", "abe", "ed", "jon", "dan"}, {"ed", "hal", "gav", "abe", "bob", "jon", "col", "ian", "fred", "dan"}};
male = menstrg /. Thread[fems -> Range[10]];
female = womstrg /. Thread[mals -> Range[10]];
lks = StableMarriage[male, female] /. Thread[ Range[10] -> fems];
MapThread[{#1, " fiance ", #2} &, {mals, lks}] // Grid

Output:

abe   fiance   ivy
bob fiance cath
col fiance dee
dan fiance fay
ed fiance jan
fred fiance bea
gav fiance gay
hal fiance eve
ian fiance hope
jon fiance abi

Replace ( /. ) funciona en todos los niveles (Levels en Mathematica). Table no es necesario.

Perdona que mi Español sea malo, aún estoy aprendiendo.

For the english-only speaking:

The code above does part one of the task. Part two of the task is to perturb the 'best matches' and test stability. Anyone?

POSTED BY: Sander Huisman
Answer
6 months ago

Hi friend, now I leave my attempt to solve the sorting radix,I must say that is intended for positive integers,I do not know if you can also make for negative integers, please see it and correct what you think is wrong. Estamos comunicacion permanente

Attachments:
POSTED BY: luis ledesma
Answer
6 months ago

Hi Luis,

I solved the Radix problem. We simply add a number to all numbers (such that all of them are positive), do the algorithm, and then subtract a number again.

ClearAll[SortByPos, RadixSort]
SortByPos[data : {_List ..}, pos_Integer] := Module[{digs, order},
digs = data[[All, pos]];
order = Ordering[digs];
data[[order]]
]
RadixSort[x : {_Integer ..}] := Module[{y, digs, maxlen, offset},
offset = Min[x];
y = x - offset;
digs = IntegerDigits /@ y;
maxlen = Max[Length /@ digs];
digs = IntegerDigits[#, 10, maxlen] & /@ y;
digs = Fold[SortByPos, digs, -Range[maxlen]];
digs = FromDigits /@ digs;
digs += offset;
digs
]

And submitted it to the Rosetta stone

POSTED BY: Sander Huisman
Answer
6 months ago

Thanks for the inspiration Luis!

POSTED BY: Sander Huisman
Answer
6 months ago

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 some of Mathematica's power.

Answer
6 months ago

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.

Answer
6 months ago

Gotta love the "Tuples" command, that saves so much time! Nice solution!

POSTED BY: Sander Huisman
Answer
6 months ago

I implemented the Rosetta Code/Find unimplemented tasks task.

POSTED BY: Sander Huisman
Answer
6 months ago

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:
POSTED BY: Douglas Kubler
Answer
6 months ago

This looks really nice! I'm not sure how it exactly works, but it works!

POSTED BY: Sander Huisman
Answer
6 months ago

I implemented Magic squares of odd order

rp[v_, pos_] := RotateRight[v, (Length[v] + 1)/2 - pos];
rho[m_] := MapIndexed[rp, m];
magic[n_] :=
rho[Transpose[rho[Table[i*n + j, {i, 0, n - 1}, {j, 1, n}]]]];

square = magic[11] // Grid
Print["Magic number is ", Total[square[[1, 1]]]]

Output for run for a square of sides 11. The formatting for the square doesn't translate well to a forum.

Magic number is 671

For a nice grid

square = magic[11]; Grid[square, Frame -> All]
POSTED BY: Douglas Kubler
Answer
6 months ago

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

POSTED BY: Sander Huisman
Answer
6 months ago

Hi all, So I have been trying rather unsuccessfully to implement the Arithmetic-geometric mean/Calculate Pi problem in the Wolfram Language, and I have been getting some rather disappointing and confusing results. Firstly, after studying the literature, it would seem to me that the method required by the Rosetta Code challenge is as follows,

Iterative formula for Pi using AGM

Where a[n] is the arithmetic mean of a[n-1] and b[n-1], while b[n] is the geometric mean of a[n-1] and b[n-1].

But the problem is that I cannot find this exact formula anywhere else on the internet, and not even in the paper (pdf) that the Rosetta page references. Regardless, my implementation in the Wolfram language follows,

piCalc[n_]:=(4*(a[n])^2)/(1-Sum[(2^(k+1))*((a[k])^2-(b[k])^2),{k,1,n}])
a[h_]:=Mean[{a[h-1],b[h-1]}]
b[l_]:=GeometricMean[{a[l-1],b[l-1]}]
a[1]=Sqrt[2];
b[1]=1;

I have been unable to find what initial conditions for a and b will give Pi. I chose Sqrt[2] and 1 here because those are what is used in one of the papers mentioned below that use a similar algorithm, but not only do these number result in a negative result, it is nowhere near Pi.

Now there is some ambiguity from what I have seen concerning what a1] and what b[1] should be, as the Rosetta Code page makes no mention of these values, and I cannot determine from the other languages presentations what the other implementations use. I found another paper, [here, which makes mention of using simply the arithmetic and geometric mean formulas, to calculate Pi with the initial conditions, a2]=1/2, and a[2]=1/4, which doesn't make sense to me, but also makes Mathematica reach its recursion limit. Additionally, the [Wikipedia page appears to have an error on their page with respect to how c[n] is defined, as well as not providing initial conditions. Another site also makes mention of using the AGM to calculate Pi, and while it includes the exact formulation for Pi, it doesn't include the formula listed on the Rosetta Code site. It also mentions some of the other formulas I have seen, which seem both simpler than the Rosetta code's formulation, as well as quicker (though I believe in one or multiple of the papers it is proven that they converge quadratically). I am wondering if anyone here knows if there is anything wrong with my code, or if the formula from the Rosetta Code page is incorrect, or even if anyone know what initial conditions I should use for this, any help would be much appreciated.

Thanks,

Ian

Attachments:
POSTED BY: Ian Johnson
Answer
6 months ago

The initials from the paper are a[1] = 1, b[1] = 1/Sqrt[2]. But I don't see that converging to Pi as you have things, so there is apparently some other conceptual confusion involved...

POSTED BY: Jason Cawley
Answer
6 months ago

The small confusion (aside from the transposition of values that Jason points out) is that the initial conditions are for a[0] and b[0] rather than a[1] and b[1].

So, with that said, this direct approach looks like

Clear[a, b, piCalc, $numericalPrecision]

$numericalPrecision = 150;

piCalc[n_] := (4*a[n]^2)/(1 -
Sum[2^(1 + k)*(a[k]^2 - b[k]^2), {k, 1, n}])

a[h_] := (a[h] = N[(a[h - 1] + b[h - 1])/2, $numericalPrecision])

b[h_] := (b[h] = N[Sqrt[a[h - 1] b[h - 1]], $numericalPrecision])

a[0] = 1;

b[0] = 1/Sqrt[2];

And here is an example of a calculation:

In[134]:= piCalc[100]

Out[134]= \ 3.1415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066

Some work needs to be done on this approach to adjust the value of $numericalPrecision and the argument of piCalc so that the desired number of digits are obtained.

Note that I have added memoization to the calculation to speed it up.

POSTED BY: David Reiss
Answer
6 months ago

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];
POSTED BY: Ian Johnson
Answer
6 months ago

Thanks Ian for adding :) looks like a very clean implementation!

POSTED BY: Sander Huisman
Answer
6 months ago

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}]
POSTED BY: Ziggy Pleunis
Answer
6 months ago

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!

POSTED BY: Sander Huisman
Answer
5 months ago

I have submitted a program for Universal Turing Machine.

I updated it to use dynamic function definition. Cuts the run time of the largest task from 9 minutes to 4 minutes. The code (without the test drivers) is:

left = 1; right = -1; stay = 0;
cmp[s_] := ToExpression[StringSplit[s, ","]];
utm[rules_, initial_, head_] :=
Module[{tape = initial, rh = head, n = 1},
Clear[nxt];
nxt[state_, field_] :=
nxt[state, field] = Position[rules, {rules[[state, 5]], field, _, _, _}][[1, 1]];
n = Position[rules, {rules[[n, 1]], BitGet[tape, rh], _, _, _}][[1,1]];
While[rules[[n, 4]] != 0,
If[rules[[n, 3]] != BitGet[tape, rh],
If[rules[[n, 3]] == 1, tape = BitSet[tape, rh],tape = BitClear[tape, rh]]];
rh = rh + rules[[n, 4]];
If[rh < 0, rh = 0; tape = 2*tape];
n = nxt[n, BitGet[tape, rh]];
]; {tape, rh}
];
POSTED BY: Douglas Kubler
Answer
5 months ago

Could built in function TuringMachine be used somehow to shorten implementation?

POSTED BY: Sam Carrettie
Answer
5 months ago

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

POSTED BY: Douglas Kubler
Answer
5 months ago