%-*- mode: latex-mathematica; fill-column: 200 -*- %---TeX-start-of-header--- \documentclass[titlepage]{article} \usepackage{mathematica,figi, alltt} \mmanobreak \newenvironment{implementation}% {\vspace{-0.4cm}\footnotesize\textbf{Implementation notes: }}{\bigskip} \begin{comment} Simple debug function: \begin{mathematica} pry = (Print[NumberForm[#,2]];#)&; \end{mathematica} \begin{mathematica} <Infinity]; \ zero = 0.00001; \ ohide = DisplayFunction->Identity; \ oshow = DisplayFunction -> $DisplayFunction; \ ojoin = PlotJoined -> True; \ oall = PlotRange->All; \ osurf = HiddenSurface->False; \ deg = N[Degree]; \ pi = N[Pi]; \end{mathematica} \end{comment} \begin{document} \psfiginit %---TeX-end-of-header--- \author{Andrzej G.\ \L{}ozowski\\ Tomasz J.\ Cholewo} \title{Mathematics for Behavioral and Social Sciences, MATH\,585\\[1cm] Optimal Allocation of a Parallel Program\\ Into a Parallel System} \maketitle %==================================================================== \section{Input data} Example 1: \begin{mathematica} procweights = {{0, 1, 0, 1}, {1, 0, 1, 0}, {0, 1, 0, 1}, {1, 0, 1, 0}};\ proccost = {.2, .4, .8, 1};\ sys = {{1, 2}, {2, 3}, {3, 1}}; \end{mathematica} Example 2: \begin{mathematica} procweights = {{0, 1, 0, 0, 0, 1}, {1, 0, 1, 0, 0, 0}, {0, 1, 0, 1, 0, 1}, {0, 0, 1, 0, 1, 0}, {0, 0, 0, 1, 0, 1}, {1, 0, 1, 0, 1, 0}};\ proccost = {1, 2, 6, 7, 10, 10};\ sys = {{1, 2}, {2, 3}, {3, 4}, {4, 1}, {1,3}}; \end{mathematica} \figii{p4s3}{p6s4d}{Process and system graphs: (a)~example~1; (b)~example~2.} Transform to graph representations: \begin{mathematica} procgraph = Graph[procweights, CircularVertices[Length[procweights]]];\ sysgraph = FromUnorderedPairs[sys]; \end{mathematica} Present graphs: \begin{mathematica} PSTeX[Show[ GraphicsArray[{ ShowLabeledGraph@procgraph, ShowLabeledGraph@sysgraph}], AspectRatio->Automatic],""]; \end{mathematica} \newpage \section{Global variables} Graph degrees: \begin{mathematica} Np = V[procgraph];\ Ns = V[sysgraph];\ nstrat = Max[ DegreeSequence[sysgraph] ] + 1; \end{mathematica} List of neighbors: \begin{mathematica} neighb = MapIndexed[ Join[#2, #1, Table[0, {nstrat - Length[#] - 1}] ]&, ToAdjacencyLists[sysgraph] ] . Out[45]= {{1, 2, 3, 4}, {2, 1, 3, 0}, {3, 1, 2, 4}, {4, 1, 3, 0}} \end{mathematica} Minimal distances in the graph: \begin{mathematica} dmin = AllPairsShortestPath[sysgraph] . Out[46]= {{0, 1, 1, 1}, {1, 0, 1, 2}, {1, 1, 0, 1}, {1, 2, 1, 0}} \end{mathematica} List of degrees of the system graph: \begin{mathematica} degr = Length /@ ToAdjacencyLists[sysgraph] . Out[47]= {3, 2, 3, 2} \end{mathematica} \newpage \section{Cost calculation} Construct cost matrix: \begin{mathematica} findcost[cbeta_, cgamma_] := Module[{cost, n1, n2, diag}, cost = Table[ If[ k != l, n1 = neighb[[ alloc[[k]], p ]]; n2 = neighb[[ alloc[[l]], q ]]; If[n1 == 0 || n2 == 0, 0., If[n1 == n2, N[proccost[[k]] + proccost[[l]]], N[procweights[[k, l]]] dmin[[n1, n2]] ] ], 0. ], {k, Np}, {p, nstrat}, {l, Np}, {q, nstrat} ]; diag = Apply[Plus, cost, 4] / ( nstrat^2 degr[[alloc[[ Range[Np] ]] ]]); Do[ cost[[k, p, k, q]] = If[p == q, -cbeta, cgamma] diag[[k]], {k, Np}, {p, nstrat}, {q, nstrat} ]; cost ]; \end{mathematica} Function for presenting cost matrices: \begin{mathematica} showcost[l_List] := Print @ NumberForm[ MatrixForm[l, TableDirections->{Column, Column, Row, Row}, TableSpacing->{1, 0, 1, 0}], 2] \end{mathematica} \newpage Cost matrix: \begin{mathematica} showcost[cost] . -12.12. 12. 12. 3. 1. 1. 0. 0 7. 0 0 0 8. 0 0 0 0 0 0. 1. 1. 11. 2. 12. -12.12. 12. 1. 3. 1. 0. 7. 0 0 0 8. 0 0 0 0 11. 0 0. 1. 11. 1. 1. 12. 12. -12.12. 1. 1. 3. 0. 0 0 7. 0 0 0 8. 0 0 0 11. 0. 11. 1. 1. 1. 12. 12. 12. -12. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 3. 1. 1. 0. -13.13. 13. 13. 1. 8. 1. 2. 0 9. 0 0 0 0 0 0. 0 0 12. 0 1. 3. 1. 0. 13. -13.13. 13. 8. 1. 1. 1. 9. 0 0 0 0 12. 0 0. 0 12. 0 0 1. 1. 3. 0. 13. 13. -13.13. 1. 1. 8. 1. 0 0 9. 0 0 0 12. 0. 12. 0 0 0 0. 0. 0. 0. 13. 13. 13. -13. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0 7. 0 0. 1. 8. 1. 0. -15.15. 15. 15. 13. 1. 1. 1. 0 16. 0 0. 1. 16. 1. 1. 7. 0 0 0. 8. 1. 1. 0. 15. -15.15. 15. 1. 13. 1. 2. 0 0 0 0. 1. 1. 16. 2. 0 0 7. 0. 1. 1. 8. 0. 15. 15. -15.15. 1. 1. 13. 1. 0 0 16. 0. 16. 1. 1. 1. 0 0 0 0. 2. 1. 1. 0. 15. 15. 15. -15. 1. 2. 1. 13. 16. 0 0 0. 1. 1. 2. 16. 0 8. 0 0. 0 9. 0 0. 13. 1. 1. 1. -15.15. 15. 15. 1. 17. 1. 0. 0 17. 0 0 8. 0 0 0. 9. 0 0 0. 1. 13. 1. 2. 15. -15.15. 15. 2. 1. 1. 0. 0 0 17. 0 0 0 8. 0. 0 0 9. 0. 1. 1. 13. 1. 15. 15. -15.15. 1. 1. 17. 0. 17. 0 0 0 0 0 0 0. 0 0 0 0. 1. 2. 1. 13. 15. 15. 15. -15. 17. 1. 1. 0. 0 0 0 17. 0 0 0 0. 0 0 0 0. 0 0 0 16. 1. 2. 1. 17. -21.21. 21. 21. 1. 1. 2. 20. 0 11. 0 0. 0 12. 0 0. 16. 0 0 0 17. 1. 1. 1. 21. -21.21. 21. 1. 20. 1. 1. 0 0 11. 0. 0 0 12. 0. 0 0 16. 0 1. 1. 17. 1. 21. 21. -21.21. 20. 1. 1. 1. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 0. 21. 21. 21. -21. 0. 0. 0. 0. 1. 1. 11. 0. 0 0 12. 0. 1. 1. 16. 1. 0 0 17. 0 1. 1. 20. 0. -18.18. 18. 18. 1. 11. 1. 0. 0 12. 0 0. 16. 1. 1. 1. 17. 0 0 0 1. 20. 1. 0. 18. -18.18. 18. 11. 1. 1. 0. 12. 0 0 0. 1. 16. 1. 2. 0 17. 0 0 2. 1. 1. 0. 18. 18. -18.18. 2. 1. 1. 0. 0 0 0 0. 1. 2. 1. 16. 0 0 0 17. 20. 1. 1. 0. 18. 18. 18. -18. \end{mathematica} %================================================================ \section{Hopfield neural network} %==================================================================== \subsection{Activation function} Elementary sigmoidal function is defined as: \begin{mathematica} SigmoidalActivation[u_,lambda_] := 1./(1. + N[E]^(-lambda u)); \end{mathematica} %-------------------------------------------------------------------- \subsection{Actualization function} The following function finds the next set of output values of a network for the two possible update paradigms: \begin{mathematica} HopfieldDiscreteCycle[w_List, u0_List, activation_, synch_:False] := Module[{u = u0}, If[ synch, activation /@ N[u . w], (u[[#]] = activation[u . w[[#]]])& /@ RandomPermutation[Length[w]]; u ] ]; \end{mathematica} \subsection{Decoding chosen strategies into new allocations} \begin{mathematica} decod[strat_List] := If[ Times @@ Apply[Plus, #, {1}] == 1, If[Count[#, 0] > 0, {}, #]& @ MapIndexed[ neighb[[ alloc[[ #2[[1]] ]], #1]]&, Position[#, x_ /; x > 0][[1,1]]& /@ #], {} ]& @ Partition[ strat, nstrat] \end{mathematica} \subsection{Hopfield simulator} \begin{mathematica} alloc = Table[1, {Np}];\ hist = {alloc};\ Do[ cost = findcost[3.5, 3.5]; flatcost = -Flatten[ Map[Flatten[#,1]&, cost, {2}], 1]; For[i = 0, start = Flatten[ Table[ Table[If[i==1, 1, 0], {i, nstrat}], {i, Np}] ]; (sele = decod[ Sign /@ Chop[ Nest[ HopfieldDiscreteCycle[flatcost, #, SigmoidalActivation[#, .4]&]&, start, 2], 10^-1]]) == {} && i < 20, i++ ]; If[sele == {}, Print["oops"]; Break[]]; Print[alloc = sele]; AppendTo[hist, alloc], {2}];\ hist . {4, 4, 1, 3, 1, 2} {4, 4, 1, 3, 1, 2} Out[52]= {{1, 1, 1, 1, 1, 1}, {4, 4, 1, 3, 1, 2}, {4, 4, 1, 3, 1, 2}} \end{mathematica} \section{Explicit energy calculation} Finds position of a minimal element: \begin{mathematica} eminpos[l_List] := Module[{i, mpos = 1, minval = l[[1, 1]]}, For[i = 2, i <= Length[l], i++, If[ l[[i, 1]] < minval, mpos = i; minval = l[[i, 1]] ] ]; l[[mpos]] ]; \end{mathematica} Explicit energy calculation simulation: \begin{mathematica} alloc = Table[1, {Np}];\ lastalloc = {};\ hist = {alloc};\ While[alloc != lastalloc, lastalloc = alloc; cost = findcost[3, 3]; flatcost = -Flatten[ Map[Flatten[#,1]&, cost, {2}], 1]; allst = Flatten /@ Map[ RotateRight[Table[ If[i==1, 1, 0], {i, nstrat}], #]&, Flatten[Array[List[##] - 1&, degr[[alloc]] + 1], Np - 1], {2}]; ene = {-#.flatcost.#/2, decod[#], #}& /@ allst; Print[ alloc = eminpos[ene][[2]] ]; AppendTo[hist, alloc] ]; . {2, 2, 1, 1, 4, 3} {2, 2, 1, 1, 4, 3} \end{mathematica} The first 17 best energetically strategies: \begin{mathematica} Print[(Sort@ene)[[Range[17]]]//TableForm[#, TableDirections->{Column, Row, Row}, TableSpacing->{0,4,1}]&] . -26.4062 2 2 1 1 4 3 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 -26.4062 2 2 3 3 4 1 1 0 0 0 1 0 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 1 0 0 -25.4062 1 1 2 2 3 4 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 0 1 0 0 0 0 1 -25.4062 1 1 2 2 4 3 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 1 0 0 0 1 0 0 0 -25.4062 1 1 3 3 4 2 0 1 0 0 0 1 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 1 0 -25.4062 1 1 4 4 3 2 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 1 0 0 1 0 0 0 1 0 -25.4062 1 2 2 1 4 3 0 1 0 0 1 0 0 0 0 1 0 0 1 0 0 0 1 0 0 0 1 0 0 0 -25.4062 2 2 1 1 3 4 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 0 1 -25.4062 2 2 3 3 1 4 1 0 0 0 1 0 0 0 0 0 1 0 0 0 1 0 0 1 0 0 0 0 0 1 -25.4062 2 2 4 4 1 3 1 0 0 0 1 0 0 0 0 0 0 1 0 0 0 1 0 1 0 0 1 0 0 0 -25.4062 2 2 4 4 3 1 1 0 0 0 1 0 0 0 0 0 0 1 0 0 0 1 0 0 1 0 0 1 0 0 -25.4062 3 2 2 3 4 1 0 0 1 0 1 0 0 0 0 1 0 0 0 0 1 0 1 0 0 0 0 1 0 0 -25.4062 3 3 1 1 4 2 0 0 1 0 0 0 1 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 -25.4062 3 3 2 2 1 4 0 0 1 0 0 0 1 0 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 1 -25.4062 3 3 2 2 4 1 0 0 1 0 0 0 1 0 0 1 0 0 0 1 0 0 1 0 0 0 0 1 0 0 -25.4062 3 3 4 4 1 2 0 0 1 0 0 0 1 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 1 0 -24.4062 1 1 1 2 3 4 0 1 0 0 0 1 0 0 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1 \end{mathematica} First five energy levels: \begin{mathematica} Union[#[[1]]& /@ ene][[ Range[5] ]] . Out[74]= {-26.4062, -25.4062, -24.4062, -23.4062, -22.4062} \end{mathematica} \end{document} %==================================================================== %==================================================================== %==================================================================== %==================================================================== \begin{mathematica} neighb = MapIndexed[ Join[#2, Flatten[#1], Table[0, {nstrat - Length[#] - 1}] ]&, Position[ #, x_ /; x > 0 ]& /@ procweights ] . Out[216]= {{1, 2, 4}, {2, 1, 3}, {3, 2, 4}, {4, 1, 3}} \end{mathematica} \begin{mathematica} Print[NumberForm[MatrixForm[flatcost, TableSpacing->{0,1}], 2];] . Null \end{mathematica} unnecessary? \begin{mathematica} resnode = Map[ If[ # != 0, alloc[[#]], 0]&, neighb, {2}] . Out[38]= {{1, 1, 1}, {1, 1, 1}, {1, 1, 1}} \end{mathematica} \begin{mathematica} start = Table[Random[Integer], {Length[flatcost]}] . Out[793]= {0, 1, 0, 0, 0, 0, 1, 0, 0, 1, 1, 0} \end{mathematica} Apply[Plus, Map[Sign, cost, 4], 4]; \begin{mathematica} (xxx = Flatten/@Chop[HopfieldDiscrete[flatcost, start, SigmoidalActivation[#, 10]&, 5], 10^-3])// Print[NumberForm[MatrixForm[#, TableSpacing->{0,2}], 1]]& . 0 0 1 0 0 1 1 0 0 1 0 0 0 0 1. 0 0 1. 1. 0 0 0.6 0 0 0 0 1. 0 0 1. 1. 0 0 0 0 0 0 0 1. 0 0 1. 1. 0 0 0 0 0 0 0 1. 0 0 1. 1. 0 0 0 0 0 0 0 1. 0 0 1. 1. 0 0 0 0 0 \end{mathematica} \begin{mathematica} start={0,1,0, 0,1,0, 0,1,0, 1,0,0}; \end{mathematica} \begin{mathematica} start={1,0,0, 1,0,0, 0,0,1, 0,0,1}; \end{mathematica} \begin{mathematica} alloc = {1, 1, 2, 3}; \end{mathematica} random hop start: start = Flatten[ RotateRight[Table[If[i==1, 1, 0], {i, nstrat}], #]& /@ Table[Random[Integer,{0, degr[[alloc[[i]] ]] }], {i, Np}] ];