(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 5.0' Mathematica-Compatible Notebook This notebook can be used with any Mathematica-compatible application, such as Mathematica, MathReader or Publicon. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. *******************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 16394, 397]*) (*NotebookOutlinePosition[ 17067, 420]*) (* CellTagsIndexPosition[ 17023, 416]*) (*WindowFrame->Normal*) Notebook[{ Cell[BoxData[ \( (*\ Best - Response\ finder . \ \ Generalized\ for\ piecewise\ uniform\ types, \ arbitrarily\ many\ payoff\ cases, \ and\ a\ payoff\ function\ that\ includes\ opponent\ type\ and\ \ \(\(action\)\(.\)\)\ *) \)], "Input"], Cell[BoxData[ \( (*\ payoff : \ theta, \ rho, \ theta', \ rho', \ phi, \ beta, \ alpha\[IndentingNewLine]\ type\ \(dist : \ d\), \ f\[IndentingNewLine]\ \(strategy : \ c\), \ m, \ b\ *) \)], "Input"], Cell[BoxData[ \(\(sharedGoodAuction = {{0, 1/2, 1}, {0, \(-1\)/4, \(-1\)/2}, {0, 0, 0}, {1/2, 1/4, 0}, {0, 0, 0}, {0, 0}, \(-1\)};\)\)], "Input"], Cell[BoxData[ \(\(vickreyAuction = {{0, 1/2, 1}, {0, 0, 0}, {0, 0, 0}, {0, \(-1\)/2, \(-1\)}, {0, 0, 0}, {0, 0}, \(-1\)};\)\)], "Input"], Cell[BoxData[ \(\(\( (*\ Vicious\ Vickrey\ auction\ *) \)\(\[IndentingNewLine]\)\(\(k = 2/7;\)\[IndentingNewLine] \(vv := {{0, \((1 - k)\)/2, 1 - k}, {k, k/2, 0}, {\(-k\), \(-k\)/2, 0}, {0, \(-\((1 - k)\)\)/2, \(-\((1 - k)\)\)}, {0, 0, 0}, {0, 0}, \(-1\)};\)\)\)\)], "Input"], Cell[BoxData[ \(\(fpsb = {{0, 1/2, 1}, {0, \(-1\)/2, \(-1\)}, {0, 0, 0}, {0, 0, 0}, {0, 0, 0}, {0, 0}, \(-1\)};\)\)], "Input"], Cell[BoxData[ \(\(allPayAuction = {{0, 1/2, 1}, {\(-1\), \(-1\), \(-1\)}, {0, 0, 0}, {0, 0, 0}, {0, 0, 0}, {0, 0}, \(-1\)};\)\)], "Input"], Cell[BoxData[ \(\(\( (*\ Supply\ Chain\ game\ *) \)\(\[IndentingNewLine]\)\(\(v = \((10 - 5^\((1/2)\))\)/5;\)\[IndentingNewLine] \(scAuction := {{\(-1\), \(-1\), 0}, {1, 1, 0}, {0, 0, 0}, {0, 0, 0}, {0, 0, 0}, {v, v}, 1};\)\)\)\)], "Input"], Cell[BoxData[{ \(\(cost = 1;\)\), "\[IndentingNewLine]", \(\(jointBuy := {{0, 1}, {0, \(-1\)/2}, {0, 0}, {0, 1/2}, {0, \(-cost\)/2}, {cost}, 1};\)\)}], "Input"], Cell[BoxData[ \(\(swinkelsGame = {{0, 1/2, 1}, {0, \(-1\)/2, \(-1\)}, {0, \(-2\), \(-4\)}, {0, 0, 0}, {0, 2, 4}, {0, 0}, \(-1\)};\)\)], "Input"], Cell[BoxData[ \(\(concessionGame = {{0, 0, 0}, {\(-1\), \(-1\), \(-1\)}, {0, 0, 0}, {0, 0, 0}, {0, 1/2, 1}, {0, 0}, \(-1\)};\)\)], "Input"], Cell[BoxData[{ \(\(bargSeller = {{\(-1\), 0}, {1/2, 0}, {0, 0}, {1/2, 0}, {0, 0}, {0}, \(-1\)};\)\), "\[IndentingNewLine]", \(\(bargBuyer = {{0, 1}, {0, \(-1\)/2}, {0, 0}, {0, \(-1\)/2}, {0, 0}, {0}, \(-1\)};\)\)}], "Input"], Cell[BoxData[ \(\(uniformTypes = {{0, 1}, {1}};\)\)], "Input"], Cell[BoxData[ \(\(truthfulBidding = {{}, {1}, {0}};\)\)], "Input"], Cell[BoxData[ \(debug[x___] := If[False, Print[x]]\)], "Input"], Cell[BoxData[ \(\(\( (*\ Make\ 0*Infinity\ evaluate\ to\ 0. \ \ Thanks\ to\ Daniel\ Lichtblau\ \ of\ \(\(WRI\)\(.\)\)\ *) \)\(\[IndentingNewLine]\)\(\(Unprotect[ DirectedInfinity];\)\n DirectedInfinity /: Unevaluated[0*DirectedInfinity[_]] := 0\n DirectedInfinity /: Unevaluated[0*DirectedInfinity[]] := 0\)\)\)], "Input"], Cell[BoxData[{ \(Unprotect[Min, Max]; \ \ (*\ Why\ aren' t\ these\ identities\ \(\(automatic\)\(?\)\)\ \ *) \[IndentingNewLine]Min[x_, \(-Infinity\)] := \(-Infinity\)\), "\n", \(Min[x_, \(+Infinity\)] := x\ \ \ (*\ The\ only\ of\ these\ identities\ that' s\ built\ \(\(in\)\(.\)\)\ *) \), "\[IndentingNewLine]", \(Max[x_, \(-Infinity\)] := x\), "\[IndentingNewLine]", \(Max[x_, \(+Infinity\)] := \(+Infinity\)\), "\[IndentingNewLine]", \(\(Protect[Min, Max];\)\)}], "Input"], Cell[BoxData[ \(\(\( (*\ The\ cdf\ given\ a\ piecewise\ uniform\ \(\(pdf\)\(.\)\)\ *) \)\(\ \[IndentingNewLine]\)\(\(F[\(-Infinity\)] = 0;\)\[IndentingNewLine] \(F[\(+Infinity\)] = 1;\)\[IndentingNewLine] F[x_] := Sum[If[d[\([i]\)] \[LessEqual] x < d[\([i + 1]\)], 1, 0]*\((f[\([i]\)]*\((x - d[\([i]\)])\) + Sum[f[\([j]\)]*\((d[\([j + 1]\)] - d[\([j]\)])\), {j, 1, i - 1}])\), {i, 1, Length[d] - 1}]\)\)\)], "Input"], Cell[BoxData[{ \(\(argMax::usage = "\";\)\), "\n", \(\(SetAttributes[argMax, HoldFirst];\)\), "\n", \(argMax[f_, dom_List] := Fold[If[f[#1] \[GreaterEqual] f[#2], #1, #2] &, First[dom], Rest[dom]]\)}], "Input"], Cell[BoxData[ \(cons[a_, l_] := Prepend[l, a]\)], "Input"], Cell[BoxData[{ \(arbAux[{a_}] := {a}\), "\[IndentingNewLine]", \(arbAux[{{c1_, m_, b_}, {c2_, r___}, r2___}] := Which[\[IndentingNewLine]{r} \[Equal] {}, cons[{c1, m, b}, arbAux[{{c2, m, b}, r2}]], \[IndentingNewLine]True, cons[{c1, m, b}, arbAux[{{c2, r}, r2}]]]\)}], "Input"], Cell[BoxData[ \(\(\( (*\ Add\ Redundant\ Boundaries . \ Returns\ new\ \(\({c, m, b}\)\(.\)\)\ *) \)\(\[IndentingNewLine]\)\(arb[c_, m_, b_, d_] := Module[{x}, x = arbAux[ Sort[Join[Transpose[{cons[\(-Infinity\), c], m, b}], Transpose[{Complement[d, c]}]], First[#1] < First[#2] &]]; \[IndentingNewLine]cons[ Rest[First /@ x], Transpose[Rest /@ x]]]\)\)\)], "Input"], Cell[BoxData[ \(\(\( (*\ Remove\ Redundant\ \(\(Boundaries\)\(.\)\)\ \ *) \)\(\[IndentingNewLine]\)\(rrb[{}, m_, b_] := {{}, m, b}\[IndentingNewLine] rrb[{c1_, c___}, {m1_, m1_, m___}, {b1_, b1_, b___}] := rrb[{c}, {m1, m}, {b1, b}]\[IndentingNewLine] rrb[{c1_, c___}, {m1_, m___}, {b1_, b___}] := MapThread[cons, {{c1, m1, b1}, rrb[{c}, {m}, {b}]}]\)\)\)], "Input"], Cell[BoxData[ \(mm[a_, b_, x_] := Min[b, Max[a, x]]\)], "Input"], Cell[BoxData[ \(x0[i_, j_, a_] := \((p6[\([i]\)] - p7*b[\([j]\)] - a)\)/\((p7* m[\([j]\)])\)\)], "Input"], Cell[BoxData[ \(y0[i_, j_, a_] := \((p6[\([i + 1]\)] - p7*b[\([j]\)] - a)\)/\((p7* m[\([j]\)])\)\)], "Input"], Cell[BoxData[ \(x[i_, j_, a_] := If[p7*m[\([j]\)] > 0, x0[i, j, a], y0[i, j, a]]\)], "Input"], Cell[BoxData[ \(y[i_, j_, a_] := If[p7*m[\([j]\)] > 0, y0[i, j, a], x0[i, j, a]]\)], "Input"], Cell[BoxData[ \(\(\(\(OLD = 0\) \)\(;\)\(\ \ \)\( (*\ for\ debugging\ *) \)\)\)], "Input"], Cell[BoxData[ \(p[i_, j_, a_] := \((F[mm[c[\([j]\)], c[\([j + 1]\)], y[i, j, a]]] - F[mm[c[\([j]\)], c[\([j + 1]\)], x[i, j, a]]])\)* If[OLD \[Equal] 0, 1, \((F[c[\([j + 1]\)]] - F[c[\([j]\)]])\)]\)], "Input"], Cell[BoxData[ \(xy[i_, j_, a_] := 1/2*\((mm[c[\([j]\)], c[\([j + 1]\)], x[i, j, a]] + mm[c[\([j]\)], c[\([j + 1]\)], y[i, j, a]])\)\)], "Input"], Cell[BoxData[ \(eu[t_, a_] := Sum[If[p7*m[\([j]\)] \[Equal] 0, If[If[OddQ[i], p6[\([i]\)] - p7*b[\([j]\)] < a < p6[\([i + 1]\)] - p7*b[\([j]\)], p6[\([i]\)] - p7*b[\([j]\)] \[LessEqual] a \[LessEqual] p6[\([i + 1]\)] - p7*b[\([j]\)]], Evaluate[\((p1[\([i]\)]*t + p2[\([i]\)]*a + 1/2*\((c[\([j]\)] + c[\([j + 1]\)])\)*\((p3[\([i]\)] + p4[\([i]\)]*m[\([j]\)])\) + p4[\([i]\)]*b[\([j]\)] + p5[\([i]\)])\)*\((F[c[\([j + 1]\)]] - F[c[\([j]\)]])\)], 0], If[c[\([j]\)] \[Equal] \(-Infinity\) || c[\([j + 1]\)] \[Equal] Infinity, 0, \((p1[\([i]\)]*t + p2[\([i]\)]*a + \((p3[\([i]\)] + p4[\([i]\)]*m[\([j]\)])\)* xy[i, j, a] + p4[\([i]\)]*b[\([j]\)] + p5[\([i]\)])\)* p[i, j, a]]], {i, 1, Length[p1]}, {j, 1, Length[m]}]\)], "Input"], Cell[BoxData[ \(abounds[] := Union[Flatten[{Table[ p6[\([i]\)] - p7*\((m[\([j]\)]*c[\([j]\)] + b[\([j]\)])\), {i, 2, Length[p1]}, {j, 2, Length[m]}], Table[p6[\([i]\)] - p7*\((m[\([j]\)]*c[\([j + 1]\)] + b[\([j]\)])\), {i, 2, Length[p1]}, {j, 1, Length[m] - 1}]}]]\)], "Input"], Cell[BoxData[{ \(\(maxima::usage = "\";\)\), "\[IndentingNewLine]", \(maxima[f_, x_] := Module[{sol}, \[IndentingNewLine]sol = Check[Solve[D[f, x] \[Equal] 0, x], \((Print["\", f]; Abort[])\)]; \[IndentingNewLine]If[ sol === {} || sol === {{}} || D[f, {x, 2}] \[GreaterEqual] 0, {}, {sol[\([1, 1, 2]\)]}]]\)}], "Input"], Cell[BoxData[ \(\(solveFor[var_]\)[{left_, right_}] := Module[{sol}, \[IndentingNewLine]sol = Check[Solve[left \[Equal] right, var], \((Print["\", var, "\<][{\>", left, "\<,\>", right, "\<}]\>"]; {})\)]; \[IndentingNewLine]If[ sol === {} || sol === {{}}, Return[{}]]; \[IndentingNewLine]\(#[\([1, 2]\)] &\) /@ sol]\)], "Input"], Cell[BoxData[ \(\(\( (*\ MidPoints . \ Take\ a\ 1 D\ list\ of\ boundary\ points\ and\ return\ points\ between\ the\ \ boundaries, \ including\ one\ just\ before\ the\ first\ boundary\ and\ just\ after\ \ the\ \(\(last\)\(.\)\)\ *) \)\(\[IndentingNewLine]\)\(\(mp[{}] = {0};\)\ \[IndentingNewLine] mp[l_] := \(\((First[#] + Last[#])\)/2 &\) /@ Partition[Join[{First[l] - 1}, l, {Last[l] + 1}], 2, 1]\)\)\)], "Input"], Cell[BoxData[ \(\(\( (*\ Best\ Action\ for\ Type . \ \ Takes\ a\ specific\ type\ and\ action - utility\ pairs\ and\ returns\ the\ action\ with\ greatest\ utility\ \ for\ that\ \(\(type\)\(.\)\)\ *) \)\(\[IndentingNewLine]\)\( (*\ TODO : \ tiebreaking\ *) \)\(\[IndentingNewLine]\)\(bat[t0_, au_] := First@argMax[\((#[\([2]\)] /. t \[Rule] t0)\) &, au]\)\)\)], "Input"], Cell[BoxData[ \(bat[t0_, a_] := argMax[Simplify[eu[t0, # /. t \[Rule] t0]] &, a]\)], "Input"], Cell[BoxData[ \(\(\( (*\ Best\ Response\ give\ game\ params, \ type\ dist, \ and\ strategy\ \(\({c, m, b}\)\(.\)\)\ *) \)\(\[IndentingNewLine]\)\(\(br[{p1a_, p2a_, p3a_, p4a_, p5a_, p6a_, p7a_}, {d0_, f0_}]\)[{c0_, m0_, b0_}] := Module[{ab, au1, u2, a2, au2, au, ca, cu, pairs, tb, actions, i}, \[IndentingNewLine]debug["\", b0]; \[IndentingNewLine]p1 = p1a; p2 = p2a; p3 = p3a; p4 = p4a; p5 = p5a; \[IndentingNewLine]p6 = Join[{\(-Infinity\)}, p6a, {\(+Infinity\)}]; \[IndentingNewLine]p7 = p7a; \[IndentingNewLine]d = Join[{\(-Infinity\)}, d0, {\(+Infinity\)}]; \[IndentingNewLine]f = Join[{0}, f0, {0}]; \[IndentingNewLine]{c, m, b} = arb[c0, m0, b0, d0]; \[IndentingNewLine]debug["\", c0, "\<, \>", m0, "\<, \>", b0, "\<, \>", d0, "\<] = \>", arb[c0, m0, b0, d0]]; \[IndentingNewLine]c = Join[{\(-Infinity\)}, c, {\(+Infinity\)}]; \[IndentingNewLine]ab = Sort[Union@Join[{\(-Infinity\)}, abounds[], {Infinity}], Less]; \[IndentingNewLine]debug["\", \ {c, m, b, p1, p6, p7}]; \[IndentingNewLine]debug["\", ab]; \[IndentingNewLine]debug["\", \ \((First[#] < a < Last[#] &)\) /@ Partition[ab, 2, 1]]; \[IndentingNewLine] (*\ action - utility\ pairs\ at\ action\ boundaries\ *) \[IndentingNewLine]au1 \ = \({#, eu[t, #]} &\) /@ Select[ab, \(-Infinity\) < # < Infinity &]; \[IndentingNewLine]debug["\", au1]; \[IndentingNewLine] (*\ \(debug["\", eu[t, 2/3 v - 1/2]];\)\ *) \[IndentingNewLine] (*\ best\ auction - utility\ pairs\ between\ action\ boundaries\ \ *) \[IndentingNewLine]u2 = \(Refine[ FullSimplify[ eu[t, a] /. DirectedInfinity[i_] \[Rule] i*10^100, First[#] < a < Last[#] && \(-10^100\) < a < 10^100], First[#] < a < Last[#] && \(-10^100\) < a < 10^100] &\) /@ Partition[ab, 2, 1]; \[IndentingNewLine]a2 = \((\(maxima[#, a] &\) /@ u2)\); \[IndentingNewLine]debug["\", Transpose[{a2, u2}]]; \[IndentingNewLine]au2 = Flatten /@ Select[Transpose[{a2, u2}], Length@First[#] \[NotEqual] 0 &]; \[IndentingNewLine] (*\ \(debug["\", au1, "\< -- au2 = \>", au2];\)\ *) \[IndentingNewLine]au2 = \((\({First[#], Last[#] /. a \[Rule] First[#]} &\) /@ au2)\); \[IndentingNewLine]au = Join[au1, au2]; \[IndentingNewLine]debug["\", au]; {ca, cu} = Transpose[au]; \[IndentingNewLine]pairs = Union@\((Sort /@ Select[Distribute[{ca, ca}, List], First[#] =!= Last[#] &])\); \[IndentingNewLine]debug["\", pairs]; \[IndentingNewLine]tb = Sort[Union[Take[c, {2, \(-2\)}], Select[Flatten[solveFor[t] /@ pairs], Im[#] \[Equal] 0 &]], Less]; \ \ (*\ don' t\ think\ we\ need\ c\ there\ *) \[IndentingNewLine]actions = \ \((\(bat[#, ca] &\) /@ mp[tb])\); \[IndentingNewLine]debug["\", bat[1/6, ca]]; \[IndentingNewLine]debug["\", {tb, actions, mp[tb]}]; \[IndentingNewLine]rrb[ tb, \(D[#, t] &\) /@ actions, actions /. t \[Rule] 0]\[IndentingNewLine]]\)\)\)], "Input"], Cell[BoxData[ \(\(\( (*\ Best\ Responses\ for\ an\ asymmetric\ game . \ \ Takes\ a\ pair\ of\ \ game\ param\ sets\ \((utility\ function\ for\ agent\ 1\ and\ 2)\), \ pair\ of\ type\ dists, \ and\ a\ pair\ of\ strategies . \ \ Returns\ new\ pair\ of\ \ \(\(strategies\)\(.\)\)\ *) \)\(\ \)\(\[IndentingNewLine]\)\(\(abr[{u1_, u2_}, {t1_, t2_}]\)[{s1_, s2_}] := {\(br[u1, t2]\)[ s2], \(br[u2, t1]\)[s1]}\)\)\)], "Input"], Cell[BoxData[ \( (*\ USAGE : \ FixedPoint[br[game, types], seedStrat, maxIterations]\ *) \)], "Input"] }, FrontEndVersion->"5.0 for Microsoft Windows", ScreenRectangle->{{0, 1400}, {0, 977}}, AutoGeneratedPackage->None, WindowSize->{656, 960}, WindowMargins->{{-2, Automatic}, {-3, Automatic}} ] (******************************************************************* Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. *******************************************************************) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[1754, 51, 263, 5, 70, "Input"], Cell[2020, 58, 217, 3, 70, "Input"], Cell[2240, 63, 162, 2, 50, "Input"], Cell[2405, 67, 166, 3, 50, "Input"], Cell[2574, 72, 325, 6, 90, "Input"], Cell[2902, 80, 143, 2, 30, "Input"], Cell[3048, 84, 155, 2, 30, "Input"], Cell[3206, 88, 283, 5, 70, "Input"], Cell[3492, 95, 182, 3, 50, "Input"], Cell[3677, 100, 174, 3, 50, "Input"], Cell[3854, 105, 156, 2, 30, "Input"], Cell[4013, 109, 259, 4, 50, "Input"], Cell[4275, 115, 66, 1, 30, "Input"], Cell[4344, 118, 70, 1, 30, "Input"], Cell[4417, 121, 67, 1, 30, "Input"], Cell[4487, 124, 349, 6, 90, "Input"], Cell[4839, 132, 532, 10, 130, "Input"], Cell[5374, 144, 489, 9, 150, "Input"], Cell[5866, 155, 380, 8, 90, "Input"], Cell[6249, 165, 62, 1, 30, "Input"], Cell[6314, 168, 311, 5, 90, "Input"], Cell[6628, 175, 470, 10, 150, "Input"], Cell[7101, 187, 408, 8, 130, "Input"], Cell[7512, 197, 68, 1, 30, "Input"], Cell[7583, 200, 130, 3, 30, "Input"], Cell[7716, 205, 134, 3, 30, "Input"], Cell[7853, 210, 104, 2, 30, "Input"], Cell[7960, 214, 104, 2, 30, "Input"], Cell[8067, 218, 101, 2, 30, "Input"], Cell[8171, 222, 254, 5, 70, "Input"], Cell[8428, 229, 168, 3, 50, "Input"], Cell[8599, 234, 1007, 18, 250, "Input"], Cell[9609, 254, 366, 7, 110, "Input"], Cell[9978, 263, 511, 10, 110, "Input"], Cell[10492, 275, 451, 9, 110, "Input"], Cell[10946, 286, 467, 10, 130, "Input"], Cell[11416, 298, 402, 6, 110, "Input"], Cell[11821, 306, 104, 2, 30, "Input"], Cell[11928, 310, 3876, 71, 930, "Input"], Cell[15807, 383, 465, 8, 90, "Input"], Cell[16275, 393, 115, 2, 30, "Input"] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)