#!/usr/local/bin/perl # sim.pl =head1 NOTES This script is the basic simulator with graphical output. This is just a toy implementation designed to run a single simulation to give the user a feel for what is going on. As with all the scripts, Perl must be installed. For this script alone, (but none of the others) the Tk library must also be in the lib. On Linux (or similar) you'll need to get Tk from CPAN (www.cpan.org) and install it yourself. On Windows, the best option is to get a recent version of ActivePerl (www.activestate.com), which is free, and has all the Tk libraries ready to go. The usage is: perl -w sim.pl Defaults will give the maximum cultural isolation, as in the paper. What you'll see is a 3-panelled screen with the population in each cell in the top, the frequencies of gene 1 perl cell in the middle and the frequencies of meme A per cell in the lower panel. To see a rather different effect, try: perl -w sim.pl -contag 0.49 -nn_contag 0.6 -cultsel Y -natsel Y Those parameters should cause fairly rapid spread of meme A to fixation If you want the simulation to run for longer try: perl -w sim.pl -time 200 Other things can be changed by rewriting the script, like: $popsize : the initial population size (default 200) $rep_rate : the reproduction rate (default 1%) $capacity : the max. population capacity per cell (default quasi-infinite) $pause : the refresh rate of the graphical display (default 1 ie. every cycle) As with all Perl scripts, they are offered as is, without any warranties concerning safety, functionality etc The author welcomes any comments on any aspects of the software. to: dgatherer2002@yahoo.co.uk This is an occasionally on-going project and newer versions of code are frequently available, so if you want the really rough cuts, please ask. =cut #------PRELIMINARIES-------------------------------------------------# use strict; # the Holy Trinity of Perl pragmas/modules use POSIX; eval { use Tk; }; srand(); # initialise randomiser #------VARIABLES-----------------------------------------------------# my $popsize = 400; # initial pop my $time = 1000; # over gens my $line = my $cols = 10; # in a 10 by 10 landscape my $rep_rate = 0.01; # pop grows per generation my $contag_rate = 0; # population contage to neighbour per gen my $nn_contag_rate = 0; # chance of contag to other culture my $mig_rate = 0; # pop move every gen my $capacity = 100000000; # max pop per cell my @pop; # map of pop density my @trait_state; my @gene_state; my $pause = 1; # when to stop and draw the map my $cult_sel = "N"; # no cultural selection my $nat_sel = "N"; # no natural selection (of trait) foreach(@ARGV) { if(/-help/) { die "\nUsage: perl -w Listing1.pl -num -time -size -cultsel -natsel\n"; } } my %args = @ARGV; if(exists($args{-num})) {$popsize = $args{-num}; print "\npopsize\t$popsize";} if(exists($args{-time})) {$time = $args{-time}; print "\ntime\t$time";} if(exists($args{-cultsel})) {$cult_sel = $args{-cultsel}; print "\ncult. sel.\t$cult_sel";} if(exists($args{-natsel})) {$nat_sel = $args{-natsel}; print "\nnat. sel.\t$nat_sel";} if(exists($args{-contag})) {$contag_rate = $args{-contag}; print "\ncontag.\t$contag_rate";} if(exists($args{-nn_contag})) {$nn_contag_rate = $args{-nn_contag}; print "\nnn_contag.\t$nn_contag_rate";} if(exists($args{-migrate})) {$mig_rate = $args{-migrate}; print "\nmigrate\t$mig_rate";} foreach($popsize, $time) { if(/[\D+]/) { die "\npopulation size, time must all positive integers\n"; } } foreach($cult_sel, $nat_sel) { unless(/[YN]/) { die "\nCultSel and NatSel must be just Y or N\n"; } } foreach($contag_rate, $nn_contag_rate, $mig_rate) { unless($_ =~ /[\d\.-]/ && ($_ <= 1) && ($_ >= 0)) { die "\ncontagion rates and migration rate must be between 0 and 1\n"; } } #------GRAPHIC_OUTPUT-----------------------------------------------------# my $top = MainWindow->new(); $top->title ("inter:$nn_contag_rate intra:$contag_rate mig:$mig_rate"); my $title = $top->Label(text => "gen.", anchor => "c", relief => "raised", width => 50, height => 1) -> pack(); my $pop_title = $top->Label(text => "population", anchor => "c", relief => "raised", width => 50, height => 1) -> pack(); my $pop_top = $top->Label(relief => "raised", width => 50, height => 11) -> pack(); my $gene_title = $top->Label(text => "vertical", anchor => "c", relief => "raised", width => 50, height => 1) -> pack(); my $gene_top = $top->Label(relief => "raised", width => 50, height => 11) -> pack(); my $trait_title = $top->Label(text => "horizontal", anchor => "c", relief => "raised", width => 50, height => 1) -> pack(); my $trait_top = $top->Label(relief => "raised", width => 50, height => 11) -> pack(); my @pop_buts; # AoAs of buttons, and co-ords my @gene_buts; my @trait_buts; my @xpos; my @ypos; for(my $x=0; $x<=$line-1; $x++) { for(my $y=0; $y<=$cols-1; $y++) { $pop[$x][$y] = 0; $trait_state[$x][$y] = sprintf("%.2f", 0); $gene_state[$x][$y] = sprintf("%.2f", 0); $xpos[$x][$y] = ($x%$line) * 1/$line; $ypos[$x][$y] = ($y%$cols) * 1/$cols; $pop_buts[$x][$y] = $pop_top->Button(-text => $pop[$x][$y], -anchor => 'c', -relief => "flat", -background => "yellow") -> pack(); $pop_buts[$x][$y]->place(-relx => $xpos[$x][$y], -rely => $ypos[$x][$y], -relwidth => 1/$cols, -relheight => 1/$line); $gene_buts[$x][$y] = $gene_top->Button(-text => $gene_state[$x][$y], -anchor => 'c', -relief => "flat", -backgrounnd => "yellow") -> pack(); $gene_buts[$x][$y]->place(-relx => $xpos[$x][$y], -rely => $ypos[$x][$y], -relwidth => 1/$cols, -relheight => 1/$line); $trait_buts[$x][$y] = $trait_top->Button(-text => $trait_state[$x][$y], -anchor => 'c', -relief => "flat", -backgrounnd => "yellow") -> pack(); $trait_buts[$x][$y]->place(-relx => $xpos[$x][$y], -rely => $ypos[$x][$y], -relwidth => 1/$cols, -relheight => 1/$line); } } #------MAIN CODE SEQUENCE---------------------------------------------# my $pop = &evenly_initialise(); &pop_state($pop); # look at it for(my $gen=1;$gen<=$time;$gen++) # for a certain number of cycles { $title->configure(text => "gen. $gen"); $title->update; $pop_title->configure(text => "population $popsize"); $pop_title->update; $pop = &reproduce($pop); # replicate and pass traits by contagion $pop = &migrate($pop); # move strings over grid if($gen%$pause ==0) # can speed by having $pause > 1 { &pop_state($pop); } # look at it } MainLoop(); #-----SUBROUTINES-----------------------------------------------------# #---------------------------------------------------------------------- sub pop_state() # prints current pop { my $input = $_[0]; my $av_fitness = $input ->{FITNESS}; my @current_pop = @{ $input ->{POPULATION} }; > my @gene_state; # arrays for calculating the my @trait_state; # horizontal and vertical dispersal for(my $x=0; $x<=$line-1; $x++) { for(my $y=0; $y<=$cols-1; $y++) { my $freq_A = my $freq_1 = 0; my $cell_count = 0; # how many per cell foreach(@current_pop) { my $xcoord = $_ -> { LOCATION }[0]; my $ycoord = $_ -> { LOCATION }[1]; if($xcoord == $x && $ycoord == $y) { $cell_count++; if($_ -> { TRAIT } eq "A") { $freq_A++; } if($_ -> { SERIAL_NUM } == 1) { $freq_1++; } } } $pop[$x][$y] = $cell_count; if($freq_A == 0 && $freq_1 == 0 && $pop[$x][$y] == 0) { $trait_state[$x][$y] = 0; $gene_state[$x][$y] = 0; } else { $freq_A /= $pop[$x][$y]; $freq_1 /= $pop[$x][$y]; $pop_buts[$x][$y]->configure(-text => $pop[$x][$y]); $pop_buts[$x][$y]->update; $trait_state[$x][$y] = sprintf("%.2f", $freq_A); $trait_buts[$x][$y]->configure(-text => $trait_state[$x][$y]); if($trait_state[$x][$y] > 0 && $trait_state[$x][$y] < 0.5) { $trait_buts[$x][$y]->configure(-background => "green"); } elsif($trait_state[$x][$y] >= 0.5) { $trait_buts[$x][$y]->configure(-background => "red"); } else{ $trait_buts[$x][$y]->configure(-background => "yellow"); } $trait_buts[$x][$y]->update; $gene_state[$x][$y] = sprintf("%.2f", $freq_1); $gene_buts[$x][$y]->configure(-text => $gene_state[$x][$y]); if($gene_state[$x][$y] > 0 && $gene_state[$x][$y] < 0.5) { $gene_buts[$x][$y]->configure(-background => "green"); } elsif($gene_state[$x][$y] >= 0.5) { $gene_buts[$x][$y]->configure(-background => "red"); } else{ $gene_buts[$x][$y]->configure(-background => "yellow"); } $gene_buts[$x][$y]->update; } } } # &disp_calc(\@gene_state, \@trait_state); # try this if you want - write your own output code inside the sub (see below) } #-------------------------------------------------------------------- sub reproduce() { my $input = $_[0]; my $contag_events = my $repro_events = 0; # how many per cycles for(my $b=0;$b<=$popsize-1;$b++) # run through pop { my $rand = rand(); if($nat_sel =~ /Y/i && @{ $input ->{POPULATION} }[$b] ->{TRAIT} eq "A") { $rand /= 2; # double the random number } if($rand < $rep_rate) # also duplicate every 10th one { my $xcoord = @{ $input ->{POPULATION} }[$b] -> { LOCATION }[0]; my $ycoord = @{ $input ->{POPULATION} }[$b] -> { LOCATION }}[1]; if($pop[$xcoord][$ycoord] < $capacity) { my @new_one_seq; my $new_seq = { LOCATION => [ $xcoord, $ycoord ], SERIAL_NUM => @{ $input ->{POPULATION} }[$b] ->{SERIAL_NUM}, TRAIT => @{ $input ->{POPULATION} }[$b] ->{TRAIT}, }; @{ $input ->{POPULATION} }[$popsize++] = $new_seqq; $pop[$xcoord][$ycoord]++; $repro_events++; } } $rand = rand(); if($cult_sel =~ /Y/i && @{ $input ->{POPULATION} }[$b] ->{TRAIT} eq "A") { $rand *= 2; # halve the random number } if($rand < $contag_rate) # and contage every 10th one { my $chosen_one = floor($rand*$popsize); while(abs(@{ $input ->{POPULATION} }[$b] -> { LOCATION }}[0] - @{ $input ->{POPULATION} }[$chosen_one] ->{ LOOCATION }[0]) > 1 || abs(@{ $input ->{POPULATION} }[$b] -> { LOCATION }[1] - @{ $input ->{POPULATION} }[$chosen_one] -> { LOCATION }[1]) > 1)< { # replace with random other string my $chos_rand = rand(); $chosen_one = floor($chos_rand*$popsize); } if($rand < $nn_contag_rate) { if(abs(@{ $input ->{POPULATION} }[$b] -> { LOCATION }}[0] - @{ $input ->{POPULATION} }[$chosen_one] ->{ LOOCATION }[0]) <= 1 && abs(@{ $input ->{POPULATION} }[$b] -> { LOCATION }[1] - @{ $input ->{POPULATION} }[$chosen_one] -> { LOCATION }[1]) <= 1) { @{ $input ->{POPULATION} }[$b] ->{TRAIT} = @{ $input ->{POPULATION} }[$chosen_one] ->{TRAIT}; my $xcoord = @{ $input ->{POPULATION} }[$b] -> { LOCATION }[0]; # direct access, better ?? my $ycoord = @{ $input ->{POPULATION} }[$b] -> { LOCATION }[1]; # yes, same method for string access my $trait = @{ $input ->{POPULATION} }[$b] -> { TRAIT }; $contag_events++; next; # only one contag per indiv per gen } } else { while(abs(@{ $input ->{POPULATION} }[$b] -> { LOCATION }}[0] - @{ $input ->{POPULATION} }[$chosen_one] ->{ LOOCATION }[0]) > 0 || abs(@{ $input ->{POPULATION} }[$b] -> { LOCATION }[1] - @{ $input ->{POPULATION} }[$chosen_one] -> { LOCATION }[1]) > 0) { # replace with random other string my $chos_rand = rand(); $chosen_one = floor($chos_rand*$popsize); } @{ $input ->{POPULATION} }[$b] ->{TRAIT} = @{ $input ->{POPULATION} }[$chosen_one] ->{TRAIT}; my $xcoord = @{ $input ->{POPULATION} }[$b] -> { LOCATION }}[0]; # direct access, better ?? my $ycoord = @{ $input ->{POPULATION} }[$b] -> { LOCATION }}[1]; # yes, same method for string access my $trait = @{ $input ->{POPULATION} }[$b] -> { TRAIT }; $contag_events++; next; } } } return $input; } #-------------------------------------------------------------------- sub migrate() # rather similar to reproduce { my $input = $_[0]; my $migrats = 0; # how many for(my $b=0;$b<=$popsize-1;$b++) { my $rand = rand(); if($rand < $mig_rate) { # choose $rand = rand(); # random direction my $xcoord = @{ $input ->{POPULATION} }[$b] ->{LOCATION}[0]]; my $ycoord = @{ $input ->{POPULATION} }[$b] ->{LOCATION}[1]]; if($rand <= 0.125 && $xcoord >0 && $ycoord >0) # go up and left { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[0]]--; @{ $input ->{POPULATION} }[$b] ->{LOCATION}[1]]--; $pop[$xcoord][$ycoord]--; $pop[$xcoord-1][$ycoord-1]++; $migrats++; } elsif($rand <= 0.25 && $xcoord >0) # go straight up { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[0]]--; $pop[$xcoord-1][$ycoord]++; $pop[$xcoord][$ycoord]--; $migrats++; } elsif($rand <= 0.375 && $xcoord >0 && $ycoord <$cols-1) # go up and right { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[0]]--; @{ $input ->{POPULATION} }[$b] ->{LOCATION}[1]]++; $pop[$xcoord-1][$ycoord+1]++; $pop[$xcoord][$ycoord]--; $migrats++; } elsif($rand <= 0.5 && $ycoord <$cols-1) # go straight right { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[1]]++; $pop[$xcoord][$ycoord+1]++; $pop[$xcoord][$ycoord]--; $migrats++; } elsif($rand <= 0.625 && $xcoord <$line-1 && $ycoord <$cols-1) # go down and right { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[0]]++; @{ $input ->{POPULATION} }[$b] ->{LOCATION}[1]]++; $pop[$xcoord+1][$ycoord+1]++; $pop[$xcoord][$ycoord]--; $migrats++; } elsif($rand <= 0.75 && $xcoord <$line-1) # go straight down { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[0]]++; $pop[$xcoord+1][$ycoord]++; $pop[$xcoord][$ycoord]--; $migrats++; } elsif($rand <= 0.825 && $xcoord < $line-1 && $ycoord > 0) # go down and left { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[0]]++; @{ $input ->{POPULATION} }[$b] ->{LOCATION}[1]]--; $pop[$xcoord+1][$ycoord-1]++; $pop[$xcoord][$ycoord]--; $migrats++; } elsif($ycoord >0) # go straight left { @{ $input ->{POPULATION} }[$b] ->{LOCATION}[1]]--; $pop[$xcoord][$ycoord-1]++; $pop[$xcoord][$ycoord]--; $migrats++; } } } return $input; } #--------------------------------------------------------------------------------------------# sub evenly_initialise() # initialise population { my @seq_array; # initialise array for seqs my $indiv_fitness = 0; # fitness of string, only used when seln. operating my $av_fitness = 0; # for whole pop, only used when seln. operating my $st_dev = 0; # ditto for(my $x=0; $x<=$line-1; $x++) { for(my $y=0; $y<=$cols-1; $y++) { if($popsize < ($line*$cols)) { die "popsize too small" }; for(my $z=0;$z<=($popsize/($line*$cols))-1;$z++) # run through pop { my @one_seq; # re-initialise each string my $rand = rand(); # decide on horiz trait state my $horiz_trait; my $initial_id; if ($rand < 0.25) { $horiz_trait = "A"; } elsif ($rand < 0.5) { $horiz_trait = "B"; } elsif ($rand < 0.75) { $horiz_trait = "C"; } else { $horiz_trait = "O"; } $rand = rand(); # decide on vertical trait state if ($rand < 0.25) { $initial_id = 1; } elsif ($rand < 0.5) { $initial_id = 2; } elsif ($rand < 0.75) { $initial_id = 3; } else { $initial_id = 4; } my $new_seq = { LOCATION => [ $x, $y ], # all are initially in square 0,0 SERIAL_NUM => $initial_id, # for lineage mapping TRAIT => $horiz_trait, # will pass by contagion }; push @seq_array, $new_seq; } } } # RECORD OF POP my $new_pop = { POPULATION => [ @seq_array ], }; return $new_pop; } #--------------------------------------------------------------------------------------------# sub disp_calc() # calculates dispersals, (optional - commented out above, try adding some output code of your own) { my($gene_state, $trait_state) = @_; my $total_genes = my $total_traits = my $nbrd_genes = my $nbrd_traits =0; my @genes = @$gene_state; my @traits = @$trait_state; for(my $x=0; $x<=$line-1; $x++) { for(my $y=0; $y<=$cols-1; $y++) { if($genes[$x][$y] >= 0.5) { $total_genes++; unless($x == 0 || $y == 0 || $x == $line-1 || $y == $cols-1) { if($genes[$x+1][$y] >= 0.5 || $genes[$x-1][$y] >= 0.5 || $genes[$x][$y+1] >= 0.5 || $genes[$x][$y-1] >= 0.5 || $genes[$x+1][$y+1] >= 0.5 ||$genes[$x-1][$y-1] >= 0.5 || $genes[$x+1][$y-1] >= 0.5 || $genes[$x-1][$y+1] >= 0.5) { $nbrd_genes++; } } else { if($x == 0 && $y == 0) # top left { if($genes[$x+1][$y] >= 0.5 || $genes[$x][$y+1] >= 0.5 || $genes[$x+1][$y+1] >= 0.5) { $nbrd_genes++; } } elsif($x == 0 && $y == $cols-1) # top right { if($genes[$x+1][$y] >= 0.5 || $genes[$x][$y-1] >= 0.5 || $genes[$x+1][$y-1] >= 0.5) { $nbrd_genes++; } } elsif($x == $line-1 && $y == 0) # bottom left { if($genes[$x-1][$y] >= 0.5 || $genes[$x][$y+1] >= 0.5 || $genes[$x-1][$y+1] >= 0.5) { $nbrd_genes++; } } elsif($x == $line-1 && $y == $cols-1) # bottom right { if($genes[$x-1][$y] >= 0.5 || $genes[$x][$y-1] >= 0.5 || $genes[$x-1][$y-1] >= 0.5) { $nbrd_genes++; } } elsif($x == 0) # top row { if($genes[$x+1][$y] >= 0.5 || $genes[$x][$y+1] >= 0.5 || $genes[$x][$y-1] >= 0.5 || $genes[$x+1][$y+1] >= 0.5 || $genes[$x+1][$y-1] >= 0.5) { $nbrd_genes++; } } elsif($y == 0) # left column { if($genes[$x+1][$y] >= 0.5 || $genes[$x-1][$y] >= 0.5 || $genes[$x][$y+1] >= 0.5 || $genes[$x+1][$y+1] >= 0.5 || $genes[$x-1][$y+1] >= 0.5) { $nbrd_genes++; } } elsif($x == $line-1) # bottom row { if($genes[$x-1][$y] >= 0.5 || $genes[$x][$y+1] >= 0.5 || $genes[$x][$y-1] >= 0.5 ||$genes[$x-1][$y-1] >= 0.5 || $genes[$x-1][$y+1] >= 0.5) { $nbrd_genes++; } } elsif($y == $cols-1) # right column { if($genes[$x+1][$y] >= 0.5 || $genes[$x-1][$y] >= 0.5 || $genes[$x][$y-1] >= 0.5 ||$genes[$x-1][$y-1] >= 0.5 || $genes[$x+1][$y-1] >= 0.5) { $nbrd_genes++; } } } } if($traits[$x][$y] >= 0.5) { $total_traits++; unless($x == 0 || $y == 0 || $x == $line-1 || $y == $cols-1) { if($traits[$x+1][$y] >= 0.5 || $traits[$x-1][$y] >= 0.5 || $traits[$x][$y+1] >= 0.5 || $traits[$x][$y-1] >= 0.5 || $traits[$x+1][$y+1] >= 0.5 ||$traits[$x-1][$y-1] >= 0.5 || $traits[$x+1][$y-1] >= 0.5 || $traits[$x-1][$y+1] >= 0.5) { $nbrd_traits++; } } else { if($x == 0 && $y == 0) # top left { if($traits[$x+1][$y] >= 0.5 || $traits[$x][$y+1] >= 0.5 || $traits[$x+1][$y+1] >= 0.5) { $nbrd_traits++; } } elsif($x == 0 && $y == $cols-1) # top right { if($traits[$x+1][$y] >= 0.5 || $traits[$x][$y-1] >= 0.5 || $traits[$x+1][$y-1] >= 0.5) { $nbrd_traits++; } } elsif($x == $line-1 && $y == 0) # bottom left { if($traits[$x-1][$y] >= 0.5 || $traits[$x][$y+1] >= 0.5 || $traits[$x-1][$y+1] >= 0.5) { $nbrd_traits++; } } elsif($x == $line-1 && $y == $cols-1) # bottom right { if($traits[$x-1][$y] >= 0.5 || $traits[$x][$y-1] >= 0.5 || $traits[$x-1][$y-1] >= 0.5) { $nbrd_traits++; } } elsif($x == 0) # top row { if($traits[$x+1][$y] >= 0.5 || $traits[$x][$y+1] >= 0.5 || $traits[$x][$y-1] >= 0.5 || $traits[$x+1][$y+1] >= 0.5 || $traits[$x+1][$y-1] >= 0.5) { $nbrd_traits++; } } elsif($y == 0) # left column { if($traits[$x+1][$y] >= 0.5 || $traits[$x-1][$y] >= 0.5 || $traits[$x][$y+1] >= 0.5 || $traits[$x+1][$y+1] >= 0.5 || $traits[$x-1][$y+1] >= 0.5) { $nbrd_traits++; } } elsif($x == $line-1) # bottom row { if($traits[$x-1][$y] >= 0.5 || $traits[$x][$y+1] >= 0.5 || $traits[$x][$y-1] >= 0.5 ||$traits[$x-1][$y-1] >= 0.5 || $traits[$x-1][$y+1] >= 0.5) { $nbrd_traits++; } } elsif($y == $cols-1) # right column { if($traits[$x+1][$y] >= 0.5 || $traits[$x-1][$y] >= 0.5 || $traits[$x][$y-1] >= 0.5 ||$traits[$x-1][$y-1] >= 0.5 || $traits[$x+1][$y-1] >= 0.5) { $nbrd_traits++; } } } } } } my $g_dispersal; ($total_genes > 0) ? ($g_dispersal = 1-($nbrd_genes/$total_genes)) : ($g_dispersal = 1); my $t_dispersal; ($total_traits > 0) ? ($t_dispersal = 1-($nbrd_traits/$total_traits)) : ($t_dispersal = 1); # try writing some output code here }