unit Unit1;
{ logigram puzzle solving
  note : rating goes up from 1(lowest) to 10(highest)
}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Grids, StdCtrls, Buttons, shellapi, ExtCtrls;

type
  TForm1 = class(TForm)
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    StaticText1: TStaticText;
    StringGrid1: TStringGrid;
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure Image1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type Tstring5 =  array[0..4] of string;
     Tactivity = record
                  row    : byte;           //place in table
                  column : byte;
                 end;

const Spersons    : Tstring5 =          //contents of fields in table
                   ('mary','william','peter','ann','rose');
      Ssubjects   : Tstring5 =
                   ('language','math','geology','history','biology');
      Stasks      : Tstring5 =
                   ('homework','examination','test','scription','paper');
      Sscores     : Tstring5 =
                   ('3','5','6','7','9');

      homework      : Tactivity = (row:0; column:1); //place in table
      examination   : Tactivity = (row:1; column:1);
      test          : Tactivity = (row:2; column:1);
      scription     : Tactivity = (row:3; column:1);
      paper         : Tactivity = (row:4; column:1);
      language      : Tactivity = (row:0; column:2);
      math          : Tactivity = (row:1; column:2);
      geology       : Tactivity = (row:2; column:2);
      history       : Tactivity = (row:3; column:2);
      biology       : Tactivity = (row:4; column:2);

      mary = 0;     //place in column
      william = 1;
      peter = 2;
      ann  = 3;
      rose = 4;

var permutNr : array[1..3] of byte; //hold permutation-index of columns
    permuts  : array[0..4,0..119] of byte;
    solution : byte;       //nummer van de oplossing

procedure makepermutations;
//make all permutations in array permuts[0..4,0..119]
const delers : array[0..3] of byte = (24,6,2,1);
var i,j,k,rest,quot : byte;
    pel : array[0..4] of byte; //pel : permutation of elements 01234
begin
 for j := 0 to 119 do
  begin
   for i := 0 to 4 do pel[i] := i;//set permutation 0 = 01234
   rest := j;
   for i := 0 to 3 do
    begin                         //make permutation j
     quot := rest div delers[i];
     rest:= rest mod delers[i];
     permuts[i,j] := pel[quot];
     for k := quot to 3 do pel[k] := pel[k+1]; //shift elements down
     pel[4] := 0;
    end;
   permuts[4,j] := pel[0];//left over number
  end;//for j
end;

procedure setCells;
//fill table according to permtNr[1..3]
var i,j,k : byte;
begin
 k := 0;
 with form1.stringgrid1 do
  for i := 0 to 3 do        //columns
   begin
     if i <> 0 then k := permutNr[i];
     for j := 0 to 4 do     //rijen
     case i of
      0 : cells[i,j] := Spersons[j];
      1 : cells[i,j] := Stasks[permuts[j,k]];
      2 : cells[i,j] := Ssubjects[permuts[j,k]];
      3 : cells[i,j] := Sscores[permuts[j,k]];
     end;//case
    end;
end;

procedure setInitial;
var i : byte;
begin
 for i := 1 to 3 do permutNr[i] := 0;
 setCells;
 form1.statictext1.caption := 'initial';
 solution := 0;
end;

function rating(n : byte) : byte;
//n: 0..4
//find rating in row n
var k : byte;
begin
 k := permuts[n,permutNr[3]];
 result := strtoint(Sscores[k]);
end;

function person(a : Tactivity) : byte;
//find person of activity a
var i,kolom,rij,k : byte;
begin
 result := 0;
 kolom := a.column;
 rij := a.row;

//--search row nr in column

 k := permutNr[kolom];
 for i := 0 to 4 do
  if permuts[i,k] = rij then result := i
end;

function checkOK : boolean;
//test of aan voorwaarden is voldaan
begin
 result := (rating(person(scription)) > rating(person(math))) and  //1a
           (rating(person(scription)) < rating(rose)) and          //1b
           (person(math) <> rose) and                               //1c
           (person(homework) <> peter) and                          //2a
           (rating(peter) > rating(ann)) and                         //2b
           (person(examination) <> peter) and                       //2c
           (rating(peter) < rating(person(history))) and            //2d
           (rating(peter) <> rating(person(examination)) + 6) and   //2e
           (rating(peter) <> rating(person(examination)) + 4) and   //2f
           (rating(person(examination)) + 6 <= 9) and               //2g
           (rating(person(test)) > rating(mary)) and                //3a
           (person(language) <> mary) and                           //3b
           (rating(person(test)) < rating(person(biology))) and    //3c
           (person(test)<>william) and (person(test)<>peter) and   //3d
           (william = person(geology)) and                          //4a
           (rating(william) > rating(person(language))) and         //4b
           (rating(william) < rating(person(paper)))                //4c
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 makepermutations;
 SetInitial;
end;

function Increment : boolean;
//increment counter permutNr[1..3]
var carry : boolean;
    i : byte;
begin
  carry := true;
  for i := 1 to 3 do
   begin
    if carry then inc(permutNr[i]);
    if permutNr[i] = 120 then permutNr[i] := 0
    else carry := false;
   end;//for
 result := carry;
end;

procedure TForm1.BitBtn2Click(Sender: TObject);
//solve
begin;
 statictext1.caption := 'computer searching...';
 repeat
  if checkOK then
   begin
    inc(solution);
    statictext1.caption := 'found solution'+' : '+inttostr(solution);
    setCells;
    increment;
    exit;
   end;
 until increment;//until overflow
 statictext1.caption := 'end';
 setInitial;
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
//initialize
begin
 setInitial;
end;

procedure TForm1.Image1Click(Sender: TObject);
//davdata website link
begin
 ShellExecute(0,'open','http://www.davdata.nl/math/logipuzzle.html', nil, nil, SW_SHOWNORMAL);
end;

end.