unit CreateU;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, ComCtrls;

type
  TCreateForm = class(TForm)
    lbWords: TListBox;
    pbCreate: TProgressBar;
    sbCreate: TStatusBar;
    Panel1: TPanel;
    Label2: TLabel;
    Label3: TLabel;
    btNext1: TBitBtn;
    ebStart: TEdit;
    btNext2: TBitBtn;
    ebEnd: TEdit;
    btnDone: TBitBtn;
    btnStop: TBitBtn;
    btnReset: TBitBtn;
    btnHelp: TBitBtn;
    Bevel1: TBevel;
    pnlPuzzle: TPanel;
    procedure ebStartChange(Sender: TObject);
    procedure ebEndChange(Sender: TObject);
    procedure lbWordsDrawItem(Control: TWinControl; Index: Integer;
      Rect: TRect; State: TOwnerDrawState);
    procedure FormCreate(Sender: TObject);
    procedure lbWordsDblClick(Sender: TObject);
    procedure btNext1Click(Sender: TObject);
    procedure btNext2Click(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure btnResetClick(Sender: TObject);
    procedure btnHelpClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure btnStopMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
    Stopped : Boolean;
    MinChanges : Integer;
    sl_mastr,
    sl_words,
    sl_solve : TStringList;
    StartGroup : String[3];
    StartLen, sSteps : Integer;
    procedure ShowWordList;
    procedure ReadWordList;
    function SolveIt : Boolean;
    function SolutionString : String;
    procedure SaveSolution;
    procedure wmGetMinMaxInfo(VAR Msg: TWMGetMinMaxInfo);
      message WM_GETMINMAXINFO;
  public
    { Public declarations }
    sFrom, sTo, sSol : String;
    procedure SetWordLength(Value : Integer);
    procedure SetHint(Gen : Boolean; const S : String);
  end;

var
  CreateForm: TCreateForm;

implementation

uses ladSharU, IniFiles, ladderu;

{$R *.DFM}
procedure TCreateForm.wmGetMinMaxInfo(VAR Msg: TWMGetMinMaxInfo);
begin
  Msg.MinMaxInfo^.ptMinTrackSize := Point(316, 270);
end;

procedure TCreateForm.FormCreate(Sender: TObject);
begin
  Stopped    := True;
  sl_solve := TStringList.Create;
  sl_words := TStringList.Create;
  sl_mastr := TStringList.Create;
  pnlPuzzle.Caption := '';
end;

procedure TCreateForm.FormActivate(Sender: TObject);
// We fill the listbox in OnActivate to give the form a
// chance to show while the list is filling
begin
  Application.ProcessMessages;
  ReadWordList;
  ShowWordList;
  SetHint(True, 'Enter start word, or double-click list');
end;

procedure TCreateForm.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  CanClose := btnDone.Enabled;
end;

procedure TCreateForm.FormMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
// This enables flyover hints for disabled buttons
VAR P : TPoint;
begin
  P := Point(X,Y);
  IF PtInRect(btNext1.BoundsRect, P) THEN
    SetHint(False, btNext1.Hint)
  ELSE IF PtInRect(btNext2.BoundsRect, P) THEN
    SetHint(False, btNext2.Hint)
  ELSE IF PtInRect(btnDone.BoundsRect, P) THEN
    SetHint(False, btnDone.Hint)
  ELSE IF PtInRect(btnReset.BoundsRect, P) THEN
    SetHint(False, btnReset.Hint)
  ELSE SetHint(False, GenHint);
end;

procedure TCreateForm.ebStartChange(Sender: TObject);
begin
  btNext1.Enabled := GoodWord(ebStart.Text, StartLen);
end;

procedure TCreateForm.btNext1Click(Sender: TObject);
VAR
  N, idx : Integer;
  S      : String;
  slTemp : TStringList;

  function AllDiff(const S1, S2 : String) : Boolean;
  VAR N : Integer;
  begin
    Result := False;
    FOR N := 1 TO StartLen DO
      IF S1[N] = S2[N] THEN Exit;
    Result := True;
  end;

begin
  sFrom := ebStart.Text;
  btNext1.Enabled := False;
  Screen.Cursor := crHourglass;
  try
    sl_mastr.Find(sFrom, idx);
    IF Pos(sFrom, sl_mastr[idx])=1 THEN
      StartGroup := Copy(sl_mastr[idx], StartLen+1, 3)
    ELSE
      begin
        SetHint(True, Format('"%s" not in %d-letter '+
          'word list', [sFrom, StartLen]));
        Exit;
      end;
    SetHint(True, Format('"%s" found. Updating list...', [sFrom]));
    // Delete words that aren't in the same group
    sl_words.assign(sl_mastr);
    FOR N := sl_words.Count-1 DOWNTO 0 DO
      IF Copy(sl_words[N], StartLen+1, 3) <> StartGroup THEN
        sl_words.Delete(N);
    lbWords.Items.Clear;
    slTemp := TStringList.Create;
    try
      FOR N := 0 TO sl_words.Count-1 DO
        begin
          S := Copy(sl_words[N], 1, StartLen);
          IF AllDiff(sFrom, S) THEN
            slTemp.AddObject(S, Pointer(1))
          ELSE slTemp.AddObject(S, NIL);
        end;
      lbWords.Items := slTemp;
    finally
      slTemp.Free;
    end;
    btnReset.Enabled := True;
    ebStart.Enabled := False;
    ebEnd.Enabled := True;
    ebEnd.SetFocus;
    SetHint(True, 'Enter ending word, or double-click list');
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TCreateForm.lbWordsDblClick(Sender: TObject);
begin
  WITH Sender AS TListBox DO
    IF ebStart.Enabled THEN
      ebStart.Text := Items[ItemIndex]
    ELSE IF ebEnd.Enabled THEN
      ebEnd.Text := Items[ItemIndex];
end;

procedure TCreateForm.lbWordsDrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  WITH Control AS TListBox, Canvas DO
    begin
      FillRect(Rect);
      IF Items.Objects[Index] = NIL THEN
        Font.Style := []
      ELSE Font.Style := [fsBold];
      TextRect(Rect, Rect.Left+2, Rect.Top, Items[Index]);
    end;
end;

procedure TCreateForm.ebEndChange(Sender: TObject);
begin
  btNext2.Enabled :=  GoodWord(ebEnd.Text, StartLen);
end;

procedure TCreateForm.btNext2Click(Sender: TObject);
VAR
  N : Integer;
  S : String;
begin
  btNext2.Enabled := False;
  sTo := ebEnd.Text;
  IF lbWords.Items.IndexOf(sTo) < 0 THEN
    begin
      SetHint(True, Format('%s to %s is not possible',
        [sTo, sFrom]));
      exit;
    end;
  MinChanges := 0;
  FOR N := 1 TO StartLen DO
    IF sFrom[N] <> sTo[N] THEN Inc(MinChanges);
  pnlPuzzle.Caption := Format('Seeking a path from %s to %s',
    [sFrom, sTo]);
  lbWords.Clear;
  Stopped          := False;
  btNext2.Enabled  := False;
  ebEnd.Enabled    := False;
  btnDone.Enabled  := False;
  btnReset.Enabled := False;
  Refresh;
  Application.ProcessMessages;
  sl_words.Sorted := False;
  FOR N := 0 TO sl_words.Count-1 DO
    begin
      S := sl_words[N];
      sl_words.Objects[N] := TWordObj2.Create(-1, Copy(S, StartLen+4, 255));
      sl_words[N] := Copy(S, 1, StartLen)
    end;
  sl_words.Sorted := True;
  btnStop.Enabled   := True;
  btnStop.SetFocus;
  SolveIt;
end;

procedure TCreateForm.btnStopClick(Sender: TObject);
begin
  Stopped          := True;
  btnDone.Enabled  := True;
  btnReset.Enabled := True;
end;

procedure TCreateForm.btnStopMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  WITH Sender AS TBitBtn DO
    SetHint(False, Hint);
end;

procedure TCreateForm.btnResetClick(Sender: TObject);
begin
  ebStart.Text := '';
  ebEnd.Text   := '';
  sFrom        := '';
  sTo          := '';
  sSteps       := 0;
  lbWords.Clear;
  sl_solve.Clear;
  sl_words.Clear;
  pbCreate.Position := 0;
  btnDone.ModalResult := mrCancel;
  ebStart.Enabled := True;
  ShowWordList;
end;

procedure TCreateForm.btnHelpClick(Sender: TObject);
begin
  Application.HelpCommand(HELP_CONTEXT, 1);
end;

procedure TCreateForm.SetHint(Gen : Boolean; const S : String);
// Display a hint on status bar; if desired retain as "generic"
// hint that's used when not displaying flyover help
begin
  sbCreate.Panels[1].Text := S;
  IF Gen THEN GenHint := S;
end;

function TCreateForm.SolveIt : Boolean;
VAR sl_temp : TStringList;

  procedure MoveStartToSolution;
  VAR N : Integer;
  begin
    N := sl_words.IndexOf(sFrom);
    sl_temp.AddObject(sFrom, sl_words.Objects[N]);
    sl_words.Delete(N);
  end;

  procedure WalkBack;
  VAR
    Idx : Integer;
    Wo2 : TWordObj2;
    S   : String;
  begin
    Result := True;
    sl_solve.Clear;
    Idx := sl_temp.IndexOf(sTo);
    REPEAT
      S := sl_temp[Idx];
      sl_solve.Insert(0, S);
      Wo2 := sl_temp.Objects[Idx] AS TWordObj2;
      Idx := Wo2.WayBack;
    UNTIL Wo2.WayBack < 0;
    sSteps := sl_solve.Count-1;
    SetHint(True, Format('Found %d-step solution', [sSteps]));
    Application.ProcessMessages;
  end;

  // fig 4 begin
  procedure DoLevels;
  VAR
    level, start : Integer;
    N, max, idx  : Integer;
    Wo2          : TWordObj2;
    NewS         : String;
  begin
    level   := 0;
    start := 0;
    WHILE Start < sl_temp.Count DO
      begin
        max := sl_temp.Count;
        pbCreate.Max := max-Start; // progress bar
        SetHint(True, Format('Searching %d words at step %d',
          [Max-Start, level]));
        Application.ProcessMessages;
        FOR N := start TO max-1 DO
          begin
            pbCreate.Position := N-Start;
            IF Stopped THEN Break;
            Wo2  := sl_temp.Objects[N] AS TWordObj2;
            NewS := Wo2.ReadyNext(sl_temp[N]);
            WHILE NewS <> '' DO
              begin
                idx := sl_words.IndexOf(NewS);
                IF idx <> -1 THEN
                  begin
                    TWordObj2(sl_words.Objects[idx]).WayBack := N;
                    sl_temp.AddObject(NewS, sl_words.Objects[idx]);
                    sl_words.Delete(idx);
                    IF NewS = sTo THEN
                      begin
                        WalkBack;
                        Exit;
                      end;
                  end;
                NewS := Wo2.NextWord(sl_temp[N]);
              end;
          end;
        IF sl_temp.Count > max THEN
          begin
            Inc(level);
            Start := Max;
          end
        ELSE Break;
      end;
  end;
  // fig 4 end

begin
  sl_solve.Clear;
  sl_temp := TStringList.Create;
  try
    pbCreate.Max      := 100;
    pbCreate.Position := 0;
    Result            := False;
    MoveStartToSolution;
    sSteps := 0;
    DoLevels;
    IF Stopped THEN
      SetHint(True, 'Processing interrupted')
    ELSE IF sSteps=0 THEN
      SetHint(True, 'No solution found')
    ELSE
      begin
        SetHint(True, Format('Saving %d-step solution', [sSteps]));
        SaveSolution;
        SetHint(True, Format('Saved %d-step solution',  [sSteps]));
      end;
    pnlPuzzle.Caption := '';
  finally
    sl_temp.Free;
    btnDone.Enabled   := True;
    btnReset.Enabled  := True;
    pbCreate.Position := 0;
  end;
end;

function TCreateForm.SolutionString : String;
VAR
  N, P   : Integer;
  C1, C2 : Char;
begin
  Result := '';
  FOR N := 1 TO sl_solve.Count-1 DO
    begin
      OneDifferent(sl_solve[N-1], sl_solve[N], P, C1, C2);
      Result := Result + Char(Ord('0')+P) + C1;
    end;
end;

procedure TCreateForm.SaveSolution;
begin
  btnStop.Enabled := False;
  Stopped := True;
  sSol := SolutionString;
  WITH TIniFile.Create(IniName) DO
    try
      WriteString('Puzzles', Format('%s-%s', [sFrom, sTo]), sSol);
    finally
      Free;
    end;
  btnDone.ModalResult := mrOK;
end;

procedure TCreateForm.SetWordLength(Value : Integer);
begin
  StartLen          := Value;
  ebStart.MaxLength := StartLen;
  ebEnd.MaxLength   := StartLen;
end;

procedure TCreateForm.ReadWordList;
VAR N : Integer;
begin
  SetHint(True, 'Reading word list; please wait...');
  Application.ProcessMessages;
  Screen.Cursor := crHourglass;
  try
    sl_mastr.Sorted := False;
    sl_mastr.LoadFromFile(Format(NAMESPEC,[StartLen]));
    FOR N := sl_mastr.Count-1 DOWNTO 0 DO
      IF Length(sl_mastr[N]) = StartLen+3 THEN
        sl_mastr.Delete(N);
    sl_mastr.Sorted := True;
  finally
    Screen.Cursor := crDefault;
  end;
  ebStart.SetFocus;
end;

procedure TCreateForm.ShowWordList;
VAR
  N      : Integer;
  slTemp : TStringList;
begin
  SetHint(True, 'Processing word list; please wait...');
  Application.ProcessMessages;
  Screen.Cursor := crHourglass;
  try
    slTemp := TStringList.Create;
    try
      slTemp.Assign(sl_mastr);
      slTemp.Sorted := False;
      FOR N := 0 TO slTemp.Count-1 DO
        slTemp[N] := Copy(slTemp[N], 1, StartLen);
      lbWords.Items := slTemp;
    finally
      slTemp.Free;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
  ebStart.SetFocus;
  SetHint(True, '');
end;


end.