Monopoly

Hal Varian
January 1992

Deadweight loss of monopoly

Let's see how the deadweightloss of monopoly varies with the elasticity of demand.  Suppose that utility, demand and costs are given by the following functions

u[x_] := x^(1-e)/(1-e)
c[x_] := x
p[x_] := x^(-e)
demand[p_] := p^(-1/e)

Given these relationships, we can easily calculate the equilibrium values:

equilPrice[e_] := 1/(1-(1/e))
equilQuant[e_] := demand[equilPrice[e]]
equilWelfare[e_] := u[equilQuant[e]] - equilPrice[e]
equilWelfare[e]

What a messy expression.  Note that this only makes sense for e>1.  (A monopolist never operates at an inelastic portion of the demand curve.)  Let's see how welfare varies with the elasticity:

Plot[Evaluate[equilWelfare[e]],{e,1.1,5}]

Second-degree price discrimination

There are two classes of consumers with utility functions u1[x,t]=tLog[x] for t=1,2.  The monopolist has a constant marginal cost of c.  We want to find the optimal price discrimination scheme.  According to the text, we simply have to solve the following two equations:

u[x_] := Log[x]
solution=Solve[{u'[x1] -1 + u'[x1]-2u'[x2]==0,
               2u'[x2]-c == 0},{x1,x2}][[1]]
out1[c_] := Evaluate[x1/.solution]
out2[c_] := Evaluate[x2/.solution]
Plot[{out1[c],out2[c]},{c,.1,3}]

As marginal cost increases, the prices paid by the high-demand and low-demand consumers converge.

Third degree price discrimination

Consider a two markets, each with linear demand curves.  We saw that sometimes it pays the monopolist to just sell to one market; when will that be the case?  Ideally, we would like a graph that would show us the good and bad regions.

x1[p_,a_,b_] := a - b*p
x2[p_] := 1 - p

We know that if the monopolist does sell to both markets, the price will be (1+a)/2.  So all we need to do is to graph the set of points where this price makes at least one of the two demand functions negative.  One way to do this is to solve for the values of a and b where the product of the two demand functions  is negative:

Solve[x1[(1+a)/2,a,b]*x2[(1+a)/2]==0,b][[1]]
ParametricPlot[{a,2a/(1+a)},{a,0,1}]

Or we can compute an indicator function and do a density plot

indicator[a_,b_] := 
     If[x1[(1+a)/2,a,b]*x2[(1+a)/2]<0.0,0,1]
DensityPlot[indicator[a,b],{a,0,1},{b,0,1},PlotPoints->50]