Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2008

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Trouble Implementing Schelling's Segregation Model

  • To: mathgroup at smc.vnet.net
  • Subject: [mg91759] Re: Trouble Implementing Schelling's Segregation Model
  • From: "Stephen Kinsella" <stephen.kinsella at gmail.com>
  • Date: Sun, 7 Sep 2008 05:37:26 -0400 (EDT)
  • References: <g7uo2p$5un$1@smc.vnet.net> <48C0EFF2.1030802@gmail.com>

Jean-Marc,

Thanks for your time, I really appreciate it.

Best,

Stephen



On Fri, Sep 5, 2008 at 9:38 AM, Jean-Marc Gulliet <
jeanmarc.gulliet at gmail.com> wrote:

> Steve_Kinsella wrote:
>
>  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
>>
>
> It would have been better if you told us what issues you encountered with
> the code below. I have corrected two potential syntax/semantic errors.
>
>  (*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}};
>>
>
> You must add a ";" semi-column after RandomInteger[], otherwise Mathematica
> will interpret the space as an implicit multiplication with society.
>
>   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];
>>
>
> It seems that a square bracket is missing to end the MapThread[] function.
>
>     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]}]]]
>>
>
> So your code could be as follows (note that it is still not working, but
> for other reasons that syntactic ones).
>
> 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[(Count[b - #1[[2]], 0] & ) /@ ({res}/0. ->
>                         {0, 0}), _?({#1 >= v/2 & })]/8.], b};
>
>  Moore[func_, lat_] := MapThread[func,
>
>    Map[RotateRight[lat, #1] & , {{0, 0}, {1, 0}, {0, -1}, {-1, 0},
>               {0, 1}, {1, -1}, {-1, -1}, {-1, 1}, {1, 1}}, 2]];
>
>  GN[func_, lat_] := MapThread[func,
>             (RotateRight[lat, #1] & ) /@ {{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, #1]] & , society, t]]
>
> SeedRandom[9]
> results = neighborhood[20, 0.6, 1, 2, 500]
> Show[GraphicsArray[
>     (Show[Graphics[Raster[#1 /. {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]}]]
>
>
> Hope this helps,
> -- Jean-Marc
>



-- 
Dr. Stephen Kinsella
www.stephenkinsella.net



  • Prev by Date: Re: How can I create a two-axis graph in Mathematica v6
  • Next by Date: Re: Points on a ContourPlot
  • Previous by thread: Re: Trouble Implementing Schelling's Segregation Model
  • Next by thread: ListDensityPlot in 6.0 creates large eps