program epics;
  { Evolving pictures }

uses
  TCG, TCProg, GrX, Crt;

const
  NRows = 3;
  NCols = 3;
  N = NRows * Ncols;
  Margin = 20;

  { Dimensions of picture display area: }
  DispX = Margin + (Margin + 64) * NCols;
  DispY = Margin + (Margin + 64) * NRows;

  MaxOps = TCProg.MaxOps;
  ProgWidth = 12;
  MaxTrace = TCProg.MaxTrace;

type
  Bit = 0..1;

  ProgP = TCProg.ProgP;
  Trace = TCProg.Trace;

  PicPos = 0..N-1; { Display position = row * NCols + col. }
  PicLab = char;   { Picture label. }
  PicRef = char;   { Picture label, or ' ' for "none". }
  PicRank = 1..N;  { Picture rank. }

  Pic = record
    lab: PicLab;      { Picture label. }
    pos: PicPos;      { Display position. }
    prog: ProgP;      { Picture definition. }
    mom, dad: PicRef; { Picture's parents. }
    trc: ^Trace;      { Picture's birth record. }
    score: real;      { Picture score for natural selection. }
  end;
  Pics = array [PicRank] of Pic;

  FunPic = function (x, y: integer): real;
    { Score for having a '1' pixel at (x,y). }

function lab_to_rank(var ps: Pics; x: PicLab): PicRank;
  var i: integer;
  begin
    i := 1;
    while ps[i].lab <> x do inc(i);
    lab_to_rank := i
  end;

procedure print_message(line: integer; txt: String);
  const LineHeight = 15;
  var dy: integer;
  begin
    dy := DispY + line * LineHeight;
    GrX.gr_set_color(1.0);
    GrX.gr_print_text(Margin, dy + LineHeight, txt);
  end;

function parity(x: integer): Bit;
  begin
    x := (x shr 16) xor x;
    x := (x shr  8) xor x;
    x := (x shr  4) xor x;
    x := (x shr  2) xor x;
    x := (x shr  1) xor x;
    parity := (x and 1)
  end;

function eval_pic(var p: Prog; x, y: integer): boolean;
  var xy, i: integer;
  begin
    xy := y*64 + x;
    for i := 0 to p.len - 1 do
      begin
        xy := TCG.eval(xy, p.op[i]);
      end;
    { eval_pic := parity(xy) = 0 }
    eval_pic := odd(xy) xor odd(xy shr 6)
  end;

procedure compute_pic_score(var p: Pic; fp: FunPic);
  var x, y, xy: integer;
      score: real;
      pixel: boolean;
  begin
    score := 0.0;
    for x := 0 to 63 do
      for y := 0 to 63 do
        begin
          xy := x + 64*y;
          pixel := eval_pic(p.prog^, x, y);
          if pixel then score := score + fp(x, y)
        end;
    p.score := score;
  end;

procedure print_pic_data(p: Pic);
  var ssco, slen: string;
  begin
    str(p.prog^.len, slen);
    if length(slen) = 1 then slen := '0' + slen;
    if p.score >= 0.0 then
      str(p.score:10:0, ssco)
    else
      ssco := '          ';
    print_message(
      3 + p.pos,
      p.mom + ' + ' + p.dad + ' =  ' + p.lab +
      ssco + '  [' + slen + '] ' + p.trc^
    )
  end;

procedure display_pic(var p: Pic);
  var x, y, xb, yb: integer;
      pixel: boolean;
  begin
    xb := Margin + (64 + Margin) * (p.pos mod NCols);
    yb := Margin + (64 + Margin) * (p.pos div NCols);
    GrX.gr_set_color(0.0);
    GrX.gr_paint_rectangle(xb, xb+64, yb - Margin, yb+64);
    GrX.gr_set_color(1.0);
    GrX.gr_print_text(xb, yb - 2, p.lab);
    for y := 0 to 63 do
      for x := 0 to 63 do
        begin
          pixel := eval_pic(p.prog^, x, y);
          GrX.gr_paint_pixel(x + xb, y + yb, pixel)
        end;
    print_pic_data(p)
  end;

procedure mate_pics(var ps: Pics; mom, dad, kid: PicLab; fn: FunPic);
  var imom, idad, ikid: PicRank;
  begin
    if (kid = mom) or (kid = dad) then
      begin
         writeln('*** ASSERT FAILURE (kid = parent) ***');
         Halt(1)
      end;
    imom := lab_to_rank(ps, mom);
    idad := lab_to_rank(ps, dad);
    ikid := lab_to_rank(ps, kid);
    TCProg.mate_and_mutate(
      ps[imom].prog,
      ps[idad].prog,
      ps[ikid].prog^,
      ps[ikid].trc^
    );
    ps[ikid].mom := mom;
    ps[ikid].dad := dad;
    compute_pic_score(ps[ikid], fn);
    display_pic(ps[ikid]);
  end;

procedure initialize_prog(var pg: Prog);
  var i, nm, nv: integer;
  begin
    pg.len := 0;
    pg.wid := ProgWidth;
    for i := 0 to pg.len -1 do
      begin
        nm := random(pg.wid);
        nv := 1 + random(pg.wid - nm);
        TCG.toss(ProgWidth, nm, nv, pg.op[i]);
      end
  end;

procedure initialize_pic(var pc: Pic; lab: PicLab; pos: PicPos);
  begin
    pc.pos := pos;
    pc.lab := lab;
    pc.score := -1.0;
    new(pc.prog);
    pc.prog^.len := 0;
    pc.prog^.wid := ProgWidth;
    new(pc.trc);
    pc.trc^ := '';
    pc.mom := lab;
    pc.dad := lab;
  end;

procedure initialize_all_pics(var p: Pics; fp: FunPic);
  var i, imom, idad: integer;
      trc: Trace;
  begin
    for i := 1 to N do
      initialize_pic(p[i], chr(ord('0') + i), i-1);
    initialize_prog(p[1].prog^);
    compute_pic_score(p[1], fp);
    display_pic(p[1]);
    for i := 2 to N do
      begin
        idad := 1 + random(i - 1);
        imom := 1 + random(i - 1);
        mate_pics(p, p[idad].lab, p[imom].lab, p[i].lab, fp);
      end
  end;

procedure move_pic(var ps: Pics; which: PicLab; where: PicRank);
  var i, now: integer;
      pt: Pic;
  begin
    { Find selected picture: }
    for i := 1 to N do
      if which = ps[i].lab then now := i;
    { Move it to position $where$: }
    if where < now then
      begin
        pt := ps[now];
        for i := now downto where+1 do ps[i] := ps[i-1];
        ps[where] := pt;
      end
    else if where > now then
      begin
        pt := ps[now];
        for i := now to where-1 do ps[i] := ps[i+1];
        ps[where] := pt
      end;
  end;

procedure pick_dad_and_mate(
    var ps: Pics;
    mom: PicLab;
    lodad, hidad: PicRank;
    fp: FunPic
  );
  var i1, i2, imom, idad, ikid: integer;
  begin
    imom := lab_to_rank(ps, mom);
    if hidad >= N then hidad := N-1;
    i1 := lodad + random(hidad - lodad + 1);
    i2 := lodad + random(hidad - lodad + 1);
    if (i1 < i2) then idad := i1 else idad := i2;
    mate_pics(ps, mom, ps[idad].lab, ps[N].lab, fp);
    ikid := (idad + imom) div 2 + 1;
    move_pic(ps, ps[N].lab, ikid);
  end;

procedure next_generation(var ps: Pics; which: string; fp: FunPic);
  var nkeep, i: integer;
  begin
    nkeep := 0;
    for i := length(which) downto 1 do
      begin
        move_pic(ps, which[i], 1);
        inc(nkeep)
      end;
    if nkeep >= N then nkeep := N-1;
    i := nkeep;
    while nkeep < N do
      begin
        pick_dad_and_mate(ps, ps[i].lab, i, nkeep, fp);
        inc(nkeep);
        if (i > 1) then dec(i)
      end
  end;

function pick_winner(var ps: Pics; ilo, ihi: PicRank): PicLab;
  var stot, smin, s, p, coin: real;
      i: integer;
      lab: PicLab;
  begin
    smin := ps[ilo].score;
    for i := ilo+1 to ihi do
      begin s := ps[i].score; if s < smin then smin := s end;
    stot := 0.0;
    for i := ilo to ihi do
      begin
        s := (ps[i].score - smin) + 0.01;
        stot := stot + s
      end;
    coin := random;
    for i := ilo to ihi do
      begin
        s := (ps[i].score - smin) + 0.01;
        p := s/stot;
        if coin >= 0.0 then lab := ps[i].lab;
        coin := coin - p;
      end;
    pick_winner := lab
  end;

function pick_loser(var ps: Pics; ilo, ihi: PicRank): PicLab;
  var stot, smax, s, p, coin: real;
      i: integer;
      lab: PicLab;
  begin
    smax := ps[ilo].score;
    for i := ilo+1 to ihi do
      begin s := ps[i].score; if s > smax then smax := s end;
    stot := 0.0;
    for i := ilo to ihi do
      begin
        s := (smax - ps[i].score) + 0.01;
        stot := stot + s
      end;
    coin := random;
    for i := ilo to ihi do
      begin
        s := (smax - ps[i].score) + 0.01;
        p := s/stot;
        if coin >= 0.0 then lab := ps[i].lab;
        coin := coin - p;
      end;
    pick_loser := lab
  end;

procedure auto_next_generation(var ps: Pics; fp: FunPic);
  var mom, dad, kid: PicLab;
  begin
    { Selects pic to be replaced by child: }
    kid := pick_loser(ps, 1, N);
    move_pic(ps, kid, N);
    { Selects "mom" and "dad" pictures: }
    mom := pick_winner(ps, 1, N-1);
    move_pic(ps, mom, 1);
    dad := pick_winner(ps, 1, N-1);
    { move_pic(ps, dad, 2); }
    { Mate and recompute scores: }
    mate_pics(ps, mom, dad, kid, fp);
  end;

procedure compute_all_scores(var ps: Pics; fp: FunPic);
  var i: integer;
  begin
    for i := 1 to N do
      begin
        if ps[i].score < 0.0 then
          compute_pic_score(ps[i], fp);
      end;
  end;

procedure display_all_pics(var p: Pics);
  var i: integer;
  begin
    for i := 1 to N do
      display_pic(p[i]);
  end;

function get_datum(msg: string): longint;
  var x: longint;
  begin
    print_message(0, msg);
    print_message(1, '                                      ');
    print_message(1, '                                      ');
    Crt.GotoXY(12, 19);
    readln(x);
    get_datum := x
  end;

{$F+}
function circle_pic(x, y: integer): real;
  var r2: integer;
  begin
    r2 := (x - 32)*(x - 32) + (y - 32)*(y - 32);
    circle_pic := r2
  end;
{$F-}

procedure main;
  var ps: Pics;
      which: longint;
      ng, ig, kg: integer;
      buf: string[20];
  begin
    RandSeed := 418418418;
    GrX.gr_begin_drawing;
    initialize_all_pics(ps, circle_pic);
    {
    which := get_datum('best pics:');
    while which > 0 do
      begin
        if which <= 999999999 then
          next_generation(ps, which)
        else
          print_message(6, 'Bad input!');
        which := get_datum('best pics:');
      end;
    }
    ng := get_datum('num generations:');
    ig := 0;
    while ng > 0 do
      begin
        for kg := 1 to ng do
          begin
            inc(ig);
            str(ig, buf);
            print_message(0, 'generation ' + buf + '         ');
            auto_next_generation(ps, circle_pic)
          end;
        ng := get_datum('num generations:')
      end;
    print_message(0, 'Done (press any key to continue).');
    GrX.gr_end_drawing;
  end;

begin
  main;
end.