(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



(* :Name: EPM`Functions` *)


(* :Book: Essentials of Programming in Mathematica *)


(* :Author: Paul Wellin *)


(* :Summary: This package contains the functions defined in Chapter 5 Functional programming. *)


(* :Context: EPM`Functions` *)


(* :Package Version: 1.0 *)


(* :Copyright: Copyright 2015, Paul R Wellin *)


(* :History: Version 1.0 by Paul Wellin, Dec 2012 *)


(* :Keywords: adjacency structure, binary matrics, Brownian sound, Collatz sequence, digit root, Eulerian numbers, attributes, options, Hamming distance, Horner polynomials, Horner form, Jacobian matrix, nilpotent matrix, point set diameter, perfect numbers, prime numbers, regular polygons, rep units, Sierpinski triangle, Smarandache-Wellin numbers, triangle medians, Vandermonde matrix, vertex neighbors *)


(* :Source: Functions.nb *)


(* :Mathematica Version: 10.3 *)


(* Tested in Mathematica 11.1 *)


Remove[AdjacencyStructure,BinaryMatrix,BrownianSoundList,EPM`Collatz`CollatzSequence,DigitRoot,EulerianNumber,FunctionsWithAttribute,HammingDistance1,HammingDistance2,HammingDistance3,HammingDistance4,HammingDistance5,HammingNumberList,HammingNumber,HornerPolynomial,JacobianMatrix,NilpotentMatrixQ,PerfectQ,PointsetDiameter,PrimeFactorForm,PrimesLessThan,RandomNote,Regular2Graph,RepUnit,ReplaceElement,SierpinskiTriangle,SmarandacheWellin,TriangleMedians,UpperTriangularMatrix,VandermondeMatrix,VertexNeighbors]


(* BeginPackage["EPM`Functions`"]; *)


AdjacencyStructure::usage="AdjacencyStructure[\!\(\*
StyleBox[\"gr\", \"TI\"]\)] returns the adjacency lists for each vertex in the graph \!\(\*
StyleBox[\"gr\", \"TI\"]\).";


BinaryMatrix::usage="BinaryMatrix[\!\(\*
StyleBox[\"n\", \"TI\"]\)] enumerates all \!\(\*FormBox[
StyleBox[
RowBox[{\"n\", 
StyleBox[\"\[Cross]\",\nFontSlant->\"Plain\"], \"n\"}], \"TI\"],
TraditionalForm]\) binary matrices.";


BrownianSoundList::usage="BrownianSoundList[] generates and plays one note randomly chosen from the 12 semitones of the C major scale.\nBrownianSoundList[\!\(\*
StyleBox[\"n\", \"TI\"]\), \!\(\*
StyleBox[\"instr\", \"TI\"]\)] generates and plays a sequence of \!\(\*
StyleBox[\"n\", \"TI\"]\) notes randomly chosen from among the 12 semitones of the C major scale, using the Midi instrument \!\(\*
StyleBox[\"instr\", \"TI\"]\). The distance between notes is also randomized, essentially performing a random walk through the C major scale.";


CollatzSequence::usage="CollatzSequence[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns the list of numbers in the Collatz sequence of \!\(\*
StyleBox[\"n\", \"TI\"]\).";


DigitRoot::usage="DigitRoot[\!\(\*
StyleBox[\"n\", \"TI\"]\)] iterates the digit sum of n until the resulting number has only one digit.";


EulerianNumber::usage="EulerianNumber[\!\(\*
StyleBox[\"n\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"k\", \"TI\"]\)] returns the the number of permutations of the set {1,2,3,\[Ellipsis],\!\(\*
StyleBox[\"n\", \"TI\"]\)} with \!\(\*
StyleBox[\"k\", \"TI\"]\) increasing runs of elements.";


FunctionsWithAttribute::usage="FunctionsWithAttribute[\!\(\*
StyleBox[\"attr\", \"TI\"]\)] returns a list of all symbols in the System` context that have the attribute \!\(\*
StyleBox[\"attr\", \"TI\"]\).";


FunctionsWithOption::usage="FunctionsWithOption[\!\(\*
StyleBox[\"opt\", \"TI\"]\)] returns a list of all symbols in the System` context that have the option \!\(\*
StyleBox[\"opt\", \"TI\"]\).";


HammingDistance1::usage="HammingDistance1[\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\),\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\)] computes the Hamming distance of the two binary signals \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\) and \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\) using Count[MapThread[SameQ[\[Ellipsis]]]].";


HammingDistance2::usage="HammingDistance2[\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\),\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\)] computes the Hamming distance of the two binary signals \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\) and \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\) using Total[BitXor[\[Ellipsis]]].";


HammingDistance3::usage="HammingDistance3[\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\),\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\)] computes the Hamming distance of the two binary signals \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\) and \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\) using Length[Select[\[Ellipsis],Mod[#,2]==1&]].";


HammingDistance4::usage="HammingDistance4[\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\),\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\)] computes the Hamming distance of the two binary signals \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\) and \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\) using Length[Select[\[Ellipsis],OddQ]].";


HammingDistance5::usage="HammingDistance5[\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\),\!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\)] computes the Hamming distance of the two binary signals \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(1\)]\) and \!\(\*SubscriptBox[
StyleBox[\"sig\", \"TI\"], \(2\)]\) using Length[Cases[Transpose[\[Ellipsis]],{p_,q_}/;p\[NotEqual]q]].";


HammingNumber::usage="HammingNumber[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns the \*
StyleBox[\(\!\(\*
StyleBox[\"n\", \"TI\"]\)th\)] Hamming number. Hamming numbers are defined as numbers that divide powers of 60.";


HammingNumberList::usage="HammingNumberList[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns the first \!\(\*
StyleBox[\"n\", \"TI\"]\) Hamming numbers.";


HornerPolynomial::usage="HornerPolynomial[\!\(\*
StyleBox[\"lis\", \"TI\"]\),\!\(\*
StyleBox[\"var\", \"TI\"]\)] gives the Horner normal form of the polynomial formed by the list \!\(\*
StyleBox[\"lis\", \"TI\"]\) in the variable \!\(\*
StyleBox[\"var\", \"TI\"]\).";


JacobianMatrix::usage="JacobianMatrix[\!\(\*
StyleBox[\"vecs\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"vars\", \"TI\"]\)] returns the Jacobian matrix of the list \!\(\*
StyleBox[\"vecs\", \"TI\"]\) differentiated with respect to the list of variables \!\(\*
StyleBox[\"vars\", \"TI\"]\).";


NilpotentMatrixQ::usage="NilpotentMatrixQ[\!\(\*
StyleBox[\"mat\", \"TI\"]\)] returns True if the matrix \!\(\*
StyleBox[\"mat\", \"TI\"]\) is a square matrix all of whose eigenvalues are zero.";


PointsetDiameter::usage="PointsetDiameter[\!\(\*
StyleBox[\"pts\", \"TI\"]\)] computes the maximum distance between any pair of points in the list of points, \!\(\*
StyleBox[\"pts\", \"TI\"]\).";


PerfectQ::usage="PerfectQ[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns True if \!\(\*
StyleBox[\"n\", \"TI\"]\) is a perfect number; i.e., if \!\(\*
StyleBox[\"n\", \"TI\"]\) is equal to the sum of its proper divisors.";


PrimeFactorForm::usage="PrimeFactorForm[\!\(\*
StyleBox[\"n\", \"TI\"]\)] formats the prime factorization of the integer \!\(\*
StyleBox[\"n\", \"TI\"]\) in a traditional form.";


PrimesLessThan::usage="PrimesLessThan[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns the number of prime numbers less than \!\(\*
StyleBox[\"n\", \"TI\"]\).";


RandomNote::usage="RandomNote[] generates and plays one note randomly chosen from the 12 semitones of the C major scale.\nRandomNote[\!\(\*
StyleBox[\"n\", \"TI\"]\), \!\(\*
StyleBox[\"instr\", \"TI\"]\)] generates and plays a sequence of \!\(\*
StyleBox[\"n\", \"TI\"]\) notes randomly chosen from among the 12 semitones of the C major scale, using the Midi instrument \!\(\*
StyleBox[\"instr\", \"TI\"]\). It also randomizes the durations of the notes.";


Regular2Graph::usage="Regular2Graph[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns a graph with \!\(\*
StyleBox[\"n\", \"TI\"]\) equilateral edges and all of whose internal angles are equiangular.";


RepUnit::usage="RepUnit[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns a number consisting the digit 1 concatenated \!\(\*
StyleBox[\"n\", \"TI\"]\) times.";


ReplaceElement::usage="ReplaceElement[\!\(\*
StyleBox[\"mat\", \"TI\"]\), \!\(\*
StyleBox[\"lis\", \"TI\"]\)] returns the matrix \!\(\*
StyleBox[\"mat\", \"TI\"]\) with elements that are strings specified by \!\(\*
StyleBox[\"lis\", \"TI\"]\) replaced with their column mean.";


SierpinskiTriangle::usage="SierpinskiTriangle[\!\(\*
StyleBox[\"n\", \"TI\"]\)] displays a Sierpinski triangle after \!\(\*
StyleBox[\"n\", \"TI\"]\) iterations of the geometric transformations that define it. SierpinskiTriangle takes the same options as Graphics.";


SmarandacheWellin::usage="SmarandacheWellin[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns the \*
StyleBox[\(\!\(\*
StyleBox[\"n\", \"TI\"]\)th\)] Smarandache-Wellin number formed by concatenating the digits of successive primes.";


TriangleMedians::usage="TriangleMedians[Triangle[{\!\(\*SubscriptBox[
StyleBox[\"p\", \"TI\"], \(1\)]\),\!\(\*SubscriptBox[
StyleBox[\"p\", \"TI\"], \(2\)]\),\!\(\*SubscriptBox[
StyleBox[\"p\", \"TI\"], \(3\)]\)]] takes a Triangle region as argument and returns the three medians (as Line objects) of the triangle.";


UpperTriangularMatrix::usage="UpperTriangularMatrix[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns a square matrix of size \!\(\*
StyleBox[\"n\", \"TI\"]\) with zeros below the diagonal and ones on and above the diagonal.";


VandermondeMatrix::usage="VandermondeMatrix[\!\(\*
StyleBox[\"n\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"var\", \"TI\"]\)] returns the Vandermonde matrix of order \!\(\*
StyleBox[\"n\", \"TI\"]\) in the variable \!\(\*
StyleBox[\"var\", \"TI\"]\).";


VertexNeighbors::usage="VertexNeighbors[\!\(\*
StyleBox[\"gr\", \"TI\"]\),\!\(\*
StyleBox[\"v\", \"TI\"]\),\!\(\*
StyleBox[\"dist\", \"TI\"]\)] finds all those vertices in the graph \!\(\*
StyleBox[\"gr\", \"TI\",\nFontSlant->\"Italic\"]\) that are distance \!\(\*
StyleBox[\"dist\", \"TI\",\nFontSlant->\"Italic\"]\) from the vertex \!\(\*FormBox[
StyleBox[\"v\", \"TI\"],
TraditionalForm]\).";


Options[BrownianSoundList]={Weights->Automatic};


Options[Regular2Graph]=Options[Graph];


Begin["`Private`"];


adjacencyList[gr_,u_]:=If[DirectedGraphQ[gr],Select[VertexList[gr],EdgeQ[gr,DirectedEdge[u,#]]&],Select[VertexList[gr],EdgeQ[gr,UndirectedEdge[u,#]]&]
]


AdjacencyStructure[gr_Graph]:=Map[{#,AdjacencyList[gr,#]}&,VertexList[gr]]


BinaryMatrix[n_Integer?Positive]:=Table[Partition[IntegerDigits[i,2,n^2],n],{i,0,2^n^2-1}]


BrownianSoundList[steps_Integer,instr_:"Vibraphone",OptionsPattern[]]:=Module[{walk,durs,weights},
weights=If[OptionValue[Weights]===Automatic,Table[1/9,{9}],OptionValue[Weights]];
walk[n_]:=Accumulate[RandomChoice[weights->Range[-4,4],n]];
durs=RandomChoice[Range[1/16,1,1/16],{steps}];
Sound@MapThread[SoundNote[#1,#2,instr]&,{walk[steps],durs}]
]


BrownianSoundList[]:=BrownianSoundList[1,"Vibraphone"]


CollatzSequence[n_]:=NestWhileList[If[EvenQ[#],#/2,3#+1]&,n,#!=1&]


DigitRoot[n_Integer?Positive]:=Module[{locn=n,lis},
While[
Length[lis=IntegerDigits@locn]>1,
locn=Total[lis]];
locn]


EulerianNumber[0,k_]=0;
EulerianNumber[n_Integer,0]=1;
EulerianNumber[n_Integer,k_Integer]/;k>=n=0;


EulerianNumber[n_Integer,k_Integer]:=Block[{$RecursionLimit=Infinity},
EulerianNumber[n,k]=(k+1)EulerianNumber[n-1,k]+(n-k)EulerianNumber[n-1,k-1]]


FunctionsWithAttribute[attrib_Symbol]:=Select[Names["System`*"],MemberQ[Attributes[#],attrib]&]


FunctionsWithOption[opt_Symbol]:=Module[{names,lis},
names=Complement[Names["System`*"],Names["System`$*"]];
lis=DeleteCases[names,f_/;Options[Symbol[f]]==={}];
Select[lis,MemberQ[Options[Symbol[#]],opt,2]&]]


HammingDistance1[lis1_,lis2_]:=
Count[MapThread[SameQ,{lis1,lis2}],False]


HammingDistance2[lis1_,lis2_]:=Total[BitXor[lis1,lis2]]


HammingDistance3[lis1_,lis2_]:=Length[Select[lis1+lis2,(Mod[#,2]==1&)]]


HammingDistance4[lis1_,lis2_]:=
Length[Select[lis1+lis2,OddQ]]


HammingDistance5[lis1_List,lis2_List]:=
Length[Cases[Transpose[{lis1,lis2}],{p_,q_}/;p!=q]]


HammingNumberList[n_]:=Module[{lim},
lim=If[n<100,Ceiling[Log2[n]],Ceiling[Log2[n/(2 3 5)] Log2[n]]];Join[{1},Take[Union@@NestList[Union@@Outer[Times,{2,3,5},#]&,{2,3,5},lim],n-1]
]]


HammingNumber[n_]:=Part[HammingNumberList[n],n]


HornerPolynomial[list_List,var_]:=Fold[var #1+#2&,0,list]


JacobianMatrix[vec_List,vars_List]:=Outer[D,vec,vars]/;Dimensions[vec]==Dimensions[vars]


NilpotentMatrixQ[mat_?SquareMatrixQ]:=AllTrue[Eigenvalues[mat],(#==0||#==0.0)&]


PerfectQ[n_]:=DivisorSigma[1,n]==2n


PointsetDiameter[pts_List]:=Max[Apply[EuclideanDistance,Subsets[pts,{2}],{1}]]


PrimeFactorForm[p_?PrimePowerQ]:=With[{fp=FactorInteger[p]},
Interpretation[
First[Superscript@@@FactorInteger[p]],
Times@@(Power@@@fp)]]


PrimeFactorForm[p_Integer]:=With[{fp=FactorInteger[p]},
Interpretation[
CenterDot@@(Superscript@@@fp),
Times@@(Power@@@fp)]]


PrimesLessThan[n_Integer]:=Table[Prime[p],{p,PrimePi[n]}]


RandomNote[n_Integer,instrument_:"Piano"]:=With[{notes=Join[{None},Range[0,11]],durations=Range[1/8,1,1/8]},Sound[{instrument,MapThread[SoundNote[#1,#2]&,{RandomChoice[notes,n],RandomChoice[durations,n]}]}]]


RandomNote[]:=RandomNote[1,"Piano"]


Regular2Graph[n_Integer,opts:OptionsPattern[]]:=
With[{lis=Range[n]},
Graph[
MapThread[UndirectedEdge,{lis,RotateLeft[lis]}],
opts,
VertexSize->0.05,EdgeStyle->Thick]
]


RepUnit[n_]:=Nest[(10 #+1)&,1,n-1]


colMean[col_,str_String]:=col/.str:>Mean[Cases[col,_?NumberQ]]


ReplaceElement[mat_,str_String]:=Transpose[Map[colMean[#,str]&,Transpose[mat]]]


SierpinskiTriangle[iter_,opts:OptionsPattern[Graphics]]:=Module[{vertices,vecs},
vertices=N[{{0,0},{1,0},{1/2,1}}];
vecs=0.5vertices;
Graphics[{Blue,Nest[{Blue,Translate[Scale[#,0.5,{0.,0.}],vecs]}&,Polygon[vertices],iter]},opts]]


SmarandacheWellin[n_Integer?Positive]:=FromDigits[Flatten[IntegerDigits@Table[Prime[i],{i,n}]]]


TriangleMedians[Triangle[{p1_,p2_,p3_}]]:=Module[{midpoint,midpts},
midpoint[{pt1_,pt2_}]:=(pt1+pt2)/2;
midpts=Map[midpoint,Subsets[{p1,p2,p3},{2}]];
MapThread[Line[{#1,#2}]&,{{p3,p2,p1},midpts}]
]


UpperTriangularMatrix[n_,val_:1]:=Table[If[i>=j,0,val],{i,n},{j,n}]


VandermondeMatrix[n_Integer/;n>1,x_]:=
Outer[Power,Table[Subscript[x, i],{i,1,n}],Range[0,n-1]]


VertexNeighbors[gr_,v_,dist_]:=VertexList[gr,_?(GraphDistance[gr,v,#]==dist&)]


End[];


(*EndPackage[]*)



