Trouble Implementing Schelling's Segregation Model
- To: mathgroup at smc.vnet.net
- Subject: [mg91286] Trouble Implementing Schelling's Segregation Model
- From: Steve_Kinsella <stephen.kinsella at gmail.com>
- Date: Wed, 13 Aug 2008 04:41:24 -0400 (EDT)
Hi All,
I'm trying to write a demonstration for a class on Schelling's 1978
segregation model. An implementation exists from Gaylord and D'Andria,
1998, but it's not playing ball with Mathematica 6.0. If anyone wants
to take a pop at the code below, I'd appreciate it. Thanks, Steve
(*Schelling Model (1978, 147 - 153) Demonstration
Model uses a square n*n lattice with wraparound boundary conditions \
with a population density p of individuals occupying lattice sites \
and the rest empty. System evolves over t time steps. *)
neighborhood[n_, p_, v_, w_, t_] :=
Module[{walk, movestay, society, RND, Moore, GN} ,
RND := RandomInteger[ {1, 4}]
society :=
Table[Floor[p + RandomInteger[]], {n}, {n}] /.
1 :> {RND, Table[Integer, {1, w}], {v}};
movestay[0, __] := 0;
movestay[{a_, b_},
res__] := {a*
Round[1 -
Count[Map[
Count[b - #[[2]], 0] &, {res}/.0 -> {0,
0}], _?{# >= v/2 &}]/8.] , b };
(*Walk Rules*)
Moore[func_, lat_] :=
MapThread[func,
Map[RotateRight[lat, #] &, {{0, 0}, {1, 0}, {0, -1}, {-1, 0}, {0,
1}, {1, -1}, {-1, -1}, {-1, 1}, {1, 1}} , 2];
GN[func_, lat_] :=
MapThread[func,
Map[RotateRight[lat, #] &, {{0, 0}, {1, 0}, {0, -1}, {-1,
0}, {0, 1}, {1, -1}, {-1, -1}, {-1, 1}, {1, 1}, {2,
0}, {0, -2}, {-2, 0}, {0, 2}}], 2];
NestList[GN[walk, Moore[movestay, #]] &, society, t]]]
SeedRandom[9]
results = neighborhood[20, 0.6, 1, 2, 500]
Show[GraphicsArray[
Map[Show[Graphics[
Raster[# /. {0 -> RGBColor[0.7, 0.7, 0.7], {_, {1}} ->
RGBColor[0, 1, 0], {_, {2}} -> RGBColor[0, 0, 1]}]],
AspectRatio -> Automatic, DisplayFunction -> Identity] &, {First[
results], Last[results]}]]]