puzzle.pas

puzzle.pas | Makefile

program Puzzle;

uses Crt;

const
  lastStone = $F;
  lastField = lastStone;
  lastField_Col = 2 + 3;
  lastField_Row = lastField_Col;
  lastDirection = 3;
  clean = -1;

type
  pFields = array[$0..lastField_Col, $0..lastField_Row] of
             Integer;

  pStones = array[$0..lastStone] of
             record
               used: Boolean;
               direction: Cardinal;
               clr: record
                      north, east, south, west: Cardinal;
                    end;
             end;

var
  fields: pFields;
  stones: pStones;
  delTime, errCode: Integer;

procedure ProcParams;
begin
  if ParamCount = 0 then
    delTime := 0
  else
  begin
    if ParamStr(1) = 'step' then
      delTime := -1
    else
    begin
      Val(ParamStr(1), delTime, errCode);
      if (errCode <> 0) or (delTime < 1) then
      begin
        WriteLn(stdErr, 'invalid delay time given');
        Halt(1);
      end;
    end;
  end;
end;

procedure ShowPuzzle;
var
  c, r: Cardinal;

procedure GotoYX(y, x: Cardinal);
begin
  GotoXY(x, y);
end;

procedure DrawSquare;
var
  offC, offR: Cardinal;
begin
  offC := Succ(Pred(c) * 4);
  offR := Succ(Pred(r) * 3) + 2;
  TextColor(darkgray);
  GotoYX(offR,     offC    ); Write(#218);
  GotoYX(offR,     offC + 3); Write(#191);
  GotoYX(offR + 2, offC + 3); Write(#217);
  GotoYX(offR + 2, offC    ); Write(#192);
  GotoYX(offR + 1, offC + 1);
  if fields[c][r] > 9 then
    Write(Char(fields[c][r] - 10 + Ord('A')))
  else
    Write(fields[c][r]);
  Write(stones[fields[c][r]].Direction);

  TextColor(stones[fields[c][r]].Clr.North);
  GotoYX(offR,     offC + 1); Write(#196 #196);
  TextColor(stones[fields[c][r]].Clr.East);
  GotoYX(offR + 1, offC + 3); Write(#179);
  TextColor(stones[fields[c][r]].Clr.South);
  GotoYX(offR + 2, offC + 1); Write(#196 #196);
  TextColor(stones[fields[c][r]].Clr.West);
  GotoYX(offR + 1, offC    ); Write(#179);
end;

begin
  ClrScr;
  for c := 1 to Pred(lastField_Col) do
    for r := 1 to Pred(lastField_Row) do
      if fields[c][r] <> clean then DrawSquare;

  if delTime <> 0 then
    if delTime = -1 then
      ReadKey
    else
      Delay(delTime);
end;

procedure Initstones;
var
  i: Cardinal;
begin
  stones[$0].Clr.North := white; stones[$0].Clr.East := blue;
  stones[$0].Clr.South := blue; stones[$0].Clr.West := red;
  stones[$1].Clr.North := green; stones[$1].Clr.East := red;
  stones[$1].Clr.South := red;   stones[$1].Clr.West := white;
  stones[$2].Clr.North := blue; stones[$2].Clr.East := blue;
  stones[$2].Clr.South := blue; stones[$2].Clr.West := blue;
  stones[$3].Clr.North := green; stones[$3].Clr.East := blue;
  stones[$3].Clr.South := blue; stones[$3].Clr.West := green;
  stones[$4].Clr.North := green; stones[$4].Clr.East := white;
  stones[$4].Clr.South := red;   stones[$4].Clr.West := red;
  stones[$5].Clr.North := green; stones[$5].Clr.East := green;
  stones[$5].Clr.South := blue; stones[$5].Clr.West := blue;
  stones[$6].Clr.North := white; stones[$6].Clr.East := red;
  stones[$6].Clr.South := green; stones[$6].Clr.West := blue;
  stones[$7].Clr.North := green; stones[$7].Clr.East := red;
  stones[$7].Clr.South := blue; stones[$7].Clr.West := blue;
  stones[$8].Clr.North := red;   stones[$8].Clr.East := green;
  stones[$8].Clr.South := blue; stones[$8].Clr.West := green;
  stones[$9].Clr.North := blue; stones[$9].Clr.East := blue;
  stones[$9].Clr.South := blue; stones[$9].Clr.West := blue;
  stones[$A].Clr.North := white; stones[$A].Clr.East := green;
  stones[$A].Clr.South := blue; stones[$A].Clr.West := white;
  stones[$B].Clr.North := white; stones[$B].Clr.East := blue;
  stones[$B].Clr.South := blue; stones[$B].Clr.West := white;
  stones[$C].Clr.North := green; stones[$C].Clr.East := red;
  stones[$C].Clr.South := red;   stones[$C].Clr.West := red;
  stones[$D].Clr.North := red;   stones[$D].Clr.East := red;
  stones[$D].Clr.South := green; stones[$D].Clr.West := red;
  stones[$E].Clr.North := blue; stones[$E].Clr.East := red;
  stones[$E].Clr.South := blue; stones[$E].Clr.West := blue;
  stones[$F].Clr.North := blue; stones[$F].Clr.East := green;
  stones[$F].Clr.South := red;   stones[$F].Clr.West := blue;

  for i := 0 to lastStone do
    stones[i].Direction := 0;
    stones[i].Used := false;
end;

procedure Initfield;
var
  c, r: Cardinal;
begin
  for c := 0 to lastField_Col do
    for r := 0 to lastField_Row do
      fields[c][r] := clean;
end;

procedure Applystones_Impr_2;
var
  c, r, tempClr: Cardinal;
  wStone: Integer;

label
  initWStone,
  advWStone,
  placeWStone,
  resetWStoneDir,
  checkWStoneMatch,
  checkAnothDirAvail,
  checkAnothStoneAvail,
  checkPrevFieldAvail,
  stopByError,
  stopBySuccess,
  done;

begin
  // point to first field
  c := 1;
  r := 1;

  // init wStone
  initwStone:
    wStone := -1;

  // advance wStone until free one is found
  advwStone:
    Inc(wStone);
    if stones[wStone].Used then
      goto advwStone;

  // check whether found wStone matches
  checkwStoneMatch:
    if ((fields[c][Pred(r)] = clean) or
        (stones[fields[c][Pred(r)]].Clr.South = stones[wStone].Clr.North)) and
       ((fields[c][Succ(r)] = clean) or
        (stones[fields[c][Succ(r)]].Clr.North = stones[wStone].Clr.South)) and
       ((fields[Pred(c)][r] = clean) or
        (stones[fields[Pred(c)][r]].Clr.East = stones[wStone].Clr.West )) and
       ((fields[Succ(c)][r] = clean) or
        (stones[fields[Succ(c)][r]].Clr.West = stones[wStone].Clr.East )) then
      goto placewStone;

  // check whether wStone still rotatable
  checkAnothDirAvail:
    if stones[wStone].Direction = lastDirection then
      goto resetwStoneDir;

  // rotate wStone into next direction
    with stones[wStone] do
    begin
      tempClr   := Clr.West;
      Clr.West := Clr.South;
      Clr.South := Clr.East;
      Clr.East := Clr.North;
      Clr.North := tempClr;
      Inc(Direction);
    end;
    goto checkwStoneMatch;

  // reset wStone color direction to zero
  resetwStoneDir:
    with stones[wStone] do
    begin
      tempClr   := Clr.West;
      Clr.West := Clr.South;
      Clr.South := Clr.East;
      Clr.East := Clr.North;
      Clr.North := tempClr;
      Direction := 0;
    end;

  // check whether another stone available
  checkAnothStoneAvail:
    if wStone = lastStone then
      goto checkPrevFieldAvail;

  // advance wStone and check whether free
    Inc(wStone);
    if stones[wStone].used then
      goto checkAnothStoneAvail;
    goto checkwStoneMatch;

  // place current wStone permanently and set used
  placewStone:
    fields[c][r] := wStone;
    stones[wStone].used := true;
    ShowPuzzle; // fdpo

  // check whether another field available
    if (c = Pred(lastField_Col)) and (r = Pred(lastField_Row)) then
      goto stopBySuccess;

  // advance to next field
    if r = Pred(lastField_Row) then
    begin
      Inc(c);
      r := 1;
    end
    else
      Inc(r);
    goto initwStone;

  // check whether previous field available
  checkPrevFieldAvail:
    if (c = 1) and (r = 1) then
      goto stopByError;

  // reset current field to clean
    fields[c][r] := clean;

  // step back to previous field
    if r = 1 then
    begin
      Dec(c);
      r := Pred(lastField_Row);
    end
    else
      Dec(r);

  // set wStone to permanently placed stone and set free
    wStone := fields[c][r];
    stones[wStone].used := false;
    goto checkAnothDirAvail;

  // error caused by invalid input
  stopByError:
    GotoXY(1, 24);
    WriteLn('halted by error');
    goto done;

  // success through valid input
  stopBySuccess:
    GotoXY(1, 24);
    WriteLn('halted by success');

  // nothing to do anymore
  done:
end;

begin
  HideCursor;
  ProcParams;
  InitStones;
  InitField;
  ApplyStones_Impr_2;
end.