program CultureDemo1;
{Axelrod's Cultural Demonstration Program}
{   begun 10/17/95 for PS 794}
{See "Cultural Demo Documentation" for details}

{Ver1, begun 10/17/95}
{       Allows only 4 neigbhors}
{       Allows maximum of 20x20 territory}


    const
{control constants}
        Version = 1;                                        {Program Version Number}
        old_random_seed = 0;        {0 means new seed, else enter an old seed to reuse}
        cyclemax = 200;         {number of cycles[events] in each reporting period. Cylce is one active actor.}
        periodmax = 10;             {number of periods of cyclemax each.}
        popmax = 1;                 {number of populations, each with cyclemax*periodmax active actors}
        write_cultures = True;  {if true, report each individual's culture each period}
        write_distances = True; {if true, report cultureal distance between adjacent sites}

{input parameters}
        Xmax = 5;                       {Size of land, west to east.}
        Ymax = 5;                       {Size of land, north to south.}
        bitmax = 5;                 {Traits. Size of chromosome, i.e. number of bits in indiv's culture. }
        allelemax = 10;             {Number of traits per feature}


    type
        x_type = 1..xmax;                           {range of  indiv's x coord}
        y_type = 1..ymax;                           {range of indiv's y coord}
        bit_type = 1..bitmax;                       {bit on culture}
        culture_array = array[0..21, 0..21, 1..bitmax] of integer;  {for x, y,bit}
  {max actual geography is 20x20}
        direction_type = 1..4;                          {4 neighbors; north, s, e, w order}
        direction_array = array[1..4] of integer;                   {for x and y moves}
    var
        initial_datetime, end_datetime: datetimerec;    {date, etc.}
        initial_hour, end_hour: longint;
        start_time, end_time, duration: longint;    {for calc of run's duration}
        random_seed: integer;
        pop: integer;                                       {current population number, 1...popmax}
        period: integer;                                    {current period number, 1..periodmax}
        cycle: integer;                                     {current cycle (ie active indiv), 1..cyclemax}
        ix: x_type;                                 {x coordinate of current active individual}
        iy: y_type;                                 {y coordinate of current active individual}
        jx: integer;                                    {x coord of a neighbor, 0..xmax+1}
        jy: integer;                                    {y coord of a neighbor, 0..ymax+1}
        culture: culture_array;                     {culture of ix,iy,bit - an integer variable}
            {-1 for beyond bord, or 0 or 1 for internal indiv's culture}
            {x=0 is beyond internal left border, x=xmax+1 is beyond right border, etc.}
            {This allows indivs on internal border to get automatic non-matches with illegal neighbors}
        xmove, ymove: direction_array;              {jointly defines North, East, West, South direction}
        bit: bit_type;                                      {the current bit of the culture}
        neighbor: direction_type;                       {neighbor, 1 to 4}
        direction: direction_type;                      {4 neighbors; north, s, e, w order}
        event: integer;                                     {cumulative count of events in this pop}
        changes_this_period: integer;                   {count of changes in this period}

  { ---------------------------------------------------------------  }
    function random_one_to_n (n: longint): longint;     {Same as in Tipping4 Program}
                            {proc returns a random number between 1 and n; modified from Bennett's random_range}
        var
            ub, lb: integer;
            r: integer;
    begin                                                       {random gives # betw -32768 and 32767}
        ub := 32767 - (32767 mod n);
        lb := -32768 - (-32768 mod n);                  {truncate distrib on 2 ends so that later mod is OK}
        repeat
            r := random;
        until (r <= ub) and (r >= lb);                      {make sure random genrated is in truncated (even) distrib}
        random_one_to_n := abs(r mod n) + 1;
    end;            {random function}
 { ---------------------------------------------------------------  }
    procedure set_random_seed;          {Same as in Tipping4 Program}
    begin
        if old_random_seed = 0 then
            begin                                               {generate new seed}
                random_seed := initial_datetime.hour + initial_datetime.minute + initial_datetime.second;
                random_seed := random_seed + (initial_datetime.second * 300);
                random_seed := random_seed + (initial_datetime.minute * initial_datetime.hour);
                random_seed := random_seed + (initial_datetime.minute * initial_datetime.second);
                randseed := random_seed;                {set system's random seed}
            end
        else
            begin                                       {use old seed, which was inputed as constant}
                randseed := old_random_seed;
            end;
    end; {set_random_seed;}
 { ---------------------------------------------------------------  }
    procedure Initialize_run;
        var
            x, y, bit: integer;
    begin
        gettime(initial_datetime);
        initial_hour := initial_datetime.hour;              {to force long int}
        start_time := 60 * 60 * initial_hour + 60 * initial_datetime.minute + initial_datetime.second;
        Writeln('Axelrod''s Cultural Demo Program, Version ', Version : 4);
        Write('   This run begun on ', initial_datetime.month : 2, '/', initial_datetime.day : 2);
        Writeln('/', initial_datetime.year : 4, ' at ', initial_datetime.hour : 2, ':', initial_datetime.minute : 2, '.');
        Writeln(cyclemax : 5, ' cycles in each reporting period');
        Writeln(periodmax : 5, '    periods in each population');
        Writeln(popmax : 5, '   population');
        Writeln(xmax : 5, ' width of land, east to west (number of cols.)');
        Writeln(ymax : 5, ' width of land, north to south (number of rows)');
        Writeln(bitmax : 5, '   traits in culture string');
        Writeln(allelemax : 5, '    features per trait');
        set_random_seed;
        writeln;
        for x := 1 to xmax do                           {initialize ind's beyond the internal borders. Never changes.}
            begin
                for bit := 1 to bitmax do
                    begin
                        culture[x, 0, bit] := -1;           {initial culture for beyond top internal border}
                        culture[x, ymax + 1, bit] := -1;            {initial culture for beyond bottom internal }
                    end;
            end; {x}
        for y := 1 to ymax do                           {initialize indiv's beyond the internal borders. Never changes.}
            begin
                for bit := 1 to bitmax do
                    begin
                        culture[0, y, bit] := -1;           {initial culture for beyond left internal border}
                        culture[Xmax + 1, y, bit] := -1;            {initial for beyond right internal border}
                    end;
            end;{y}
        Xmove[1] := 0;                  {define North, in seeking neighbors}
        Ymove[1] := -1;
        Xmove[2] := 1;                  {define East}
        Ymove[2] := 0;
        Xmove[3] := -1;                 {define West}
        Ymove[3] := 0;
        Xmove[4] := 0;                  {define South}
        Ymove[4] := 1;
    end; {initialize run procedure}

  { ---------------------------------------------------------------  }
    procedure interact;                 {i converges one bit to j if possible}
        var
            try_another_bit: boolean;       {control on whether still searching for another bit that differs}
            bit_count: integer;             {count so as to give up when all bit tried, ie x=y}
            bit_try: integer;               {bit being tried looking for dissimilarity}
    begin
        bit_try := random_one_to_n(bitmax);         {initial bit location tried}
        try_another_bit := true;
        bit_count := 1;
        repeat
            if culture[ix, iy, bit_try] <> culture[jx, jy, bit_try] then
                begin
                    culture[ix, iy, bit_try] := culture[jx, jy, bit_try];       {i converges since unequal on current bit}
                    changes_this_period := changes_this_period + 1;     {a change took place}
                    try_another_bit := false;                               { done with search }
                end
            else
                begin
                    bit_count := bit_count + 1;
                    bit_try := (bit_try + 1) mod bitmax + 1;
                    if bit_count > bitmax then                      {give up because just tried all bits}
                        try_another_bit := false;
                end;
        until try_another_bit = false;
    end;{interact procedure}
  { ---------------------------------------------------------------  }
    procedure Report_Cultures;          {from output_period procedure}
        var                                                     {reports first five bits of culture}
            xtemp, ytemp: integer;
            bit_temp: integer;
    begin
        for ytemp := 1 to ymax do
            begin
                write(' y=', ytemp : 3, '. Culture = ');
                for xtemp := 1 to xmax do
                    begin
                        for bit_temp := 1 to bitmax do
                            begin
                                write(culture[xtemp, ytemp, bit_temp] : 1);
                            end;{bit_temp}
                        write('  ');        {space between individuals}
                    end;{ixtemp}
                writeln;
            end; {iytemp}
    end;
  { ---------------------------------------------------------------  }
    procedure Calc_and_Report_Distance;                 {cultural distances with output}
        type
            row_array = array[1..xmax] of integer;          {for output of distances}
        var
            xtemp, ytemp: integer;          {geo loc}
            itemp: integer;                     {bit position}
            X_distance: row_array;          {cultural distance between (x,y) to (x+1,y), ie to right }
            Y_distance: row_array;          {cultural distance between (x,y) to (x,y+1), ie down }
    begin
        for ytemp := 1 to ymax do
            begin
                for xtemp := 1 to xmax do
                    begin
                        X_distance[xtemp] := 0;             {calcs will be for one row at a time}
                        Y_distance[xtemp] := 0;
                        for itemp := 1 to bitmax do
                            begin                                           {increment distance on x axis, then y axis}
                                if xtemp < xmax then                        {to avoid going off right side}
                                    if culture[xtemp, ytemp, itemp] <> culture[xtemp + 1, ytemp, itemp] then
                                        X_distance[xtemp] := X_distance[xtemp] + 1;
                                if (ytemp < ymax) then                  {only do down calcs if not last row}
                                    begin
                                        if (culture[xtemp, ytemp, itemp] <> culture[xtemp, ytemp + 1, itemp]) then
                                            Y_distance[xtemp] := Y_distance[xtemp] + 1
                                    end; {if not last row}
                            end; {itemp loop for culture bits}
                    end; {xtemp loop for calc distances}
                if write_distances then
                    begin
                        write('y= ', ytemp : 3, '. Dis across: ');
                        for xtemp := 1 to xmax - 1 do
                            begin  {write row for across distances}
                                write(' ', X_distance[xtemp] : 3);
                            end; {xtemp for writing row for across distances}
                        writeln;
                        if (ytemp < ymax) then
                            write('y= ', ytemp : 3, '. Dis down: ');
                        if (ytemp < ymax) then
                            begin
                                for xtemp := 1 to xmax do
                                    begin  {write row for distances down, only if not last row}
                                        write(' ', Y_distance[xtemp] : 3);
                                    end; {xtemp for writing row for  distances down}
                                writeln;
                            end; {if not last row}
                    end;{if write_distances}
            end;{ytemp}
        writeln;
    end;
  { ---------------------------------------------------------------  }
    procedure Periodic_Output;
    begin
        writeln('Event', event : 5, '. Changes this period', changes_this_period : 5, '.');
        if write_cultures then
            Report_Cultures;                                    {first output of a period}
        Calc_and_Report_Distance;                   {second output of a period}
    end;
 { ---------------------------------------------------------------  }
    procedure Initialize_pop;
        var
            x, y: integer;                                      {local variable for coord of an individual}
            bit: integer;                                       {local variable for number of gene on the cultrual chormosome}
    begin
        writeln('Pop ', pop : 3, ':');
        for x := 1 to xmax do
            begin
                for y := 1 to ymax do
                    begin
                        for bit := 1 to bitmax do
                            begin
                                culture[x, y, bit] := Random_One_to_N(allelemax) - 1;
                    {initial culture for internal places}
                            end;
                    end;
            end; {x loop}
        changes_this_period := 0;                           {Needed here for pop >1}
        Periodic_Output;
    end; {initialize_pop procedure}
  { ---------------------------------------------------------------  }
    procedure Output_Run;                       {Output for run - last thing written}
    begin
        gettime(end_datetime);
        end_hour := end_datetime.hour;          {to force long interger}
        end_time := 60 * 60 * end_hour + 60 * end_datetime.minute + end_datetime.second;
        duration := end_time - start_time;
        Writeln('Duration of this run is ', duration : 5, ' seconds.');
    end;
 { ---------------------------------------------------------------  }
 {- - - - - - - - - - - - - - - - - ----------------- - - - - - - - - - - - - - - - - }
 { ---------------------------------------------------------------  }
{M A I N    P R O G R A M }
begin
    initialize_run;                                                             {initialize whole run}
    for pop := 1 to popmax do
        begin
            event := 0;                                                         {count of events in this pop}
            Initialize_pop;                                                 {INITIALIZE current population}
            for period := 1 to periodmax do                          {REPORTING PERIOD }
                begin
                    changes_this_period := 0;                           {count of changes in this period}
                    for cycle := 1 to cyclemax do                   {CYCLE of one active actor}
                        begin
                            event := event + 1;                             {every cycle is an event}
                            ix := Random_one_to_n(Xmax);            {select X coord of active actor}
                            iy := Random_one_to_n(Ymax);            {select Y coord of active actor}
                            bit := random_one_to_n(bitmax);     {first bit to be checked for match}
                            repeat                                              {get an internal direction}
                                direction := random_one_to_n(4);        {select one of four directions for interaction}
                                jx := ix + xmove[direction];                {cacl  coords of selected neighbor}
                                jy := iy + ymove[direction]
                            until culture[jx, jy, bit] <> -1;           {check not gotten a neighbor outside of region}
                            if (culture[ix, iy, bit] = culture[jx, jy, bit]) then  {match on selected bit}
                                interact;                                           {including count if a change occured}
                        end; { cycle of one active }
                    Periodic_Output;
                end;{pop cycle}
        end; {run}
    Output_Run;                                         {output of the run}
end.{main program}