Choosing between science and leisure

No Credit

p1NoCredit[x_, y_, a_] :=(Sqrt[x+y]) + a (Sqrt[1-x])
p2NoCredit[x_, y_, a_] :=(Sqrt[x+y]) + a (Sqrt[1-y])

NoCreditNE = Solve[{(∂_x)p1NoCredit[x,y,a]==0, (∂_y)p2NoCredit[x,y,a]==0}, {x,y}]

SocialNoCredit[x_, y_, a_] := p1NoCredit[x,y,a] + p2NoCredit[x,y,a]

OptNoCredit = Solve[{(∂_x)SocialNoCredit[x,y,a]==0, (∂_y)SocialNoCredit[x,y,a]==0}, {x,y}]

plot1= Plot[{x /. OptNoCredit ,x /. NoCreditNE},{a, 0,2}, PlotLegends -> {"Socially optimal", "Nash equilibrium"}, Filling -> {1 -> {2}}, AspectRatio -> 0.75]

Export["/home/kzollman/Research/ScienceIncentives/Credit Economy/NewDiagrams/SocialDilemma.svg", plot1]

With Credit

p1WithCredit[x_, y_, a_, c_] := (Sqrt[x+y]) + a (Sqrt[1-x]) + c (Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[y]))
p2WithCredit[x_, y_, a_, c_] := (Sqrt[x+y]) + a (Sqrt[1-y]) + c (Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[x]))

(∂_x)p1WithCredit[x,y,a,c]

(c/2)-(a/(2 (Sqrt[1-x])))+(1/(2 (Sqrt[x+y])))+((c (-(Sqrt[y])+(Sqrt[x+y])))/(2 (Sqrt[x+y])))==0/.y->x

p1OnlyCredit[x_,y_, a_, c_] := a (Sqrt[1-x]) + c (Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[y]))
p2OnlyCredit[x_, y_,a_, c_] := a (Sqrt[1-y]) + c (Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[x]))

(∂_x)p1OnlyCredit[x,y,a,c]

Plot[{x /. OptNoCredit ,x /. NoCreditNE, Max[0,x /. Solve[(c/2)-(a/(2 (Sqrt[1-x])))+((c (-(Sqrt[y])+(Sqrt[x+y])))/(2 (Sqrt[x+y]))) ==0/. c->1 /. y-> x, {x}]]},{a, 0,2}, PlotLegends -> {"Socially optimal", "Nash equilibrium","Credit only"}, Filling -> {1 -> {2}}, AspectRatio -> 0.75]

plot2 = Plot[{x/. OptNoCredit /. a-> 0.9,x/.Solve[(c/2)-(a/(2 (Sqrt[1-x])))+(1/(2 (Sqrt[2]) (Sqrt[x])))+((c (-(Sqrt[x])+(Sqrt[2]) (Sqrt[x])))/(2 (Sqrt[2]) (Sqrt[x])))==0 /. a->0.9, x], Max[0,x/.Solve[(c/2)-(a/(2 (Sqrt[1-x])))+((c (-(Sqrt[x])+(Sqrt[x+x])))/(2 (Sqrt[x+x])))==0 /. a->0.9, x]]}, {c, 0,2},  PlotLegends -> {"No Credit Optimum", "Hybrid", "Only-Credit"}]

Export["/home/kzollman/Research/ScienceIncentives/Credit Economy/NewDiagrams/ProductionWithCredit.svg", plot2]

Choosing between two scientific projects

No Credit

p1TwoPNoCredit[x_,y_,b_] := (Sqrt[x+y]) + b (Sqrt[2-x-y])
p2TwoPNoCredit[x_,y_,b_] := (Sqrt[x+y]) + b (Sqrt[2-x-y])

TwoPNoCredNE = Solve[{(∂_x)p1TwoPNoCredit[x,y,b]==0, (∂_y)p2TwoPNoCredit[x,y,b]==0}, {x,y}]

Solve[x==((2-x-(b^2) x)/(1+(b^2))), x]

With Credit

p1TwoPCredit[x_,y_,b_, c_] := (Sqrt[x+y]) + b (Sqrt[2-x-y]) + c((Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[y]))) + c(b(Sqrt[2-x-y])(b(Sqrt[2-x-y]) - b(Sqrt[1-y])))
p2TwoPCredit[x_,y_,b_, c_] := (Sqrt[x+y]) + b (Sqrt[2-x-y]) + c((Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[y]))) + c(b(Sqrt[2-x-y])(b(Sqrt[2-x-y]) - b(Sqrt[1-y])))

(∂_x)p1TwoPCredit[x,y,b, c]

(c/2)-(((b^2) c)/2)-(b/(2 (Sqrt[2-x-y])))-((b c (-b (Sqrt[1-y])+b (Sqrt[2-x-y])))/(2 (Sqrt[2-x-y])))+(1/(2 (Sqrt[x+y])))+((c (-(Sqrt[y])+(Sqrt[x+y])))/(2 (Sqrt[x+y])))/. y->x

plot3 = Plot[{x /. Solve[(c/2)-(((b^2) c)/2)-(b/(2 (Sqrt[2-2 x])))-((b c (b (Sqrt[2-2 x])-b (Sqrt[1-x])))/(2 (Sqrt[2-2 x])))+(1/(2 (Sqrt[2]) (Sqrt[x])))+((c (-(Sqrt[x])+(Sqrt[2]) (Sqrt[x])))/(2 (Sqrt[2]) (Sqrt[x])))==0/. c->1, x], (1/(1+(b^2)))}, {b,0,2}, PlotLegends -> {"Truth and Credit",  "Socially Optimal"}, Filling -> {1->{2}}]

Export["/home/kzollman/Research/ScienceIncentives/Credit Economy/NewDiagrams/TwoProjectsWithCredit.svg", plot3]

p1TwoPOnlyCredit[x_,y_,b_] := (Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[y]))+ b(Sqrt[2-x-y])(b(Sqrt[2-x-y]) - b(Sqrt[1-y]))
p2TwoPOnlyCredit[x_,y_,b_] :=  (Sqrt[x+y])((Sqrt[x+y]) - (Sqrt[y])) + b(Sqrt[2-x-y])(b(Sqrt[2-x-y]) - b(Sqrt[1-y]))

ContourPlot[p1TwoPOnlyCredit[1,y,b] == p1TwoPOnlyCredit[0,y,b], {y,0,1}, {b,0,2}]

Alternative Credit System

p1AltCredit[x_,y_,b_, c_] := (Sqrt[x+y]) + b (Sqrt[2-x-y]) + c((Sqrt[x+y]) - (Sqrt[y])) + c(b(Sqrt[2-x-y]) - b(Sqrt[1-y]))
p2AltCredit[x_,y_,b_, c_] := (Sqrt[x+y]) + b (Sqrt[2-x-y]) + c((Sqrt[x+y]) - (Sqrt[y])) + c(b(Sqrt[2-x-y]) - b(Sqrt[1-y]))

Solve[{(∂_x)p1AltCredit[x,y,b, c]  ==0, (∂_y)p2AltCredit[x,y,b, c]  ==0}, {x, y}]

Choosing between two scientific projects and leisure

No Credit

p1ThreeDecisionNoCredit[x1_, x2_,y1_, y2_,a_, b_] := (Sqrt[x1+y1])+b(Sqrt[x2 + y2 ]) +a(Sqrt[1-x1 -x2 ])

p2ThreeDecisionNoCredit[x1_, x2_, y1_, y2_,a_, b_] := (Sqrt[x1+y1])+b(Sqrt[x2 + y2])+a(Sqrt[1-y1 -y2 ])

Solve[Grad[p1ThreeDecisionNoCredit[x1, x2, y1, y2, a, b], {x1, x2}] =={0,0}, {x1, x2}]

Solve[{((1-(a^2) y1-(b^2) y1+y2)/(1+(a^2)+(b^2)))==y1, (((b^2)+(b^2) y1-y2-(a^2) y2)/(1+(a^2)+(b^2))) == y2}]

NoCredNE3Problem[a_, b_] := {(1/(1+2 (a^2)+(b^2))), ((b^2)/(1+2 (a^2)+(b^2)))}

With Credit

p1ThreeDecisionWithCredit[x1_, x2_,y1_, y2_,a_, b_, c_] := (Sqrt[x1+y1])+b(Sqrt[x2 + y2 ]) +a(Sqrt[1-x1 -x2 ]) +c((Sqrt[x1+y1])*((Sqrt[x1+y1])- (Sqrt[y1])) +b(Sqrt[x2+y2])*(b(Sqrt[x2+y2])-b(Sqrt[y2])))

p2ThreeDecisionWithCredit[x1_, x2_, y1_, y2_,a_, b_, c_] := (Sqrt[x1+y1])+b(Sqrt[x2 + y2])+a(Sqrt[1-y1 -y2 ])+ c((Sqrt[x1+y1])*((Sqrt[x1+y1])- (Sqrt[x1])) +b(Sqrt[x2+y2])*(b(Sqrt[x2+y2])- b(Sqrt[x2])))
Grad[p1ThreeDecisionWithCredit[x1, x2, y1, y2, a, b, c], {x1, x2}]

CreditNE3Problem[a_, b_, c_] := {x1, x2}/. NSolve[{-(a/(2 (Sqrt[1-x1-x2])))+(1/(2 (Sqrt[x1+y1])))+c ((1/2)+((-(Sqrt[y1])+(Sqrt[x1+y1]))/(2 (Sqrt[x1+y1])))),-(a/(2 (Sqrt[1-x1-x2])))+(b/(2 (Sqrt[x2+y2])))+c (((b^2)/2)+((b (-b (Sqrt[y2])+b (Sqrt[x2+y2])))/(2 (Sqrt[x2+y2]))))} == {0,0} /. {{y1 -> x1, y2->x2}},  {x1, x2}][[1]]

ProbSolved3Problem[z_, b_] := (Sqrt[2z[[1]]])+b (Sqrt[2z[[2]]])

Only Credit

(* To reduce variables I have replaced c and a with a single variable aoc (a over c) *)

p1ThreeDecisionOnlyCredit[x1_, x2_,y1_, y2_,b_, aoc_] := aoc(Sqrt[1-x1 -x2 ]) +((Sqrt[x1+y1])*((Sqrt[x1+y1])- (Sqrt[y1])) +b(Sqrt[x2+y2])*(b(Sqrt[x2+y2])-b(Sqrt[y2])))

p2ThreeDecisionOnlyCredit[x1_, x2_, y1_, y2_,b_, aoc_] := aoc(Sqrt[1-y1 -y2 ])+ ((Sqrt[x1+y1])*((Sqrt[x1+y1])- (Sqrt[x1])) +b(Sqrt[x2+y2])*(b(Sqrt[x2+y2])- b(Sqrt[x2])))

Grad[p1ThreeDecisionOnlyCredit[x1, x2, y1, y2, b, aoc], {x1, x2}]

Solve[{(1/2)-(aoc/(2 (Sqrt[1-x1-x2])))+((-(Sqrt[y1])+(Sqrt[x1+y1]))/(2 (Sqrt[x1+y1]))),((b^2)/2)-(aoc/(2 (Sqrt[1-x1-x2])))+((b (-b (Sqrt[y2])+b (Sqrt[x2+y2])))/(2 (Sqrt[x2+y2])))} == {0,0} /. {{y1 -> x1, y2->x2}},  {x1, x2}]

Reduce[{p1ThreeDecisionOnlyCredit[x, 0, y1, y2, 0.5, aoc] ≤ p1ThreeDecisionOnlyCredit[0, x, y1, y2, 0.5, aoc], 1≥ x> 0, y1≥ 0, y2 ≥ 0, aoc>0} , {x, y1, y2, aoc}]

(∂_x)p1ThreeDecisionOnlyCredit[x, 0, y, 0, 0.5, aoc]

(1/2)-(aoc/(2 (Sqrt[1-x])))+((-(Sqrt[y])+(Sqrt[x+y]))/(2 (Sqrt[x+y]))) /. y-> x

(* We will now assume c=1, so aoc = a *)

Solve[(1/2)-(a/(2 (Sqrt[1-x])))+((-(Sqrt[x])+(Sqrt[2]) (Sqrt[x]))/(2 (Sqrt[2]) (Sqrt[x]))) ==0, {x}]

Plot[{Total[NoCredNE3Problem[a,0.5]],Total[CreditNE3Problem[a,0.5, 1]], ((-9+4 (Sqrt[2])+2 (a^2))/(-9+4 (Sqrt[2])))}, {a, 0.01, 1}, PlotLegends -> {"Truth only", "Hybrid", "Credit only"}]

plot4=Plot[{ProbSolved3Problem[NoCredNE3Problem[a,0.5], 0.5],ProbSolved3Problem[CreditNE3Problem[a,0.5, 1], 0.5], ProbSolved3Problem[{x/.Solve[(1/2)-(a/(2 (Sqrt[1-x])))+((-(Sqrt[x])+(Sqrt[2]) (Sqrt[x]))/(2 (Sqrt[2]) (Sqrt[x]))) ==0, {x}],0}, 0.5]}, {a, 0.01, 1}, PlotLegends -> {"Truth only", "Hybrid", "Credit only"}]

Export["/home/kzollman/Research/ScienceIncentives/Credit Economy/NewDiagrams/ThreeProjectsComparison.svg", plot4]