(* Content-type: application/vnd.wolfram.mathematica *) (*** Wolfram Notebook File ***) (* http://www.wolfram.com/nb *) (* CreatedBy='Mathematica 8.0' *) (*CacheID: 234*) (* Internal cache information: NotebookFileLineBreakTest NotebookFileLineBreakTest NotebookDataPosition[ 157, 7] NotebookDataLength[ 32734, 803] NotebookOptionsPosition[ 31216, 746] NotebookOutlinePosition[ 31868, 771] CellTagsIndexPosition[ 31825, 768] WindowTitle->Statistical Mechanics of Money - Source WindowFrame->Normal*) (* Beginning of Notebook Content *) Notebook[{ Cell[CellGroupData[{ Cell["Statistical Mechanics of Money", "Section", CellFrame->{{0, 0}, {0, 0}}, ShowCellBracket->False, FontColor->RGBColor[0.597406, 0, 0.0527047]], Cell[BoxData[ GraphicsBox[RasterBox[CompressedData[" 1:eJztnVuSozgWQDNiPqa3MJ+zpVlCbaB3WlGVNV9dvYH6TQRUph/ZGIHQmwvG xoZzQu3Aku7VfUj4Nk53//fLn//78q+Xl5f/NP/88e+Xl8v154Xj5+fp89y0 4+X63L7VnQu02XqOt9FzjRK5qtRMoYZFpk11/Ji+WDye92+r7+fFfbnGkuu9 eIQ4LBVJ+YRo5DPnRdITDp0TLRg6m/62nY/n08f5+H461G37fWqum57z4Xy2 jby0prMZOh4/jodLOx2bt6fzRSEA3B/KMKGSBy/DSKVcyYOn8krHqajvqed6 G6iol4qkfAIVNQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADsizPA/lj72AEA AMCmWLu0AXh01j6jAAAAcdb+hNwUJ5e1zZnPDEeey/e1jx0AAABsirVLm03x XFVlhs1X1JNY+4wCAAB02B9PJ4BdsvYpBAAAgOeGihpADo9GAUDIr+Lnr7ef a9vw16/i73VtMPx6+2v1gGwMijeAE89FAQA2DRW1BxX14lBRA0wi+lx0baMA AAAAAAAAAAAAbkj0uegR4L4cDoe1TYA1YQMAbIaDy9rm3JU9+w4AjwB3np3D BgDYDHuuKu/su3k0ynNRACGLHMy93dm2ijCPpHvD7LliAQAAmA0VNRioqIGK GlYk9Vz0AAAAAAAAAAAAALBR9KPR8Kf0a9sFAAAAAAAAAAAAcCt4LgoAAAAA AAAAAAB7I/Vc9ONheH9/X9uEzUJsZ0PoAGBZ3gNuLQgggR21GUjl7SC2syF0 ALAsVNQgxMv14XAI/xOja9sIAAAAT0lYWM5jbT/msGffAQAAAGAp9lxV3sF3 b1r0uehSZgAAAAAAAAAAAAA8Ar9b6rpuXpu3+tf0PBcFWJcFvxYBAAAAANgh VNQAADCK5LnobwAAAAAAAAAAAIANUbcPRav+wehH7LmoUqpsqKqmNTSXRVE0 by593mtRXlrfo7mImTlVN6ebUOhR07q3jmxVWXqquqxVOUjZq1eDVNe662ro Nxe1Xr5o2lt5cUc7VWr3BpGindNL6TkDl5nVIGWtbuaXWbwJo/OVKjSX68oL shMTO4ylHf+yy5GbhU5EubJJPeWgx5ayBfvOIR2qD5QJXWmFtJs2pLsLvu40 4oOesh/tJ3TKW/3DomZONgVdVPtNXvVXYWydyBRl/NWNWNW62L06G344TcNW L/SVpaTqcmeOWGWOm3W+TFPWsbL8dE1yklUal73ghDtBH+Hu1dE/HBM7/t7h sjNoN29Calrl2GadWfsMeoc0elcR584clrm5qzO5a+5mQe4imy2Tu1qcu+g2 7od7mkvVtqJtajgInQuqzUrRtWFCzIAkzQdK0/RR1U33JEhtgOhosnmLKtX0 DArVhaJHtZOlmgPbVN+mWZhRGzNvEc13MD61kIRcEPS2WciRp/C97a0ow569 DCOVRurZU0lFnUoBFbWkKiv7I0xFLc4dFXUAFfVUtVTUYRD2V1EnfTd7u920 v+va/NXoSXM86qXVwFtzgNvS7vJG3730Ga76Wkq/6lFz3dlWOa+69XpUOSix ixQtrrVV1pxBleO+uesMsv6QjenXF+bViFjGO5rtObaUp7bVoENe21Kqy1Un 1M8xOaxNftysOh61q5joKStQpbkIQ2p54HRWXcqsOsbVU7oZNBr8Fbv+yotk GBkvbuFbu9/LkY6DF3ZvTvqtOVXdBi0dlN6WZekEsHfQ2flmjpnQ+25vfn// 2yH1eswnokp/tNkpsJNrTqJruX4tzAkKBJXJVdUbbJmtrwtrUfuoGm2Ru5S3 AcrEGQyPld3jzbFTH+oP+is3d+XVuev2wI1zN9w8rZM1I3dFf203xxKvuUyT TevJkd8JSzF7iVHBzJa+D0vFZJLapawNh6xiQ91ixaf03R+lDHvaMqwPCKl8 +lRGgkZF3W3Q0oGKmoq685yKmoo6L5jZ0vdhqZhMUruUteEQFfUk37VU98C8 qRvq+uPjQz8UPZ/P+snoZYIqVAwtaFY0r+E0+8l8VIM3Gs70JkelUoLR0XBm 2X5dldcmWS5lQ2r1jDue+DBaRvrzvidVpc2WOKJicRvVZu+HaFqjgpngC/MS Fek2rRvSjKCy9rnxfepWFFKokVMzWaEsU9GDbEYnbfuoYOpGkdcwql/Sv+fc CVdJcY1a+Yo3WuUaZsfE+9S+j3mTRuFZoAxL9eTtFK6ecccTH0bnlmGkMtXz dKnMLCTpifZTUUfnyNOR4QGrstQuHTXGFqSiXiV3wlVSXKNWvuKNVrmG2TGh ooZb0+T0rUWf/br9e1HvuWjR/z1/+JOUIujKPxYu+l9YCEX0kGVARDxjjHxa ygZv6ejF6KiE0cfp0eUk6JMrmVamQx1qkPTIRzNSo4LC0OnbV7S/tD7WRw32 ElFYP1/y7EkZn09lPhHedej7vDiHSkbzq79YsWcWfUUUzYgXf7mdqa04eiK0 ebYxe86d9yE+T3n+OzuVqHbMx01Up/kkCud7Q0ZJ5uvCRQhNGvVCoueayK9O mKP8qDDd9szol7b5AM5LSup0P7LvxXBX8dWGvlCGTTJm1IBwianK3QySyo2k clR/KtShBkmPfDQjNSpIRS0xexJRy8NjS0UtMfVBcmegoh6FijrkEarKPVfU Gd89w+rwd/Tt34uq/kuT6C2xsG5WhXvLsu+KUb+8/kxsvQMryUIxdp8PLc/c FiblXaJEcgvKuODFf54N8yYXwYejZ2fUbO8i5b7kXwRSPfJtFu1JWZ7BtlZu eRg9XXJEbcuriorIU2xkjYjQi2hJFjXeFvFmhjeNUWu9HhO3/LQoe8tdSKqC ys+f+tE5aZVoBSU0T87U+sr2emq4Ur7k9eQrhydiaqiF3LqSX4QFfacMk684 yaT7l2GkUr7iJJOoqKMrUlGPritxZ9RyT9aIUFHn133e3IVQUQvVUlHPhor6 1r6r/k9G9X1A/47+dDrZ/9+lb9++vbr8+PHDe7X7w077rafHU+JNTo1GF/Wu U52hhtCjqGEZJVGdoZsp5ZmZoRe2kc3Fd0tnKGKvJQ9UKr8pRh15dY0MZTOO e/pTa43OSUmFpn5Pbzzv7agveTNCJRnZ70FCX4OU5ZWn9KfiELrpLZ3aIZn0 RYmGN+NRPsIpd7y19pa7qIhQZ15coicVmamMLjpb1SLmLUgmzlOtzau6RRAm bYxFTJoh9Vy+U4aNKonqDN1MKc/MDL2wjXydWIaRylElz5LKVExSS2Scigqm HHl1jQxlM457+lNrjc5JSYWmUlF7jqQ2RmqHZNIXJRrejEf5CKfc8dbaW+6i IkKdeXGJnlRkpjK66GxVi5i3IJk4T7U2r+oWQZi0MRYxaYbUZnyPLvH/lte2 FP/69esnAAAAAAAAAAAAwM74B4thROM= "], {{0, 0}, {1800, 25}}, {0, 255}, ColorFunction->RGBColor], ImageSize->{1800, 25}, PlotRange->{{0, 1800}, {0, 25}}]], "Section", CellFrame->{{0, 0}, {0, 0}}, ShowCellBracket->False], Cell[BoxData[ RowBox[{"Manipulate", "[", "\[IndentingNewLine]", RowBox[{ RowBox[{"Module", "[", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"moneyDist", "=", RowBox[{"moneyDistHistory", "\[LeftDoubleBracket]", RowBox[{"Round", "[", "time", "]"}], "\[RightDoubleBracket]"}]}], ",", RowBox[{"truncEntropyHistory", "=", RowBox[{"Take", "[", RowBox[{"entropyHistory", ",", RowBox[{"Round", "[", "time", "]"}]}], "]"}]}]}], "}"}], ",", "\[IndentingNewLine]", RowBox[{"GraphicsGrid", "[", RowBox[{ RowBox[{"{", RowBox[{"{", RowBox[{ RowBox[{"Histogram", "[", RowBox[{"moneyDist", ",", RowBox[{"ImageSize", "\[Rule]", "250"}], ",", RowBox[{"PlotLabel", "\[Rule]", "\"\\""}], ",", RowBox[{"AxesLabel", "\[Rule]", RowBox[{"{", RowBox[{"\"\\"", ",", "\"\\""}], "}"}]}], ",", RowBox[{"PlotRange", "\[Rule]", RowBox[{"{", RowBox[{"0", ",", "500"}], "}"}]}]}], "]"}], ",", RowBox[{"ListPlot", "[", RowBox[{"truncEntropyHistory", ",", RowBox[{"Joined", "\[Rule]", "True"}], ",", RowBox[{"PlotRange", "\[Rule]", "Full"}], ",", RowBox[{"AxesLabel", "\[Rule]", RowBox[{"{", RowBox[{"\"\\"", ",", "\"\\""}], "}"}]}]}], "]"}]}], "}"}], "}"}], ",", RowBox[{"ImageSize", "\[Rule]", RowBox[{"{", RowBox[{"600", ",", "300"}], "}"}]}]}], "]"}]}], "\[IndentingNewLine]", "]"}], ",", "\[IndentingNewLine]", RowBox[{"{", RowBox[{"time", ",", "1", ",", "50", ",", "1"}], "}"}], ",", "\[IndentingNewLine]", RowBox[{"Initialization", "\[RuleDelayed]", RowBox[{"{", "\[IndentingNewLine]", RowBox[{"(*", " ", RowBox[{ "Exchange", " ", "random", " ", "amount", " ", "of", " ", "money", " ", "between", " ", "two", " ", "randomly", " ", "selected", " ", "agents"}], " ", "*)"}], RowBox[{ RowBox[{ RowBox[{"randomExchange", "[", RowBox[{"agents_List", ",", "dM_Real"}], "]"}], ":=", RowBox[{"Module", "[", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"newAgents", "=", "agents"}], ",", RowBox[{"a1", "=", RowBox[{ RowBox[{"RandomInteger", "[", RowBox[{ RowBox[{"Length", "[", "agents", "]"}], "-", "1"}], "]"}], "+", "1"}]}], ",", RowBox[{"a2", "=", RowBox[{ RowBox[{"RandomInteger", "[", RowBox[{ RowBox[{"Length", "[", "agents", "]"}], "-", "1"}], "]"}], "+", "1"}]}], ",", "money"}], "}"}], ",", "\[IndentingNewLine]", RowBox[{ RowBox[{"money", "=", RowBox[{ RowBox[{"Random", "[", "]"}], "*", "dM"}]}], ";", "\[IndentingNewLine]", RowBox[{"If", "[", RowBox[{ RowBox[{ RowBox[{ "newAgents", "\[LeftDoubleBracket]", "a1", "\[RightDoubleBracket]"}], "\[GreaterEqual]", "money"}], ",", "\[IndentingNewLine]", RowBox[{ RowBox[{ RowBox[{ "newAgents", "\[LeftDoubleBracket]", "a1", "\[RightDoubleBracket]"}], "-=", "money"}], ";", "\[IndentingNewLine]", RowBox[{ RowBox[{ "newAgents", "\[LeftDoubleBracket]", "a2", "\[RightDoubleBracket]"}], "+=", "money"}], ";"}]}], "\[IndentingNewLine]", "]"}], ";", "\[IndentingNewLine]", "newAgents"}]}], "\[IndentingNewLine]", "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"(*", " ", RowBox[{ "Calculate", " ", "entropy", " ", "of", " ", "money", " ", "distribution"}], " ", "*)"}], "\[IndentingNewLine]", RowBox[{ RowBox[{"calcEntropy", "[", "agents_List", "]"}], ":=", RowBox[{"Module", "[", RowBox[{ RowBox[{"{", "bins", "}"}], ",", "\[IndentingNewLine]", RowBox[{ RowBox[{"bins", "=", RowBox[{"BinCounts", "[", RowBox[{"agents", ",", RowBox[{"{", RowBox[{"0", ",", RowBox[{"Ceiling", "[", RowBox[{"Total", "[", "agents", "]"}], "]"}], ",", "1"}], "}"}]}], "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"bins", "=", RowBox[{"bins", "/", RowBox[{"Length", "[", "agents", "]"}]}]}], ";", "\[IndentingNewLine]", RowBox[{"bins", "=", RowBox[{"DeleteCases", "[", RowBox[{"bins", ",", "0"}], "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"-", RowBox[{"bins", ".", RowBox[{"Log", "[", "bins", "]"}]}]}]}]}], "\[IndentingNewLine]", "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"(*", " ", RowBox[{ "Create", " ", "an", " ", "initial", " ", "state", " ", "of", " ", "the", " ", RowBox[{"economy", "."}]}], " ", "*)"}], "\[IndentingNewLine]", RowBox[{ RowBox[{"initSimulation", "[", RowBox[{ "numAgents_Integer", ",", "numEconomies_Integer", ",", "initialMoneyEndowment_Real"}], "]"}], ":=", "\[IndentingNewLine]", RowBox[{"Table", "[", RowBox[{ RowBox[{"Table", "[", RowBox[{"initialMoneyEndowment", ",", RowBox[{"{", "numAgents", "}"}]}], "]"}], ",", RowBox[{"{", "numEconomies", "}"}]}], "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"(*", " ", RowBox[{ "Run", " ", "the", " ", "simulation", " ", "for", " ", "specified", " ", "time", " ", RowBox[{"steps", "."}]}], " ", "*)"}], "\[IndentingNewLine]", RowBox[{ RowBox[{"runSimulation", "[", RowBox[{"economyList_List", ",", "dM_Real", ",", "time_Integer"}], "]"}], ":=", RowBox[{"Module", "[", RowBox[{ RowBox[{"{", RowBox[{"newEconomyList", "=", "economyList"}], "}"}], ",", "\[IndentingNewLine]", RowBox[{ RowBox[{"Do", "[", RowBox[{ RowBox[{ RowBox[{"newEconomyList", "=", RowBox[{"Map", "[", RowBox[{ RowBox[{ RowBox[{"(", RowBox[{"randomExchange", "[", RowBox[{"#", ",", "dM"}], "]"}], ")"}], "&"}], ",", "newEconomyList"}], "]"}]}], ";"}], ",", RowBox[{"{", "time", "}"}]}], "]"}], ";", "\[IndentingNewLine]", "newEconomyList"}]}], "\[IndentingNewLine]", "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"(*", " ", RowBox[{"Create", " ", "simulation", " ", "data"}], " ", "*)"}], "\[IndentingNewLine]", RowBox[{ RowBox[{"makeData", "[", RowBox[{ "numAgents_Integer", ",", "numEconomies_Integer", ",", "initialMoneyEndowment_Real", ",", "numSamples_Integer", ",", "stepSize_Integer"}], "]"}], ":=", RowBox[{"Module", "[", RowBox[{ RowBox[{"{", RowBox[{ RowBox[{"economyList", "=", RowBox[{"initSimulation", "[", RowBox[{ "numAgents", ",", "numEconomies", ",", "initialMoneyEndowment"}], "]"}]}], ",", RowBox[{"entropyHistory", "=", RowBox[{"{", "}"}]}], ",", RowBox[{"moneyDistHistory", "=", RowBox[{"{", "}"}]}], ",", RowBox[{"incomeDistHistory", "=", RowBox[{"{", "}"}]}]}], "}"}], ",", "\[IndentingNewLine]", RowBox[{ RowBox[{"Do", "[", "\[IndentingNewLine]", RowBox[{ RowBox[{ RowBox[{"moneyDistHistory", "=", RowBox[{"Append", "[", RowBox[{"moneyDistHistory", ",", RowBox[{"Flatten", "[", "economyList", "]"}]}], "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"entropyHistory", "=", RowBox[{"Append", "[", RowBox[{"entropyHistory", ",", RowBox[{ RowBox[{"(", RowBox[{ RowBox[{"Map", "[", RowBox[{"calcEntropy", ",", "economyList"}], "]"}], "/", RowBox[{"Length", "[", "economyList", "]"}]}], ")"}], "\[LeftDoubleBracket]", "1", "\[RightDoubleBracket]"}]}], "]"}]}], ";", "\[IndentingNewLine]", RowBox[{"economyList", "=", RowBox[{"runSimulation", "[", RowBox[{ "economyList", ",", "initialMoneyEndowment", ",", "stepSize"}], "]"}]}], ";"}], ",", "\[IndentingNewLine]", RowBox[{"{", "numSamples", "}"}]}], "\[IndentingNewLine]", "]"}], ";", "\[IndentingNewLine]", RowBox[{"{", RowBox[{"moneyDistHistory", ",", "entropyHistory"}], "}"}]}]}], "\[IndentingNewLine]", "]"}]}], ";", "\[IndentingNewLine]", RowBox[{ RowBox[{"{", RowBox[{"moneyDistHistory", ",", "entropyHistory"}], "}"}], "=", RowBox[{"makeData", "[", RowBox[{"25", ",", "20", ",", "100.0", ",", "50", ",", "5"}], "]"}]}], ";"}], "\[IndentingNewLine]", "}"}]}]}], "\[IndentingNewLine]", "]"}]], "Input", CellChangeTimes->{ 3.35696210375764*^9, {3.400097286898212*^9, 3.400097289397562*^9}, { 3.400176560481587*^9, 3.4001765844499607`*^9}, {3.400177370764964*^9, 3.400177453314054*^9}, {3.400177570762148*^9, 3.400177580475705*^9}, { 3.400258460323915*^9, 3.4002584663239403`*^9}, {3.400259719689416*^9, 3.400259815244425*^9}, {3.40025986420507*^9, 3.400259868419015*^9}, { 3.400259910150309*^9, 3.40025992860235*^9}, {3.4002600839871683`*^9, 3.400260084169619*^9}, {3.4002633663089333`*^9, 3.400263393808577*^9}, { 3.4002634433224173`*^9, 3.4002635648357286`*^9}, {3.4002636291526127`*^9, 3.400263631084235*^9}, {3.4002636828357553`*^9, 3.4002636935214243`*^9}, { 3.400263730810226*^9, 3.400263739056665*^9}, {3.400264064460557*^9, 3.4002640778191957`*^9}, {3.400264861338706*^9, 3.400264901534711*^9}, { 3.4002649692534*^9, 3.4002649841557083`*^9}, {3.400265066082036*^9, 3.400265100482307*^9}, 3.4002651359903107`*^9, {3.4002651927617292`*^9, 3.400265195066496*^9}, {3.400265292235642*^9, 3.4002652944499474`*^9}, { 3.400265324744124*^9, 3.400265327734659*^9}, {3.400265412833894*^9, 3.400265418864279*^9}, {3.4002654825015917`*^9, 3.400265509495571*^9}, { 3.400265706300345*^9, 3.400265713842018*^9}, {3.400265760600679*^9, 3.400265786566965*^9}, {3.400265896325344*^9, 3.400265981968547*^9}, { 3.400266328720264*^9, 3.400266396258861*^9}, 3.400266479868615*^9, 3.4002667960807657`*^9, {3.4002669510326767`*^9, 3.400266954761198*^9}, { 3.400267424951214*^9, 3.400267441440762*^9}, {3.400268692028563*^9, 3.400268753371441*^9}, {3.400268784181637*^9, 3.400268842354678*^9}, 3.4002695650278053`*^9, {3.400269611185111*^9, 3.400269613064251*^9}, { 3.400269756242898*^9, 3.400269759964035*^9}, {3.400273412296875*^9, 3.40027342025*^9}, {3.400273488046875*^9, 3.40027350778125*^9}, { 3.40027355896875*^9, 3.40027359375*^9}, {3.400273625125*^9, 3.400273634359375*^9}, {3.400273665953125*^9, 3.400273726671875*^9}, { 3.4018636887118177`*^9, 3.401863736138673*^9}, {3.401863793244708*^9, 3.4018639654677763`*^9}, {3.401864041736948*^9, 3.4018640441441927`*^9}, { 3.4018642317663937`*^9, 3.401864241471233*^9}, {3.40186457336049*^9, 3.401864728614409*^9}, {3.401864826684577*^9, 3.4018648303242826`*^9}, { 3.4018649055725603`*^9, 3.401864910121526*^9}, {3.40186565390584*^9, 3.4018657118660593`*^9}, {3.4019021229949083`*^9, 3.401902202678989*^9}, { 3.40190225570749*^9, 3.40190226360087*^9}, {3.4019024427861843`*^9, 3.401902453971793*^9}, {3.401902846391879*^9, 3.401902869257175*^9}, 3.401902972180229*^9, {3.4019289111875*^9, 3.401928944234375*^9}, { 3.505239869221139*^9, 3.505239903705587*^9}, {3.5052403373779497`*^9, 3.5052403529875107`*^9}, {3.505240451919403*^9, 3.50524050609482*^9}}] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[ TagBox[ StyleBox[ DynamicModuleBox[{$CellContext`time$$ = 1, Typeset`show$$ = True, Typeset`bookmarkList$$ = {}, Typeset`bookmarkMode$$ = "Menu", Typeset`animator$$, Typeset`animvar$$ = 1, Typeset`name$$ = "\"untitled\"", Typeset`specs$$ = {{ Hold[$CellContext`time$$], 1, 50, 1}}, Typeset`size$$ = { 600., {148., 152.}}, Typeset`update$$ = 0, Typeset`initDone$$, Typeset`skipInitDone$$ = False, $CellContext`time$257666$$ = 0}, DynamicBox[Manipulate`ManipulateBoxes[ 1, StandardForm, "Variables" :> {$CellContext`time$$ = 1}, "ControllerVariables" :> { Hold[$CellContext`time$$, $CellContext`time$257666$$, 0]}, "OtherVariables" :> { Typeset`show$$, Typeset`bookmarkList$$, Typeset`bookmarkMode$$, Typeset`animator$$, Typeset`animvar$$, Typeset`name$$, Typeset`specs$$, Typeset`size$$, Typeset`update$$, Typeset`initDone$$, Typeset`skipInitDone$$}, "Body" :> Module[{$CellContext`moneyDist = Part[$CellContext`moneyDistHistory, Round[$CellContext`time$$]], $CellContext`truncEntropyHistory = Take[$CellContext`entropyHistory, Round[$CellContext`time$$]]}, GraphicsGrid[{{ Histogram[$CellContext`moneyDist, ImageSize -> 250, PlotLabel -> "money distribution", AxesLabel -> {"money", "number of agents"}, PlotRange -> {0, 500}], ListPlot[$CellContext`truncEntropyHistory, Joined -> True, PlotRange -> Full, AxesLabel -> {"time", "entropy"}]}}, ImageSize -> {600, 300}]], "Specifications" :> {{$CellContext`time$$, 1, 50, 1}}, "Options" :> {}, "DefaultOptions" :> {ControllerLinking -> True}], ImageSizeCache->{645., {192., 197.}}, SingleEvaluation->True], Deinitialization:>None, DynamicModuleValues:>{}, Initialization:>({$CellContext`randomExchange[ Pattern[$CellContext`agents, Blank[List]], Pattern[$CellContext`dM, Blank[Real]]] := Module[{$CellContext`newAgents = $CellContext`agents, $CellContext`a1 = RandomInteger[Length[$CellContext`agents] - 1] + 1, $CellContext`a2 = RandomInteger[Length[$CellContext`agents] - 1] + 1, $CellContext`money}, $CellContext`money = Random[] $CellContext`dM; If[Part[$CellContext`newAgents, $CellContext`a1] >= \ $CellContext`money, SubtractFrom[ Part[$CellContext`newAgents, $CellContext`a1], \ $CellContext`money]; AddTo[ Part[$CellContext`newAgents, $CellContext`a2], \ $CellContext`money]; Null]; $CellContext`newAgents]; $CellContext`calcEntropy[ Pattern[$CellContext`agents, Blank[List]]] := Module[{$CellContext`bins}, $CellContext`bins = BinCounts[$CellContext`agents, {0, Ceiling[ Total[$CellContext`agents]], 1}]; $CellContext`bins = $CellContext`bins/ Length[$CellContext`agents]; $CellContext`bins = DeleteCases[$CellContext`bins, 0]; -Dot[$CellContext`bins, Log[$CellContext`bins]]]; $CellContext`initSimulation[ Pattern[$CellContext`numAgents, Blank[Integer]], Pattern[$CellContext`numEconomies, Blank[Integer]], Pattern[$CellContext`initialMoneyEndowment, Blank[Real]]] := Table[ Table[$CellContext`initialMoneyEndowment, \ {$CellContext`numAgents}], {$CellContext`numEconomies}]; \ $CellContext`runSimulation[ Pattern[$CellContext`economyList, Blank[List]], Pattern[$CellContext`dM, Blank[Real]], Pattern[$CellContext`time, Blank[Integer]]] := Module[{$CellContext`newEconomyList = $CellContext`economyList}, Do[$CellContext`newEconomyList = Map[$CellContext`randomExchange[#, $CellContext`dM]& , \ $CellContext`newEconomyList]; Null, {$CellContext`time}]; $CellContext`newEconomyList]; \ $CellContext`makeData[ Pattern[$CellContext`numAgents, Blank[Integer]], Pattern[$CellContext`numEconomies, Blank[Integer]], Pattern[$CellContext`initialMoneyEndowment, Blank[Real]], Pattern[$CellContext`numSamples, Blank[Integer]], Pattern[$CellContext`stepSize, Blank[Integer]]] := Module[{$CellContext`economyList = \ $CellContext`initSimulation[$CellContext`numAgents, \ $CellContext`numEconomies, $CellContext`initialMoneyEndowment], \ $CellContext`entropyHistory = {}, $CellContext`moneyDistHistory = {}, \ $CellContext`incomeDistHistory = {}}, Do[$CellContext`moneyDistHistory = Append[$CellContext`moneyDistHistory, Flatten[$CellContext`economyList]]; \ $CellContext`entropyHistory = Append[$CellContext`entropyHistory, Part[ Map[$CellContext`calcEntropy, $CellContext`economyList]/ Length[$CellContext`economyList], 1]]; $CellContext`economyList = \ $CellContext`runSimulation[$CellContext`economyList, \ $CellContext`initialMoneyEndowment, $CellContext`stepSize]; Null, {$CellContext`numSamples}]; {$CellContext`moneyDistHistory, \ $CellContext`entropyHistory}]; {$CellContext`moneyDistHistory, \ $CellContext`entropyHistory} = $CellContext`makeData[25, 20, 100., 50, 5]; Null}; Typeset`initDone$$ = True), SynchronousInitialization->True, UnsavedVariables:>{Typeset`initDone$$}, UntrackedVariables:>{Typeset`size$$}], "Manipulate", Deployed->True, StripOnInput->False], Manipulate`InterpretManipulate[1]]], "Output", CellID->293128009], Cell[CellGroupData[{ Cell["CAPTION", "Section", CellFrame->{{0, 0}, {1, 0}}, CellFrameColor->RGBColor[0.87, 0.87, 0.87], FontFamily->"Helvetica", FontSize->12, FontWeight->"Bold", FontColor->RGBColor[0.597406, 0, 0.0527047]], Cell["\<\ The empirical distribution of the majority of people's wealth is consistent \ with an exponential (Boltzmann-Gibbs) distribution. This outcome can be \ replicated by an abstract agent-based simulation that models the exchange of \ money for goods in market economies. In this simulation, (i) total money is \ conserved and (ii) a random amount of money is transferred from one randomly \ selected agent to another ad infinitum. The first plot tracks the \ instantaneous money distribution (a simple proxy for wealth). The money \ distribution is initially equitable but rapidly converges to the highly \ unequal exponential distribution, at which point the economy enters \ statistical equilibrium. The second plot tracks the entropy of the money \ distribution, which increases to a maximum. The exponential distribution is \ the maximum entropy distribution under the constraint of money conservation. \ So market exchange between large numbers of independent agents is a mechanism \ that produces the \"most disorderly\" distribution of wealth subject to a \ simple conservation constraint.\ \>", "Text"] }, Close]] }, Open ]], Cell[CellGroupData[{ Cell["DETAILS", "Section", CellFrame->{{0, 0}, {1, 0}}, CellFrameColor->RGBColor[0.87, 0.87, 0.87], FontFamily->"Helvetica", FontSize->12, FontWeight->"Bold", FontColor->RGBColor[0.597406, 0, 0.0527047]], Cell[TextData[{ "In this simulation, a random amount of money in the range [0, ", Cell[BoxData[ FormBox["m", TraditionalForm]], "InlineMath"], "] is transferred from one randomly selected agent to another; if the agent \ has insufficient funds, the exchange does not take place. To produce smoother \ results, independent economies are simulated in parallel. The graphs \ summarize the income distribution and entropy of economies, each with 25 \ agents. This model of money distribution was first described in a classic \ paper of the econophysics movement [1]." }], "Text"], Cell["\<\ The complete wealth distribution is characterized by an exponential body \ (approximately 80% of the population) coupled to a power-law tail (a Pareto \ distribution, accounting for the wealthiest 20% of the population). A similar \ agent-based approach, described in [2], replicates the complete wealth \ distribution, in addition to other empirical regularities of capitalist \ economies, such as the power-law of firm sizes, the Laplace distribution of \ firm and GDP growth, etc. These results, and others, suggest that capitalist \ economies approximate a state of statistical equilibrium.\ \>", "Text"], Cell[TextData[{ "[1] A. Dragulescu and V. M. Yakovenko, \"Statistical Mechanics of Money,\" ", StyleBox["The European Physical Journal B", FontSlant->"Italic"], ", ", StyleBox["17", FontWeight->"Bold"], "(4), 2000 pp. 723\[Dash]729." }], "Text"], Cell[TextData[{ "[2] I. Wright, \"The Social Architecture of Capitalism,\" ", StyleBox["Physica A: Statistical Mechanics and its Applications", FontSlant->"Italic"], ", ", StyleBox["346", FontWeight->"Bold"], "(3-4), 2005 pp. 589\[Dash]620." }], "Text"] }, Close]], Cell[CellGroupData[{ Cell["THIS NOTEBOOK IS THE SOURCE CODE FROM", "Text", CellFrame->{{0, 0}, {0, 0}}, CellMargins->{{48, 10}, {4, 28}}, CellGroupingRules->{"SectionGrouping", 25}, CellFrameMargins->{{48, 48}, {6, 5}}, CellFrameColor->RGBColor[0.87, 0.87, 0.87], FontFamily->"Helvetica", FontSize->10, FontWeight->"Bold", FontColor->RGBColor[0.597406, 0, 0.0527047]], Cell[TextData[{ "\"", ButtonBox["Statistical Mechanics of Money", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/StatisticalMechanicsOfMoney/"], None}, ButtonNote-> "http://demonstrations.wolfram.com/StatisticalMechanicsOfMoney/"], "\"", " from ", ButtonBox["the Wolfram Demonstrations Project", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/"], None}, ButtonNote->"http://demonstrations.wolfram.com/"], "\[ParagraphSeparator]\[NonBreakingSpace]", ButtonBox["http://demonstrations.wolfram.com/StatisticalMechanicsOfMoney/", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/StatisticalMechanicsOfMoney/"], None}, ButtonNote->"http://demonstrations.wolfram.com/StatisticalMechanicsOfMoney/"] }], "Text", CellMargins->{{48, Inherited}, {0, Inherited}}, FontFamily->"Verdana", FontSize->10, FontColor->GrayLevel[0.5]], Cell[CellGroupData[{ Cell[TextData[{ "Contributed by: ", ButtonBox["Ian Wright", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/author.html?author=Ian+Wright"], None}, ButtonNote-> "http://demonstrations.wolfram.com/author.html?author=Ian+Wright"] }], "Text", CellDingbat->"\[FilledSmallSquare]", CellMargins->{{66, 48}, {2, 4}}, FontFamily->"Verdana", FontSize->10, FontColor->GrayLevel[0.6], CellID->127789522], Cell[TextData[{ "After work by: ", ButtonBox["A. A. Dragulescu", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/author.html?author=A.+A.+\ Dragulescu"], None}, ButtonNote-> "http://demonstrations.wolfram.com/author.html?author=A.+A.+Dragulescu"], ", ", ButtonBox["V. M. Yakovenko", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/author.html?author=V.+M.+\ Yakovenko"], None}, ButtonNote-> "http://demonstrations.wolfram.com/author.html?author=V.+M.+Yakovenko"], ", and ", ButtonBox["Justin Chen", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/author.html?author=Justin+Chen."], None}, ButtonNote-> "http://demonstrations.wolfram.com/author.html?author=Justin+Chen."] }], "Text", CellDingbat->"\[FilledSmallSquare]", CellMargins->{{66, 48}, {2, 4}}, FontFamily->"Verdana", FontSize->10, FontColor->GrayLevel[0.6], CellID->1421581542] }, Open ]], Cell[CellGroupData[{ Cell[TextData[{ "A full-function Wolfram ", StyleBox["Mathematica", FontSlant->"Italic"], " system (Version 6 or higher) is required to edit this notebook.\n", StyleBox[ButtonBox["GET WOLFRAM MATHEMATICA \[RightGuillemet]", BaseStyle->"Hyperlink", ButtonData->{ URL["http://www.wolfram.com/products/mathematica/"], None}, ButtonNote->"http://www.wolfram.com/products/mathematica/"], FontFamily->"Helvetica", FontWeight->"Bold", FontSlant->"Italic", FontColor->RGBColor[1, 0.42, 0]] }], "Text", CellFrame->True, CellMargins->{{48, 68}, {8, 28}}, CellFrameMargins->12, CellFrameColor->RGBColor[0.87, 0.87, 0.87], CellChangeTimes->{3.3750111182355957`*^9}, ParagraphSpacing->{1., 1.}, FontFamily->"Verdana", FontSize->10, FontColor->GrayLevel[0.411765], Background->RGBColor[1, 1, 1]], Cell[TextData[{ "\[Copyright] ", StyleBox[ButtonBox["Wolfram Demonstrations Project & Contributors", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/"], None}, ButtonNote->"http://demonstrations.wolfram.com/"], FontColor->GrayLevel[0.6]], "\[ThickSpace]\[ThickSpace]\[ThickSpace]|\[ThickSpace]\[ThickSpace]\ \[ThickSpace]", StyleBox[ButtonBox["Terms of Use", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/termsofuse.html"], None}, ButtonNote->"http://demonstrations.wolfram.com/termsofuse.html"], FontColor->GrayLevel[0.6]], "\[ThickSpace]\[ThickSpace]\[ThickSpace]|\[ThickSpace]\[ThickSpace]\ \[ThickSpace]", StyleBox[ButtonBox["Make a new version of this Demonstration \ \[RightGuillemet]", BaseStyle->"Hyperlink", ButtonData->{ URL["http://demonstrations.wolfram.com/participate/upload.jsp?id=\ StatisticalMechanicsOfMoney"], None}, ButtonNote->None], FontColor->GrayLevel[0.6]] }], "Text", CellFrame->{{0, 0}, {0, 0.5}}, CellMargins->{{48, 10}, {20, 50}}, CellFrameMargins->{{6, 0}, {6, 6}}, CellFrameColor->GrayLevel[0.6], FontFamily->"Verdana", FontSize->9, FontColor->GrayLevel[0.6]] }, Open ]] }, Open ]] }, Editable->True, Saveable->False, ScreenStyleEnvironment->"Working", CellInsertionPointCell->None, WindowSize->{780, 650}, WindowMargins->{{Inherited, Inherited}, {Inherited, 0}}, WindowElements->{ "StatusArea", "MemoryMonitor", "MagnificationPopUp", "VerticalScrollBar", "MenuBar"}, WindowTitle->"Statistical Mechanics of Money - Source", DockedCells->{}, CellContext->Notebook, FrontEndVersion->"8.0 for Microsoft Windows (32-bit) (November 7, 2010)", StyleDefinitions->"Default.nb" ] (* End of Notebook Content *) (* Internal cache information *) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[CellGroupData[{ Cell[632, 23, 150, 3, 70, "Section"], Cell[785, 28, 3700, 64, 70, "Section"], Cell[4488, 94, 12570, 275, 70, "Input"] }, Open ]], Cell[CellGroupData[{ Cell[17095, 374, 5898, 126, 70, "Output", CellID->293128009], Cell[CellGroupData[{ Cell[23018, 504, 209, 6, 70, "Section"], Cell[23230, 512, 1117, 16, 70, "Text"] }, Close]] }, Open ]], Cell[CellGroupData[{ Cell[24395, 534, 209, 6, 70, "Section"], Cell[24607, 542, 580, 10, 70, "Text"], Cell[25190, 554, 618, 9, 70, "Text"], Cell[25811, 565, 254, 8, 70, "Text"], Cell[26068, 575, 262, 8, 70, "Text"] }, Close]], Cell[CellGroupData[{ Cell[26366, 588, 355, 9, 70, "Text", CellGroupingRules->{"SectionGrouping", 25}], Cell[26724, 599, 956, 27, 70, "Text"], Cell[CellGroupData[{ Cell[27705, 630, 447, 15, 70, "Text", CellID->127789522], Cell[28155, 647, 979, 31, 70, "Text", CellID->1421581542] }, Open ]], Cell[CellGroupData[{ Cell[29171, 683, 815, 24, 70, "Text"], Cell[29989, 709, 1199, 33, 70, "Text"] }, Open ]] }, Open ]] } ] *) (* End of internal cache information *) (* NotebookSignature bTzIt8xJVqYzMDpuOH9XQ0FH *)