mainfrm.pas

Sudoku is a logic-based number placement puzzle. A deceptively simple game of logic, Sudoku is puzzl

      if (key >= 97) AND (key <= 105)  then begin  // 10 key nums 1 - 9
         DEC(key,48);  // convert to numeric key
      end;
      if (key >= 49) AND (key <= 57)  then begin  // key nums 1 - 9
          c := chr(key);
          h := TMaskEdit(sender).Hint;
          i := POS(c,h);
    //    only valid choices are keyed in
          if (i = 0) then begin
             beep;  // bad key
             key := 0;
          end;
      end;
   end;    }
end;


procedure TMainForm.LoadCellHints;
VAR
  i,j:  Integer;
  hnt:  String;
begin
  for i:= 1 to cMaxCells do begin // for each cell
     hnt := '';
     for j := 1 to ncSIZE  do begin // for each possible value
        If Squares[i].Possibles[j] > 0 Then begin
           hnt := hnt + IntToStr(j)+',';
        end;
     end;  //for j
     TMaskEdit(GridSudoku[i]).Hint := hnt;
  end; // for i
end;

procedure TMainForm.ClearCellHints;
VAR
  i:    Integer;
begin
  for i:= 1 to cMaxCells do begin // for each cell
     TMaskEdit(GridSudoku[i]).Hint := '';
  end; // for i
end;


function TMainForm.GridToString: String;
VAR
   i: Integer;
   c: String;
begin
    Result := '';
    For i := 1 to cMaxCells do begin
       c := TRIM(TMaskEdit(GridSudoku[i]).Text);
       // Strip bad data characters, only numeric digits,
       if ((c > '9') OR (c < '1')) then begin // change zero's too
          c := '0';
       end;
       Result := Result + c;
    end;
end;


function TMainForm.SquaresToString: String;
var
   GridStr,c: string;
   i:  Integer;
begin
   GridStr := '';
   For i := 1 to cMaxCells do begin
       c :=  IntToStr(Squares[i].Value);
       if c = '' then
          GridStr := GridStr + '0'
       else begin
          GridStr := GridStr + c;
      end;
   end; // for i
   Result := GridStr;
end;

procedure TMainForm.ReloadSqauresFromString(gridStr: String);
var
   i,j:   integer;
   c:     string;
begin
// For i := 1 to Length(gridStr) do begin
   For i := 1 to cMaxCells do begin
       c :=  MIDStr(gridStr,i,1);
       Squares[i].Value := StrToInt(c);
   end;
   // clear all possibles
    For i := 1 To cMaxCells  do begin // Set all possibles to 1 someday to true;
       For j := 1 To ncSIZE do begin
           Squares[i].Possibles[j] := 1;
       end;
    end;
//  To reset all the Possibles, use SetSquare to reset the known squares
    For i  := 1 To cMaxCells do begin
       If Squares[i].Value > 0 Then begin
          SetSquare(Squares[i].Value, i);
       End;
    end;
end;

function TMainForm.MYMissingValues: Integer;
VAR
   i,n:  Integer;
begin
    n := 0;
    For i := 1 To cMaxCells do begin
        If Squares[i].Value = 0 Then begin
           INC(n);
        End;
        if CountPossibles(i) = 0 then begin // bad data! or invalid solution
           n := -1;
           break;
        end;
    end;
    result := n;
end;


// locate and set all cells with only one possible value
procedure TMainForm.SetAllKnownCells;
VAR
    i, CellValue:   Integer;
    ACellHasChanged:  Boolean;
begin
    ACellHasChanged  := True;
    WHILE ACellHasChanged do begin
       ACellHasChanged  := False;
       For i := 1 To cMaxCells do begin
           If ((CountPossibles(i) = 1) and (Squares[i].Value = 0)) Then begin
              CellValue := ThePossible(i); // Found only one possible value for the cell
              SetSquare(CellValue,i);      // Set the value (and remove more possibles)
              ACellHasChanged := True;
           end;
       end; // for i
    end; // while changing
end;


function TMainForm.CellWithLowestPossibles: Integer;
VAR
   i, nMin, MinCellNo:          Integer;
begin
    MinCellNo := 0;
    nMin      := ncSIZE + 1;
    For i := 1 To cMaxCells do begin
       If ((Squares[i].Value = 0) AND (CountPossibles(i) < nMin)) Then begin
            nMin      := CountPossibles(I);
            MinCellNo := i;
        End;
    end;
    result := MinCellNo;
end;


procedure TMainForm.MYDoPuzzle;
VAR
    BadIndex: Integer;
begin
    LoadingORSolving := True;
//  MemoUserMessages.Lines.Clear;
    rIterations  := 0;
    rDepth       := 0;
    GgDepth.MaxValue := 50;
    GgDepth.Progress := 0;
    GgIterations.MaxValue := 50;
    GgIterations.Progress := 0;
    PaneliNo.Caption      := '0';
    PaneldNo.Caption      := '0';
    if ((MnuFileVisualize.Checked) AND (NOT(Cheating))) then begin
       GgDepth.Visible       := true;
       GgIterations.Visible  := true;
//     PanelGauges.Visible   := true;
       Application.ProcessMessages;
    end;
    InitPuzzle();   //Set up matrix
    BadIndex := ReadInput(); // Read the data into matrix
    If BadIndex <> 0 Then begin
        LblRC.Caption := 'ERR@Cell ('+IntToStr(GetRow(BadIndex))+','+
                                      IntToStr(GetCol(BadIndex))+')';
        UserMessage('Invalid input. Initial Problem with Cell('+
                    IntToStr(GetRow(BadIndex))+','+
                    IntToStr(GetCol(BadIndex))+')');
        Exit;  // don't like this exit at all...........................................
    End;
    UserMessage('Values Left To Find ='+ IntToStr(MYMissingValues()));
    SetAllKnownCells();
    If MYMissingValues() > 0 Then begin
//      UserMessage('Now we''ll have to guess, recursively');
        SolveThePuzzle();// MYTryToSolve;
    End;
    LoadCellHints();
    LblRC.Caption := '';
    PanelPossibleChoices.Caption  := '';
    If MYMissingValues() = 0 Then begin
        UserMessage('Solved: '+
                                            'Depth=' +IntToStr(rMaxDepth) +
                                    ', Interations=' +IntToStr(rIterations));
        PaneliNo.Caption      := IntToStr(rMaxDepth);
        PaneldNo.Caption      := IntToStr(rIterations);
        if NOT(Cheating) then begin
           if (MnuFileVisualize.Checked) then begin
//            values are already on the screen so just show them
              FillInResults;
           end else begin
              if Application.MessageBox(
                  PChar('Solution found, do you want to see it?'),
                                  '*Solved*',
                                  MB_YESNO + MB_DEFBUTTON2) = IDYES then begin
                 FillInResults;
              end;
           end;
        end;
    end else begin
        If MYMissingValues() < 0 Then begin
           MessageDlg('Unable to Solve Puzzle with the supplied values.',
                       mtInformation,[mbOk], 0);
        end else begin  // missing values > 0 so...
           MessageDlg('Unfortunately, this puzzle can not be solved.',
                       mtInformation,[mbOk], 0);
        End;
    End;
    GgDepth.Visible       := False;
    GgIterations.Visible  := False;
//  PanelGauges.Visible   := False;
    LoadingORSolving      := False;
end;


function TMainForm.SolveThePuzzle: Integer;
VAR
   i,m,LowX:               Integer;
   SqStr:              String;
begin
    Result   := -1;
    LowX     := CellWithLowestPossibles();
    SqStr    := SquaresToString();
//  for each possible value try it until failed
    INC(rDepth);
  // make sure that it is bumped at least once,
  // will make it a little higher than it should, but oh well
    INC(rIterations);
    if rMaxDepth <  rDepth then begin
       rMaxDepth := rDepth;
    end;
//  if MnuFileVisualize.Checked then begin
    if ((MnuFileVisualize.Checked) AND (NOT(Cheating))) then begin
       GgDepth.Progress       := rDepth;
       GgIterations.Progress  := rIterations;
       paneldno.Caption       := IntToStr(rDepth);
       panelino.Caption       := IntToStr(rIterations);
       Application.ProcessMessages;
    end;
    for i := 1 To ncSIZE do begin
       Result := -1;
       if Squares[LowX].Possibles[i] = 1 then begin // number is possible
          INC(rIterations);
{          if MnuFileVisualize.Checked then begin
             GgIterations.Progress  := rIterations;
             Application.ProcessMessages;
          end; }
//        if MnuFileVisualize.Checked then begin
          if ((MnuFileVisualize.Checked) AND (NOT(Cheating))) then begin
             GgDepth.Progress       := rDepth;
             GgIterations.Progress  := rIterations;
             paneldno.Caption       := IntToStr(rDepth);
             panelino.Caption       := IntToStr(rIterations);
             FillInResults;
             Application.ProcessMessages;
             sleep(VisualDelay);
          end;
          SetSquare(i,LowX);
          SetAllKnownCells();
          m := MYMissingValues();
          if m < 0 then begin
             // no solution here so...
             // reset and try again with the next possible for this cell
             // or fall through and quit.
             ReloadSqauresFromString(SqStr);
          end else begin
             if m = 0 then begin
                Result := 0;
                Break;  // solved it so quit now!
             end else begin
             // m > 0 more to try, so continue
                m := SolveThePuzzle();
                if m = 0 then begin
                   Result := 0;
                   Break;  // solved it so quit now!
                end else begin // didn't work so try the next possible
                   ReloadSqauresFromString(SqStr);
                end;
             end;
          end; // if M
       end; // if Possible[n]
    end; // for
    DEC(rDepth);
end;


procedure TMainForm.PopUpCellCheatClick(Sender: TObject);
VAR
   i:    Integer;
   cmp:  TComponent;
begin
// if PopUpCell.PopupComponent = EdtCell1  then begin cellNo := 1; end;
   for i := 1 to cMaxCells do begin
      cmp := FindComponent('EdtCell'+IntToStr(i));
      if Assigned(cmp) then begin
         if PopUpCell.PopupComponent = cmp then begin
            ActCheat.Execute;
//          StatusBar.Panels[2].Text  := TMaskEdit(cmp).Name;
            break;
         end;
      end;
   end;
end;

procedure TMainForm.ActCheatExecute(Sender: TObject);
var
     cheatValue:  Integer;
     BadIdx:      Integer;
     NextCell:    Integer;
begin
     StatusBar.Panels[2].Text  := IntToStr(CheatingForCellNo);
     cheatValue  := CheatCellIndex(CheatingForCellNo);
//   SetSquare(cheatValue,CheatingForCellNo);
     TMaskEdit(GridSudoku[CheatingForCellNo]).Text := IntToStr(cheatValue);
     InitPuzzle;
     BadIdx  := ReadInput();  // Read the data into matrix
     If BadIdx = 0 Then begin
        LoadCellHints();
//        NextCell  := (CheatingForCellNo Mod 81)+1;
        NextCell  := (CheatingForCellNo);
        EdtCellEnter(TMaskEdit(GridSudoku[NextCell]));
//      LblRC.Caption := 'Cell ('+IntToStr(MyRow)+','+IntToStr(MyCol)+')';
//      PanelPossibleChoices.Caption  := TMaskEdit(GridSudoku[NextCell]).Hint;
     end else begin
        beep;
        ClearCellHints();
        LblRC.Caption := 'ERR@Cell ('+IntToStr(GetRow(BadIdx))+','+
                                      IntToStr(GetCol(BadIdx))+')';
        PanelPossibleChoices.Caption  := '';
        UserMessage('Invalid input data. Problem Cheating at/with ('+
                        IntToStr(GetRow(BadIdx))+','+
                        IntToStr(GetCol(BadIdx))+')');
     end;
end;

function TMainForm.CheatCellIndex(idx: Integer): Integer;
VAR
  CheatValue:  Integer;
begin
   // save the current visualize setting
   Cheating := True;
   MYDoPuzzle();
   Result   := GetSquare(idx);
// read input should reset everything
   Cheating := False;
end;


function TMainForm.PopUndoStack: String;
VAR
  s:  String;
begin
   if LENGTH(UndoStr) > cMaxCells then begin
      // there are more than one undo, so undo and remove
      s := RightStr(UndoStr,cMaxCells);
      UndoStr  := LeftStr(UndoStr,Length(UndoStr) - cMaxCells);
   end else begin
      // this is the starting point, return the string, leaving undostr alone
      s := UndoStr; //StringOfChar('0',cMaxCells);
      ActUndo.Enabled  := False;
   end;
   statusbar.panels[1].Text := 'Undo:'+IntToStr((Length(UndoStr) DIV cMaxCells)-1);
   result := s;
end;

procedure TMainForm.PushUndoStack(s: String);
begin
   UndoStr := UndoStr + s;
   statusbar.panels[1].Text := 'Undo:'+IntToStr((Length(UndoStr) DIV cMaxCells)-1);
   ActUndo.Enabled := True;
end;

procedure TMainForm.ClearUndoStack;
begin
   UndoStr := StringOfChar('0',cMaxCells);
   statusbar.panels[1].Text := 'Undo:'+IntToStr((Length(UndoStr) DIV cMaxCells)-1);
end;

procedure TMainForm.ActUndoExecute(Sender: TObject);
begin
  ReloadGridFromString(PopUndoStack());
end;

procedure TMainForm.ReloadGridFromString(gridStr: String);
var
   i,LL, BadIndex: integer;
   c: string;
begin
   LoadingORSolving := True;
   LL := Length(gridStr);
   if LL = cMaxCells then begin
      // check for bad data too
      For i := 1 to cMaxCells do begin
         c :=  MIDStr(gridStr,i,1);
         // Strip bad data characters, only numeric digits,
         if ((c > '9') OR (c < '1')) then begin // change zero's too
            c := '';
         end;
         TMaskEdit(GridSudoku[i]).Text := c;
      end;
      InitPuzzle();             //Set up matrix
      BadIndex := ReadInput();  // Read the data into matrix
      If BadIndex = 0 Then begin
         LoadCellHints();
      end else begin
         beep;
         LblRC.Caption := 'Cell (,)';
         PanelPossibleChoices.Caption  := '';
         UserMessage('Invalid input data. Problem with ('+
                       IntToStr(GetRow(BadIndex))+','+
                       IntToStr(GetCol(BadIndex))+')');
      end;
   end;
   LoadingORSolving := False;
end;

end.