« POPE IV Home | Email msg. | Reply to msg. | Post new | Board info. Previous | Home | Next

Re: Lazarus (Pascal) - Code part 4of 5 

By: Decomposed in POPE IV | Recommend this post (2)
Mon, 20 Nov 17 10:55 PM | 60 view(s)
Boardmark this board | POPES NEW and Improved Real Board
Msg. 38938 of 47202
(This msg. is a reply to 38937 by Decomposed)

Jump:
Jump to board:
Jump to msg. #



procedure Rule5; (* Is one of the cell's Possibilities not possible on any other cell in the column? *)
var
  j : integer;
  PossibilityPosition : integer;
  FoundCount : integer;
  FoundSolution : string;
  CheckThisColumn : integer;
  PossibilitiesCopy : string;
  PossibilityBeingChecked : string;
  FoundCharacter : string;
begin
  CheckThisColumn := Currentpos_x;
  PossibilitiesCopy := GridInfo{Currentpos_x}{Currentpos_y}.Possibilities;
  FoundSolution := '';
  (* For each possibility *)

  (* if zero other cells have the possibility then it is a Solution. *)
   for PossibilityPosition := 1 to length(PossibilitiesCopy) do
   begin
      FoundCount := 0;
      PossibilityBeingChecked := PossibilitiesCopy{PossibilityPosition};
      (* check every cell in the column's possibilities *)
      for j := 1 to 9 do
      begin
        if (Pos(PossibilityBeingChecked,GridInfo{CheckThisColumn}{j}.Possibilities)  0) then
         begin
           FoundCount := FoundCount+1;
           if FoundCount = 1 then
            FoundCharacter := PossibilityBeingChecked;
         end; (* if Pos(PossibilityBeingChecked *)
      end; (* for j *)
      if FoundCount = 1 then (* then FoundCharacter is not possible in any other cell of the current column. *)
        FoundSolution := FoundCharacter;
   end;  (* for PossibilityPosition *)
   if length(FoundSolution) = 1 then
    begin
      ProcessSolution(Currentpos_x,Currentpos_y,FoundSolution,
                      'No other cell in the column has this numeral as a possibility. (Rule 5)');
    end;
end;  (* Procedure Rule5 *)
procedure Rule6; (* Is one of the cell's Possibilities not possible on any other cell in the row? *)
var
  i : integer;
  PossibilityPosition : integer;
  FoundCount : integer;
  FoundSolution : string;
  CheckThisRow : integer;
  PossibilitiesCopy : string;
  PossibilityBeingChecked : string;
  FoundCharacter : string;
begin
  CheckThisRow := Currentpos_y;
  PossibilitiesCopy := GridInfo{Currentpos_x}{Currentpos_y}.Possibilities;
  FoundSolution := '';
  (* For each possibility *)

  (* if zero other cells have the possibility then it is a Solution. *)
   for PossibilityPosition := 1 to length(PossibilitiesCopy) do
   begin
      FoundCount := 0;
      PossibilityBeingChecked := PossibilitiesCopy{PossibilityPosition};
      (* check every cell in the row's possibilities *)
      for i := 1 to 9 do
      begin
        if (Pos(PossibilityBeingChecked,GridInfo{i}{CheckThisRow}.Possibilities)  0) then
         begin
           FoundCount := FoundCount+1;
           if FoundCount = 1 then
            FoundCharacter := PossibilityBeingChecked;
         end; (* if Pos(PossibilityBeingChecked *)
      end; (* for i *)
      if FoundCount = 1 then (* then FoundCharacter is not possible in any other cell of the current column. *)
        FoundSolution := FoundCharacter;
   end;  (* for PossibilityPosition *)
   if length(FoundSolution) = 1 then
    begin
      ProcessSolution(Currentpos_x,Currentpos_y,FoundSolution,
                      'No other cell in the row has this numeral as a possibility. (Rule 6)');
    end;
end;  (* Procedure Rule6 *)
procedure Rule7; (* Is one of the cell's Possibilities not possible on any other cell in the block? *)
var
  i,j: integer;
  PossibilityPosition : integer;
  FoundCount : integer;
  FoundSolution : string;
  CheckThisBlock : integer;
  PossibilitiesCopy : string;
  PossibilityBeingChecked : string;
  FoundCharacter : string;
begin
  CheckThisBlock := GridInfo{Currentpos_x}{Currentpos_y}.BlockNumber;
  PossibilitiesCopy := GridInfo{Currentpos_x}{Currentpos_y}.Possibilities;
  FoundSolution := '';
  (* For each possibility *)

  (* if zero other cells have the possibility then it is a Solution. *)
   for PossibilityPosition := 1 to length(PossibilitiesCopy) do
   begin
      FoundCount := 0;
      PossibilityBeingChecked := PossibilitiesCopy{PossibilityPosition};
      (* check every cell in the row's possibilities *)
      for i := 1 to 9 do
      begin
       for j:= 1 to 9 do
       begin
        if (Pos(PossibilityBeingChecked,GridInfo{i}{j}.Possibilities)  0) then
         begin
           FoundCount := FoundCount+1;
           if FoundCount = 1 then
            FoundCharacter := PossibilityBeingChecked;
         end; (* if Pos(PossibilityBeingChecked *)
       end; (* for j; *)
      end; (* for i *)
      if FoundCount = 1 then (* then FoundCharacter is not possible in any other cell of the current block. *)
        FoundSolution := FoundCharacter;
   end;  (* for PossibilityPosition *)
   if length(FoundSolution) = 1 then
    begin
      ProcessSolution(Currentpos_x,Currentpos_y,FoundSolution,
                      'No other cell in the block has this numeral as a possibility. (Rule 7)');
    end;
end;  (* Procedure Rule7 *)

 




Avatar

Gold is $1,581/oz today. When it hits $2,000, it will be up 26.5%. Let's see how long that takes. - De 3/11/2013 - ANSWER: 7 Years, 5 Months


- - - - -
View Replies (1) »



» You can also:
- - - - -
The above is a reply to the following message:
Re: Lazarus (Pascal) - Code part 2 of 5
By: Decomposed
in POPE IV
Mon, 20 Nov 17 10:49 PM
Msg. 38937 of 47202



procedure ProcessSolution(x,y:integer; Solution:string; SolutionReason:string);
begin
  PassesSinceLastSolution := 0;
  TotalCellsSolved := TotalCellsSolved + 1;
  GridInfo{x}{y}.IsSolved := TRUE;
  GridInfo{x}{y}.Possibilities := Solution;
  GridInfo{x}{y}.Impossibilities := EliminateCharacter('123456789',Solution{1});
  GridInfo{x}{y}.DisplayValue := Solution{1};
  GridInfo{x}{y}.NumberOfModifications := GridInfo{x}{y}.NumberOfModifications + 1;
  GridInfo{x}{y}.ModificationReasons{GridInfo{x}{y}.NumberOfModifications} := SolutionReason;
end;

procedure LoadPuzzle(PuzzleNum: string);
var
  i,j,x : integer;
  row : integer;
  fp : textfile;
begin

  assignfile(fp,'Puzzle325.txt');
  (* assignfile(fp,'Test001.txt'); *)
  try
    reset(fp);
    for j:=1 to 9 do
     begin
      readln(fp,OrigPuzzle{j});
     end;   (* for j *)
    close(fp);
   except
    writeln('Error.  Please check the text file.');
  end; (* try - except *)

  for j:= 1 to 9 do
   begin
     for i := 1 to 9 do
      begin
        GridInfo{i}{j}.xCoord := i;
        GridInfo{i}{j}.yCoord := j;
        GridInfo{i}{j}.CellNumber := ((j-1) * 9) + i;
        GridInfo{i}{j}.BlockColumn := (((GridInfo{i}{j}.CellNumber - ((j-1)*9)) - 1) div 3) + 1;
        GridInfo{i}{j}.BlockRow := ((GridInfo{i}{j}.CellNumber - 1) div 27) + 1;
        if (GridInfo{i}{j}.BlockRow = 1) then
        begin
          case GridInfo{i}{j}.BlockColumn of
            1 : GridInfo{i}{j}.BlockNumber := 1;
            2 : GridInfo{i}{j}.BlockNumber := 2;
            3 : GridInfo{i}{j}.BlockNumber := 3;
          end; (* case *)
        end;
        if (GridInfo{i}{j}.BlockRow = 2) then
        begin
          case GridInfo{i}{j}.BlockColumn of
            1 : GridInfo{i}{j}.BlockNumber := 4;
            2 : GridInfo{i}{j}.BlockNumber := 5;
            3 : GridInfo{i}{j}.BlockNumber := 6;
          end; (* case *)
        end;
        if (GridInfo{i}{j}.BlockRow = 3) then
        begin
          case GridInfo{i}{j}.BlockColumn of
            1 : GridInfo{i}{j}.BlockNumber := 7;
            2 : GridInfo{i}{j}.BlockNumber := 8;
            3 : GridInfo{i}{j}.BlockNumber := 9;
          end; (* case *)
        end;

        if OrigPuzzle{j}{i} = '0' then
        begin
         GridInfo{i}{j}.displayvalue := '-';
         GridInfo{i}{j}.IsSolved := FALSE;
         GridInfo{i}{j}.Possibilities := '123456789';
         GridInfo{i}{j}.Impossibilities := '';
         GridInfo{i}{j}.NumberOfModifications := 0;
         for x:=1 to MAXMODS do
          GridInfo{i}{j}.ModificationReasons{x} := '';
        end
        else
         begin
          GridInfo{i}{j}.displayvalue := OrigPuzzle{j}{i};
          GridInfo{i}{j}.IsSolved := TRUE;
          GridInfo{i}{j}.Possibilities := OrigPuzzle{j}{i};
          GridInfo{i}{j}.Impossibilities := EliminateCharacter('123456789',OrigPuzzle{j}{i});
          GridInfo{i}{j}.NumberOfModifications := 1;
          GridInfo{i}{j}.ModificationReasons{1} := 'Given.';
          for x:=2 to MAXMODS do
           GridInfo{i}{j}.ModificationReasons{x} := '';
        end;    (* end of the 'if 0 else something else' statement *)
       end;  (* for i *)
   end;   (* for j *)
end; (* procedure LoadPuzzle*)
procedure ExamineCell(Old_x, Old_y, Examine_x, Examine_y:integer);
var
  k,ExtraSpace : integer;
begin
  (* Clear the old cell's brackets *)
    ExtraSpace := 0;
    if Old_y>=4 then ExtraSpace := 1;
    if Old_y>=7 then ExtraSpace := 2;

    gotoxy(GRID_XBASE+1+((Old_x-1)*4),GRID_YBASE+2+Old_y+ExtraSpace);
    write(' ');
    gotoxy(GRID_XBASE+3+((Old_x-1)*4),GRID_YBASE+2+Old_y+ExtraSpace);
    write(' ');
  (* Draw the new cell's brackets *)
    ExtraSpace := 0;
    if Examine_y >=4 then ExtraSpace := 1;
    if Examine_y >=7 then ExtraSpace := 2;

    gotoxy(GRID_XBASE+2+((Examine_x-1)*4),GRID_YBASE+2+Examine_y+ExtraSpace);
    write(GridInfo{Examine_x}{Examine_y}.displayvalue  );

    if (not AutoMovement) or (AutoMovement and (not GridInfo{Currentpos_x}{Currentpos_y}.IsSolved)) then
     begin
      gotoxy(GRID_XBASE+1+((Examine_x-1)*4),GRID_YBASE+2+Examine_y+ExtraSpace);
      write('{');

      gotoxy(GRID_XBASE+3+((Examine_x-1)*4),GRID_YBASE+2+Examine_y+ExtraSpace);
      write('}');
      (* Update the cell's displayed information *)
      DisplayCurrentCoordinates;
      DisplayMessage(39+GRID_XBASE,5+GRID_YBASE,'                                    ');
      DisplayMessage(39+GRID_XBASE,5+GRID_YBASE,GridInfo{Examine_x}{Examine_y}.Possibilities);
      DisplayMessage(49+GRID_XBASE,5+GRID_YBASE,GridInfo{Examine_x}{Examine_y}.Impossibilities);
      for k := MAXMODS downto 1 do
        DisplayMessage(1+GRID_XBASE,15+k+GRID_YBASE,'                                                                            ');
      if (GridInfo{Examine_x}{Examine_y}.NumberOfModifications >= 1) then
      begin
       for k := 1 to GridInfo{Examine_x}{Examine_y}.NumberOfModifications do
        begin
         gotoxy(2+GRID_XBASE,15+k+GRID_YBASE);
         write(' ');
         DisplayMessage(6+GRID_XBASE,15+k+GRID_YBASE,GridInfo{Examine_x}{Examine_y}.ModificationReasons{k});
        end;
      end;
    end;
end;  (* Procedure ExamineCell *)
procedure Rule1;  (* Is the cell the only blank one in the current column? *)
var
  j : integer;
  CheckThisColumn : integer;
  NumberSolvedInColumn : integer;
  StringBeingReduced : string;
  ImpossibleCharacters : string;
  OnlyRemainingCharacter : char;
begin
  NumberSolvedInColumn := 0;
  StringBeingReduced := '123456789';
  CheckThisColumn := Currentpos_x;

  for j := 1 to 9 do
  begin
    if GridInfo{CheckThisColumn}{j}.IsSolved = TRUE then
     begin
       NumberSolvedInColumn := NumberSolvedInColumn + 1;
       StringBeingReduced := EliminateCharacter(StringBeingReduced,GridInfo{CheckThisColumn}{j}.DisplayValue);
       (* Eliminate from the Possibilities any Solution which was found elswhere in the column. *)
       GridInfo{Currentpos_x}{Currentpos_y}.Possibilities
         := EliminateCharacter(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
                               GridInfo{CheckThisColumn}{j}.DisplayValue);
     end;
  end; (* for j *)

  if NumberSolvedInColumn = 8 then (* ... then the cell we're checking is the only blank one in the column *)
    ProcessSolution(Currentpos_x,Currentpos_y,StringBeingReduced,'Last blank cell in the column. (Rule 1)');
  if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
   begin
     if length(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities) = 1 then
       ProcessSolution(Currentpos_x,Currentpos_y,GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
            'Column, row and block solutions leave just one possibility. (Rule 4.1)');
   end;
end; (* Procedure Rule1 *)
procedure Rule2;  (* Is the cell the only blank one in the current row? *)
var
  i : integer;
  CheckThisRow : integer;
  NumberSolvedInRow : integer;
  StringBeingReduced : string;
  ImpossibleCharacters : string;
  OnlyRemainingCharacter : char;
begin
  NumberSolvedInRow := 0;
  StringBeingReduced := '123456789';
  CheckThisRow:= Currentpos_y;

  for i := 1 to 9 do
  begin
    if GridInfo{i}{CheckThisRow}.IsSolved = TRUE then
     begin
       NumberSolvedInRow := NumberSolvedInRow + 1;
       StringBeingReduced := EliminateCharacter(StringBeingReduced,GridInfo{i}{CheckThisRow}.DisplayValue);
       (* Eliminate from the Possibilities this Solution which was found elswhere in the row. *)
       GridInfo{Currentpos_x}{Currentpos_y}.Possibilities
         := EliminateCharacter(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
                               GridInfo{i}{CheckThisRow}.DisplayValue);
     end;
  end; (* for i *)

  if NumberSolvedInRow = 8 then (* ... then the cell we're checking is the only blank one in the row *)
    ProcessSolution(Currentpos_x,Currentpos_y,StringBeingReduced,'Last blank cell in the row. (Rule 2)');

  if GridInfo{Currentpos_x}{Currentpos_y}.IsSolved = FALSE then
   begin
     if length(GridInfo{Currentpos_x}{Currentpos_y}.Possibilities) = 1 then
       ProcessSolution(Currentpos_x,Currentpos_y,GridInfo{Currentpos_x}{Currentpos_y}.Possibilities,
            'Column, row and block solutions leave just one possibility. (Rule 4.2)');
   end;

end; (* Procedure Rule2 *)

 


« POPE IV Home | Email msg. | Reply to msg. | Post new | Board info. Previous | Home | Next