(* ::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: PwM`Chap05Functional` *)


(* :Book: Programming with Mathematica: An Introduction *)


(* :Author: Paul Wellin *)


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


(* :Context: PwM`Chap05Functional` *)


(* :Package Version: 1.0 *)


(* :Copyright: Copyright 2012, Cambridge University Press *)


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


(* :Keywords: adjacency structure, composite number, attributes, options, Hamming distance, perfect numbers, pointset diameter, regular graph, random colors, rep unit, Smith numbers, Sierpinski triangle, stem plot, truth table, upper triangular matrix, Vandermonde matrix *)


(* :Source: Chap05Functional.nb *)


(* :Mathematica Version: 8.0.4 *)


Remove[PerfectSearch,TruthTable,CompositeQ,UpperTriangularMatrix]


BeginPackage["PwM`Chap05Functional`"];


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


CompositeQ::usage="CompositeQ[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns True if \!\(\*
StyleBox[\"n\", \"TI\"]\)\*
StyleBox[\(\!\(\*
StyleBox[\" \", \"TI\"]\) \)]is a composite number.";


CompositeQ::badarg="Argument `1` in CompositeQ[`1`] is not an integer greater than 1.";


ExpandFactors::usage="ExpandFactors[\!\(\*
StyleBox[\"lis\", \"TI\"]\)] expands a list of factors, \!\(\*
StyleBox[\"lis\", \"TI\"]\), of an integer as given by FactorInteger and returns the explicit number.";


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.";


NearTo::usage="NearTo[\!\(\*
StyleBox[\"lis\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"elem\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns those elements in \!\(\*
StyleBox[\"lis\", \"TI\"]\) that are \!\(\*
StyleBox[\"n\", \"TI\"]\) positions from \!\(\*
StyleBox[\"elem\", \"TI\"]\)\!\(\*
StyleBox[\".\", \"TI\"]\)\nNearTo[\!\(\*
StyleBox[\"lis\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"elem\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"{\", \"TI\"]\)\!\(\*
StyleBox[\"n\", \"TI\"]\)\!\(\*
StyleBox[\"}\", \"TI\"]\)] returns those elements in \!\(\*
StyleBox[\"lis\", \"TI\"]\) that are less than or equal to \!\(\*
StyleBox[\"n\", \"TI\"]\) positions away from \!\(\*
StyleBox[\"elem\", \"TI\"]\).";


PerfectSearch::usage="PerfectSearch[\!\(\*
StyleBox[\"n\", \"TI\"]\),\!\(\*
StyleBox[\"m\", \"TI\"]\)] returns a list of all those perfect numbers (numbers that are equal to the sum of their proper divisors) between \!\(\*
StyleBox[\"n\", \"TI\"]\) and \!\(\*
StyleBox[\"m\", \"TI\"]\).\nPerfectSearch[\!\(\*
StyleBox[\"n\", \"TI\"]\),\!\(\*
StyleBox[\"m\", \"TI\"]\),\!\(\*
StyleBox[\"k\", \"TI\"]\)] returns a list of all those perfect numbers between \!\(\*
StyleBox[\"n\", \"TI\"]\) and \!\(\*
StyleBox[\"m\", \"TI\"]\), searching by increment \!\(\*
StyleBox[\"k\", \"TI\"]\).";


PerfectSearchParallel::usage="PerfectSearchParallel[\!\(\*
StyleBox[\"n\", \"TI\"]\),\!\(\*
StyleBox[\"m\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"k\", \"TI\"]\)] searches for \!\(\*
StyleBox[\"k\", \"TI\"]\)-perfect numbers between \!\(\*
StyleBox[\"n\", \"TI\"]\) and \!\(\*
StyleBox[\"m\", \"TI\"]\) performing the search in parallel. If no subkernels are available, the search is performed on a single kernel.";


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


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


RandomColor::usage="RandomColor[] returns an RGBColor expression with random values for the red, green, and blue components.\nRandomColor[\!\(\*
StyleBox[\"n\", \"TI\"]\)] return a list of \!\(\*
StyleBox[\"n\", \"TI\"]\) random colors.";


RegularGraph::usage="RegularGraph[\!\(\*
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.";


SmithNumberQ::usage="SmithNumberQ[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns if \!\(\*
StyleBox[\"n\", \"TI\"]\) is a Smith number \[Dash] a composite number the sum of whose digits is equal to the sum of the digits of its prime factors.";


StemPlot::usage="StemPlot[\!\(\*
StyleBox[\"data\", \"TI\"]\)] returns a stem plot of the discrete data, \!\(\*
StyleBox[\"data\", \"TI\"]\).";


StemPlot::badarg="The first argument to StemPlot must be a list of numbers.";


ToGraph::usage="ToGraph[\!\(\*
StyleBox[\"lis\", \"TI\"]\)] converts the list of pairs, \!\(\*
StyleBox[\"lis\", \"TI\"]\), to a directed graph.";


TruthTable::usage="TruthTable[\!\(\*
StyleBox[\"expr\", \"TI\"]\), \!\(\*
StyleBox[\"vars\", \"TI\"]\)] returns a table of truth values for the logical expression \!\(\*
StyleBox[\"expr\", \"TI\"]\) in the variables \!\(\*
StyleBox[\"vars\", \"TI\"]\).";


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\"]\).";


Options[StemPlot]=Options[ListPlot];


Options[RegularGraph]=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]]


CompositeQ[n_Integer/;n>1]:=Not[PrimeQ[n]]


CompositeQ[n_]/;If[TrueQ[Head[n]==Integer&&n>1],True,Message[CompositeQ::badarg,n];False]:=Not@PrimeQ[n]


ExpandFactors[lis_]:=Apply[Times,Apply[Power,lis,{1}]]


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


FunctionsWithOption[opt_Symbol]:=Quiet[Select[Names["System`*"],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]


NearTo[lis_List,elem_,n_]:=Module[{pos=Position[lis,elem]},Extract[lis,{pos-n,pos+n}]]


NearTo[lis_List,elem_,{n_}]:=Module[{pos=Position[lis,elem]},Extract[lis,Range[pos-n,pos+n]]]


PerfectSearch[n_,m_]:=Module[{perfectQ},
perfectQ[j_]:=DivisorSigma[1,j]==2 j;
Select[Range[n,m,2],perfectQ]]


PerfectSearch[n_,m_,k_]:=Module[{perfectQ},
perfectQ[j_]:=DivisorSigma[1,j]==k j;
Select[Range[n,m],perfectQ]]


PerfectSearchParallel[n_,m_,k_]:=Module[{perfectQ},perfectQ[j_]:=DivisorSigma[1,j]==k j;
DistributeDefinitions[perfectQ];
Parallelize[Select[Range[n,m,2],perfectQ]]]


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


RandomColor[]:=Apply[RGBColor,RandomReal[1,{3}]]


RandomColor[n_Integer?Positive]:=Apply[RGBColor,RandomReal[1,{n,3}],{1}]


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


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


colMean[mat_,col_,{strings___String}]:=mat[[All,col]]/.Apply[Alternatives,{strings}]->Mean[Cases[mat[[All,col]],_?NumberQ]]


ReplaceElement[mat_,{strings__}]:=
Transpose[Map[colMean[#,{strings}]&,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]]


SmithNumberQ[n_/;n<=1]:=False


SmithNumberQ[n_?PrimeQ]:=False


SmithNumberQ[n_]:=With[{lis=FactorInteger[n]},
Total[Flatten[MapThread[IntegerDigits[#1]#2&,Transpose[lis]]]]==Total[IntegerDigits[n]]]


StemPlot[lis_,opts:OptionsPattern[]]:=
If[MatchQ[lis,{__?NumericQ}],
ListPlot[lis,opts,Filling->Axis],
Message[StemPlot::badarg]
]


ToGraph[lis:{{_,_}..}]:=DirectedEdge@@@lis


ToGraph[lis:{_,_}]:=DirectedEdge@@lis


TruthTable[expr_,vars_]:=Module[{len=Length[vars],tuples,rules,table,head},
tuples=Tuples[{True,False},len];
rules= Thread[vars->#1]&/@tuples;table=Transpose@Join[Transpose[tuples],{expr/.rules}];head=Append[vars,TraditionalForm[expr]];Grid[Prepend[table/.{True->"T",False->"F"},head],
Dividers->{{1->{Thin,Black},-1->{Thin,Black},-2->{Thin,LightGray}},{1->{Thin,Black},2->{Thin,LightGray},-1->{Thin,Black}}},
BaseStyle->{FontFamily->"Times"}]]


UpperTriangularMatrix[n_Integer?Positive]:=Table[If[j>=i,1,0],{i,n},{j,n}]


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


End[];


EndPackage[]



