program conn4;

uses crt,graph;

const
  b2 = 9; {dialog type}
  b3 = 4; {dialog color}
  b4 = 9; {intro back type}
  b5 = 3; {intro back color}
  b6 = 9; {board back type}
  b7 = 1; {board back color}

type
  piecetype = -1..1;
  boardtype = array[1..7,1..7] of piecetype;
  toptype = array[1..7] of integer;

  procedure draw_board(board:boardtype); forward;

  procedure reset(var board:boardtype;var top:toptype);
  var
    i,j:integer;
  begin
    for i:=1 to 7 do
    begin
      for j:=1 to 7 do board[i,j] := 0;
      top[i] := 0;
    end;
  end;

  function goodmove(a:integer;b:toptype):boolean;
  begin
    if (a<1) or (a>7) then goodmove := false
    else if b[a]=7 then goodmove := false
    else goodmove := true;
  end;

  function scalex(x:integer):integer;
  begin
    scalex := trunc(x*(getmaxx/1000));
  end;

  function scaley(y:integer):integer;
  begin
    scaley := trunc(y*((getmaxy-50)/1000));
  end;

  function find_row(n:integer):integer;
  begin
    find_row:=scalex(trunc(142*n)-71);
  end;

  function find_col(n:integer):integer;
  begin
    find_col:=scaley(trunc(142*n)-71);
  end;

  procedure put_red(x,y:integer);
  begin
    setfillstyle(1,4);
    circle(find_row(x),find_col(y),20);
    floodfill(find_row(x),find_col(y),15);
  end;

  procedure put_green(x,y:integer);
  begin
    setfillstyle(1,2);
    circle(find_row(x),find_col(y),20);
    floodfill(find_row(x),find_col(y),15);
  end;

  procedure kil_square(x,y:integer);
  begin
    setfillstyle(b6,b7);
    bar(find_row(x)-20,find_col(y)-20,find_row(x)+20,find_col(y)+20);
  end;

  procedure kil_message;
  begin
    setfillstyle(b6,b7);
    bar(0,scaley(1050),scalex(1000),scaley(1200));
  end;

  procedure draw_dialog;
  begin
    setfillstyle(b2,b3);
    bar(scalex(400),scaley(400),scalex(600),scaley(600));
    moveto(scalex(400),scaley(400));
    lineto(scalex(600),scaley(400));
    lineto(scalex(600),scaley(600));
    lineto(scalex(400),scaley(600));
    lineto(scalex(400),scaley(400));
  end;

  procedure Hi_bye;
  begin
    setfillstyle(b4,b5);
    bar(scalex(100),scaley(200),scalex(900),scaley(900));
    moveto(scalex(100),scaley(200));
    lineto(scalex(900),scaley(200));
    lineto(scalex(900),scaley(900));
    lineto(scalex(100),scaley(900));
    lineto(scalex(100),scaley(200));
    settextstyle(triplexfont,horizdir,4);
    outtextxy(scalex(285),scaley(300),'Connect 4 v-3.6');
    outtextxy(scalex(190),scaley(500),'Written by Brock Wilcox');
    outtextxy(scalex(200),scaley(700),'c.2021 Eggplant Farms');
    repeat until readkey<>'';
    settextstyle(defaultfont,horizdir,0);
  end;

  procedure init;
  var
    gd,gm:integer;
  begin
    randomize;
    gd := detect;
    initgraph(gd,gm,'c:\tp\bgi');
    if graphresult<>grok then halt;
    Hi_bye;
  end;

  procedure stop_it;
  begin
    closegraph;
    clrscr;
    writeln('Y''all come back now, ya hear?');
    halt;
  end;

  procedure lev(var level:integer);
  var a:char;
  begin
    draw_dialog;
    outtextxy(scalex(480),scaley(445),'What');
    outtextxy(scalex(468),scaley(495),'Level?');
    outtextxy(scalex(476),scaley(550),'<1/2>');
    repeat
    begin
      a := readkey;
      a := upcase(a);
    end;
    until (ord(a)>47) and (ord(a)<52) or (a='Q');
    if a='Q' then stop_it;
    level := ord(a)-48;
  end;


  procedure players(var p,level:integer);
  var a:char;
  begin
    draw_dialog;
    outtextxy(scalex(450),scaley(445),'How many');
    outtextxy(scalex(450),scaley(495),'Players?');
    outtextxy(scalex(470),scaley(550),'<1/2>');
    repeat
    begin
      a := readkey;
      a := upcase(a);
    end;
    until (((a='1') or (a='2')) or ((a='q') or (a='Q')));
    if a='1' then
    begin
      lev(level);
      p:=1;
    end
    else if a='2' then p:=2
    else stop_it;
  end;

  procedure loop_again_cont;
  var a:char;
  begin
    repeat
    begin
      a := readkey;
      a := upcase(a);
    end;
    until ((a='Y') or (a='N'));
    if a='N' then stop_it;
  end;

  procedure play_again(board:boardtype);
  var a:char;
  begin
    draw_dialog;
    outtextxy(scalex(435),scaley(445),'Game over!!');
    outtextxy(scalex(435),scaley(495),'Play again?');
    outtextxy(scalex(470),scaley(550),'<Y/N>');
    loop_again_cont;
  end;

  procedure continue(board:boardtype);
  var a:char;
  begin
    draw_dialog;
    outtextxy(scalex(450),scaley(480),'Continue?');
    outtextxy(scalex(470),scaley(520),'<Y/N>');
    loop_again_cont;
    draw_board(board);
  end;

  procedure plr1(var board:boardtype;var top:toptype);
  var
    m:char;
  begin
    m := ' ';
    while goodmove(ord(m)-48,top)=false do
    begin
      m:=readkey;
      if (m='q') or (m='Q') then continue(board);
    end;
    top[ord(m)-48] := top[ord(m)-48] + 1;
    put_red(ord(m)-48,8-top[ord(m)-48]);
    board[ord(m)-48,top[ord(m)-48]] := 1;
  end;

  procedure plr2(var board:boardtype;var top:toptype);
  var
    m:char;
  begin
    m := ' ';
    while goodmove(ord(m)-48,top)=false do
    begin
      m:=readkey;
      if (m='q') or (m='Q') then continue(board);
    end;
    top[ord(m)-48] := top[ord(m)-48] + 1;
    put_green(ord(m)-48,8-top[ord(m)-48]);
    board[ord(m)-48,top[ord(m)-48]] := -1;
  end;

  function who_win(a:boardtype):integer;
  var
    x,y,z,n,l:integer;
  begin
    who_win :=0;
    for x := 1 to 7 do
      for y := 1 to 4 do
      begin
        n:=0;
        l:=0;
        for z := 0 to 3 do
        begin
          l := l+a[y+z,x];
          n := n+a[x,y+z];
          if (abs(l)<(z+1)) and (abs(n)<(z+1)) then z := 3;
        end;
        if (n = -4) or (l = -4) then who_win := -1;
        if (n = 4) or (l = 4) then who_win := 1;
      end;
    for x := 1 to 4 do
      for y:=1 to 4 do
      begin
        l :=0;
        n:=0;
        for z := 0 to 3 do
        begin
          l:=l+a[x+z,y+z];
          n:=n+a[8-(x+z),(y+z)];
          if (abs(l)<(z+1)) and (abs(n)<(z+1)) then z := 3;
        end;
        if (n = -4) or (l = -4) then who_win := -1;
        if (n = 4) or (l = 4) then who_win := 1;
      end;
  end;

  procedure comp_rand(var board:boardtype;var top:toptype);
  var
    m:integer;
  begin
    m := 0;
    while goodmove(m,top)=false do m:=trunc(random(7))+1;
    top[m] := top[m] + 1;
    put_green(m,8-top[m]);
    board[m,top[m]] := -1;
  end;

  procedure setmove(var board:boardtype;var top:toptype;m,p:integer);
  begin
    top[m] := top[m] + 1;
    board[m,top[m]] := p;
  end;

  procedure unsetmove(var board:boardtype;var top:toptype;m:integer);
  begin
    board[m,top[m]] := 0;
    top[m] := top[m] - 1;
  end;

  function comp_move2(xboard,board:boardtype;top:toptype;level:integer):integer;
  var
    a,b,m,mo,i,ix,j:integer;
    v,xtop:toptype;
  begin
    m:=0;
    mo := 0;
    for i:=1 to 7 do m:=m+top[i];
    if m<50 then
    begin
    for i:=1 to 7 do v[i]:=0;
    m:=-30000;
    for i:=1 to 7 do
    begin
      if top[i] < 7 then
      begin
        ix := i;
        setmove(board,top,i,-1);
        a:=who_win(board);
        if a=-1 then
        begin
          if level>1 then
          begin
            v[i]:=v[i]+5;
            i := 7;
          end else v[i] := v[i] + 1
        end else begin
          for j:=1 to 7 do
          begin
            if top[j]<7 then
            begin
              setmove(board,top,j,1);
              b:=who_win(board);
              if b=1 then v[i]:=v[i]-1
              else if level>2 then v[i] := v[i] + comp_move2(xboard,board,top,level-1);
              unsetmove(board,top,j);
            end;
          end;
        end;
        unsetmove(board,top,ix);
      end;
    end;
    mo := 0;
    for i:=1 to 7 do mo:=mo+v[i];
    end;
    comp_move2:=mo;
  end;

  procedure comp_smart1(var board:boardtype;var top:toptype;level:integer);
  var
    a,b,m,mo,i,ix,j,jx:integer;
    xboard:boardtype;
    v,xtop:toptype;
  begin
    xboard := board;
    xtop := top;
    for i:=1 to 7 do v[i]:=0;
    for i:=1 to 7 do
      if goodmove(i,xtop)=false then v[i]:=-100;
    m:=-30000;
    for i:=1 to 7 do
    begin
      if xtop[i]<7 then
      begin
        ix := i;
        setmove(xboard,xtop,i,-1);
        a:=who_win(xboard);
        if a=-1 then
        begin
          if level>1 then
          begin
            v[i]:=v[i]+1000;
            i := 7;
          end else v[i] := v[i] + 1;
        end else begin
          for j:=1 to 7 do
          begin
            if xtop[j]<7 then
            begin
              jx := j;
              setmove(xboard,xtop,j,1);
              b:=who_win(xboard);
              if b=1 then
              begin
                if level>1 then
                begin
                  v[i]:=v[i]-30;
                  j := 7;
                end else v[i] := v[i] - 20;
              end else if level>1 then v[i] := v[i] + comp_move2(board,xboard,xtop,level);
              unsetmove(xboard,xtop,jx);
            end;
          end;
        end;
        unsetmove(xboard,xtop,ix);
      end;
      outtextxy(scalex(522+((i-1)*12)),scaley(1070),'.');
    end;
    for i:=1 to 7 do
      if v[i]>m then
      begin
        m:=v[i];
        mo:=i;
      end;
    setmove(board,top,mo,-1);
    put_green(mo,8-top[mo]);
  end;


  procedure draw_board(board:boardtype);
  var
    i,j:integer;
  begin
    setfillstyle(b6,b7);
    bar(0,0,getmaxx,getmaxy);
    for i:=1 to 6 do
      line(0,scaley(trunc(142*i)),scalex(1000),scaley(trunc(142*i)));
    for i:=1 to 6 do
      line(scalex(trunc(142*i)),0,scalex(trunc(142*i)),scaley(1000));
    moveto(0,0);
    lineto(0,scaley(1000));
    lineto(scalex(1000),scaley(1000));
    lineto(scalex(1000),0);
    lineto(0,0);
    for i:=0 to 6 do outtextxy(getmaxx-(56+((i)*90)),getmaxy-40,chr(49+(6-i)));
    for i:=1 to 7 do
      for j:=1 to 7 do
      begin
        if board[i,j]=-1 then put_green(i,8-j);
        if board[i,j]=1 then put_red(i,8-j);
      end;
  end;

  procedure get_moves(var board:boardtype;top:toptype;var pl,level:integer);
  var
    moves:integer;
  begin
    moves := 0;
    while (who_win(board)=0) and (moves<49) do
    begin
      outtextxy(scalex(435),scaley(1070),'Red''s turn.');
      plr1(board,top);
      kil_message;
      moves := moves + 1;
      if (who_win(board)<>1) and (moves<49) then
      begin
        if pl=2 then outtextxy(scalex(425),scaley(1070),'Green''s turn.')
        else outtextxy(scalex(422),scaley(1070),'Thinking');
        if pl=2 then plr2(board,top)
          else if level=0 then comp_rand(board,top)
            else comp_smart1(board,top,level);
        kil_message;
        moves := moves + 1;
      end;
    end;
  end;

  procedure show_who_wins(board:boardtype);
  begin
    if who_win(board)=1 then outtextxy(scalex(440),scaley(1070),'Red Wins!!');
    if who_win(board)=-1 then outtextxy(scalex(425),scaley(1070),'Green Wins!!');
    if who_win(board)=0 then outtextxy(scalex(470),scaley(1070),'Tie!!');
  end;

  procedure main;
  var
    board:boardtype;
    top:toptype;
    pl,level:integer;
    done:boolean;
  begin
    done := false;
    init;
    reset(board,top);
    draw_board(board);
    while done=false do
    begin
      reset(board,top);
      players(pl,level);
      draw_board(board);
      get_moves(board,top,pl,level);
      show_who_wins(board);
      play_again(board);
    end;
  end;

begin
  main;
end.