User talk:VHF: Difference between revisions

From Rosetta Code
Content added Content deleted
(Blanked the page)
 
Line 1: Line 1:
== Subsets ==
Built-in function that either gives all possible subsets, subsets with at most n elements, subsets with exactly n elements or subsets containing between n and m elements. Example of all subsets:
<lang Mathematica>Subsets[{a, b, c}]</lang>
gives:
<lang Mathematica>{{}, {a}, {b}, {c}, {a, b}, {a, c}, {b, c}, {a, b, c}}</lang>
Subsets[list, {n, Infinity}] gives all the subsets that have n elements or more.

Subsets[list, n] gives all the subsets that have at most n elements.

Subsets[list, {n}] gives all the subsets that have exactly n elements.

Subsets[list, {m,n}] gives all the subsets that have between m and n elements.

== Prime decomposition ==
Bare built-in function does:
<lang Mathematica> FactorInteger[2016] => {{2, 5}, {3, 2}, {7, 1}}</lang>

Read as: 2 to the power 5 times 3 squared times 7 (to the power 1). To show them nicely we could use the following functions:
<lang Mathematica>supscript[x_,y_]:=If[y==1,x,Superscript[x,y]]
ShowPrimeDecomposition[input_Integer]:=
Print@@{input," = ",Sequence@@Riffle[supscript@@@FactorInteger[input]," "]}</lang>

Example for small prime:
<lang Mathematica> ShowPrimeDecomposition[1337]</lang>
gives:
<lang Mathematica> 1337 = 7 191</lang>
Examples for large primes:
<lang Mathematica> Table[AbsoluteTiming[ShowPrimeDecomposition[2^a-1]]//Print[#[[1]],
" sec"]&,{a,50,150,10}];</lang>
gives back:
<lang Mathematica>1125899906842623 = 3 11 31 251 601 1801 4051
0.000231 sec
1152921504606846975 = 3^2 5^2 7 11 13 31 41 61 151 331 1321
0.000146 sec
1180591620717411303423 = 3 11 31 43 71 127 281 86171 122921
0.001008 sec
1208925819614629174706175 = 3 5^2 11 17 31 41 257 61681 4278255361
0.000340 sec
1237940039285380274899124223 = 3^3 7 11 19 31 73 151 331 631 23311 18837001
0.000192 sec
1267650600228229401496703205375 = 3 5^3 11 31 41 101 251 601 1801 4051 8101 268501
0.000156 sec
1298074214633706907132624082305023 = 3 11^2 23 31 89 683 881 2971 3191 201961 48912491
0.001389 sec
1329227995784915872903807060280344575 = 3^2 5^2 7 11 13 17 31 41 61 151 241 331 1321 61681 4562284561
0.000374 sec
1361129467683753853853498429727072845823 = 3 11 31 131 2731 8191 409891 7623851 145295143558111
0.024249 sec
1393796574908163946345982392040522594123775 = 3 5^2 11 29 31 41 43 71 113 127 281 86171 122921 7416361 47392381
0.009419 sec
1427247692705959881058285969449495136382746623 = 3^2 7 11 31 151 251 331 601 1801 4051 100801 10567201 1133836730401
0.007705 sec</lang>

== Function composition ==
Built-in function that takes any amount of function-arguments:
<lang Mathematica>Composition[f, g][x]
Composition[f, g, h, i][x]</lang>
gives back:
<lang Mathematica>f[g[x]]
f[g[h[i[x]]]]</lang>
Custom function:
<lang Mathematica>compose[f_, g_][x_] := f[g[x]]
compose[Sin, Cos][r]</lang>
gives back:
<lang Mathematica>Sin[Cos[r]]</lang>
Composition can be done in more than 1 way:
<lang Mathematica>Composition[f,g,h][x]
f@g@h@x
x//h//g//f</lang>
all give back:
<lang Mathematica>f[g[h[x]]]</lang>
The built-in function has a couple of automatic simplifications:
<lang Mathematica>Composition[f, Identity, g]
Composition[f, InverseFunction[f], h][x]</lang>
becomes:
<lang Mathematica>f[g[x]]
h[x]</lang>

== 100 doors ==
'''unoptimized 1'''
<lang mathematica>n=100;
tmp=ConstantArray[-1,n];
Do[tmp[[i;;;;i]]*=-1;,{i,n}];
Do[Print["door ",i," is ",If[tmp[[i]]==-1,"closed","open"]],{i,1,Length[tmp]}]</lang>

'''optimized 1'''
<lang mathematica>Do[Print["door ",i," is ",If[IntegerQ[Sqrt[i]],"open","closed"]],{i,100}]</lang>

'''optimized 2'''
<lang mathematica>n=100;
a=Range[1,Sqrt[n]]^2
Do[Print["door ",i," is ",If[MemberQ[a,i],"open","closed"]],{i,100}]</lang>

'''optimized 3'''
<lang mathematica>n=100
nn=1
a=0
For[i=1,i<=n,i++,
If[i==nn,
Print["door ",i," is open"];
a++;
nn+=2a+1;
,
Print["door ",i," is closed"];
];
]</lang>

'''optimized 4'''
<lang mathematica>Range[Sqrt[100]]^2</lang>

== 99 Bottles ==

<lang Mathematica>texts = ToString[#] <> " bottles of beer on the wall\n" <> ToString[#] <>
" bottles of beer\nTake one down and pass it around\n" <>
ToString[# - 1] <> " bottles of beer on the wall" & /@ Range[99, 1, -1];
AppendTo[texts, "No more bottles of beer on the wall, no more bottles of beer\nGo \
to the store and buy some more, 99 bottles of beer on the wall"];
texts = StringJoin@Riffle[texts, "\n\n"];
Print@StringReplace[texts, "\n1 bottles" -> "\n1 bottle"]</lang>


== Array concatenation ==
<lang Mathematica>Join[{1,2,3}, {4,5,6}]

-> {1, 2, 3, 4, 5, 6}</lang>

== Median ==
Built-in function:
<lang Mathematica>Median[{1, 5, 3, 2, 4}]
Median[{1, 5, 3, 6, 4, 2}]</lang>
gives back:
<lang Mathematica>3
7/2</lang>
Custom function:
<lang Mathematica>mymedian[x_List]:=Module[{t=Sort[x],L=Length[x]},
If[Mod[L,2]==0,
(t[[L/2]]+t[[L/2+1]])/2
,
t[[(L+1)/2]]
]
]</lang>
Example of custom function:
<lang Mathematica>mymedian[{1, 5, 3, 2, 4}]
mymedian[{1, 5, 3, 6, 4, 2}]</lang>
gives back:
<lang Mathematica>3
7/2</lang>

== Bubble Sort ==
A rule-based solution is only one line, for large lists this method is not optimal, not so because of the method but because of the usage of patterns in a rule based solution:
<lang Mathematica>BubbleSort[input_] := input //. {a___, i_, j_, b___} /; OrderedQ[{j, i}] :> {a, j, i, b}</lang>
Example:
<lang Mathematica>BubbleSort[{10, 3, 7, 1, 4, 3, 8, 13, 9}]</lang>
gives back:
<lang Mathematica>{1, 3, 3, 4, 7, 8, 9, 10, 13}</lang>


== Dragon Curve ==
Two functions: one that makes 2 lines from 1 line. And another that applies this function to all existing lines:
<lang Mathematica>FoldOutLine[{a_,b_}]:={{a,#},{b,#}}&[a+0.5(b-a)+{{0.,0.5},{-0.5,0.}}.(b-a)]
NextStep[in_]:=Flatten[FoldOutLine/@in,1]
lines={{{0.,0.},{1.,0.}}};
Graphics[Line/@Nest[NextStep,lines,11]]</lang>

== N-Queens ==
This code recurses through the possibilities, using the "safe" method to check if the current set is allowed. The recursive method has the advantage that finding all possibilities is about as hard (code-wise, not computation-wise) as finding just one.
<lang Mathematica>safe[q_List, n_] :=
With[{l = Length@q},
Length@Union@q == Length@Union[q + Range@l] ==
Length@Union[q - Range@l] == l]
nQueen[q_List:{}, n_] :=
If[safe[q, n],
If[Length[q] == n, q,
Cases[Flatten[{nQueen[Append[q, #], n]}, 2] & /@ Range[n],
Except[{Null} | {}]]], Null]</lang>

This returns a list of valid permutations by giving the queen's column number for each row. It can be displayed in a list of chess-board tables like this:
<lang Mathematica>matrixView[n_] :=
Grid[Normal@
SparseArray[MapIndexed[{#, First@#2} -> "Q" &, #], {n, n}, "."],
Frame -> All] & /@ nQueen[n]
matrixView[6] // OutputForm</lang>
<pre>{. . . Q . ., . . . . Q ., . Q . . . ., . . Q . . .}

Q . . . . . . . Q . . . . . . Q . . . . . . . Q

. . . . Q . Q . . . . . . . . . . Q . Q . . . .

. Q . . . . . . . . . Q Q . . . . . . . . . Q .

. . . . . Q . . . Q . . . . Q . . . Q . . . . .

. . Q . . . . Q . . . . . . . . Q . . . . Q . .</pre>

== Perfect Numbers ==
Custom function:
<lang Mathematica>PerfectQ[i_Integer] := Total[Divisors[i]] == 2 i</lang>
Examples (testing 496, testing 128, finding all perfect numbers in 1...10000):
<lang Mathematica>PerfectQ[496]
PerfectQ[128]
Flatten[PerfectQ/@Range[10000]//Position[#,True]&]</lang>
gives back:
<lang Mathematica>True
False
{6,28,496,8128}</lang>

== Spiral ==
We split the task up in 2 functions, one that adds a 'ring' around a present matrix. And a function that adds rings to a 'core':
<lang Mathematica>AddSquareRing[x_List/;Equal@@Dimensions[x] &&
Length[Dimensions[x]]==2]:=Module[{new=x,size,smallest},
size=Length[x];
smallest=x[[1,1]];
Do[
new[[i]]=Prepend[new[[i]],smallest-i];
new[[i]]=Append[new[[i]],smallest-3 size+i-3]
,{i,size}];
PrependTo[new,Range[smallest-3size-3-size-1,smallest-3size-3]];
AppendTo[new,Range[smallest-size-1,smallest-size-size-2,-1]];
new
]
MakeSquareSpiral[size_Integer/;size>0]:=Module[{largest,start,times},
start=size^2+If[Mod[size,2]==0,{{-4,-3},{-1,-2}},{{-1}}];
times=If[Mod[size,2]==0,size/2-1,(size-1)/2];
Nest[AddSquareRing,start,times]
]</lang>
Examples:
<lang Mathematica>MakeSquareSpiral[2] // MatrixForm
MakeSquareSpiral[7] // MatrixForm</lang>
gives back:

<math>
\left(
\begin{array}{cc}
0 & 1 \\
3 & 2
\end{array}
\right)
</math>

<math>
\left(
\begin{array}{ccccccc}
0 & 1 & 2 & 3 & 4 & 5 & 6 \\
23 & 24 & 25 & 26 & 27 & 28 & 7 \\
22 & 39 & 40 & 41 & 42 & 29 & 8 \\
21 & 38 & 47 & 48 & 43 & 30 & 9 \\
20 & 37 & 46 & 45 & 44 & 31 & 10 \\
19 & 36 & 35 & 34 & 33 & 32 & 11 \\
18 & 17 & 16 & 15 & 14 & 13 & 12
\end{array}
\right)
</math>

== Sierpinski triangle ==
Cellular automaton (rule 90) based solution:
<lang mathematica>n=4;Grid[CellularAutomaton[90,{{1},0},2^n-1]/.{0->" ",1->"*"},ItemSize->All]</lang>

== Sierpinsky carpet ==
Replace a empty spot with a 3x3 empty matrix, and replace a full spot with an empty spot surrounded by 8 full spots:
<lang Mathematica>full={{1,1,1},{1,0,1},{1,1,1}}
empty={{0,0,0},{0,0,0},{0,0,0}}
n=3;
Grid[Nest[ArrayFlatten[#/.{0->empty,1->full}]&,{{1}},n]//.{0->" ",1->"#"}]</lang>

== Select from Array ==
Check for even integers:
<lang Mathematica>Select[{4, 5, Pi, 2, 1.3, 7, 6, 8.0}, EvenQ]</lang>
gives:
<lang Mathematica>{4, 2, 6}</lang>
To check also for approximate number (like 8.0 in the example above) a possible solution is:
<lang Mathematica>Select[{4, 5, Pi, 2, 1.3, 7, 6, 8.0}, Mod[#, 2] == 0 &]</lang>
gives:
<lang Mathematica>{4, 2, 6, 8.}</lang>
notice that the function returns 8. not 8 (the dot indicates that it is a float number, not an integer).

== ROT-13 ==
<lang Mathematica>charslower="abcdefghijklmnopqrstuvwxyz"//Characters;
charsupper="ABCDEFGHIJKLMNOPQRSTUVWXYZ"//Characters;
ruleslower=Rule@@@({charslower,RotateLeft[charslower,13]} // Transpose);
rulesupper=Rule@@@({charsupper,RotateLeft[charsupper,13]} // Transpose);
rules=Join[ruleslower,rulesupper];
text="Hello World! Are you there!?"
text=StringReplace[text,rules]
text=StringReplace[text,rules]</lang>
gives back:
<lang Mathematica>Hello World! Are you there!?
Uryyb Jbeyq! Ner lbh gurer!?
Hello World! Are you there!?</lang>

== Roman Form ==
Define a custom function that works on positive numbers (RomanForm[0] will not be evaluated):
<lang Mathematica>RomanForm[i_Integer?Positive] :=
Module[{num = i, string = "", value, letters, digits},
digits = {{1000, "M"}, {900, "CM"}, {500, "D"}, {400, "CD"}, {100,
"C"}, {90, "XC"}, {50, "L"}, {40, "XL"}, {10, "X"}, {9,
"IX"}, {5, "V"}, {4, "IV"}, {1, "I"}};
While[num > 0, {value, letters} =
Which @@ Flatten[{num >= #[[1]], ##} & /@ digits, 1];
num -= value;
string = string <> letters;];
string]</lang>
Examples:
<lang Mathematica>RomanForm[4]
RomanForm[99]
RomanForm[1337]
RomanForm[1666]
RomanForm[6889]</lang>
gives back:
<lang Mathematica>IV
XCIX
MCCCXXXVII
MDCLXVI
MMMMMMDCCCLXXXIX</lang>


== Happy Numbers ==
Custom function HappyQ:
<lang Mathematica>AddSumSquare[input_]:=Append[input,Total[IntegerDigits[Last[input]]^2]]
NestUntilRepeat[a_,f_]:=NestWhile[f,{a},!MemberQ[Most[Last[{##}]],Last[Last[{##}]]]&,All]
HappyQ[a_]:=Last[NestUntilRepeat[a,AddSumSquare]]==1</lang>
Examples for a specific number:
<lang Mathematica>HappyQ[1337]
HappyQ[137]</lang>
gives back:
<lang Mathematica>True
False</lang>
Example finding the first 8:
<lang Mathematica>m = 8;
n = 1;
i = 0;
happynumbers = {};
While[n <= m,
i++;
If[HappyQ[i],
n++;
AppendTo[happynumbers, i]
]
]
happynumbers</lang>
gives back:
<lang Mathematica>{1, 7, 10, 13, 19, 23, 28, 31}</lang>

Latest revision as of 18:29, 4 February 2010

Retrieved from "https://rosettacode.org/wiki/User_talk:VHF?oldid=138041"