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


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


(* :Author: Paul Wellin *)


(* :Summary: This package contains the functions defined in Chapter 6 Programs *)


(* :Context: EPM`Programs` *)


(* :Package Version: 1.0 *)


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


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


(* :Keywords: amino acid, bond percolation, residues, lag plots, lucky numbers, perfect numbers, radius of gyration, random graphs, Smith numbers, stem plots, truth tables *)


(* :Source: Programs.nb *)


(* :Mathematica Version: 10.3 *)


(* Tested in Mathematica 11.1 *)


Remove[Amino,BondPercolation,ColorResidues,ColorScheme,FindPercolationPath,LagPlot,LuckyNumbers,MultiplyCount,NearTo,PerfectSearch,PerfectSearchParallel,RadiusOfGyrationTensor,RandomGraphGnp,SmithNumberQ,StemPlot,ToEdges,TruthTable]


(* BeginPackage["EPM`Programs`"] *)


Amino::usage="Amino is a scheme used with the option ColorScheme in the ColorResidues function.";


BondPercolation::usage="BondPercolation[{\!\(\*
StyleBox[\"m\", \"TI\"]\),\!\(\*
StyleBox[\"n\", \"TI\"]\)},\!\(\*
StyleBox[\"prob\", \"TI\"]\)] simulates a bond percolation on an \!\(\*
StyleBox[\"m\", \"TI\"]\)\[Cross]\!\(\*
StyleBox[\"n\", \"TI\"]\) rectangular lattice using 0<\!\(\*
StyleBox[\"prob\", \"TI\"]\)<1 as the probability of a bond forming between a site and its neighbors.";


BondPercolation::baddims="The arguments `1` and `2`, giving the grid dimensions, should be positive integers.";


ColorResidues::usage="ColorResidues[\!\(\*
StyleBox[\"seq\", \"TI\"]\)] displays a sequence of amino acids from the protein sequence \!\(\*
StyleBox[\"seq\", \"TI\"]\).";


ColorScheme::usage="ColorScheme is an option to ColorResidues that specifies the colors used for each amino acid.";


FindPercolationPath::usage="FindPercolationPath[\!\(\*
StyleBox[\"gr\", \"TI\"]\),{\!\(\*
StyleBox[\"dimx\", \"TI\"]\),\!\(\*
StyleBox[\"dimy\", \"TI\"]\)}] returns a connected path (if it exists) for the graph \!\(\*
StyleBox[\"gr\", \"TI\"]\) of dimension \!\(\*
StyleBox[\"dimx\", \"TI\"]\)\[Cross]\!\(\*
StyleBox[\"dimy\", \"TI\"]\).";


LagPlot::usage="LagPlot[\!\(\*
StyleBox[\"data\", \"TI\"]\), \!\(\*
StyleBox[\"lag\", \"TI\"]\)] returns a lag plot of \!\(\*
StyleBox[\"data\", \"TI\"]\).";


LuckyNumbers::usage="LuckyNumber[\!\(\*
StyleBox[\"n\", \"TI\"]\)] returns a list of the lucky numbers less than \!\(\*
StyleBox[\"n\", \"TI\"]\).";


MultiplyCount::usage="MultiplyCount[\!\(\*
StyleBox[\"poly\", \"TI\"]\)] computes the number of explicit multiplications in the arithmetic expression \!\(\*
StyleBox[\"poly\", \"TI\"]\).\nMultiplyCount[\!\(\*
StyleBox[\"poly\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"var\", \"TI\"]\)] computes the number of explicit multiplications in the polynomial \!\(\*
StyleBox[\"poly\", \"TI\"]\) in the independent variable \!\(\*
StyleBox[\"var\", \"TI\"]\).";


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


RadiusOfGyrationTensor::usage="RadiusOfGyrationTensor[\!\(\*
StyleBox[\"lis\", \"TI\"]\)] computes the radius of gyration tensor of the numerical list \!\(\*
StyleBox[\"lis\", \"TI\"]\).";


RadiusOfGyrationTensor::badarg="The argument to RadiusOfGyrationTensor should be a list of the form {{\!\(\*SubscriptBox[\(x\), \(1\)]\),\!\(\*SubscriptBox[\(y\), \(1\)]\)},{\!\(\*SubscriptBox[\(x\), \(2\)]\),\!\(\*SubscriptBox[\(y\), \(2\)]\)},\[Ellipsis]}.";


RandomGraphGnp::usage="RandomGraphGnp[\!\(\*
StyleBox[\"n\", \"TI\"]\)\!\(\*
StyleBox[\",\", \"TI\"]\)\!\(\*
StyleBox[\" \", \"TI\"]\)\!\(\*
StyleBox[\"p\", \"TI\"]\)] creates a random graph on \!\(\*
StyleBox[\"n\", \"TI\"]\) vertices with probability \!\(\*
StyleBox[\"p\", \"TI\"]\) of an edge being included.";


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


ToEdges::usage="ToEdges[\!\(\*
StyleBox[\"lis\", \"TI\"]\)] converts the list of pairs, \!\(\*
StyleBox[\"lis\", \"TI\"]\), to a list of directed edges of a 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\"]\).";


Options[ColorResidues]=Join[{ColorScheme->Amino},Options[Framed]];


Options[RandomGraphGnp]=Options[Graph];


Options[StemPlot]=Options[ListPlot];


Options[ToEdges]={DirectedEdges->True};


Begin["`Private`"];


Amino={{"P",RGBColor[Rational[44, 51], Rational[10, 17], Rational[26, 51]]},{"W",RGBColor[Rational[12, 17], Rational[6, 17], Rational[12, 17]]},{"L",RGBColor[Rational[1, 17], Rational[26, 51], Rational[1, 17]]},{"V",RGBColor[Rational[1, 17], Rational[26, 51], Rational[1, 17]]},{"I",RGBColor[Rational[1, 17], Rational[26, 51], Rational[1, 17]]},{"N",RGBColor[0, Rational[44, 51], Rational[44, 51]]},{"Q",RGBColor[0, Rational[44, 51], Rational[44, 51]]},{"S",RGBColor[Rational[50, 51], Rational[10, 17], 0]},{"T",RGBColor[Rational[50, 51], Rational[10, 17], 0]},{"C",RGBColor[Rational[46, 51], Rational[46, 51], 0]},{"M",RGBColor[Rational[46, 51], Rational[46, 51], 0]},{"H",RGBColor[Rational[26, 51], Rational[26, 51], Rational[14, 17]]},{"A",RGBColor[Rational[40, 51], Rational[40, 51], Rational[40, 51]]},{"G",RGBColor[Rational[47, 51], Rational[47, 51], Rational[47, 51]]},{"F",RGBColor[Rational[10, 51], Rational[10, 51], Rational[2, 3]]},{"Y",RGBColor[Rational[10, 51], Rational[10, 51], Rational[2, 3]]},{"K",RGBColor[Rational[4, 51], Rational[6, 17], 1]},{"R",RGBColor[Rational[4, 51], Rational[6, 17], 1]},{"D",RGBColor[Rational[46, 51], Rational[2, 51], Rational[2, 51]]},{"E",RGBColor[Rational[46, 51], Rational[2, 51], Rational[2, 51]]}};


makeAAbox[scheme_,opts:OptionsPattern[]]:=Module[{aa,col},
{aa,col}=Transpose[Amino];MapThread[#1:>Framed[#1,opts,Background->#2,FrameStyle->#2]&,{aa,col}]]


BondPercolation[{m_,n_},prob_,opts:OptionsPattern[]]:=Module[{gr},
If[!(IntegerQ[m]&&IntegerQ[n]),
Message[BondPercolation::baddims,m,n],
gr=GridGraph[{m,n}];Graph[Pick[EdgeList[gr],RandomVariate[BernoulliDistribution[prob],EdgeCount[gr]],1],opts]
]]


ColorResidues[str_String,opts:OptionsPattern[]]:=Module[{},
Row[Characters[str]/.makeAAbox[Amino,FilterRules[{opts},Options[Framed]]]]]


FindPercolationPath[gr_,{dimx_,dimy_}]:=Module[{vert,bot,top},
vert=Intersection[VertexList[gr],VertexList[GridGraph[{dimx,dimy}]]];
bot=Select[vert,Mod[#,dimx]==1&];
top=Select[vert,Mod[#,dimx]==0&];
Flatten[Outer[FindPath[gr,#1,#2]&,top,bot],2]
]


LagPlot[data_,lag_:1,opts:OptionsPattern[ListPlot]]:=ListPlot[Transpose[{Drop[data,lag],Drop[data,-lag]}],opts]


LuckyNumbers[n_Integer?Positive]:=Module[{p,i=2,ints=Range[1,n,2]},
While[ints[[i]]<Length[ints],
p=ints[[i]];
ints=Drop[ints,p;;-1;;p];
i++];
ints]


MultiplyCount[expr_?PolynomialQ]:=Total@Cases[{expr},Power[_,exp_]:>exp-1,Infinity]+Total@Cases[{expr},fac_Times:>Length[fac]-1,Infinity]


MultiplyCount[expr_,var_]:=If[PolynomialQ[expr,var],Total@Cases[{expr},Power[_,exp_]:>exp-1,Infinity]+Total@Cases[{expr},fac_Times:>Length[fac]-1,Infinity],Message[MultiplyCount::poly,expr]]


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


RadiusOfGyrationTensor[lis_]:=Module[{xy,vx,vy},
If[Not@MatchQ[lis,{{_,_}..}],
Message[RadiusOfGyrationTensor::badarg],
xy=Dot@@(Transpose[lis]-Mean[lis])/Length[lis];
{vx,vy}=CentralMoment[lis,2];
{{vx,xy},{xy,vy}}
]]


RandomGraphGnp[n_,p_,opts:OptionsPattern[]]:=Module[{cg=CompleteGraph[n],probs},
probs=RandomChoice[{p,1-p}->{True,False},EdgeCount[cg]];
Graph[Pick[EdgeRules[cg],probs],opts,DirectedEdges->False]]


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}..}|{__?NumericQ}],
ListPlot[lis,opts,Filling->Axis],
Message[StemPlot::badarg]
]


ToEdges[lis:{{_,_}..},OptionsPattern[]]:=If[OptionValue[DirectedEdges],DirectedEdge@@@lis,UndirectedEdge@@@lis]


ToEdges[lis:{_,_},OptionsPattern[]]:=If[OptionValue[DirectedEdges],DirectedEdge@@lis,UndirectedEdge@@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,GrayLevel[0.5]}},{1->{Thin,Black},2->{Thin,GrayLevel[0.5]},-1->{Thin,Black}}},
BaseStyle->{"SRSmall"},Spacings->{1, .8}]]


(* using BooleanTable *)
(*
truthTable[expr_]:=Module[{head,vars=BooleanVariables[expr]},
head=Append[vars,expr];Grid[Prepend[BooleanTable[Flatten[{vars,expr}],vars]/.{True\[Rule]"T",False\[Rule]"F"},head],
Dividers\[Rule]{{1\[Rule]{Thin,Black},-1\[Rule]{Thin,Black},-2\[Rule]{Thin,GrayLevel[0.5]}},{1\[Rule]{Thin,Black},2\[Rule]{Thin,GrayLevel[0.5]},-1\[Rule]{Thin,Black}}},
BaseStyle\[Rule]{"SRSmall"},Spacings\[Rule]{Scaled[.025],Scaled[.015]},Background\[Rule]{None,{LightGray,{None,LightBlue}}}]]
*)


End[];


(*EndPackage[]*)



