(* Voting Theory Using Mathematica
by
Alexander Tabarrok
This package implements a number of functions from Donald Saari's book "The Geometry of Voting" (Springer-Verlag, 1994). The package is Copyright (c) (1997) by Alexander Tabarrok.
Version 1.5
May 29, 1998
This package is copyright 1997 by Alexander Tabarrok. This package may be copied in its entirety for nonprofit purposes only.
Sale, other than for the direct cost of the media,
is prohibited. This copyright notice must
accompany all copies. Published work using this package must cite Alexander Tabarrok, the name of the package, and the version number.
The author make no representations, express or
implied, with respect to this documentation or
the software it describes and contains, including
without limitations, any implied warranties of
mechantability or fitness for a particular purpose,
all of which are expressly disclaimed. The author
shall in no event be liable for any indirect,
incidental, or consequential damages.
Comments, bugs, and improvements may be reported to:
Alexander Tabarrok
Department of Economics
Ball State University
Muncie, IN, 47306
USA
EMail: 00attabarrok@bsu.edu (note: the first two characters are zeroes).
*)
StylePrint["This package is Copyright 1997, Alexander Tabarrok. If you use this package in academic work please cite, Tabarrok, Alexander. Voting Theory with Mathematica - Computer Software, Ball State University, 1997. Thank you.","Section"]
BeginPackage["Voting`",{"LinearAlgebra`CrossProduct`",
"Geometry`VertexEnumeration`","DiscreteMath`ComputationalGeometry`","Algebra`InequalitySolve`","Graphics`Legend`","Utilities`FilterOptions`"}]
(*USAGE - PROGRAMS FOR ANALYSIS OF POSITIONAL VOTING*)
PositionalVoteTally::usage ="PositionalVoteTally[P,s] calculates the voting tally when the profile of voters is given by P and the voting system is given by s. P is a 6 unit vector where P[i] represents the proportion of voters of type i. (For the six types see VoterTypes[]). s =[0,1/2]. s=0 represents plurality rule, s=1/3 is the Borda Count, s=1/2 is anti-plurality rule."
PositionalVoteTally4::usage="PositionalVoteTally4[P,{w1,w2,w3}] calculates the vote tally when there are four candidates and the voting system is w1,w2,w3. Note that w1+w2+w3 must equal 1 and w1>=w2>=w3 for a positional vote system. The output is simply the proportional vote for each of the four candidates. P must be a 24 vector. The order of the 24 vector is the same as Permutations[{a,b,c,d}]."
PVT4::usage="Short form for PositionalVoteTally4."
PlotTally::usage="PlotTally[P,s,size,opts] plots the vote tally for a particular profile P and vote system s. It has a size option as well as other graphic options. Note that if other options are specified then the size option must be specified."
VoterTypes::usage = "VoterTypes[] prints all the possible rankings of the three candidates C1,C2,C3. When called with a voting profile P, VoterTypes[P] prints the proportion of voters of each type."
FindProfile::usage="FindProfile[q0,q1] finds a set of profiles such that for any profile in the set the outcome under plurality rule (s=0)is q0 and the outcome under anti-plurality rule (s=1/2) is q1 where q0 and q1 are voting tallies eg. {.2,.4,.4}, {.4,.2,.4}. In other words, FindProfile finds a voting profile such the outcome under plurality and anti-plurality rules is essentialy as different as you want it to be. Some conditions on q1,q2 must be satisfied q1<<1/2, q2<<1/2, sum q1=1, sum q2=1 and for i=1,2,3 q2[[i]]-1/2 * q1[[i]] => 0. FindProfile checks for these conditions. See also LegitProfileArea"
PlotPL::usage="PlotPL[P,size,opts] plots the procedure line for the profile P in the representation triangle. The regions 1,2,3,4,5,6 are marked and represent the voting outcomes (and also the voter types, see VoterTypes[] for a list). The s=0 plurality rule outcome is denoted by a red point, the Borda Count (s=1/3) by a green point and the anti-plurality rule outcome (s=1/2) by a blue point. PlotPL[] plots the representation triangle alone. The size parameter is an option which changes the size of the points, on low res monitors the default value of .03 is to large. opts can include any graphics options. Note that if options are specified then size must also be specified."
PlotPLLines::usage="PlotPLLines[P,size] takes a profile and creates a graphic procedure line but it does not show the line or the RTriangle. It is useful when one wants to create a number of PL's and plot them together in one diagram."
PlotPHull::usage="PlotPHull[profile,size] plots the procedure hull when there are four candidates. The fourth candidate's tally is suppressed (it is 1 - the first three tallies). The plurality rule point is given in red, the top-two (ie, {1/2,1/2,0,0}) equal outcome is given in light blue, the anti-plurality rule (top three equal={1/3,1/3,1/3,0}) is given in dark blue. The Borda Count outcome {1/2,1/3,1/6,0} is given in green."
Options[PlotPHull]={size->.01,thick->.01,MakeLegend->True,LegendPosition->{1,-.55},LegendTextSpace->10,LegendSize->0.7,DrawPolygon->True}
f::usage="The function f[P,s] is the basic function underlying PlotPL and PositionalVoteTally, it computes the vote tally given any profile, P, and voting system s. Unlike PositionalVoteTally it simply returns the vote tally in the order (C1,C2,C3)."
fP4::usage="The function fP4[P,{w1,w2,w3} is the basic function underlying PlotPHull and PositionalVoteTally4 it computes the vote tally for any profile, P, and vote system {w1,w2,w3}. Unlike PVT$ it simply returns the vote tally in the order {C1,C2,C3,C4}."
LegitProfileArea::usage="LegitProfileArea[q0,size,opts] takes q0 and draws within the R Triangle the area within which q1 must be if Saari's Theorem 2.4.6 is to be satisfied. Clicking once on a graph and holding down the ctrl key prints the x,y coordinates of the cursor point in the bottom right corner of the screen. Using this capability we can easily find points in any region such that the conditions for T.2.4.6 hold. qo is drawn as a red point. The size of the point has a default value of .03 but can be adjusted if necessary. Note that if any options are used the size variable must be specified."
SimpleClosedPath::usage="Gives a simple closed path of a set of points."
VotingHull::usage="VotingHull[s], plots the convex hull of voting outcomes which are possible with voting system s."
SumToOne::usage="Takes any vector and normalizes it so the elements sum to one"
AllProfiles1::usage="AllProfiles[q,s,opts] finds (the vertexes of) all profiles which lead to outcome q under voting system s, ie. if P is any of the outputed profile vertices or any linear combination of the outputed vertices then f[P,s]=q . AllProfiles can take some time to work, using the option MonitoringFile->\"stdout\" prints some intermediary output as the function evaluates."
CreatePoint::usage="CreatePoint[P_,s_,size_:.025] creates graphic points representing vote tallies for profile P and system s but does not plot them. It is sometimes useful when you want to create a table of points and then plot them all together in the RTriangle."
DefineNames::usage="DefineNames[{\"name1\",\"name2\",\"name3\"}] lets you change the names of the candidates from C1,C2,C3 to something more descriptive. DefineNames3 affects PositionalVoteTally, and BinaryVotes only. Note the curly brackets and quotation marks are necessary."
DefineNames4::usage="Lets you define the names for PVT4."
RemoveCandidate::usage="RemoveCandidate[profile, cand #] takes a 24 vector and elminates candidate # (cand #) to produce the a six vector. RemoveCandidate generates profiles which can be used to ask questions like what would have happenned if candidate 2 had dropped out of the election."
(*USAGE - PROGRAMS FOR ANALYSIS OF PAIRWISE OR BINARY VOTING*)
BinaryVotes::usage="The function BinaryVotes[P_] takes a profile vector and calculates the binary vote tallies, ie. it calculates the vote tallies of C1 v C2, C2 v C3 and C3 v C1. It returns the numerical vote tally followed by the ordinal vote where the numerical vote tally is calculated as (% voting for Ci- % voting for Cj)."
F3::usage="F3[P_] is the 'primitive' underlying BinaryVotes. F3 takes a profile vector, calculates the cyclic coordinates {d,alpha,beta} and then the binary election outcomes d alpha + (1-d) beta."
PlotBV::usage="PlotBV[P] takes the profile P finds the implied binary votes outcomes and plots these within the representation cube."
BinaryPoint::usage="BinaryPoint[P,size] takes a profile, P, and calculates the implied binary outcomes. Unlike PlotBV it does not draw a figure, Binary Point returns a 3D graphics object which should then be named. BinaryPoint can be used to generate several different points which can then be shown together within the R Cube. The size parameter is optional."
PlotCone::usage="PlotCone[q] takes the binary outcomes q, calculates the implied profile cone and plots the cone along with q in the representation cube."
ConeArea::usage="ConeArea[q] takes the binary outcome, finds the vertices of the appropriate profile cone projection and calculates the area using the cross product formula. If called, the package LinearAlgebra`CrossProduct` will be read in (if it is on the search path!)."
VLength::usage="The length of a vector."
ToMatrix::usage="Converts a set of equations from Solve or ToRules[Reduce[]] into matrix form. ToMatrix[[1]] =m, ToMatrix[[2]]=x, ToMatrix[[3]]=b such that m.x=b ."
AllProfiles2::usage="AllProfiles2[q,opts] finds the vertexes of all profiles which lead to the pairwise outcome q. The option is MonitoringFile->\"stdout\" which prints some intermediary output as the function evaluates."
(*USAGE - PROGRAMS FOR COMPARING POSITIONAL AND PAIRWISE VOTING*)
F4::usage="Primitive which returns the cyclic coordinates which can be used to compare pairwise and positional voting schemes."
PosPairCompare::usage="PosPairCompare[P,s] takes a profile vector, P, and a voting system, s, and returns the pairwise vote C1 v C2 along with the positional vote C1,C2,C3. Note that the positional C1, C2 ranking can reverse the pairwise C1,C2 ranking."
PlotPosPair::usage="PlotPosPair[P,s] takes a profile vector, P, and a voting system, s, and plots the alpha, beta pair (from Saari's positional group coordinates) and the vote outcome. The vote outcome is in red. If the red block is closer to the C1-C3 axis this indicates C1>C2 if the red block is closer to the C2-C3 axis C2>C1. (See also PosPairCompare for these rankings)."
PosPairPoints::usage="PosPairPoints[P,s,size] generates points in the RTriangle representing the plurality rankings and the C1-C2 pairwise rankings. It is used when a lot of points need to be created."
PlotPolygon4::usage="PlotPolgyon4[q,s,bv,thick,size,opts] plots in the RTriangle areas which represent all profiles P, such that under voting system s, a profile from P leads to positional vote outcome q and C1 v C1 binary vote bv. Thickness determines the thickness of the lines describing the profile areas the default is 0.01, size determines the size of point q, the default is 0.04. Opts are any of the standard plot options."
AllProfiles4::usage="AllProfiles4[q,s,bv,Opts] finds the vertices of the set of all profiles P such that under voting system s a profile from the set P generates positional vote outcome q and C1 v C2 binary outcome bv. The option is MonitoringFile->\"stdout\" which prints some intermediary output as AllProfiles4 evaluations."
(*USAGE - PROGRAMS FOR THE ANALYSIS OF APPROVAL VOTING*)
AVOutcomes::usage="AVOutcomes[P] takes a preference profile and returns the convex hull of the vertices of the possible AV outcomes plus the ballot matrix under which each outcome could occur."
Options[AVOutcomes]={AllPoints->False}
PlotAVOutcomes::usage="PlotAVOutcomes[P] takes a preference profile and plots the convex hull of AV outcomes within the RTriangle."
PosAVCompare::usage="PosAVCompare[q,s] takes output q from voting system s and shows all the AV outcomes which are also consistent with outcome q. PosAVCompare calls the function AllProfiles1[q,s] to find the vertices of all preferences profiles consistent with {q,s}, it then creates all AV outcomes consistent with those preferences and finally it plots the convex hull of the AV outcomes. Warning! - make sure q is indeed a possible outcome under system s."
(*USAGE - PROGRAMS FOR THE ANALYSIS OF CUMULATIVE VOTING*)
CumulativeOutcomes::usage="CumulativeOutcomes[P] takes a preference profile and returns the convex hull of the vertices of the possible Cumulative outcomes plus the ballot matrix under which each outcome could occur."
Options[CumulativeOutcomes]={AllowIndifference->False}
PlotCumulativeOutcomes::usage="PlotCumulativeOutcomes[P] takes a preference profile and plots the convex hull of AV outcomes within the RTriangle."
PosCumulativeCompare::usage="PosCumulativeCompare[q,s] takes output q from voting system s and shows all the AV outcomes which are also consistent with outcome q. PosCumulativeCompare calls the function AllProfiles1[q,s] to find the vertices of all preferences profiles consistent with {q,s}, it then creates all AV outcomes consistent with those preferences and finally it plots the convex hull of the AV outcomes. Warning! - make sure q is indeed a possible outcome under system s."
AllowIndifference::usage="An option which can be used in functions involving cumulative voting. AllowIndifference->False is the default, AllowIndifference-True allows cumulative voters the option of casting a ballot indicating indifference."
AV4::usage="Approval Vote for four candidates."
(* Usage- STRATEGIC VOTING*)
PayoffMatrix::usage="PayoffMatrix[P,s,pfac] generates the payoff for every possible combination of strategic moves."
FindNash::usage="FindNash[P,s,pfac,options] takes a voter profile P, a voter system s, and a percent factor, pfac, and it finds every Nash Equilibria where pfac of each voter type may try to manipulate the outcome. The function returns A) the strategy vector where a indicates that the voter type is following a sincere strategy and 2 indicates an insincere strategy, B) the payoff vector, C) the ordinal and cardinal tallies. There are two options whose defaults are Order->True and NewOnly->False. If Order->False FindNash returns a list of NE where the vote tallies are unordered i.e. in the form C1,C2,C3. NewOnly->True shows only those NE where the outcome is different from the all sincere outcome."
Options[FindNash]={Order->True,NewOnly->False}
PlotNash::usage="PlotNash[P,s,pfac,options] takes a vote vector P, a voting system s, and a percent factor pfac and returns a Graphics object where each NE is a Point. The graphics object can be combined with other graphics via Show. There are three options whose defaults are Color->.82, Size->.022, and NewOnly->False. Color and Size control the color and size of the plotted points, NewOnly->True only plots NE where the ordinal outcome is different from the all sincere outcome."
Options[PlotNash]={Color->0.82,Size->.022,NewOnly->False}
ReArrange::usage=""
(*USAGE - GRAPHICS PRIMITIVES*)
RCube::usage="Graphics primitives for showing the Representation Cube. Can be seen via Sbow[RCube]."
RCubeOpts::usage="Options used in showing the RCube, eg, Show[Rcube,RCubeOpts]."
CyclicRegions::usage="Graphics primitives showing the cyclic regions within the RCube."
CondorcetRegionC1::usage="Graphics primitives showing the C1 Condorcet winner region within the RCube."
CondorcetRegionC2::usage="Graphics primitives showing the C2 Condorcet winner region within the RCube."
CondorcetRegionc3::usage="Graphics primitives showing the C3 Condorcet winner region within the RCube."
simpleplot::usage="A simple plot used in creating the RTriangle."
RTriangle::usage="The Rtriangle is a graphic used to analyze positional voting."
Pfp={p1,p2,p3,p4,p5,p6}
Begin["`Private`"]
(*PRIMITIVE MATRICES USED IN VARIOUS CALCULATIONS*)
Wp={{1,0,0},{1,0,0},{0,0,1},{0,0,1},{0,1,0},{0,1,0}}
Wap={{1/2,1/2,0},{1/2,0,1/2},{1/2,0,1/2},{0,1/2,1/2},{0,1/2,1/2},{1/2,1/2,0}}
binmat4={{1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 1, 1, -1, -1, 1,-1, 1, 1, -1, -1, 1, -1},
{1, 1, 1, 1, 1, 1, 1, 1, -1, -1, 1, -1, -1, -1, -1, -1, -1,
-1, 1, 1, 1, -1, -1, -1},
{1, 1, 1, 1, 1, 1, 1, 1, 1, -1, -1, -1, 1, 1, 1, -1, -1, -1,
-1, -1, -1, -1, -1, -1},
{1, 1, -1, -1, 1, -1, 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1,
-1, 1, -1, 1, 1, -1, -1},
{1, 1, 1, -1, -1, -1, 1, 1, 1, 1, 1, 1, 1, -1, 1, 1, -1, -1,
-1, -1, -1, -1, -1, -1},
{1, -1, 1, 1, -1, -1, 1, -1, 1, 1, -1, -1, 1, 1, 1, 1, 1, 1,
-1, -1, -1, -1, -1, -1}}
(* Strategies=
{{p1,p2,p3,p4,p5,p6},
{p1 + p6, p2, p3, p4, p5, 0},
{p1, p2, p3, p4 + p5, 0, p6},
{p1 + p6, p2, p3, p4 + p5, 0, 0},
{p1, p2, p3, 0, p4 + p5, p6},
{p1 + p6, p2, p3, 0, p4 + p5, 0},
{p1, p2, p3, p4 + p5, 0, p6},
{p1 + p6, p2, p3, p4 + p5, 0, 0},
{p1, p2 + p3, 0, p4, p5, p6},
{p1 + p6, p2 + p3, 0, p4, p5, 0},
{p1, p2 + p3, 0, p4 + p5, 0, p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0},
{p1, p2 + p3, 0, 0, p4 + p5, p6},
{p1 + p6, p2 + p3, 0, 0, p4 + p5, 0},
{p1, p2 + p3, 0, p4 + p5, 0, p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0},
{p1, 0, p2 + p3, p4, p5, p6},
{p1 + p6, 0, p2 + p3, p4, p5, 0},
{p1, 0, p2 + p3, p4 + p5, 0, p6},
{p1 + p6, 0, p2 + p3, p4 + p5, 0, 0},
{p1, 0, p2 + p3, 0, p4 + p5, p6},
{p1 + p6, 0, p2 + p3, 0, p4 + p5, 0},
{p1, 0, p2 + p3, p4 + p5, 0, p6},
{p1 + p6, 0, p2 + p3, p4 + p5, 0, 0},
{p1, p2 + p3, 0, p4, p5, p6},
{p1 + p6, p2 + p3, 0, p4, p5, 0},
{p1, p2 + p3, 0, p4 + p5, 0, p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0},
{p1, p2 + p3, 0, 0, p4 + p5, p6},
{p1 + p6, p2 + p3, 0, 0, p4 + p5, 0},
{p1, p2 + p3, 0, p4 + p5, 0, p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0},
{0, p2, p3, p4, p5, p1 + p6},
{p1 + p6, p2, p3, p4, p5, 0},
{0, p2, p3, p4 + p5, 0, p1 + p6},
{p1 + p6, p2, p3, p4 + p5, 0, 0},
{0, p2, p3, 0, p4 + p5, p1 + p6},
{p1 + p6, p2, p3, 0, p4 + p5, 0},
{0, p2, p3, p4 + p5, 0, p1 + p6},
{p1 + p6, p2, p3, p4 + p5, 0, 0},
{0, p2 + p3, 0, p4, p5, p1 + p6},
{p1 + p6, p2 + p3, 0, p4, p5, 0},
{0, p2 + p3, 0, p4 + p5, 0, p1 + p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0},
{0, p2 + p3, 0, 0, p4 + p5, p1 + p6},
{p1 + p6, p2 + p3, 0, 0, p4 + p5, 0},
{0, p2 + p3, 0, p4 + p5, 0, p1 + p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0},
{0, 0, p2 + p3, p4, p5, p1 + p6},
{p1 + p6, 0, p2 + p3, p4, p5, 0},
{0, 0, p2 + p3, p4 + p5, 0, p1 + p6},
{p1 + p6, 0, p2 + p3, p4 + p5, 0, 0},
{0, 0, p2 + p3, 0, p4 + p5, p1 + p6},
{p1 + p6, 0, p2 + p3, 0, p4 + p5, 0},
{0, 0, p2 + p3, p4 + p5, 0, p1 + p6},
{p1 + p6, 0, p2 + p3, p4 + p5, 0, 0},
{0, p2 + p3, 0, p4, p5, p1 + p6},
{p1 + p6, p2 + p3, 0, p4, p5, 0},
{0, p2 + p3, 0, p4 + p5, 0, p1 + p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0},
{0, p2 + p3, 0, 0, p4 + p5, p1 + p6},
{p1 + p6, p2 + p3, 0, 0, p4 + p5, 0},
{0, p2 + p3, 0, p4 + p5, 0, p1 + p6},
{p1 + p6, p2 + p3, 0, p4 + p5, 0, 0}}
*)
(*Generate Strategies List*)
ReArrange[P_,vec_]:=(ReplacePart[ReplacePart[P,az P[[vec[[1]]]]+P[[vec[[2]]]],
vec[[2]]],(1-az) P[[vec[[1]]]], vec[[1]]]
)
SList1=Flatten[Outer[List,{{1,1},{1,6}},{{2,2},{2,3}},{{3,3},{3,2}},{{4,4},{4,
5}},{{5,5},{5,4}},{{6,6},{6,1}},1],5]/.{{a_,a_}->dd} ;
SList1=Rest @ Delete[SList1,Position[SList1,dd]] ;
(*SList1=Sort[SList1,Length[#1]"}
(*Matrices for PositionalVoteTally4*)
mat1 = {{1, 0, 0, 0}, {1, 0, 0, 0}, {1, 0, 0, 0}, {1, 0, 0, 0}, {1, 0, 0, 0},
{1, 0, 0, 0}, {0, 1, 0, 0}, {0, 1, 0, 0}, {0, 1, 0, 0}, {0, 1, 0, 0},
{0, 1, 0, 0}, {0, 1, 0, 0}, {0, 0, 1, 0}, {0, 0, 1, 0}, {0, 0, 1, 0},
{0, 0, 1, 0}, {0, 0, 1, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}, {0, 0, 0, 1},
{0, 0, 0, 1}, {0, 0, 0, 1}, {0, 0, 0, 1}, {0, 0, 0, 1}}
mat2 = {{1/2, 1/2, 0, 0}, {1/2, 1/2, 0, 0}, {1/2, 0, 1/2, 0},
{1/2, 0, 1/2, 0}, {1/2, 0, 0, 1/2}, {1/2, 0, 0, 1/2}, {1/2, 1/2, 0, 0},
{1/2, 1/2, 0, 0}, {0, 1/2, 1/2, 0}, {0, 1/2, 1/2, 0}, {0, 1/2, 0, 1/2},
{0, 1/2, 0, 1/2}, {1/2, 0, 1/2, 0}, {1/2, 0, 1/2, 0}, {0, 1/2, 1/2, 0},
{0, 1/2, 1/2, 0}, {0, 0, 1/2, 1/2}, {0, 0, 1/2, 1/2}, {1/2, 0, 0, 1/2},
{1/2, 0, 0, 1/2}, {0, 1/2, 0, 1/2}, {0, 1/2, 0, 1/2}, {0, 0, 1/2, 1/2},
{0, 0, 1/2, 1/2}}
mat3 = {{1/3, 1/3, 1/3, 0}, {1/3, 1/3, 0, 1/3}, {1/3, 1/3, 1/3, 0},
{1/3, 0, 1/3, 1/3}, {1/3, 1/3, 0, 1/3}, {1/3, 0, 1/3, 1/3},
{1/3, 1/3, 1/3, 0}, {1/3, 1/3, 0, 1/3}, {1/3, 1/3, 1/3, 0},
{0, 1/3, 1/3, 1/3}, {1/3, 1/3, 0, 1/3}, {0, 1/3, 1/3, 1/3},
{1/3, 1/3, 1/3, 0}, {1/3, 0, 1/3, 1/3}, {1/3, 1/3, 1/3, 0},
{0, 1/3, 1/3, 1/3}, {1/3, 0, 1/3, 1/3}, {0, 1/3, 1/3, 1/3},
{1/3, 1/3, 0, 1/3}, {1/3, 0, 1/3, 1/3}, {1/3, 1/3, 0, 1/3},
{0, 1/3, 1/3, 1/3}, {1/3, 0, 1/3, 1/3}, {0, 1/3, 1/3, 1/3}}
(*End Primitive Matrices*)
(*PROGRAMS FOR ANALYSIS OF POSITIONAL VOTING*)
PositionalVoteTally[P_List /;Length[P]==6, s_] :=
(Module[{tally,li}, tally = f[SumToOne[P], s];
li=Transpose @ Reverse @ Sort[Transpose @ {tally,CNames3}]/.{{{a_,a_,a_},{c_,d_,e_}}->{{a,a,a},{{c,d,e}}},{{a_,a_,b_},{c_,d_,e_}}->{{a,
a,b},{{c,d},e}},{{a_,b_,b_},{c_,d_,e_}}->{{a,b,b},{c,{d,e}}}};
ColumnForm[{li[[1]],li[[2]]}]
])
(*PositionalVoteTally normalizes the vote vector and calls f to find the outcome. The rest of the function puts the vector in ordinal form and outputs it. Transpose[{tally, CNames3}] creates the matrix {{#votes C1, C1}, {#votes C2,C2}, {#votes C3,C3}}. Sort, sorts from lowest to highest vote according to the first element of each list. Reverse puts in highest to lowest order. Transpose puts ordinal ranks first and the numerical tallies second. The pattern matching places ties within brackets. ColumnForm prints vote tallies and ordinal ranking in column format.*)
PositionalVoteTally4[P_List /;Length[P]==24, {w1_, w2_, w3_}] := (
Module[{tally},
tally=fP4[SumToOne[P],{w1,w2,w3}];
ColumnForm[Reverse @ Sort[Transpose @ {tally,CNames4}] ]
])
PVT4[P_, {w1_, w2_, w3_}] := PositionalVoteTally4[P, {w1, w2, w3}]
fP4[P_,{w1_,w2_,w3_}]:=
Flatten[N[(w1-w2)*P . mat1 + (2 w2 - 2 w3)*P . mat2 +
3 w3*P .mat3] ]
(*PositionalVoteTally4 and the short form PVT4 calculates the vote tally for vote system w1,w2,w3 when there are four candidates. fP4 does the calculations Pos.. formats the output.*)
f[P_,s_]:= (1-2 s) P.Wp + 2 s P.Wap
(*f[P,s] calculates the voting tally using a formula from Saari[1994, Theorem 2.4.2 b, p.56). There are six possible preference profiles each profile implies a certain number of points (depending on the voting system) for first, second, and third place. For example, the type one profile has C1>C2>C3 and the type 5 profile has C2>C3>C1. If there is 1 voter of type 1 and two voters of type 5 then using plurality rule c1 gets 1 vote and c2 gets 2 votes. The plurality voting system is represented by the scoring vector Wp. P Wp returns a 3 row by 6 col matrix where the columns give all the votes to C1,C2,C3. Tally makes use of
theorem 2.4.2. b of Saari that all positional voting vectors are a linear combination of plurality and anti-plurality rule.*)
SumToOne[P_]:=If[Apply[Plus,P]>0,P/Apply[Plus,P],P,P]
VoterTypes[P_:{0,0,0,0,0,0}]:=(Module[ {a},
a=Map[ToString,N[SumToOne[P],4] ];
Print[ TableForm[{
{a[[1]],"Type 1", ToString[ CNames3[[1]] ],">",ToString[ CNames3[[2]] ],">",ToString[ CNames3[[3]] ] },
{a[[2]],"Type 2", ToString[ CNames3[[1]] ],">",ToString[ CNames3[[3]] ],">",ToString[ CNames3[[2]] ] },
{a[[3]],"Type 3", ToString[ CNames3[[3]] ],">",ToString[ CNames3[[1]] ],">",ToString[ CNames3[[2]] ] },
{a[[4]],"Type 4", ToString[ CNames3[[3]] ],">",ToString[ CNames3[[2]] ],">",ToString[ CNames3[[1]] ] },
{a[[5]],"Type 5", ToString[ CNames3[[2]] ],">",ToString[ CNames3[[3]] ],">",ToString[ CNames3[[1]] ] },
{a[[6]],"Type 6", ToString[ CNames3[[2]] ],">",ToString[ CNames3[[1]] ],">",ToString[ CNames3[[3]] ] }}
]]
])
(*VoterTypes takes in a six vector of profiles. If no profiles are inputted the expression :{0,0,0,0,0,0} indicates that P={0,...0}. Profile numbers are converted to strings so Mathematica doesn't start multipying things in the output. The rest of the function prints in column form the number of voters of each type.*)
PlotTally[P_List /;Length[P]==6,s_,size_:.025,opts___]:=(Module[ {list1},
list1=f[SumToOne[P],s];
x1=list1[[1]];y1=list1[[2]];
pts=Graphics[{Hue[0],PointSize[size], Point[{x1,y1}]}];
Show[simpleplot,pts,RTriangle, opts]
] )
PlotPL[]:=Show[simpleplot,RTriangle,Graphics @ Text[CNames3[[3]],{0,0},{0,1}], AxesLabel->{CNames3[[1]],CNames3[[2]]}]
PlotPL[P_List/;Length[P]==6,size_:.025,opts___]:=(Module[ {pts,list1,list2,list3,x1,y1,x2,y2,x3,y3},
list1=f[SumToOne[P],0];
x1=list1[[1]];y1=list1[[2]];
list2=f[SumToOne[P],1/3];
x2=list2[[1]];y2=list2[[2]];
list3=f[SumToOne[P],1/2];
x3=list3[[1]];y3=list3[[2]];
pts=Graphics[{{Hue[0],PointSize[size], Point[{x1,y1}]},{RGBColor[0.4,.65,0],PointSize[size],Point[{x2,y2}]},{Hue[0.6],PointSize[size],Point[{x3,y3}]} }];
Show[simpleplot,pts,Graphics[Line[{{x1,y1},{x3,y3}}]],
RTriangle, Graphics @ Text[CNames3[[3]],{0,0},{0,1}], AxesLabel->{CNames3[[1]],CNames3[[2]]}, opts]
] )
PlotPLLines[P_List /;Length[P]==6,size_:.025]:=Module[{list1,list3},
list1=f[SumToOne[P],0];
list3=f[SumToOne[P],1/2];
{Map[Graphics ,
{{Hue[0],PointSize[size], Point[{list1[[1]],list1[[2]]}]},{Hue[0.6],
PointSize[size],Point[{list3[[1]],list3[[2]]}]} ,{
Line[{{list1[[1]],list1[[2]]},{list3[[1]],list3[[2]]}}] } } ] }
]
PlotPHull[p_List, opts___] :=
( Module[{pt1, pt2, pt3, pt4,posplane,eq,a,b,c,sol1,sol2,lpt1,lpt2,lines,Fregions,Tregions,cbounds,V1,V2,LOptions,POptions,Lsp,Lpos,Lsize},
POptions=FilterOptions[Graphics3D,opts];
LOptions=FilterOptions[Legend,opts];
{Lsp,Lpos,Lsize}={LegendTextSpace,LegendPosition,LegendSize}/.Flatten[{opts}]/.Options[PlotPHull];
{sz,thck,MLegend,poly}={size,thick,MakeLegend,DrawPolygon}/.Flatten[{opts}]/.Options[PlotPHull];
P = SumToOne[p]; pt1 = Drop[fP4[P, {1, 0, 0}], -1];
pt2 = Drop[fP4[P, {1/2, 1/2, 0}], -1];
pt3 = Drop[fP4[P, {1/3, 1/3, 1/3}], -1];
pt4 = Drop[fP4[P, {1/2, 1/3, 1/6}], -1];
eq=a pt1 + b pt2 + c pt3;
eq=Join[eq,{1-eq[[1]]-eq[[2]]-eq[[3]]}];
Off[Solve::svars];
sol1=Map[Solve[{eq[[#[[1]]]]==eq[[#[[2]]]],a+b+c==1},{a,b,c}]&,
{{1,2},{1,3},{1,4},{2,3},{2,4},{3,4}}];
On[Solve::svars];
sol2=Flatten[{a,b}/.sol1,1] ;
cbounds=Map[InequalitySolve[#[[1]] >=0 && #[[1]] <=1 && #[[2]] >=0 && #[[
2]]<=1 && c >=0 && c <=1,c]&,sol2];
Fregions=Position[cbounds,False];
Tregions=Complement[{1,2,3,4,5,6},Flatten @ Fregions];
eq=eq/.Delete[sol1,Fregions];
cbounds=Delete[cbounds,Fregions];
cbounds=cbounds/.{Inequality[a_, LessEqual, c,
LessEqual, b_]->{c->a,c->b},Equal[c,b_]->{c->b,c->b}};
V1=Transpose[cbounds][[1]];
V2=Transpose[cbounds][[2]];
lpt1=Map[Drop[#,-1]&,Flatten[Table[eq[[i]]/.V1[[i]],{i, 1, Length[V1]}],
1]];
lpt2=Map[Drop[#,-1]&,Flatten[Table[eq[[i]]/.V2[[i]],{i, 1, Length[V2]}],
1]];
lines= Map[Line,Transpose[{lpt1,lpt2}]];
lcolors={Hue[0.1],Hue[0.24],Hue[0.45],Hue[.58],Hue[0.72],Hue[0.89]}[[
Tregions]];
lines={Thickness[thck],Transpose[{lcolors,lines}]};
posplane={If[poly,Polygon[{pt1,pt2,pt3}],{Thickness[thck],Line[{pt1, pt2, pt3,pt1}]}],
{PointSize[sz], Hue[0], Point[pt1]},
{PointSize[sz], Hue[0.58],
Point[pt2]}, {PointSize[sz],
Hue[0.72], Point[pt3]},
{PointSize[sz], RGBColor[0.4, 0.65, 0], Point[pt4]}};
legendlabels={
{Hue[0.1], StringJoin[Map[ToString,{CNames4[[1]],"=",CNames4[[2]]}]] },
{Hue[0.24], StringJoin[Map[ToString,{CNames4[[1]],"=",CNames4[[3]]}]] },
{Hue[0.45], StringJoin[Map[ToString,{CNames4[[1]],"=",CNames4[[4]]}]] },
{Hue[0.58], StringJoin[Map[ToString,{CNames4[[2]],"=",CNames4[[3]]}]] },
{Hue[0.72], StringJoin[Map[ToString,{CNames4[[2]],"=",CNames4[[4]]}]] },
{Hue[0.89], StringJoin[Map[ToString,{CNames4[[3]],"=",CNames4[[4]]}]] }}[[Tregions]];
If[MLegend,
ShowLegend[Graphics3D[{posplane,lines},Axes -> True, AxesLabel ->{CNames4[[1]],CNames4[[2]],CNames4[[3]]}, POptions],{legendlabels,LegendTextSpace->Lsp,LegendSize->Ls,LegendPosition->Lpos,LOptions}],
Show[Graphics3D[{posplane,lines},Axes -> True, AxesLabel ->{CNames4[[1]],CNames4[[2]],CNames4[[3]]}, POptions]]
]
])
PlotPHull[p_List /;Length[p]==6,size_,opts___]:=PlotPL[p,size,opts]
(*PLotPHull plots the procedure hull when there are 4 candidates (or if the input is a 6 vector it redirects to PlotPL) - the fourth candidates tally is 1-the first three candidates tally. The first several lines set up all of the various options, these are options on the Legend, Graphics options and options for the function itself. The next couple of lines calculate the three points defining the positional vote plane as well as the Borda Count outcome. eq is the implicit equation of the positional vote plane. We then Solve six equations (one at a time) with the side constraint a+b+c==1. The first equation solved, for example, finds the equation for the line where candidate 1 and candidate 2 are tied, the second for candidates 1 and 3 and so on. Solve returns functions for a and b and c is left a free variable. We then substitute the functions for a and b back into the equations and use inequality solve to find the bounds on c such that 0<=a,b,c<=1. (Unfortunately, Solve itself cannot handle inequality conditions so we need to do this two step procedure). Of course there may be no points on the plane such that C1=C2 in which case inequality solve returns False. Fregions notes the positions of these False statements and in the next lines we delete from the original equations those corresponding to the False statements. In other words Solve returns an equation for the set of point such that C1=C2, we then find that these points fall outside of the positional vote plane so we delete this set of equations as irrelevant. We use pattern matching to turn an answer like .2<=c<=.5 into the pair of numbers {.2,.5}. By substituting into the appropriate equations we then find the beginning and ending points of the line of pts satisfying the conditions that Ci=Cj and on the positional vote plane. Notice that the colors of the lines are set up so that the C1=C2 line always has the same color and so that it matches the colors used in the Legend. The rest of the function turns the points and lines into graphics and shows them with or without a legend according to MLegend.*)
CreatePoint[P_List /;Length[P]==6,s_,size_:.025]:=(Module[ {list1},
list1=f[SumToOne[P],s];
x1=list1[[1]];y1=list1[[2]];
Graphics[{Hue[0],PointSize[size], Point[{x1,y1}]}]
] )
RTriangle={Graphics[Line[{{0,1/2},{1,0}}]],
Graphics[Line[{{0,1/2},{1,0}}]],
Graphics[Line[{{0,0},{1/2,1/2}}]],
Graphics[Line[{{0,1},{1/2,0}}]],
Graphics[Text["1",{0.54,.34}]],
Graphics[Text["2",{.54,.14}]],
Graphics[Text["3",{.30,.14}]],
Graphics[Text["4",{.12,.3}]],
Graphics[Text["5",{.12,.57}]],
Graphics[Text["6",{.30,.57}]]}
simpleplot={Graphics[Line[{{1,0},{0,1}}],
{PlotRange -> Automatic,
AspectRatio -> Automatic,
DisplayFunction :> $DisplayFunction,
ColorOutput -> Automatic, Axes -> True,
AxesOrigin -> Automatic, PlotLabel -> None,
Ticks -> {{0, 0.5, 1}, {0, 0.5, 1}},
GridLines -> None, Prolog -> {}, Epilog -> {},
AxesStyle -> Automatic,
Background -> Automatic,
DefaultColor -> Automatic,
DefaultFont :> $DefaultFont, RotateLabel -> True,
Frame -> False, FrameStyle -> Automatic,
FrameTicks -> Automatic, FrameLabel -> None,
PlotRegion -> Automatic
}]}
(*PlotPL plots the procedure line for a given profile. Most of the effort is taken up plotting the representation triangle and numbering the sectors. PlotPL accepts any graphics options. If options are used then the size variable must also be specified.*)
VotingHull[s_,opts___]:=(Module[ {vertices,VHull},
vertices=Union[Table[f[RotateRight[{1,0,0,0,0,0},i],s], {i, 0, 5}]];
vertices=Map[Drop[#,-1]&,vertices,{1}];
vertices=vertices/.{a_,b__}->{a,b,a};
VHull=Graphics[Line[SimpleClosedPath[vertices]]];
Show[simpleplot,VHull,RTriangle,Graphics[Text[CNames3[[3]],{0,0},{0,1}]],AxesLabel->{CNames3[[1]],CNames3[[2]]}, opts]
])
FindProfile[q1_,q2_]:=(
If[MemberQ[{Apply[Plus,q1]==1},False],Return[Print["Elements of the vector q1 must sum to one"]]];
If[MemberQ[{Apply[Plus,q2]==1},False],Return[Print["Elements of the vector q2 must sum to one"]]];
If[MemberQ[Map[# < 1/2 &,q1],False],Return[Print["All elements of q1 must be less than 1/2"]]];
If[MemberQ[Map[# < 1/2 &,q2],False],Return[Print["All elements of q2 must be less than 1/2"]]];
If[MemberQ[Map[# >= 0 &,q2- 1/2 q1],False],Return[Print["Each element of q2 must be at least as large as 1/2 the corresponding element in q1"]]];
N[Pfp/.Chop[ToRules[Reduce[{Rationalize[q1]==f[Pfp,0],Rationalize[q2]==f[Pfp,1/2]}, Pfp]]] ])
(* At the beginning of FindProfile are a number of conditions which must be met if the procedure is not to return a null set. The last line does all the work. q1, q2 are three element vectors but one variable is redunant since the elements sum to one. There are six variables in P but again one is reduntant since the profile proportions also sum to one. Thus there are 5 unknowns in 4 equations which indicates the solution is in the form of a line. Reduce and ToRules is used because sometimes the 'line' is a single point and Solve returns only generic solutions" *)
LegitProfileArea[q_,size_:.025,opts___]:=(Module[ {m,b,vertices3D,vertices2D,area},
m={ {1,0,0},{0,1,0},{-1,-1,0}, {-1,0,0}, {0,-1,0}, {1,1,0} };
b={1/2,1/2,-1/2,-q[[1]]/2,-q[[2]]/2,1-q[[3]]/2 };
vertices3D=VertexEnumeration[m,b][[1]];
vertices2D=Map[Drop[#,-1]&,vertices3D,{1}];
pt=Graphics[{Hue[0],PointSize[size], Point[{q[[1]],q[[2]]}] }];
area=Graphics[Line[SimpleClosedPath[vertices2D]]];
Show[simpleplot,area,pt,RTriangle,Graphics[Text[CNames3[[3]],{0,0},{0,1}]],AxesLabel->{CNames3[[1]],CNames3[[2]]}, opts]
])
(*In his theorem 2.4.6 Saari shows that for any q0,q1 a set of profiles can be found such that if P is within the set then f[P,0]=q0 and f[P,1/2]=q1 - if a certain set of conditions holds (the conditions are described in FindProfile) LegitProfileArea takes q0 and draws within the R Triangle the area within which q1 must be if the Theorem 2.4.6 is to be satisfied. The function VertexEnumeration takes as input a matrix m and vector b which together describe the set of inequalities which must hold for theorem 2.4.6. Let r={x,y,z,x,y,z} then VertexEnumeration finds the vertices of the system m.r<=b where r>=0. The first three lines of m, therefore, are the conditions x<1/2,y<1/2, (1-x-y)=z<1/2. The next line indicates -x<=-q[[1]]/2 or x=>q[[1]]/2 and so forth. The program VertexEnumeration is copyright .. VertexEnumeration returns vertices in 3D but the last dimension is always zero so the last term in each triple is dropped and a set of 2D points passed to SimpleClosedPath. SimpleClosedPath takes the vertices and sorts them so a line joining the vertices forms a simple, closed, path." *)
SimpleClosedPath[pts_]:= (Module[{xMax,xMin,yMax,yMin,base,remain,angle,sorted1,sorted2,rpts},
rpts=Rationalize[pts];
xMax=Max[Transpose[rpts][[1]]];
xMin=Min[Transpose[rpts][[1]]];
yMax=Max[Transpose[rpts][[2]]];
yMin=Min[Transpose[rpts][[2]]];
base={(xMax+xMin)/2,(yMax+yMin)/2};
base2=base+Random[]/(xMax+yMax+10000);
remain=DeleteCases[rpts,base];
If[Length[remain]==0,Return[{base,base}]];
angle[a_,b_]:= Apply[ArcTan, (a - b)];
sorted1 = Sort[remain, (N[angle[base, #1]] <= N[angle[base, #2]])&];
sorted2=Sort[sorted1,(N[angle[base2,#1]]<=N[angle[base,#2]])&];
Join[sorted2,{sorted2[[1]]}]
])
(* An irrational number can occassionally cause problems so Rationalize converts all points to rational numbers. In the next four lines a base point somewhere near the 'middle' of the inputted points is found. Angle calculates the angle between two points. The next line sorts all the points according to the angle between the base point and the given point. N[angle[base,#1]] is required because Sort has trouble comparing and sorting irrational and rational numbers. The base point is then returned to the list and the list sorted again according to a random point just slightly different from the base point - this avoids problems when the base point is on a line joining two other points. A list of points is returned. SimpleClosedPath is based on Gaylord, Wellin and modified and improved by Tabarrok*)
AllProfiles1[q_,s_,Opts___]:=AllProfiles1[q,s,Opts]=(Module[{eqs,mat,ans,m,b},eqs={ToRules[Reduce[q==f[Pfp,s],Pfp]]};
mat=ToMatrix[eqs] ;
b=Join[mat[[3]], {-1,1,1} ];
m=Join[mat[[1]], { {-1,-1,-1,-1,-1,-1}, {1,1,1,1,1,1}, {0,0,0,0,0,1} }];
ans=VertexEnumeration[m,b,Opts];
Chop[ans[[1]]]
] )
(* AllProfiles1[q_,s_,opts___] finds the vertices in profile space such that if P is any vertice or any linear combination of the vertices then f[P,s]=q. eqs solves the necessary equations. Since there are three equations and six unknowns there are three 'free' parameters (which Mathematica makes p2,p4,p6). (note: ToRules[Reduce is used instead of Solve because sometimes the solution is a single point and Solve only gives general solutions, also solve returns {{rules}} and ToRules[Reduce returns {rules } so we add an outside bracket.) mat takes the output of ToMatrix. VertexEnumeration finds the vertices of the system m.x<=b where x>=0. To set up the m matrix properly we need to impose two other conditions. First p1+p2+p3+p4+p5+p6==1. We impose this condition by adding the two constraints -p1-p2-p3-p4-p5-p6<=-1 and p1+p2+p3+p4+p5+p6<=1. These take care of two of the free parameters the third free parameter is p6 and we set p6<=1. The only option possible is MonitoringFile->"stdout" which prints some intermediary output as VE works *)
ToMatrix[eqs_]:=(Module[{num,vars},
vars= Union[Flatten[Map[Variables[{#[[1]],#[[2]]}] &,eqs[[1]] ]] ];
num= Expand [ Numerator [Map[ Together[#[[1]]-#[[2]] ] &, eqs[[1]] ] ]];
{Outer[Coefficient,#,#2],#2,-# /.Map[#->0 &, #2]} &[num,vars]
])
(* ToMatrix[eqs] takes equations from Solve or {Reduce} and outputs three matrices, m,x and b such that mx=b. eqs is a list of rules like {p1->1-p4,p2->2+p3/2+p6,p3->1+p6....}. The expression Map[Variables[{#[[1]],#[[2]]}] &,eqs[[1]] ] maps the function Variables on to each element of the eqs list. The #[[1]] position in p1->1-p4 is p1, the second position is 1-p4 so Variables[{#[[1]],#[[2]]}] returns {p1,p4} for the first element, then {p2,p3,p6} and so forth. Flatten gets rids of the brackets and Union gets rid of any repeats so vars gives all the variables. The expression Map[ Together[#[[1]]-#[[2]] ] &, eqs[[1]] ] subtracts the right hand side of the rule from the left hand side and puts the result over a common denominator if necessary. eg p1->1-p4 goes to p1-1+p4 and p2->2+p3/2+p6 goes to (2 p2-4- p3- 2 p6)/2. Since both the left and right hand side (of the implicit equation) are divided by 2 we can drop the denominator and focus on 2 p2 - p3 - 2 p6 (hence the term Numerator). So [num,,vars] looks something like [{p1-1+p4, 2 p2 - 4 - p3 -2 p6...},{p1,p2,p3...}] The entire bracket { } is then applied to [num,vars]. (eg. {#,#2}&[a,b]={a,b} ). Outer works as follows Outer[f, {a,b},{x,y}] ---> {{f [a, x], f [a, y]}, {f [b, x], f [b, y]}}. In this case f is Coefficient and the first bracket would thus be { {Coefficient[p1-1+p4,p1], Coefficient[p1-1+p4,p2]},...} ={{1,0....}, ..} So the Outer expression returns us the m matrix. #2 simply repeats the vars vector,
-# /.Map[#->0 &, #2] takes the variables (#2) and maps the #->0 expression to them so we get a set of rules like p1->0,p2->0,p3->0 etc. These rules are then substituted into the expressions p1-1+p4 etc. so we are left with the constant part of the equations -1, we want --1=1 because we are putting the b vector on the other side of the equal sign in mx=b.
ToMatrix is a less elegant but more transparent version of a one liner written by Lee Killough*)
RemoveCandidate[data_, elim_] := (Module[{perms1,perms2,pos1},
perms1 = DeleteCases[Permutations[{1,2,3,4}],elim,2];
perms2=Union[perms1];
pos1 = Table[Position[perms1, perms2[[i]]], {i, 1, 6}];
SumToOne[Table[Plus @@ data[[Flatten[pos1[[i]]]]], {i, 1, 6}]][[{1,2,5,6,4,3}]]
])
(*RemoveCandidate takes a 24 vector and a candidate # {1,2,3 or 4} and returns the six vector which results when that candidate is removed. perms1 is a 24 vector of candidates labelled 1,2,3, and 4 called the reference vector. We drop the six rankings where the eliminated candidate was ranked first in the reference vector and also in the data vector. We then delete all remaining elements in the reference vector which refer to the eliminated candidate. The Union of this group gives a reference six vector. We find the position in the 18 reference vector of each of the elements in the six reference vector. Knowing these positions we can then add up the same elements in the data vector. The code [[{1,2,5,6,4,3}]] permutes the elements in the final vector so they are in the same order as 6 vector profile vectors - This is necessary because Saari's order is not the same as Permutations[{C1,C2,C3}]*)
(*End Programs for Analysis of Positional Voting*)
(*PROGRAMS FOR THE REPRESENTATION CUBE*)
F3[p_]:=( Module[{d,alpha,beta,a0,b0},
If[VectorQ[p,NumberQ],P=SumToOne[p],P=p];
a0=( {{1,1,-1},{1,-1,1},{-1,1,1}}.{P[[1]],P[[3]],P[[5]]} ) ;
b0=-1 ( {{-1,1,1},{1,1,-1},{1,-1,1}}.{P[[2]],P[[4]],P[[6]]} ) ;
d=( P[[1]]+P[[3]]+P[[5]] );
If[NumberQ[d]==False || d>0,alpha=a0/d,alpha=0];
If[NumberQ[d]==False || d<1,beta=b0/(1-d),beta=0];
{{d,{alpha,beta}}, a0 + b0}
])
(* F3 divides the voters into the "positive" cyclic types and the "negative" cyclic types. Consider the types 1,3,5, on any binary choice two will favor one candidate and one will favor the other candidate. Each type is in the minority on one of the candidates (1,3,5 define cyclic preferences). The expression ( {{1,1,-1},{1,-1,1},{-1,1,1}}.{a,b,c} ) is a vector multiplication so it results in a three vector with the elements being {a+b-c,a-b+c,-a+b+c}. But these are exactly the tallies for C1 v C2, C2 v C3, C3 v C1 (look at the odd voter types!). The function makes use of Saari's cyclic coordinate system which shows that any profile is a combination of positive and negative cyclic voters with the weight d where d=proportion of positive type voters. The function returns the cyclic coordinates {d,alpha,beta} which uniquely determine the profile and outcome and then the three vector tally which indicates for each pair which is preferred (or indifferent). *)
BinaryVotes[P_List /;Length[P]==6]:=( Module[ {temp},
temp=F3[P][[2]];
Print[temp];
Print[CNames3[[1]],Varray[[Sign[ temp[[1]] ]+2]],CNames3[[2]] ];
Print[CNames3[[2]],Varray[[Sign[ temp[[2]] ]+2]],CNames3[[3]] ];
Print[CNames3[[3]],Varray[[Sign[ temp[[3]] ]+2]],CNames3[[1]] ]
])
BinaryVotes[P_List /;Length[P]==24]:=(Module[{temp},
temp=binmat4.SumToOne[P];
Print[temp];
Print[CNames4[[1]],Varray[[Sign[ temp[[1]] ]+2]],CNames4[[2]] ];
Print[CNames4[[1]],Varray[[Sign[ temp[[2]] ]+2]],CNames4[[3]] ];
Print[CNames4[[1]],Varray[[Sign[ temp[[3]] ]+2]],CNames4[[4]] ];
Print[CNames4[[2]],Varray[[Sign[ temp[[4]] ]+2]],CNames4[[3]] ];
Print[CNames4[[2]],Varray[[Sign[ temp[[5]] ]+2]],CNames4[[4]] ];
Print[CNames4[[3]],Varray[[Sign[ temp[[6]] ]+2]],CNames4[[4]] ];
])
(*BinaryVotes calls on the primtive F3 to find the representation outcome, it then translates the outcome into text expressions "C1>C2" etc. Varray just holds < = and > in text form.*)
PlotBV[P_:0,size_:.025,Opts___]:=(
If[P==0,Show[RCube,RCubeOpts,Opts];Return[]];
Show[RCube,BinaryPoint[P,size],RCubeOpts,Opts] )
(*PlotBV find the voting outcome in cyclic coordinates and plots this in the representation cube.*)
BinaryPoint[P_List /;Length[P]==6,size_:.025]:=Graphics3D[{PointSize[size],Hue[0.65],Point[F3[P][[2]]]} ]
(*BinaryPoint is a 'primtive' underlying PlotBV it finds the location of the binary vote in the representation cube and returns a 3D graphics object.*)
AllProfiles2[q_,opts___]:=AllProfiles2[q,opts]=(Module[{m,b,mat,eqs,ans},
eqs={ToRules[Reduce[{q==F3[Pfp][[2]],p1+p2+p3+p4+p5+p6==1},Pfp]]};
mat=ToMatrix[eqs] ;
b=Join[mat[[3]], {-1,1} ];
m=Join[mat[[1]], { {-1,-1,-1,-1,-1,-1}, {1,1,1,1,1,1} }];
ans=VertexEnumeration[m,b,opts];
Chop[ans[[1]]]
])
(* AllProfiles2[q,opts] solves the three unknown, six equation, profile system. The resulting equations are then converted into matrix form. We then add the condition that p1+p2+p3+p4+p5+p6==1 to the set of equations and send the result to VertexEnumeration which returns the set of profile vertices. AllProfiles2 remembers its results so subsequent calculations of the same values are much speeded up - to turn this feature off erase AllProfiles2[q,opts]= so the function reads AllProfiles2[q_,opts___]:=(Module[... *)
PlotCone[q_,size_:.025,opts___]:=( Module[{cone1,cone2,pts,pt,ap},
pt=Graphics3D[{PointSize[size],Hue[0.65],Point[q]} ] ;
ap=AllProfiles2[q];
If[Length[ap]==1,Show[RCube,pt,RCubeOpts,opts];Return[],Null];
If[Length[ap]==2,head=Line,head=Polygon];
pts=Transpose[Table[F3[ap[[i]] ][[1,2]], {i, 1, Length[ap]}]];
cone1=Graphics3D[{Thickness[.008],SurfaceColor[Hue[0.55]],head[pts[[1]]]}];
cone2=Graphics3D[{Thickness[.008],SurfaceColor[Hue[0.55]],head[pts[[2]]]}];
Show[RCube,pt,cone1,cone2,RCubeOpts,opts]
])
(*In this function we reverse Saari's methodology. Saari uses the geometry of the RCube to find the profile vectors supporting a given q. Here we find all the profile vectors supporting a given q and then from these calculate 'backwards' to the double cone which can be plotted in the RCube and which implicitly represents the profiles. Saari's method is very easy to use analytically when the q point is close to the center of say the T2 surface, then all the points in T1 are alpha points and the beta points can be calculated by extending lines from the vertices of T1 through q until they reach T2. When the q point is off to the side, however, not all points in T1 are alpha points so extended lines from the T1 vertices may never reach T2. Analytically things become complex although it is easy to see conceptually what is involved. To get around this problem we solve for our three unknowns six equation system and then find all the vertices of the relevant convex polytope. VertexEnumeration is not easy but luckily the VertexEnumeration package does an excellent, albeit slow, job of returning the vertices of a set of equations (formatted properly). Once we have the profile vertices we convert back into alpha,beta coordinates using F3. Each profile results in an alpha and a beta coordinate. There are three profiles thus transposing we have the alpha and beta vertices {{a1,a2,a3}, {b1,b2,b3}} which we plot along with the point q.*)
ConeArea[q_]:=( Module[ {ap,pts},
ap=AllProfiles2[q];
If[Length[ap]==1,Return[Print["Single Profile, 0 Area"]],Null];
pts=Transpose[Table[F3[ap[[i]] ] [[1,2]], {i, 1, Length[ap]}]];
Apply[ Plus,
Table[
N[.5 VLength[Cross[pts[[i,1]]-pts[[i,2]], pts[[i,3]]-pts[[i,2]] ] ]
], {i,1,2}]
]
])
VLength[v_]:=Sqrt[v.v]
(*ConeArea finds the profile vertices, then it calculates the cone projection and calculates the area using the crossproduct formula. It requires the function Cross from the LinearAlgebra`CrossProduct` package*)
(*End Programs for the Representation Cube*)
(*Programs for comparing Pairwise with Positional Voting*)
F4[p_,s_]:= (Module[{a0,b0,d,alpha,beta,P},
If[VectorQ[p,NumberQ],P=SumToOne[p],P=p];
a0=f[{P[[1]],P[[2]],P[[3]],0,0,0},s];
b0=f[{0,0,0,P[[4]],P[[5]],P[[6]]},s] ;
d=( P[[1]]+P[[2]]+P[[3]] );
If[NumberQ[d]==False || d>0,alpha=1/d a0,alpha={0,0,0}];
If[NumberQ[d]==False || d<1,beta=1/(1-d) b0,beta={0,0,0}];
{{alpha,beta,d,d-(1-d)}, a0 + b0}
])
PosPairCompare[P_List /;Length[P]==6,s_]:=(Module[{dsign,tally},
dsign=F4[P,s][[1,4]];
tally=Transpose @ Reverse @ Sort[Transpose @ {f[SumToOne[P],s],CNames3}];
Which[
Sign[dsign]==1,Print[TableForm[{{"C1>C2 ",{tally[[2]]} } ,{dsign,{tally[[1]]} }}]],
Sign[dsign]==0,Print[TableForm[{{"C1=C2 ",{tally[[2]]} }
,{dsign,{tally[[1]]} }}]],
Sign[dsign]==-1,Print[TableForm[{{"C2>C1 ",{tally[[2]]} }
,{dsign,{tally[[1]]} }}]]
]
])
PlotPolygon4[q_,s_,bv_,thick_:.01,size_:.03,Opts___]:=( Module[{ans,vertices3D,vertices2D,area1,area2,pt},
ans=Check[AllProfiles4[q,s,bv],Return[Print["No profiles satisfy the conditions"]],VertexEnumeration::Infeasible];
col=-(Sign[bv]-1)/3;
vertices3D=Transpose @ Map[F4[#,s][[1,{1,2}]]&,ans];
vertices2D=Map[Drop[#,-1]&,vertices3D,{2}];
pt=Graphics @ {Hue[col],PointSize[size],Point[{q[[1]],q[[2]]}] };
area1=Graphics @ {Hue[0.3],Thickness[thick],Line @ SimpleClosedPath[ vertices2D[[2]] ] };
area2=Graphics @ {Hue[0.3],Thickness[thick],Line @ SimpleClosedPath[ vertices2D[[1]] ] };
Show[simpleplot,RTriangle,area1,area2,pt,Opts]
])
(*PlotPolygon4[q,s,bv,thick,size,Opts] calls AllProfiles4 to find the (vetices of) set of profiles P such that f[P,s]=q and the c1 v c2 vote is equal to bv. It then takes the profiles vertices and applies the F4[P,s][[1,{1,2}]] mapping (which is the same as f) to find the outcome vertices. These are then plotted using SimpleClosedPath. thick determines the thickness of the lines, size the size of the points.*)
AllProfiles4[q_,s_,bv_,Opts___]:= AllProfiles4[q,s,bv,Opts]=
(Module[{eqs,mat,ans,m,b},
If[MemberQ[{Apply[Plus,q]==1},False],Return[Print["Elements of the vector q must sum to one"]]];
eqs={ToRules[Reduce[{q==f[Pfp,s],bv==2 (p1+p2+p3) -1},Pfp]]};
mat=ToMatrix[eqs] ;
b=Join[mat[[3]], {-1,1} ];
m=Join[mat[[1]], { {-1,-1,-1,-1,-1,-1}, {1,1,1,1,1,1} }];
ans=VertexEnumeration[m,b,Opts];
Chop[ans[[1]]]
] )
(*AllProfiles4[q,s,bv,Opts] takes an outcome vector q, given under positional vote system s, and a binary vote between c1 and c2 bv and it finds the vertices of all allprofiles P such that the binary vote is bv and the positional vote given profiles P and system s is q. The eqs line finds the set of solutions such that q=f[Pfp,s] and bv=2 (p1+p2+p3)-1. Recall that the voters 1,2,3 vote for c1 in a paiwise vote and the voters 4,5,6 vote against. The vote for c1 is therefore p1+p2+p3-p4-p5-p6 but using p1+p2+p3+p4+p5+p6==1 we have the vote for c1 is 2(p1+p2+p3)-1. The additional condition that the sum of the p's equal one is added in the two Join commands.*)
PlotPosPair[P_List /;Length[P]==6,s_,size_:.03,noline_:1,Opts___]:=(Module[{list,x1,y1,x2,y2,x3,y3,pts,ln,triang,col},
list=F4[P,s];
x1=list[[2,1]];
y1=list[[2,2]];
x2=list[[1,1,1]];
y2=list[[1,1,2]];
x3=list[[1,2,1]];
y3=list[[1,2,2]];
col=-(Sign[ list[[1,4]] ] -1)/3 ;
triang={RTriangle,Graphics[{AbsoluteThickness[1.5],{Line[{{1-s,s},{1-s,0},{s,0},{1-s,s}}], Line[{{0,s},{0,1-s},{s,1-s},{0,s}}]}
}
]} ;
pts=Graphics[{{PointSize[size],Point[{x2,y2}],Point[{x3,y3}]},
{PointSize[size],Hue[col],Point[{x1,y1}]}
}];
If[{x2,y2} != {0,0} && {x3,y3} != {0,0} && noline==1, ln=Graphics[{Dashing[{.01}], Line[{{x2,y2},{x3,y3}}]} ],ln= Graphics[{AbsolutePointSize[0],Point[{0,0}]}] ];
Show[simpleplot,pts,ln,triang,Opts]
])
PosPairPoints[P_List /;Length[P]==6,s_,size_:.025]:=(Module[{list,x1,y1,col},
list=F4[P,s];
x1=list[[2,1]];
y1=list[[2,2]];
col=-(Sign[ list[[1,4]] ] -1)/3 ;
Graphics[{PointSize[size],Hue[col],Point[{x1,y1}]} ]
])
(* Programs for Approval Voting *)
AVOutcomes[P_List /;Length[P]==6,opts___]:= (Module[{vlist,outvertices,AP},
AP=AllPoints/.{opts}/.Options[AVOutcomes];
vlist=Map[Transpose,Flatten[Outer[List,{a1,a2},{b1,b2},{c1,c2},{d1,d2},{e1,e2},
{f1,f2}],5]/.{a1->{1,0,0},a2->{1,1,0},b1->{1,0,0},b2->{1,0,1},
c1->{0,0,1},c2->{1,0,1},d1->{0,0,1},d2->{0,1,1},e1->{0,1,0},
e2->{0,1,1},f1->{0,1,0},f2->{1,1,0}} ] ;
vlist=Insert[Drop[vlist,-1],Last[vlist],2] ;
outvertices=Map[SumToOne[#]&, Map[#.P&,vlist]] ;
Map[{outvertices[[#]],MatrixForm @ vlist[[#]]}&,
ConvexHull[Map[Drop[#,-1]&, outvertices],AllPoints->AP] ] ])
(* AVOutcomes takes a preference profile and calculates the vertexes of all the possible election outcomes. With approval voting (and three candidates) a voter can vote for his first choice or his first and second choice (if he 'approves' of both) this means that type one voters have the opportunity to cast a ballot of {1,0,0} or {1,1,0}. Similarly type 4 voters may cast {0,0,1) or (0,1,1). Outer[List, {a1,a2},{b1,b2}... creates all the possible combinations of these ballots. Each possible ballot combination is then multiplied by the preference vector to find the voting outcome. We then find the normalized voting outcomes and drop the last element. ConvexHull returns the indices of the ConvexHull. Map[{outvertices[[#]],MatrixForm... returns the vertice followed by the list of ballots under which that vertice was created. We Insert and Drop in the second line to handle a minor problem. If there are zero types of some voters then some outcomes could be associated with several different ballots. If one of those ballots is anti-plurality rule we would like to associate the outcome with this ballot for neatness sake. Putting the anti-plurality ballot early in the list makes sure this occurs. *)
PlotAVOutcomes[P_List /;Length[P]==6,opts___Rule]:= (Module[{pts},
pts=Map[Drop[#,-1]&, Transpose[AVOutcomes[P]][[1]]]/.{a_,b___}->{a,b,a};
Show[simpleplot,RTriangle,Graphics @ {Text[CNames3[[3]],{0,0},{0,1}],
{Hue[0],
Line @ pts}},
AxesLabel->{CNames3[[1]],CNames3[[2]]},opts]
])
(*PlotAVOutcomes takes the vertices from AVOutcomes and plots them. The pattern matching rule {a_,b___}->{a,b,a} adds the first element to the back of the list so the plotted line will be a closed path.*)
PosAVCompare[q_,s_,opts___Rule]:=(
Module[{avout,pts},
avout=Map[Drop[#,-1]&, Transpose[Flatten[
Map[AVOutcomes[#]&, AllProfiles1[q,s] ]
,1]][[1]]];
pts=Map[avout[[#]]&,ConvexHull[avout]]/.{a_,b___}->{a,b,a} ;
Show[simpleplot,RTriangle,
Graphics @ Text[CNames3[[3]],{0,0},{0,1}],
Graphics @ {Hue[0],PointSize[0.03],Point[{q[[1]],q[[2]]}] },
Graphics @ {Hue[0], Line @ pts},AxesLabel->{CNames3[[1]],CNames3[[2]]},opts
]
])
(* PosAVCompare[q,s] takes a vote-outcome from vote system s and finds all the AV outcomes which are consistent that s outcome. AllProfiles1[q,s] finds the vertices of the profile set which leads to outcome q when s=s. These are then mapped into AVOutcome so we find in the first line the vertices of AV outcomes. In the second line the ConvexHull of the vertices is found and plotted along with the s outcome. *)
AV4[P_List,{w1_,w2_,w3_}]:=(Module[{P},P=SumToOne[p];
Flatten[N[w1*P . mat1 + w2*P . (2*mat2) + w3*P . (3*mat3)]]
])
(*Programs for Cumulative Voting*)
CumulativeOutcomes[P_List /;Length[P]==6,opts___Rule]:= (Module[{vlist,outvertices,
indif=AllowIndifference/.{opts}/.Options[CumulativeOutcomes]},
If[indif,vlist=Map[Transpose,Flatten[Outer[List,{a1,a2,a3},{b1,b2,b3},{c1,c2,c3},{d1,d2,d3},{e1,e2,e3},
{f1,f2,f3}],5]/.{a1->{3,0,0},a2->{2,1,0},a3->{3/2,3/2,0},b1->{3,0,0},b2->{2,0,1},b3->{3/2,0,3/2},
c1->{0,0,3},c2->{1,0,2},c3->{3/2,0,3/2},d1->{0,0,3},d2->{0,1,2},d3->{0,3/2,3/2},e1->{0,3,0},
e2->{0,2,1},e3->{0,3/2,3/2},f1->{0,3,0},f2->{1,2,0},f3->{3/2,3/2,0}} ],
vlist=Map[Transpose,Flatten[Outer[List,{a1,a2},{b1,b2},{c1,c2},{d1,d2},{e1,e2},
{f1,f2}],5]/.{a1->{3,0,0},a2->{2,1,0},b1->{3,0,0},b2->{2,0,1},
c1->{0,0,3},c2->{1,0,2},d1->{0,0,3},d2->{0,1,2},e1->{0,3,0},e2->{0,2,1},f1->{0,3,0},f2->{1,2,0}} ] ];
vlist=Insert[Drop[vlist,-1],Last[vlist],2] ;
outvertices=Map[SumToOne[#]&, Map[#.P&,vlist]] ; Map[{outvertices[[#]],MatrixForm @ vlist[[#]]}&,
ConvexHull[Map[Drop[#,-1]&, outvertices],AllPoints->False] ] ])
(* CumulativeOutcomes takes a preference profile and calculates the vertexes of all the possible election outcomes. With cumulative voting (and three candidates) a voter can distribute up to 3 points in any way he chooses. A rational-sincere voter will either vote for his first choice only or his first and second choice. This means that type one voters have the opportunity to cast a ballot of {3,0,0} or {2,1,0}. Similarly type 4 voters may cast {0,0,3) or (0,1,2). Outer[List, {a1,a2},{b1,b2}... creates all the possible combinations of these ballots. Each possible ballot combination is then multiplied by the preference vector to find the voting outcome. We then find the normalized voting outcomes. ConvexHull returns the indices of the ConvexHull. Map[{outvertices[[#]],MatrixForm... returns the vertice followed by the list of ballots under which that vertice was created. We Insert and Drop in the second line to handle a minor problem. We map Drop in the last line to Drop the last element of each voting outcome since it is irrelevant. If there are zero types of some voters then some outcomes could be associated with several different ballots. If one of those ballots is the Borda Count we would like to associate the outcome with this ballot for neatness sake. Putting the Borda Count ballot early in the list makes sure this occurs. *)
PlotCumulativeOutcomes[P_List /;Length[P]==6,Iopt___Rule]:= (Module[{pts},
pts=Map[Drop[#,-1]&, Transpose[CumulativeOutcomes[P,Iopt]][[1]]]/.{a_,b___}->{a,b,a} ;
Show[simpleplot,RTriangle,Graphics @ {Text[CNames3[[3]],{0,0},{0,1}],
{Hue[0.66],
Line @ pts}},
AxesLabel->{CNames3[[1]],CNames3[[2]]}]
])
(*PlotCumulativeOutcomes takes the vertices from CumulativeOutcomes and plots them. The pattern matching rule {a_,b___}->{a,b,a} adds the first element to the back of the list so the plotted line will be a closed path.*)
PosCumulativeCompare[q_,s_,Iopt___Rule]:=(
Module[{cumout,pts},
cumout=Map[Drop[#,-1]&, Transpose[Flatten[
Map[CumulativeOutcomes[#,Iopt]&, AllProfiles1[q,s] ],1]][[1]]];
pts=Map[cumout[[#]]&,ConvexHull[cumout]]/.{a_,b___}->{a,b,a} ;
Show[simpleplot,RTriangle,Graphics @ Text[CNames3[[3]],{0,0},{0,1}],
Graphics @ {Hue[0],PointSize[0.03],Point[{q[[1]],q[[2]]}]},
Graphics @
{Hue[0.66],
Line @ pts},AxesLabel->{CNames3[[1]],CNames3[[2]]}]
])
(* PosCumulativeCompare[q,s] takes a vote-outcome from vote system s and finds all the Cumulative outcomes which are consistent that s outcome. AllProfiles1[q,s] finds the vertices of the profile set which leads to outcome q when s=s. These are then mapped into CumulativeOutcome so we find in the first line the vertices of Cumulative outcomes. In the second line the ConvexHull of the vertices is found and plotted along with the s outcome. *)
(* Programs for Strategic Voting*)
PayoffMatrix[P_List /;Length[P]==6,s_,pfac_]:=
(Module[{winner,payoffs,Results},
az=pfac;
p1=P[[1]];
p2=P[[2]]; p3=P[[3]];p4=P[[4]];p5=P[[5]];p6=P[[6]];
Results=Map[f[SumToOne[#],s]&,Strategies];
winner=Map[Flatten @ Position[#,Max[#]]&,Results];
payoffs=Table[Map[#[[winner[[i]]]]&,PMat], {i, 1, 64}]/.{{a_,b_}->(a+b)/2,{a_,b_,c_}->(a+b+c)/3};
az=.;p1=.;p2=.;p3=.;p4=.;p5=.;p6=.;
Return[{Partition[Flatten[payoffs],6],Results }]
])
(*PayoffMatrix[P,s,pfac] takes a voter profile P, a positional voting system s and a percentage factor, pfac, and returns the payoff for every possible combination of non-dominated strategies (i.e. the sincere strategy and the insincere strategy where the top two ranked candidates are switched) where pfac of each type of voter may switch. The matrix Strategies shows all the combinations in variable form, the first line has the effect of switching all the variables to numbers. The second line creates a 64 vector of outcomes. winner is the Position of the winning candidate (1,2 or 3) or {1,3} in the case of a tie between 1 and 3 say. payoffs takes the winner and finds the corresponding payoff in the matrix PMat which in the normal case is set to 2 for a top ranked choice, 1 for a second ranked choice and 0 for a third ranked choice. The pattern matching at the end replaces a tie with the 'expected value' we put the Strategies matrix back to variable form in the next line. The function returns the payoffs and the cardinal tally. *)
FindNash[P_List /;Length[P]==6,s_,pfac_,opts___Rule]:=(Module[{pm,npm,ans,rep,Results,ord,new},
{ord,new}={Order,NewOnly}/.{opts}/.Options[FindNash] ;
pm=PayoffMatrix[P,s,pfac];
Results=Map[{#,CNames3}&,pm[[2]] ];
OResults=Map[Transpose @ Reverse @ Sort @ Transpose[{#, CNames3}] &,pm[[2]]]/.{{{a_,a_,a_},{c_,d_,e_}}->{{a,a,a},{{c,d,e}}},{{a_,a_,b_},{c_,d_,e_}}->{{a,
a,b},{{c,d},e}},{{a_,b_,b_},{c_,d_,e_}}->{{a,b,b},{c,{d,e}}}} ;
npm=Partition[Partition[Partition[Partition[Partition[pm[[1]],2],2],2],2],2];
ans=Map[Drop[#,1]&,
Select[Table[{
Apply[And,
Table[
npm[[ Apply[ Sequence, StratIndex[[j]] ] ]][[i]]>=
npm[[ Apply[ Sequence, Flip[StratIndex[[j]],i] ] ]][[i]],
{i, 1, 6}
]
],
StratIndex[[j]],pm[[1,j]], OResults[[j]],Results[[j]]
}, {j, 1, 64}
],#[[1]]==True&
]
];
If[new,rep=Select[ans,#[[3,2]]==ans[[1,3,2]]& ];ans=Prepend[Complement[ans,rep],ans[[1]]]];
If[ord,ans=Transpose[Transpose[ans][[{1,2,3}]]],ans=Transpose[Transpose[ans][[{1,2,4}]]] ];
ans=Sort[ans,Count[#1[[1]],1]>Count[#2[[1]],1]&];
Table[Map[ColumnForm[#]&,ans[[i]]], {i, 1, Length[ans]}]
])
Flip=If[#1[[#2]]==1,ReplacePart[#1,2,#2],ReplacePart[#1,1,#2]]&
(*Flip is a pure function version of Flip[z_,i_]:=If[z[[i]]==1,ReplacePart[z,2,i],ReplacePart[z,1,i]]*)
(*FindNash[P,s,pfac,options] finds all the pure strategy NE. The first line creates the payoff matrix the second line puts the results alongside the names, OResults is the ordered results where the results are sorted from highest to lowest and ties are indicated by {{C1,C3},C2} for example - the pattern matching adds the appropriate brackets to the sorted lists. The next line Partitions the payoff matrix so that the location of the payoff is equal to the strategy vector. Let the sincere strategy=1 and the insincere strategy=2 then every possible combination of strategies can be represented by a six vector like {1,2,1,1,2,2}. We partition the payoff vector so that npm[[1,2,1,1,2,2]] is the payoff to the strategy combination {1,2,1,1,2,2}. To understand the next line note that Apply[ Sequence,StratIndex[[j]] ] is just what we have to write to get npm[[1,2,1,1,2,2]]. So the inner Table takes the payoff to strategy j and player i and compares it to the strategy where all is the same except player i tries his other strategy. The Flip command takes a strategy vector and a player i and flips the player's strategy from sincere to insincere or vice versa depending on which strategy we are checking. If the current payoff is bigger than the player's alternative payoff we get a True statement. The inner table thus gives us a six vector of {True,True,False,True...}. The Apply[And,{True,True....}] gives True only if every entry is True. The Select command thus picks out all entries True, ie. all NE. We Drop the True element of the vector. We then evaluate the options if new is true we Select every ordinal outcome which is the same as the sincere (the first outcome) and then find the complement of these (i.e. we drop all the NE which have the same outcome as the all sincere outcome). The Table created includes both the ordered results and the unordered results. If ord is true we drop the unordered results (element 4 of the appropriately transposed matrix) else we drop the ordered results (element 3). The Sort command puts the list from most to least sincere, where sincere is measured by the number of voter types playing sincere strategies. We then then print out all the NE in columnform.*)
PlotNash[P_List /;Length[P]==6,s_,pfac_,opts___]:=(
Module[{col,size,new},
{col,size,new}={Color,Size,NewOnly}/.{opts}/.Options[PlotNash];
Graphics[{PointSize[size],Hue[col],
Map[Point,Map[Drop[#,-1]&,Map[#[[3,1,1]]&,FindNash[P,s,pfac,Order->False,NewOnly->new] ]
]
]
}]
])
(*PlotNash[P,s,pfact,options] takes a voter profile and a vote system and a percent factor. It calls FindNash and strips off the vote outcomes (dropping the last one to get a 2D vector) then creates a Graphics statement with each NE a Point. There are three options NewOnly->True only plots the NE with ordinal outcomes different than the all sincere outcome. Color->[0,1] controls the color and Size->[0,1] the size of the points.*)
(*3D GRAPHICS PRIMITIVES FOR THE REPRESENTATION CUBE*)
Cross3D=Map[Graphics3D,{{Thickness[.008],Line[{{0,0,-1},{0,0,1}}]},{Thickness[.008],Line[{{-1,0,0},{1,0,0}}]},{Thickness[.008],Line[{{0,1,0},{0,-1,0}}]} } ]
(*Draws x,y,z axis centered at (0,0,0) *)
HalfBox1=Map[Graphics3D,{ Line[{{-1,-1,1},{1,-1,1}}],Line[{{1,-1,1},{1,-1,-1}}],Line[{{1,-1,-1},{1,1,-1}}],Line[{{-1,-1,1},{-1,1,1}}],Line[{{-1,1,1},{-1,1,-1}}],Line[{{-1,1,-1},{1,1,-1}}] }]
(*Draws the solid lines of the cube.*)
(* HalfBox2=Graphics3D[{ {Dashing[{0.01}],Line[{{-1,1,1},{1,1,1}}], Line[{{1, -1, -1},
{-1, -1, -1}}],Line[{{1,1,1},{1,1,-1}}],Line[{{1,-1,-1},{-1,-1,-1}}],
Line[{{-1,-1,-1},{-1,-1,1}}],Line[{{-1,-1,-1},{-1,1,-1}}], Line[{{1,1,1},{
1,-1,1}}]}}, {PlotRange -> All, Boxed->False, Prolog-> PostScript["/Mdot { newpath currentlinewidth 2 div 0 360 arc fill } bind def"] }]
*)
HalfBox2=Map[Graphics3D,{Line[{{-1,1,1},{1,1,1}}],Line[{{1,1,1},{1,1,-1}}],Line[{{1,-1,-1},{-1,-1,-1}}],Line[{{-1,-1,-1},{-1,-1,1}}],Line[{{-1,-1,-1},{-1,1,-1}}],Line[{{1,1,1},{1,-1,1}}]} ]
(*Draws the non-dashed lines of the cube.*)
ChopBox=Map[Graphics3D,{{FaceForm[GrayLevel[0.9],GrayLevel[0.9]],Polygon[{{-1,-1,1},{1,-1,-1},{-1,1,-1}}]},Polygon[{{-1,1,1},{1,-1,1},{1,1,-1}}] }]
(*Draws two Polygons indicating the two chopped corners of the cube.*)
RCube={HalfBox1,HalfBox2,Cross3D,ChopBox}
RCubeOpts={Axes->True,AxesStyle->{Hue[1]},Boxed->False,AxesLabel->{"C1-C2","C2-C3","C3-C1"},Ticks->{{-1,0,1},{-1,0,1},{-1,0,1}},AxesEdge->{Automatic,Automatic,{1,1} } }
CyclicRegions=Graphics3D[{{SurfaceColor[Hue[0]],Polygon[{{1,0,0},{0,1,0},{0,0,1}}]},{SurfaceColor[Hue[0]],Polygon[{{-1,0,0},{0,-1,0},{0,0,-1}} ]}} ]
(*Draws the cyclic regions within the two Polygons, ie. the surface points above the positive and negative orthants.*)
CondorcetRegionC1=Map[Graphics3D,Map[Polygon,{
{ {1,-1,0}, {1,-1,-1}, {1,1,-1}, {1,0,0} },
{ {0,-1,0}, {1,-1,0}, {1,-1,-1} },
{ {1,-1,0}, {0,-1,0}, {0,1,0}, {1,0,0} },
{ {1,-1,-1}, {0,0,-1}, {0,1,-1}, {1,1,-1} },
{ {0,-1,0}, {0,1,0}, {0,1,-1}, {0,0,-1} },
{ {0,1,0}, {0,1,-1}, {1,1,-1} } }
] ]
(*Graphics Primitives for the C1 Condorcet Region *)
CondorcetRegionC2=Map[Graphics3D,Map[Polygon,{
{ {-1,1,1},{0,0,1},{-1,0,1} },
{ {-1,1,-1},{0,0,-1},{0,1,-1} },
{ {-1,0,1},{-1,0,0},{0,0,-1},{0,0,1} },
{ {-1,1,1},{-1,0,1},{-1,0,0},{-1,1,-1} },
{ {-1,1,1},{-1,1,-1},{0,1,-1},{0,1,0} },
{ {0,0,1},{0,0,-1},{0,1,-1},{0,1,0} }
}]]
(*Graphics Primitives for the C2 Condorcet Region*)
CondorcetRegionC3=Map[Graphics3D, Map[Polygon, {
{ {-1,0,1},{0,0,1},{1,0,0},{-1,0,0} },
{ {1,-1,0},{0,-1,0},{-1,0,0},{1,0,0} },
{ {-1,-1,1},{-1,0,1},{-1,0,0} },
{ {-1,-1,1},{-1,0,1},{0,0,1},{1,-1,1} },
{ {-1,-1,1},{1,-1,1},{1,-1,0},{0,-1,0} },
{ {1,-1,1},{1,-1,0},{1,0,0}}
}]]
(*End 3D Graphics Primitives*)
End[]
EndPackage[]