StormDuko

Programs which generate, solve, and analyze Sudoku puzzles

StormDuko

Postby StrmCkr » Wed Mar 02, 2016 3:56 pm

This thread is for my Sudoku Solver written in "Turbo pascal" Via Free pascal 2.4+

Current code posted here in is designed for Windows operating system.
all inclusive .pas file

my current build of my solver is based on Setwise operations
+ Union of two sets
- Difference of two sets
* Intersection of two sets
= Checks equality of two sets
<> Checks non-equality of two sets
in Checks set membership of an element in a set
".. " operator precedence

Grid space index References
Solving space Data storage and type cast
Screen display functions
Load,Save and initiate a Grid
Peers building functions
Solving techniques
timer & main body code
Last edited by StrmCkr on Wed Jan 25, 2017 8:01 am, edited 17 times in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Grid space index

Postby StrmCkr » Wed Mar 02, 2016 3:56 pm

Constants
Hidden Text: Show
Code: Select all
const
       LEFT    = 12;
       UP      = 4;
       SPACE   = ' ';
       dat_file= 'stormduko.dat'; {save file}
       dat_file2= 'stormdukoPM.dat';{save pm file}
       text_file= 'Generated.txt';

       COL1   = lightblue; {preset colors}
       COL2   = lightgray;
       COLBG  = black;


index constants for quicker referencing
Hidden Text: Show
Code: Select all
Const
Rx: array[0..80] of integer =
   (0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,
    3,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,
    6,6,6,6,6,6,6,6,6,7,7,7,7,7,7,7,7,7,8,8,8,8,8,8,8,8,8);

  Cy: array[0..80] of integer =
   (0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,
    0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,
    0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8,0,1,2,3,4,5,6,7,8);

  Bxy: array[0..80] of integer =
   (0,0,0,1,1,1,2,2,2,0,0,0,1,1,1,2,2,2,0,0,0,1,1,1,2,2,2,
    3,3,3,4,4,4,5,5,5,3,3,3,4,4,4,5,5,5,3,3,3,4,4,4,5,5,5,
    6,6,6,7,7,7,8,8,8,6,6,6,7,7,7,8,8,8,6,6,6,7,7,7,8,8,8);

  BxyN: array[0..80] of integer =
   (0,1,2,0,1,2,0,1,2,3,4,5,3,4,5,3,4,5,6,7,8,6,7,8,6,7,8,
    0,1,2,0,1,2,0,1,2,3,4,5,3,4,5,3,4,5,6,7,8,6,7,8,6,7,8,
    0,1,2,0,1,2,0,1,2,3,4,5,3,4,5,3,4,5,6,7,8,6,7,8,6,7,8);

  {quick look up for each space}
  Rset: array [0..8,0..8] of integer =
    ( (0,1,2,3,4,5,6,7,8),
    (9,10,11,12,13,14,15,16,17),
    (18,19,20,21,22,23,24,25,26),
    (27,28,29,30,31,32,33,34,35),
    (36,37,38,39,40,41,42,43,44),
    (45,46,47,48,49,50,51,52,53),
    (54,55,56,57,58,59,60,61,62),
    (63,64,65,66,67,68,69,70,71),
    (72,73,74,75,76,77,78,79,80) );

  Cset: array [0..8,0..8] of integer =
    ( (0,9,18,27,36,45,54,63,72),
    (1,10,19,28,37,46,55,64,73),
    (2,11,20,29,38,47,56,65,74),
    (3,12,21,30,39,48,57,66,75),
    (4,13,22,31,40,49,58,67,76),
    (5,14,23,32,41,50,59,68,77),
    (6,15,24,33,42,51,60,69,78),
    (7,16,25,34,43,52,61,70,79),
    (8,17,26,35,44,53,62,71,80) );

   Bset: array [0..8,0..8] of integer =
    ( (0,1,2,9,10,11,18,19,20),
    (3,4,5,12,13,14,21,22,23),
    (6,7,8,15,16,17,24,25,26),
    (27,28,29,36,37,38,45,46,47),
    (30,31,32,39,40,41,48,49,50),
    (33,34,35,42,43,44,51,52,53),
    (54,55,56,63,64,65,72,73,74),
    (57,58,59,66,67,68,75,76,77),
    (60,61,62,69,70,71,78,79,80) );

 SecSet: array [0..26,0..8] of integer =
    ( {row}
    (0,1,2,3,4,5,6,7,8),
    (9,10,11,12,13,14,15,16,17),
    (18,19,20,21,22,23,24,25,26),
    (27,28,29,30,31,32,33,34,35),
    (36,37,38,39,40,41,42,43,44),
    (45,46,47,48,49,50,51,52,53),
    (54,55,56,57,58,59,60,61,62),
    (63,64,65,66,67,68,69,70,71),
    (72,73,74,75,76,77,78,79,80),
      {col}
    (0,9,18,27,36,45,54,63,72),
    (1,10,19,28,37,46,55,64,73),
    (2,11,20,29,38,47,56,65,74),
    (3,12,21,30,39,48,57,66,75),
    (4,13,22,31,40,49,58,67,76),
    (5,14,23,32,41,50,59,68,77),
    (6,15,24,33,42,51,60,69,78),
    (7,16,25,34,43,52,61,70,79),
    (8,17,26,35,44,53,62,71,80),
    {box}
    (0,1,2,9,10,11,18,19,20),
    (3,4,5,12,13,14,21,22,23),
    (6,7,8,15,16,17,24,25,26),
    (27,28,29,36,37,38,45,46,47),
    (30,31,32,39,40,41,48,49,50),
    (33,34,35,42,43,44,51,52,53),
    (54,55,56,63,64,65,72,73,74),
    (57,58,59,66,67,68,75,76,77),
    (60,61,62,69,70,71,78,79,80) );

Last edited by StrmCkr on Fri Feb 10, 2017 7:28 am, edited 3 times in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Data sets and type cast

Postby StrmCkr » Wed Mar 02, 2016 4:01 pm

Type Definition for data space
Hidden Text: Show
Code: Select all
type
sector = 0 .. 26;
cell = 0 .. 80;
digits = 1 .. 9;
RCB = 0 .. 8;

numberset = set of cell;   {the grid}
nums =  set of digits;   {digits 1-9}

RCBnums = set of Rcb;  {R,C,B spaces 0 - 8}
RCBpeer = set of sector; {RCB peer sectors}


Data storage Space
Hidden Text: Show
Code: Select all
var

peer: array [cell] of numberset;
peer2: array [cell,0..19] of integer; {a quick call version to use the peers}

comboset: array [0..511] of nums;        { digits }
comboset2: array [0..511] of RCbnums;    { 0-8 cells}

combosetR: array [rcb,0..511] of numberset;     {cells for row}
combosetC: array [rcb,0..511] of numberset;     {cells for col}
combosetB: array [rcb,0..511] of numberset;     {cells for box}

combosetS: array [sector,0..511] of numberset;  {listing cells for sector}


 Rnum:  array[rcb] of numberset; {area peers}
 Bnum:  array[rcb] of numberset;
 Cnum:  array[rcb] of numberset;

 RCBnum: array[sector] of numberset; {RCB call function for easier use}

 peerRCB: array[sector] of rcbpeer; {RCB peer sectors}

 DigitRCB: array[digits,sector] of numberset; {RBC function listing active cells for digit N}

 NSector: array[sector] of nums; {function listing all  digits for sector}

 SectorRCB: array[Sector,RCB] of numberset;   {Rbc function listing active cells for a sectors rcb}

      X,Y           : integer; {coridinals}
      Grid          : String ; {imported grid string}
      Count,Countpm : integer; {counts the given clues and pms}
      active{,unique} : boolean;
      ch            : char;
      iter          : integer;
      //variation     : boolean;

S:  array [cell] of nums;  {solved grid}

PM: array [cell] of nums;  {pm combined view} {RD*CD*BD}
IPM: array[cell] of nums; {saved pm combined view} {RD*CD*BD}

NM: array [cell] of integer; { # of digits found in cell}

Delpm: array [cell] of nums;    {manual deletion of pencil marks}

covered: array [cell] of nums;

covered2: array [digits] of numberset;

{hidden sets}
Rn: array [Rcb,digits] of RCBnums;   {nums represet Col #}
Cn: array [Rcb,digits] of RCBnums;   {nums represet Row #}
Bn: array [Rcb,digits] of RCBnums;   {nums represet Box ordering #}

RnSector: array [sector,Digits] of RCBnums;  {saves RCB}

RnSectorNum: array [sector,Digits] of numberset;  {saves cells}

BnC: array [Rcb,digits] of RCBnums;   {nums represet Box col }
BnR: array [Rcb,digits] of RCBnums;   {nums represet Box row }

{Naked sets}
RC: array[RCB,RCB] of nums;      {# in row x col}
BS: array[RCB,RCB] of nums;      {# in box - square}

SectorRC: array[sector,rcb] of nums; {# in row x col with in sector}

BSR: array[RCB,RCB] of nums;      {# in box - row}
BSC: array[RCB,RCB] of nums;      {# in box - Col}

B: array[Rcb,digits] of integer;   { exact number of unassigned cells for # given in space}
C: array[Rcb,digits] of integer;
R: array[Rcb,digits] of integer;

Sec:Array[sector,digits] of integer; {exact number of unassigned cells for # givens in a sector}

Rd: array[RCB] of nums;
Cd: array[RCB] of nums;
Bd: array[RCB] of nums;
Last edited by StrmCkr on Fri Feb 10, 2017 7:29 am, edited 3 times in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Displaying txt fuctions

Postby StrmCkr » Wed Mar 02, 2016 4:20 pm

Write to screen
Hidden Text: Show
Code: Select all
//writing functions grid layout.
procedure writexy(x,y:integer; s:string);
begin
  gotoxy(x,y);
  write(s);
end;


move courser around in main Sudoku grid
Hidden Text: Show
Code: Select all
{moves the cursers n screen in the givens box & displays some info on the cell active}
procedure Curser(A,c:integer);
var
xr,yr:integer;
i:integer;
begin

  Gotoxy(3,3); write(BXY[a]);
  gotoxy(7,3); write(Rx[a]);
  gotoxy(11,3); write(Cy[a]);

  gotoxy(15,3); write(Rset[rx[a],cy[a]],' ');

  Gotoxy(42,3); write(BXY[a]+18,' ',Rx[a],' ',Cy[a]+9,' ');

  gotoxy(2,6); {displaying the pm grid}

  for i:= 1 to 9 do
   if (i in ((Rd[rx[a]] * Cd[cy[a]] * Bd[bxy[a]]) * Delpm[a] * covered[a] * pm[a] * ipm[a]) )
   and  (s[a]=[])
   and ( a in covered2[i])
     then
      write(I)
     else
      write(space);

  xr:=LEFT + (Cy[a]+1)*4 -2;
  yr:=UP + (Rx[a]+1)*2 -1;

  gotoxy(xr,yr);

  textbackground(c);

  if( S[a]=[] )
   then
     write( SPACE )
  else
     for i in (S[a]) do
         write(i);

  gotoxy(xr,yr);

end;


move mouse courser around Pencil mark box
Hidden Text: Show
Code: Select all
{moves the curser on screen in the pm's box}
procedure curserpm(A,c:integer);
var
xr,yr,i:integer;

begin

  Gotoxy(3,3); write(BXY[a]);
  gotoxy(7,3); write(Rx[a]);
  gotoxy(11,3); write(Cy[a]);
  gotoxy(15,3); write(Rset[rx[a],cy[a]],' ');
  Gotoxy(42,3); write(BXY[a]+18,' ',Rx[a],' ',Cy[a]+9,' ');

  gotoxy(2,6); {displaying the pm grid}

  for i:= 1 to 9 do
   if (i in ((Rd[rx[a]] * Cd[cy[a]] * Bd[bxy[a]]) * Delpm[a] * covered[a] * pm[a] * ipm[a]) )
   and  (s[a]=[])
   and ( a in covered2[i])
     then
      write(I)
     else
      write(space);

 xr:= (Cy[a]+1)*12 - 9;
 yr:= up+29 +(Rx[a]+1)*2 -2;

  textbackground(c);

  gotoxy(xr,yr);

end;


write pencil marks to screen
Hidden Text: Show
Code: Select all
{writes the pencil marks to screen}
procedure Wpm(R:integer);
var
A,Xw,Yw,i:integer;

begin

for a:= 0 to 80 do

 begin

  textcolor(col2);

  if (S[a] <> []) or (R=1)
   then
     curser(a,colbg);

  xw:= ( (Cy[a])+1) * 12 - 9 ;
  yw:= up + 29 + ((Rx[a])+1)*2-2;

  textcolor(5);
  gotoxy(xw,yw);

 For I:= 1 to 9 do
    if (I in  (Rd[rx[a]] * Cd[cy[a]] * Bd[bxy[a]] * delpm[a] * covered[a] * pm[a] * Ipm[a] ))
   and (a in covered2[i])
    then
       write(I)
      else
       write(space);


 end;


textcolor(col2);

writexy(20,23,'   ');
gotoxy(20,23);
write(count);
writexy(17,24,'   ');
gotoxy(17,24);
write(countpm);

end;


The grid display
Hidden Text: Show
Code: Select all
procedure ViewGiven; { grid }
begin
  textcolor(13);
  writexy(26,2,'Stormdoku');
  textcolor(COL1);
  writexy( LEFT, UP   ,  'ÉÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍ»' );
  writexy( LEFT, UP+ 1,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+ 2,  'º---+---+---º---+---+---º---+---+---º' );
  writexy( LEFT, UP+ 3,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+ 4,  'º---+---+---º---+---+---º---+---+---º' );
  writexy( LEFT, UP+ 5,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+ 6,  'ÌÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍ͹' );
  writexy( LEFT, UP+ 7,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+ 8,  'º---+---+---º---+---+---º---+---+---º' );
  writexy( LEFT, UP+ 9,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+10,  'º---+---+---º---+---+---º---+---+---º' );
  writexy( LEFT, UP+11,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+12,  'ÌÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍ͹' );
  writexy( LEFT, UP+13,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+14,  'º---+---+---º---+---+---º---+---+---º' );
  writexy( LEFT, UP+15,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+16,  'º---+---+---º---+---+---º---+---+---º' );
  writexy( LEFT, UP+17,  'º   |   |   º   |   |   º   |   |   º' );
  writexy( LEFT, UP+18,  'ÈÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍͼ' );
  textcolor(13);
  writexy(42,23,'Build 6');
  writexy(42,24,'Vrs .88');
  textcolor(COL1);
end;


The pencil mark grid Display
Hidden Text: Show
Code: Select all
procedure ViewPM; { pm grid }
begin
textcolor(27);
writexy(50,30,'Pencil Mark');
textcolor(19);
writexy( 1 , up+28, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');
writexy( 1 , up+29, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+30, 'º-----------+-----------+-----------º-----------+-----------+-----------º-----------+-----------+-----------º');
writexy( 1 , up+31, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+32, 'º-----------+-----------+-----------º-----------+-----------+-----------º-----------+-----------+-----------º');
writexy( 1 , up+33, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+34, 'ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹');
writexy( 1 , up+35, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+36, 'º-----------+-----------+-----------º-----------+-----------+-----------º-----------+-----------+-----------º');
writexy( 1 , up+37, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+38, 'º-----------+-----------+-----------º-----------+-----------+-----------º-----------+-----------+-----------º');
writexy( 1 , up+39, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+40, 'ÌÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͹');
writexy( 1 , up+41, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+42, 'º-----------+-----------+-----------º-----------+-----------+-----------º-----------+-----------+-----------º');
writexy( 1 , up+43, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+44, 'º-----------+-----------+-----------º-----------+-----------+-----------º-----------+-----------+-----------º');
writexy( 1 , up+45, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+46, 'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
textcolor(col2);
end;


help screen info
Hidden Text: Show
Code: Select all
procedure Help; {info menu}
begin
  textcolor(lightred);
  writexy(2, 2,'Box Row Col Cell');
  writexy(42,2,'Sectors');
  textcolor(67);
  writexy(2,5,'choice');
  textcolor(24);
  writexy(12,23,'Givens:');
  writexy(12,24,'PMs:');

  textcolor(green);
  writexy(26,25,'ESC : Exit');

  textcolor(67);
  writexy(58,4,'Keystroke');

  textcolor(24);
  writexy(51,6,'Movement:');

  textcolor(green);
  writexy(50,7,'Arrows    - Direction');
  writexy(50,8,'Home      - Goto Col 1 on Row');
  writexy(50,9,'End       - Goto Col 9 on Row');
  writexy(50,10,'Page up   - Goto Row 1 on Col');
  writexy(50,11,'Page down - Goto Row 9 on Col');
  writexy(50,12,'Backspace - Delete # in cell');
  writexy(50,13,'Delete    - Delete # in cell');
  Writexy(50,14,'Tab       - Switch PM | Grid');
  writexy(50,15,'1 - 9     - Enter # into cell');

  textcolor(24);
  writexy(51,17,'Functions:');

  textcolor(green);
 { writexy(50,25,'B        - Batch solve');  }
  {writexy(50,22,'G        - Generate a Puzzle'); }
  writexy(50,18,'~ or `   - Solve');
  writexy(50,19,'R        - Reset Grid');
  writexy(50,20,'S        - Save Grid String');
  writexy(50,21,'s        - Save Pm state');
  writexy(50,22,'L        - Load Saved Grid');
  writexy(50,23,'l        - Load Saved Pm');
  writexy(50,24,'I        - Import a Grid');
  writexy(50,25,'C        - Isomorphic ');

  textcolor(24);

  writexy(85,1,'Starter Techniques:');
  textcolor(green);
  writexy(81,2,'F1          - Hidden Single');
  writexy(81,3,'Shift + F1  - Naked Single');
  writexy(81,4,'F3          - Hidden Pair');
  writexy(81,5,'Shift + F3  - Naked Pair');
  writexy(81,6,'F4          - Hidden Triple');
  writexy(81,7,'SHift + F4  - Naked Triple');
  writexy(81,8,'F5          - Hidden Quad');
  writexy(81,9,'Shift + F5  - Naked Quad');

  textcolor(24);
  writexy(85,11,'Fish Techniques:');
  textcolor(green);

  writexy(81,12,'F2          - Box Line Reduction');
  writexy(81,13,'Shift + F2  - X - Wing');
  writexy(81,14,'F6          - Skyscraper');
  writexy(81,15,'F7          - Empty Rectangle');
  Writexy(81,16,'F8          - 2-String Kyte');
  writexy(81,17,'F9          - Sword Fish');
  writexy(81,18,'F10         - Jelly Fish');
  writexy(81,19,'Shift + F9  - Finned/Sashimi Sword');
  writexy(81,20,'Shift + F10 - Finned/Sashimi Jelly');
  writexy(81,22,'F          - N x ( N + K ) Fish');
   //writexy(81,30,'T          - N x N Fish');

  textcolor(24);
  writexy(85,24,'Bent Subset Techniques:');
  textcolor(green);
  writexy(81,25,'Shift + F6  - XY - Wing');
  writexy(81,26,'Shift + F7  - XYZ - Wing');
  writexy(81,27,'Shift + F8  - WXYZ - Wing');

  writexy(81,29,'B           - Barns');

  textcolor(24);
  writexy(120,24,'Subset Techniques:');
  textcolor(green);

  writexy(115,25, 'D          - Sue De Coq');

  textcolor(24);
  writexy(120,1,'Chain Techniques:');
  textcolor(green);

  writexy(115,2, 'F11         - W-Wing');
  writexy(115,3, 'Shift + 11  - M-Wing');
  writexy(115,4, 'F12         - S-Wing');
  writexy(115,5, 'Shfit + F12 - L-Wing');
  writexy(115,7, 'X           - XY Chain');

  textcolor(24);
  writexy(120,11,'Almost locked Sets Techniques:');
  textcolor(green);

  writexy(115,12,'A           - ALS - XZ rule');
  writexy(115,13,'H           - AHS - XZ rule');
  writexy(115,14,'Y           - ALS - XY rule');
 { writexy(115,15,'M           - Muti - Set');   }

  writexy(50,52,' PM keystroke ');
  textcolor(24);
  writexy(39,53,'Movment:');
  textcolor(green);
  writexy(39,54,'Arrows    - Direction');
  writexy(39,55,'Home      - Goto Col 1 on Row');
  writexy(39,56,'End       - Goto Col 9 on Row');
  writexy(39,57,'Page up   - Goto Row 1 on Col');
  writexy(39,58,'Page down - Goto Row 9 on Col');
  writexy(39,59,'Backspace - Resets PM #s in cell');
  writexy(39,60,'Delete    - Resets PM #s in cell');
  writexy(39,61,'1 - 9     - Delete # from cell');

  textcolor(darkgray);
  writexy(78,52,'Copyright © Strmckr 2009 ->> 2017');
  writexy(73,54,'This program is free software: you can ');
  writexy(73,55,'redistribute it and/or modify it under the');
  writexy(73,56,'terms of the GNU general public License');
  writexy(73,58,'This program is distributed without any ');
  writexy(73,59,'warrenty; without even the implied warranty');
  writexy(73,60,'of Merchantability or fitness for a ');
  writexy(73,61,'particular purpose. See the GNU general');
  writexy(73,62,'public license for more details.  ');
  writexy(75,64,' < http://www.gnu.org/licenses// > ');
  textcolor(col2);

end;


Isomorphic transformations
Hidden Text: Show
Code: Select all
procedure issomorph(K2,B2,F2:char);
var
K,B,F:char;
xn,n:integer;
S2:  array [cell] of nums;  {solved grid copy}
begin

for xn:= 0 to 80 do
 s2[xn]:=S[xn];

for xn:= 0 to 8 do
  begin

   Rd[xn]:= [1..9];
   Cd[xn]:= [1..9];
   Bd[xn]:= [1..9];
   covered2[xn+1]:=[0..80];


    for n:= 1 to 9 do
      begin

      // S[rset[xn,(n-1)]]:= [];
       delpm[rset[xn,(n-1)]]:= [1..9];
       covered[rset[xn,(n-1)]]:= [1..9];

      end;

   end;
k:=k2;
b:=b2;
f:=f2;

if not (K in ['d','t','s','b','c','r'])
 then
   begin
writexy(2,25,' which area to move, R{ow},C{ol},s{tack},B{and},T{ranspose},D{igit}');
K:=readkey;  write(': ',K);
   end;

 case K of

{R} #114:
 begin

   if not (B in ['1'..'9'])
    then
     begin
   writexy(2,26,' Which Row to move? {1..9}');
   B:=readkey;  write(': ',B);
     end;

   if not (F in ['1'..'9'])
    then
     begin
   writexy(2,27,' Swaping with Row?');

   case B of
    #49,#50,#51 : write(' 1,2,3');
    #52,#54,#55 : write(' 4,5,6');
    #56,#57,#58 : write(' 7,8,9');

   end;

   F:=readkey; write(': ',F);
    end;

   for xn:=0 to 8 do
    begin

    s[Rset[(ord(b)-48)-1,xn]]:= S2[Rset[(ord(f)-48)-1,xn]];
    s[Rset[(ord(f)-48)-1,xn]]:= S2[Rset[(ord(b)-48)-1,xn]];

    end;

  end;  {row}

{C} #99:
 begin

  if not (B in ['1'..'9'])
    then
     begin
   writexy(2,26,' Which Col to move? {1..9}');
   B:=readkey;  write(': ',B);
     end;

   if not (F in ['1'..'9'])
    then
     begin
   writexy(2,27,' Swaping with Col?');

   case B of
    #49,#50,#51 : write(' 1,2,3');
    #52,#54,#55 : write(' 4,5,6');
    #56,#57,#58 : write(' 7,8,9');

   end;

   F:=readkey; write(': ',F);
    end;
   for xn:=0 to 8 do
    begin

    s[Cset[(ord(b)-48)-1,xn]]:= S2[Cset[(ord(f)-48)-1,xn]];
    s[Cset[(ord(f)-48)-1,xn]]:= S2[Cset[(ord(b)-48)-1,xn]];

    end;


 end; {col}

{Band} #98:
 begin

    if not (B in ['1'..'3'])
    then
     begin
   writexy(2,26,' Which Band to Swap? {1..3}');
   B:=readkey;  write(': ',B);
     end;

    if not (F in ['1'..'3'])
    then
     begin
   writexy(2,27,' Swaping with Band? {1..3}');
   F:=readkey;  write(': ',F);
      end;

   For xn:= 0 to 8 do
    for n:= 0 to 2 do
      begin
        s[Rset[(((ord(b)-48)-1)*3+n),xn]]:=s2[Rset[(((ord(f)-48)-1)*3+n),xn]];
        s[Rset[(((ord(f)-48)-1)*3+n),xn]]:=s2[Rset[(((ord(b)-48)-1)*3+n),xn]];
      end;

 end;  {Band}

{stack} #115:
 begin

     if not (B in ['1'..'3'])
    then
     begin
   writexy(2,26,' Which Stack to Swap? {1..3}');
   B:=readkey;  write(': ',B);
     end;

    if not (F in ['1'..'3'])
    then
     begin
   writexy(2,27,' Swaping with Stack? {1..3}');
   F:=readkey;  write(': ',F);
      end;

   For xn:= 0 to 8 do
    for n:= 0 to 2 do
      begin
        s[Cset[(((ord(b)-48)-1)*3+n),xn]]:=s2[Cset[(((ord(f)-48)-1)*3+n),xn]];
        s[Cset[(((ord(f)-48)-1)*3+n),xn]]:=s2[Cset[(((ord(b)-48)-1)*3+n),xn]];
      end;

 end; {stack}

{Transpose} #116:
 begin

 if not(k2 in['t'])
 then
 writexy(2,26,' Transposing Grid (main diagonal reflection)');

 for xn:= 0 to 8 do
  for n:= 0 to 8 do
   begin

     S[Rset[xn,n]]:=s2[Cset[xn,n]];
     s[Cset[n,xn]]:=S2[Rset[n,xn]];

    end;

 end; {Transpose}

{D} #100:
 begin

  if not (b in ['1'..'9'] )
   then
   begin
  writexy(2,26,' Which Digit to Swap? {1..9}');
   B:=readkey;  write(': ',B);
   end;

  if not (f in ['1'..'9'] )
   then
   begin
   writexy(2,27,' Swaping with Digit {1..9}');
   F:=readkey;  write(': ',F);
    end;

   For xn:= 0 to 80 do
   begin

    if S2[xn]= [ord(b)-48 ]
      then
      s[xn]:=[ord(F)-48];

    if S2[xn]= [ord(F)-48 ]
      then
      s[xn]:=[ord(B)-48];
    end;

 end;


   end;

 setpm;
 Sbrc;
 wpm(1);
writexy(2,25,'                                                                      ');
writexy(2,26,'                                                                      ');
writexy(2,27,'                                                                      ');

end;  {issomorphic transformation}
Last edited by StrmCkr on Fri Feb 10, 2017 7:34 am, edited 6 times in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

initiate, load, save functions

Postby StrmCkr » Wed Mar 02, 2016 4:36 pm

sets all basic data storage areas to zero/filled.
Hidden Text: Show
Code: Select all
{resets the starting variables to zero or filled}
procedure initiate;
var
xn,n:integer;
begin

 for xn:= 0 to 8 do
  begin

   Rd[xn]:= [1..9];
   Cd[xn]:= [1..9];
   Bd[xn]:= [1..9];
   covered2[xn+1]:=[0..80];


    for n:= 1 to 9 do
      begin

       S[rset[xn,(n-1)]]:= [];
       delpm[rset[xn,(n-1)]]:= [1..9];
       covered[rset[xn,(n-1)]]:= [1..9];

       Ipm[rset[xn,(n-1)]]:= [1..9];

      end;

   end;

end;


Fill data tables using the loaded grid
Hidden Text: Show
Code: Select all
{activates loaded puzzle}
procedure setpm;
var
xn,n:integer;
begin

for n:= 1 to 9 do
   for xn:= 0 to 80 do
     if N in (s[xn])
      then
        begin

         exclude(Rd[Rx[xn]],n);
         exclude(Cd[Cy[xn]],n);
         exclude(Bd[bxy[xn]],n);

        end;

end;


Set grid string as loaded puzzle
Hidden Text: Show
Code: Select all
{place imported 81 char string onto Grid}
procedure Arange;
var

xa,N:integer;
dig:string;
dig3,dig2: integer;

begin
N:=0;
 for xa:=0 to 80 do
   begin
    inc(n);
    dig:=grid[n];
    val(dig,dig3,dig2);

    if dig3 <>0
      then
      S[xa]:=[dig3];

        end;
  setpm;
  sbrc;
end;


import a grid string
Hidden Text: Show
Code: Select all
{loads a grid from a txt file}
procedure import;
var
myfile:text;
ior:integer;
filename:string;
verifygrid:integer;
Begin

initiate;

repeat
      repeat
      writexy(2,26,'                                       ');
      writexy(2,26, 'file path ');
       readln(filename);
           if (filename = ('')) or (filename = ('exit'))
            then exit
           else
        writexy(2,27,'                                       ');
        writexy(2,28,'                                       ');
        assign(myfile,filename);
        ior:= 0;
        {$I-}
        reset(myfile);
        {$I+}
        IOR:=ioresult;

      if Ior <> 0
      then
      writexy(2,27,'file not found')
      else
       begin
        textcolor(yellow );
        writexy(2,15,'Import');
        delay(300);
        writexy(2,15,'       ');
        textcolor(col2);
       end;

      until IoR = 0;
      read(myfile,grid);
      close(myfile);

Verifygrid:= length(Grid);

if( verifygrid <> 81) then
   writexy(2,28,'incorrect string size => <> 81 ');
until verifygrid=81;

if verifygrid=81
  then
   begin
   Arange;
   wpm(1);
   end;

end;


save grid to data_file
Hidden Text: Show
Code: Select all
{save current grid }
procedure save;
var
f: file of nums;
xs:integer;
begin

 assign(F,Dat_file);
 rewrite(f);

 for xs:=0 to 80 do
   write(f,S[xs]);

 close(f);

end;


Load saved grid from Data_file.
Hidden Text: Show
Code: Select all
{load from save}
procedure load;
var
F:file of nums;
XL:integer;
begin
initiate;

{$I-}
 assign(f,Dat_file);
 reset(f);
{$I+}

if Ioresult=0 then
 begin
   for xL:=0 to 80 do
    begin
      read (f, S[xl]);
     end;
     close(f);
 end;

setpm;
sbrc;
wpm(1);

end;


save pm state to file
Hidden Text: Show
Code: Select all
{save current pm and grid state}
procedure savepm;
var
f: file of nums;
xs:integer;
begin

assign(F,dat_file2);
rewrite(f);

for xs:= 0 to 80 do
  if  s[xs] = []
   then
    write(F,pm[xs])
   else
    write(F,s[xs]);

close(f);

end;


load Pencil mark state
Hidden Text: Show
Code: Select all
{load from gird and pm save}
procedure loadpm;
var
F:file of nums;
XL:integer;
begin
initiate;

{$I-}
 assign(f,Dat_file2);
 reset(f);
{$I+}

if Ioresult=0 then
 begin
   for xL:=0 to 80 do
    begin
      read (f, Ipm[xl]);
      if popcnt(dword(Ipm[xl])) = 1
       then   
        S[xl]:= Ipm[xl];

     end;
     close(f);
 end;

end;


Sets all subset data spaces used by solver
Hidden Text: Show
Code: Select all
procedure SBRC;
var
xn,n:integer;
begin

countpm:=0;
count:=0;

FOR XN:= 0 to 8 do
 for n:= 1 to 9 do
 begin

  r[xn,n]:=0;
  b[xn,n]:=0;
  c[xn,n]:=0;

  sec[xn,n]:=0;
  sec[xn+9,n]:=0;
  sec[xn+18,n]:=0;

  Rn[xn,n]:=[];
  Cn[xn,n]:=[];
  Bn[xn,n]:=[];

  RnSector[xn,n]:=[];
  RnSector[xn+9,n]:=[];
  RnSector[xn+18,n]:=[];

  RnSectorNum[xn,n]:=[];
  RnSectorNum[xn+9,n]:=[];
  RnSectorNum[xn+18,n]:=[];

  BnR[xn,n]:=[];
  BnC[xn,n]:=[];

  RC[xn,(n-1)]:=[];
  BS[xn,(n-1)]:=[];

  SectorRC[xn,(n-1)]:=[];
  SectorRC[xn+9,(n-1)]:=[];
  SectorRC[xn+18,(n-1)]:=[];


  BSC[xn,(n-1)]:=[];
  BSR[xn,(n-1)]:=[];

  digitRCb[n,xn]:=[];
   digitRCb[n,xn+9]:=[];
    digitRCb[n,xn+18]:=[];

  nm[rset[xn,(n-1)]]:=0;
  PM[rset[xn,(n-1)]]:=[];


  end;

for xn:= 0 to 80 do
 begin

  if s[xn] = []
   then

    begin

     for n:= 1 to 9 do

      if (N in (Rd[rx[xn]] * Cd[cy[xn]] * Bd[bxy[xn]] * delpm[xn] * covered[xn] * IPM[xn]) )
       and (xn in covered2[n])
       then
        begin

         inc(R[rx[xn],n]);
         inc(C[Cy[xn],n]);
         inc(B[Bxy[xn],n]);

         inc(sec[rx[xn],n]);
         inc(sec[cy[xn]+9,n]);
         inc(sec[bxy[xn]+18,n]);

         include(Rn[Rx[xn],n],Cy[xn]);
         include(Cn[Cy[xn],n],Rx[xn]);
         include(Bn[Bxy[xn],n],Bxyn[xn]);

         include(RnSector[Rx[xn],n],Cy[xn]);
         include(RnSector[Cy[xn]+9,n],Rx[xn]);
         include(RnSector[Bxy[xn]+18,n],Bxyn[xn]);

         include(RnSectorNum[Rx[xn],n],xn);
         include(RnSectorNum[Cy[xn]+9,n],xn);
         include(RnSectorNum[Bxy[xn]+18,n],xn);

         include(BnR[Bxy[xn],n],Rx[xn]);
         include(BnC[Bxy[xn],n],Cy[xn]);

         include(RC[Rx[xn],Cy[xn]],n);
         include(BS[Bxy[xn],Bxyn[xn]],n);

         include(SectorRC[Rx[xn],Cy[xn]],n);
         include(sectorRC[Cy[xn]+9,Rx[xn]],n);
         include(SectorRC[Bxy[xn]+18,Bxyn[xn]],n);


         include(BSC[Bxy[xn],Cy[xn]],n);
         include(BSR[Bxy[xn],Rx[xn]],n);

         include(DigitRCB[n,Rx[xn]],xn);
         include(DigitRCB[n,Cy[xn]+9],xn);
         include(DigitRCB[n,bxy[xn]+18],xn);

         include(PM[xn],n);

         inc(nm[xn]);

         inc(countpm);

        end;

     end

     else

        inc(count);


   end;

end;


strong/ weak link detection
Hidden Text: Show
Code: Select all
procedure Links;
var
xn,xn2,n,q,cn:integer;
begin


for n:= 1 to 9 do
 for xn:= 0 to 26 do
  for xn2:= 0 to 26 do
   begin
    sli[n,xn,xn2]:=[];
    wli[n,xn,xn2]:=[];
   end;

 for n:= 1 to 9 do
  for xn:= 0 to 26 do
   if (digitrcb[n,xn] <> [])
    then
     for xn2:= 0 to 26 do
     if  (xn2 in peerrcb[xn])
     and (digitrcb[n,xn2] <> [])
     and ( (digitrcb[n,xn2] * digitrcb[n,xn]) <> [])
      then
       begin
        cn:=0;

        for q:= 0 to 80 do
         if q in (digitrcb[n,xn] * digitrcb[n,xn2])
          then
           inc(cn);

        if cn > 1 then
         wli[n,xn,xn2]:=(digitrcb[n,xn2] * digitrcb[n,xn]);

        if cn = 1 then
         sli[n,xn,xn2]:= (digitrcb[n,xn] * digitrcb[n,xn2]);

       end;

end;{links}
Last edited by StrmCkr on Fri Feb 10, 2017 7:39 am, edited 3 times in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Peer building functions

Postby StrmCkr » Wed Mar 02, 2016 4:57 pm

Combination set
Hidden Text: Show
Code: Select all
{combination sets}
function next_combination (var v : array of integer; n, k : integer) : boolean;

var i, j : integer;

begin
   if (v[0] = (n - k)) or (k = 0) then
   begin
      next_combination := false;
      exit
   end;

   i := k - 1;

   while (i > 0) and (v[i] = n - k + i) do i := i - 1;

   v[i] := v[i] + 1;
   j := i;

    while (j < k - 1) do
       begin
         v[j+1] := v[j] + 1;
         inc(j);

       end;

   next_combination := true;

end;


Combo
Hidden Text: Show
Code: Select all
procedure combo;
var
vx : array [0..8] of integer;
   n,l,m,count : integer;
begin
count:=0;

For m:= 1 to 9 do
 begin

  for n := 0 to 8 do
   begin
     vx[n] := n;
   end;

  repeat
   begin

    for l:= 0 to (m-1)  do
     begin

      comboset[count]:=comboset[count] + [ (vx[l]+1) ];
      comboset2[count]:=comboset2[count] + [ (vx[l]) ];

     end;

     inc(count);

    end;
   until (next_combination (vx,9,m) = false);


  end;

end;


peers
Hidden Text: Show
Code: Select all
procedure peers;
var
xa,xa2,z:integer;
number1:numberset;

begin

for xa:= 0 to 80 do
  begin

     number1:=[];

     z:=0;

      For xa2:= 0 to 80 do
       IF (XA <> XA2)
        then
         if   ((Rx[xa])  in [  Rx[xa2] ] )
          or  ((Cy[xa])  in [  Cy[xa2] ] )
          or  ((Bxy[xa]) in [ Bxy[xa2] ] )
            then
             begin
              include(number1,xa2);

              peer2[xa,z]:=xa2;

              inc(z);

             end;

       peer[xa]:=number1;

 end;

end;


Link Peer
Hidden Text: Show
Code: Select all
procedure Linkpeers;
var
xn,xn2,q,n:integer;
begin

for xn:= 0 to 26 do
 for xn2:= 0 to 26 do
  linkpeer[xn,xn2]:=[];

for n:= 1 to 1 do

for xn:= 0 to 26 do
 for xn2:= 0 to 26 do
  if xn2 in peerrcb[xn]
    then
      for q:= 0 to 80 do;
       if peer[q] * (digitrcb[n,xn] * digitrcb[n,xn2])  = (digitrcb[n,xn] * digitrcb[n,xn2])
        then
         linkpeer[xn,xn2]:= linkpeer[xn,xn2] + [q];

end;


Row Col box peers
Hidden Text: Show
Code: Select all
procedure RCBpeers;
var
xa,xa2:integer;
number1,number2,number3:numberset;
number4,number5,number6:RcBpeer;

begin

for xa:= 0 to 8 do
  begin

     number1:=[];
     number2:=[];
     number3:=[];

     number4:=[];
     number5:=[];
     number6:=[];

      For xa2:= 0 to 80 do
         begin

            if Rx[xa2] = xa
               then
                begin
                include(number1,xa2);
                include(number4,cy[xa2]+9);
                include(number4,bxy[xa2]+18);
                end;

            if Cy[xa2] = xa
               then
                begin
                include(number2,xa2);
                include(number5,rx[xa2]);
                include(number5,bxy[xa2]+18);
                end;

            if bxy[xa2] = xa
               then
                begin
                include(number3,xa2);
                include(number6,cy[xa2]+9);
                include(number6,rx[xa2]);
                end;

         end;

         Rnum[xa]:= number1;
         Cnum[xa]:= number2;
         Bnum[xa]:= number3;

         RCBnum[xa]:=number1;
         RCBnum[xa+9]:=number2;
         RCBnum[xa+18]:=number3;

         peerRCB[xa]:=number4;
         peerRCB[xa+9]:=number5;
         peerRCB[xa+18]:=number6;

       end;
end;


Sector Row/Col/Box lookup
Hidden Text: Show
Code: Select all
procedure lookupSectorRBC;
var
xn,n:integer;
a: numberset;
begin

for xn:= 0 to 26 do
 begin

 nsector[xn]:= [1..9];

   for n:= 0 to 8 do
    begin
      a:=[];

       if xn in [0..8]
        then
         a:=a+ [Rset[xn,n]];

       if xn in [9..17]
        then
         a:=a+ [Cset[xn-9,n]];

       if xn in [18..26]
        then
         a:=a+ [Bset[xn-18,n]];

     SectorRCB[xn,n]:=A;


   end;
  end;

end;
Last edited by StrmCkr on Thu Jan 05, 2017 11:58 am, edited 1 time in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Solving Techniques

Postby StrmCkr » Wed Mar 02, 2016 5:18 pm

Hidden Singles
Hidden Text: Show
Code: Select all
{finds hidden singles}
procedure Hs(K:integer);
var
xn,yn,n:integer;
begin
  for xn:= 0 to 8 do
    for n:= 1 to 9 do
      begin

      if R[xn,n] = 1
       then
        For yn:= 0 to 8 do
          if Rn[xn,n] = [yn]
           then
             begin
              active:=true;

                S[Rset[xn,yn]]:=[n];

                exclude(Rd[xn],n);
                exclude(Cd[yn],n);
                exclude(Bd[bxy[rset[xn,yn]]],n);

             end;


      if C[xn,n] = 1
       then
        For yn:= 0 to 8 do
          if Cn[xn,n] = [yn]
           then
             begin
              active:=true;

                S[Cset[xn,yn]]:=[n];

                exclude(Rd[yn],n);
                exclude(Cd[xn],n);
                exclude(Bd[bxy[rset[yn,xn]]],n);

             end;

      if B[xn,n] = 1
       then
        For yn:= 0 to 8 do
         if Bn[xn,n] = [yn]
           then
             begin
              active:=true;

                S[Bset[xn,yn]]:=[n];

                exclude(Rd[Rx[bset[xn,yn]]],n);
                exclude(Cd[cy[bset[xn,yn]]],n);
                exclude(bd[xn],n);

             end;


       end;

end;  {hidden singles}


Hidden Pairs
Hidden Text: Show
Code: Select all
{hidden pairs}
procedure HP(k:integer);
var
xn,yn,n,n2,z:integer;
begin

For xn:= 0 to 8 do

   For n:= 1 to 8 do
    for n2:= (n+1) to 9 do
       begin

         If   (R[xn,n] > 0) and (R[xn,n] < 3 )
           and (R[xn,n2] > 0) and (R[xn,n2] < 3 )
            then
              for yn:= 9 to 44 do
                if Rn[xn,n] + Rn[xn,n2] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[rset[xn,z]]:= covered[rset[xn,z]] * [n,n2] * pm[rset[xn,z]];
                  end;

           If  (C[xn,n] > 0) and (C[xn,n] < 3 )
           and (C[xn,n2] > 0) and (C[xn,n2] < 3 )
            then
              for yn:= 9 to 44 do
                if Cn[xn,n] + Cn[xn,n2] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] * [n,n2] * pm[Cset[xn,z]];
                  end;

           If  (b[xn,n] > 0) and (b[xn,n] < 3 )
           and (b[xn,n2] > 0) and (b[xn,n2] < 3 )
            then
              for yn:= 9 to 44 do
                if bn[xn,n] + bn[xn,n2] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[bset[xn,z]]:= covered[bset[xn,z]] * [n,n2] * pm[bset[xn,z]];
                  end;

        end;

end;{hidden pair}


Hidden Triple
Hidden Text: Show
Code: Select all
{hidden triples}
procedure HT(k:integer);
var
xn,yn,n,n2,n3,z:integer;
begin

For xn:= 0 to 8 do

   For n:= 1 to 7 do
    for n2:= (n+1) to 8 do
     for n3:= (n2+1) to 9 do
       begin

         If   (R[xn,n] > 0) and (R[xn,n] < 4 )
           and (R[xn,n2] > 0) and (R[xn,n2] < 4 )
           and (R[xn,n3] > 0) and (R[xn,n3] < 4 )
            then
              for yn:= 45 to 128 do
                if Rn[xn,n] + Rn[xn,n2] + Rn[xn,n3] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[rset[xn,z]]:= covered[rset[xn,z]] * [n,n2,n3] * pm[rset[xn,z]];
                  end;

           If  (C[xn,n] > 0) and (C[xn,n] < 4 )
           and (C[xn,n2] > 0) and (C[xn,n2] < 4 )
            and (C[xn,n3] > 0) and (C[xn,n3] < 4 )
            then
              for yn:= 45 to 128 do
                if Cn[xn,n] + Cn[xn,n2] + Cn[xn,n3] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] * [n,n2,n3] * pm[Cset[xn,z]];
                  end;

           If  (b[xn,n] > 0) and (b[xn,n] < 4 )
           and (b[xn,n2] > 0) and (b[xn,n2] < 4 )
           and (b[xn,n3] > 0) and (b[xn,n3] < 4 )
            then
              for yn:= 45 to 128 do
                if bn[xn,n] + bn[xn,n2] + bn[xn,n3] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[bset[xn,z]]:= covered[bset[xn,z]] * [n,n2,n3] * pm[bset[xn,z]];
                  end;

        end;

end;{hidden triple}


Hidden Quad
Hidden Text: Show
Code: Select all
{hidden Quad}
procedure HQ(k:integer);
var
xn,yn,n,n2,n3,n4,z:integer;
Begin

For xn:= 0 to 8 do

   For n:= 1 to 6 do
    for n2:= (n+1) to 7 do
     for n3:= (n2+1) to 8 do
      for n4:= (n3+1) to 9 do
       begin

         If    (R[xn,n] > 0) and (R[xn,n] < 5 )
           and (R[xn,n2] > 0) and (R[xn,n2] < 5 )
           and (R[xn,n3] > 0) and (R[xn,n3] < 5 )
           and (R[xn,n4] > 0) and (R[xn,n4] < 5 )
            then
              for yn:= 129 to 254 do
                if Rn[xn,n] + Rn[xn,n2] + Rn[xn,n3] + Rn[xn,n4] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[rset[xn,z]]:= covered[rset[xn,z]] * [n,n2,n3,n4] * pm[rset[xn,z]];
                  end;

           If  (C[xn,n] > 0) and (C[xn,n] < 5 )
            and (C[xn,n2] > 0) and (C[xn,n2] < 5 )
            and (C[xn,n3] > 0) and (C[xn,n3] < 5 )
            and (C[xn,n4] > 0) and (C[xn,n4] < 5 )
             then
              for yn:= 129 to 254 do
                if Cn[xn,n] + Cn[xn,n2] + Cn[xn,n3] + CN[xn,n4] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] * [n,n2,n3,n4] * pm[Cset[xn,z]];
                  end;

           If  (b[xn,n] > 0) and (b[xn,n] < 5 )
           and (b[xn,n2] > 0) and (b[xn,n2] < 5 )
           and (b[xn,n3] > 0) and (b[xn,n3] < 5 )
           and (b[xn,n4] > 0) and (b[xn,n4] < 5 )
            then
              for yn:= 129 to 254 do
                if bn[xn,n] * bn[xn,n2] * bn[xn,n3] * bn[xn,n4] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                           covered[bset[xn,z]]:= covered[bset[xn,z]] * [n,n2,n3,n4] * pm[bset[xn,z]];
                  end;

        end;

end;{hidden Quad}


Naked Single
Hidden Text: Show
Code: Select all
{naked singles}
procedure NS(K:integer);
var
xn,n:integer;
begin
 For xn:= 0 to 80 do
   if nm[xn]=1
    then
      begin
       active:=true;

         s[xn]:=PM[xn];

         Rd[Rx[xn]]:= Rd[rx[xn]] - s[xn];
         Cd[Cy[xn]]:= Cd[cy[xn]] - s[xn];
         Bd[Bxy[xn]]:= Bd[bxy[xn]] - s[xn];

      end;

end; {naked singles}


Naked Pair
Hidden Text: Show
Code: Select all
{Naked pairs}
procedure NP(k:integer);
var
xn,yn,n,n2,z:integer;
begin

For xn:= 0 to 8 do
  For n:= 0 to 7 do
    for n2:= (n+1) to 8 do

        begin

           if(RC[xn,n] <> []) and (RC[xn,n2] <> [])
           and (nm[rset[xn,n]] <3) and (nm[rset[xn,n2]] <3)
            then
             for yn:= 9 to 44 do
              if ( RC[xn,n] + RC[xn,n2] = comboset[yn])
               then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if  not (z in [n,n2] )
                        then
                           covered[rset[xn,z]]:= covered[rset[xn,z]] - comboset[yn];

                  end;

           if (RC[n,xn] <> []) and (RC[n2,xn] <> [])
           and (nm[rset[n,xn]] < 3 ) and (nm[rset[n2,xn]] <3)
            then
             for yn:= 9 to 44 do
              if (RC[n,xn] + RC[n2,xn] = comboset[yn] )
                then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if  not (z in [n,n2] )
                        then
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] - comboset[yn];

                  end;

           if (Bs[xn,n] <> []) and (BS[xn,n2] <> [])
           and (nm[bset[xn,n]] < 3) and (nm[bset[xn,n2]] <3)
            then
             for yn:= 9 to 44 do
              if (BS[xn,n] + Bs[xn,n2] = comboset[yn] )
               then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if  not (z in [n,n2] )
                        then
                           covered[Bset[xn,z]]:= covered[Bset[xn,z]] - comboset[yn];

                  end;

        end;

end;{naked pair}


Naked Triple
Hidden Text: Show
Code: Select all
{Naked Triple}
procedure NT(k:integer);
var
xn,yn,n,n2,n3,z:integer;
begin

For xn:= 0 to 8 do
  For n:= 0 to 6 do
    for n2:= (n+1) to 7 do
     for n3:= (n2+1) to 8 do

        begin

           if (RC[xn,n] <> []) and (RC[xn,n2] <> []) and (RC[xn,n3] <> [])
           and (nm[rset[xn,n]] <4) and (nm[rset[xn,n2]] <4) and (nm[rset[xn,n3]] < 4 )
            then
              for yn:= 45 to 128 do
               if (RC[xn,n] + RC[xn,n2] + RC[xn,n3] = comboset[yn] )
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if not (z in [n,n2,n3] )
                        then
                          covered[rset[xn,z]]:= covered[rset[xn,z]] - comboset[yn];

                  end;

           if (RC[n,xn] <> []) and (RC[n2,xn] <> []) and (RC[n3,xn] <> [])
           and (nm[rset[n,xn]] < 4 ) and (nm[rset[n2,xn]] <4)  and (nm[rset[xn,n3]] <4)
            then
              for yn:= 45 to 128 do
               if ( RC[n,xn] + RC[n2,xn] + RC[n3,xn] = comboset[yn] )
                then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if  not (z in [n,n2,n3] )
                        then
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] - comboset[yn];

                  end;

           if (bS[xn,n] <> []) and (bS[xn,n2] <> []) and (bs[xn,n3] <> [])
           and (nm[bset[xn,n]] < 4) and (nm[bset[xn,n2]] <4) and (nm[bset[xn,n3]] <4)
            then
              for yn:= 45 to 128 do
               if(BS[xn,n] + Bs[xn,n2] + BS[xn,n3]= comboset[yn] )
                then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if  not (z in [n,n2,n3] )
                        then
                           covered[Bset[xn,z]]:= covered[Bset[xn,z]] - comboset[yn];

                  end;

        end;

end;{naked triple}


Naked Quad
Hidden Text: Show
Code: Select all
{Naked Quad}
procedure Nq(k:integer);
var
xn,yn,n,n2,n3,n4,z:integer;
Begin

For xn:= 0 to 8 do


  For n:= 0 to 5 do
    for n2:= (n+1) to 6 do
     for n3:= (n2+1) to 7 do
      for n4:= (n3+1) to 8 do


        begin

           if (RC[xn,n] <> []) and (RC[xn,n2] <> []) and (RC[xn,n3] <> []) and (RC[xn,n4] <> [])
           and (nm[rset[xn,n]] <5) and (nm[rset[xn,n2]] <5) and (nm[rset[xn,n3]] < 5 ) and (nm[rset[xn,n4]] <5)
            then
             for yn:= 129 to 254 do
              if (RC[xn,n] + RC[xn,n2] + RC[xn,n3] + RC[xn,n4] = comboset[yn] )

                then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if not (z in [n,n2,n3,n4] )
                        then
                           covered[rset[xn,z]]:= covered[rset[xn,z]] - comboset[yn];

                  end;

           if (RC[n,xn] <> []) and (RC[n2,xn] <> []) and (RC[n3,xn] <> []) and (RC[n4,xn] <> [])
           and (nm[rset[n,xn]] < 5 ) and (nm[rset[n2,xn]] <5)  and (nm[rset[xn,n3]] <5) and (nm[rset[xn,n4]] <5)
            then
              for yn:= 129 to 254 do
               if  (RC[n,xn] + RC[n2,xn] + RC[n3,xn] + RC[n4,xn]= comboset[yn] )
                then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if  not (z in [n,n2,n3,n4] )
                        then
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] - comboset[yn];

                  end;

           if (bS[xn,n] <> []) and (bS[xn,n2] <> []) and (bs[xn,n3] <> []) and (bs[xn,n4] <> [])
            and (nm[bset[xn,n]] < 5) and (nm[bset[xn,n2]] <5) and (nm[bset[xn,n3]] <5) and (nm[bset[xn,n4]] <5)
            then
              for yn:=129 to 254 do
               if (BS[xn,n] + Bs[xn,n2] + BS[xn,n3] + BS[xn,n4] = comboset[yn] )
                then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if  not (z in [n,n2,n3,n4])
                        then
                           covered[Bset[xn,z]]:= covered[Bset[xn,z]] - comboset[yn];

                  end;

        end;

end;{naked quad}


Box Line reduction
Hidden Text: Show
Code: Select all
{box line reduction}
procedure BLR(k:integer);
var
xn,sq,n,z:integer;
begin

for n:= 1 to 9 do
 for xn:= 0 to 8 do
   if  N  in Bd[xn]
    then
  for sq:= 0 to 8 do

  if sq in (BnR[xn,n] + BnC[xn,n])
   then
  begin

   {type 1 all cells for  a box are in a row }
    if  (BNR[xn,n] = [sq] )
     then
      begin
       active:=true;
       covered2[n]:= Covered2[n] - (Rnum[sq] - Bnum[xn]);

      end;

   {type 2 all cells for a row are in 1 box }

    if ( Rn[sq,n] - BnC[xn,n] = []  )  and (sq in BnR[xn,n]  )
     then
      begin
       active:= true;

       covered2[n]:=covered2[n] - (Bnum[xn] - Rnum[sq]);

       end;

   {type 1 all cells for  a box are in a  col}
   if  (BNC[xn,n] = [sq] )
     then
      begin
       active:=true;

       covered2[n]:= Covered2[n] - (Cnum[sq] - Bnum[xn]);

      end;

     {type 2 all cells for a Col are in 1 box }
     if ( Cn[sq,n] - BnR[xn,n] = []  )  and (sq in BnC[xn,n]  )
     then
      begin
       active:= true;

        covered2[n]:=covered2[n] - (Bnum[xn] - Cnum[sq]);

       end;

   end; {xn}

end;{box,line reduction}


X- Wing
Hidden Text: Show
Code: Select all
{x-wing}
procedure xwing(k:integer);
var
xn,xn2,xn3,yn,n,z:integer;
begin


For n:= 1 to 9 do

For xn:= 0 to 7 do
 for xn2:= (xn+1) to 8 do

       begin

         If   (R[xn,n] > 0) and (R[xn,n] < 3 )
           and (R[xn2,n] > 0) and (R[xn2,n] < 3 )
            then
              for yn:= 9 to 44 do
                if Rn[xn,n] + Rn[xn2,n] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if (z in comboset2[yn])
                        then
                         for xn3:= 0 to 8 do
                          if not (xn3 in [xn,xn2])
                           then
                             exclude( covered[Rset[xn3,z]],n);

                  end;

        If   (C[xn,n] > 0) and (C[xn,n] < 3 )
           and (C[xn2,n] > 0) and (C[xn2,n] < 3 )
            then
              for yn:= 9 to 44 do
                if Cn[xn,n] + Cn[xn2,n] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if (z in comboset2[yn])
                        then
                         for xn3:= 0 to 8 do
                          if not (xn3 in [xn,xn2])
                           then
                             exclude( covered[Cset[xn3,z]],n);


                  end;

     If   (B[xn,n] > 0) and (B[xn,n] < 7 )
           and (B[xn2,n] > 0) and (B[xn2,n] < 7 )
            then

             for yn:= 9 to 44 do
              begin

                if BNC[xn,n] + BnC[xn2,n] = comboset2[yn]
                 then
                   begin
                    active:= true;

                    for xn3:= 0 to 8 do
                     if not (xn3 in [xn,xn2])
                      then
                       for z:= 0 to 8 do
                        if Cy[bset[xn3,z]] in comboset2[yn]
                          then
                           exclude(covered[bset[xn3,z]],n);

                   end;

                if BNR[xn,n] + BnR[xn2,n] = comboset2[yn]
                 then
                   begin
                    active:= true;

                    for xn3:= 0 to 8 do
                     if not (xn3 in [xn,xn2])
                      then
                       for z:= 0 to 8 do
                        if Rx[bset[xn3,z]] in comboset2[yn]
                          then
                           exclude(covered[bset[xn3,z]],n);

                   end;


             end;

        end;

end;{x-wing}


Skyscraper { finned & Sashimi X-wing }
Hidden Text: Show
Code: Select all
{ Skyscrapers - Finned and or Sashimi x-wings}
procedure smashi(k:integer);
var
xn,xn2,xn3,yn,n,z:integer;
Finn:RCBnums;
finns:numberset;

begin

For n:= 1 to 9 do

For xn:= 0 to 7 do
 for xn2:= (xn+1)  to 8 do

       begin

         If   (R[xn,n] > 0) and (R[xn,n] < 5 )
           and (R[xn2,n] > 0) and (R[xn2,n] < 5 )
            then
              for yn:= 9 to 44 do

                if (( Rn[xn,n] + Rn[xn2,n]) * comboset2[yn] = comboset2[yn] )

                 then
                   begin

                    active:= true;

                    finn:= (Rn[xn2,n] + Rn[xn,n]) - comboset2[yn];

                    Finns:=[];

                     for z:= 0 to 8 do
                       if z in finn
                         then
                          begin

                           if (Rn[xn,n] - comboset2[yn] <> [])
                            then
                              include(finns,Rset[xn,z]);

                           if (Rn[xn2,n] - comboset2[yn] <> [])
                            then
                              include(finns,Rset[xn2,z]);
                           end;

                      for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn3:= 0 to 8 do
                           if not (xn3 in [xn,xn2])
                            and  ( finns * peer[Rset[xn3,z]] = finns )
                             then
                              exclude(covered[Rset[xn3,z]],n);


                  end;

        If   (C[xn,n] > 0) and (C[xn,n] < 5 )
           and (C[xn2,n] > 0) and (C[xn2,n] < 5 )
            then
              for yn:= 9 to 44 do
                if ((Cn[xn,n] + Cn[xn2,n]) * comboset2[yn] = comboset2[yn])

                 then
                   begin
                    active:= true;

                    finn:= (Cn[xn2,n] + Cn[xn,n]) - comboset2[yn];

                    Finns:=[];

                     for z:= 0 to 8 do
                       if z in finn
                         then
                          begin

                           if (CN[xn,n] - comboset2[yn]  <> [] )
                            then
                             include(finns,Cset[xn,z]);

                            if (CN[xn2,n]  - comboset2[yn]   <> [] )
                            then
                             include(finns,Cset[xn2,z]);
                           end;

                    for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn3:= 0 to 8 do
                           if not (xn3 in [xn,xn2])
                            and  ( finns * peer[Cset[xn3,z]] = finns )
                             then
                              exclude(covered[Cset[xn3,z]],n);

                  end;


        end;


end;{SMASHI}


2 - String kite
Hidden Text: Show
Code: Select all
{2-String Kyte}
procedure kyte(k:integer);
var
n,yn,xn,xa,ya,I,j,xn2,yn2,q:integer;
begin

 for n:= 1 to 9 do

    for xa:=0 to 2 do
     for ya:=0 to 2 do
       for I:= 0 to 2 do
         for yn:= (ya*3) to (2+(ya*3)) do     {columns}
          begin
           xn:=(I+(xa*3));    {rows}

           j:= (xa*3)+(ya);    {box}

          if  (DigitRCB[n,j+18] * DigitRCB[n,xn] <> [] )     {mini row contains cells}
          and (DigitRCB[n,J+18] * DigitRCB[n,yn+9] <> [])    {mini col contains cells}
          and ( DigitRCB[n,xn] * DigitRcb[n,yn+9] = [] )     {r&c intersection = []}

          and (DigitRCB[n,xn] - (DigitRCB[n,j+18]*DigitRCB[n,xn]) <> [] )      {row has digits out side the box}
          and (DigitRCB[n,yn+9] - (DigitRCB[n,j+18]*DigitRCB[n,yn+9]) <> [] )   {col has digits out side the box}
          then

          for xn2:= 0 to 8 do
           if ((xn2 div 3 ) <> (xn div 3) )
            then
             for yn2:= 0 to 8 do
              if ((yn2 div 3) <> (yn div 3))

              then
                 if  (   DigitRCB[n,xn] = (   DigitRCB[n,xn] * DigitRCB[n,j+18]) +  (DigitRCB[n,xn] * DigitRCB[n,yn2+9]) )
                 and (   DigitRCB[n,yn+9] = (   DigitRCB[n,yn+9] * DigitRCB[n,j+18]) +  (DigitRCB[n,yn+9] * DigitRCB[n,xn2]) )

                 then
                  begin
                  active:= true;

                  covered2[n]:= covered2[n] - (DigitRCB[n,xn2] * DigitRCB[n,yn2+9]);

                 end;

          end;
end;


Empty Rectangle
Hidden Text: Show
Code: Select all
 {Empty Rectangle}
procedure ER(K:integer);
var
n,yn,xn,xa,ya,I,j,q,xn2,yn2:integer;
begin

 for n:= 1 to 9 do

    for xa:=0 to 2 do
     for ya:=0 to 2 do
       for I:= 0 to 2 do
         for yn:= (ya*3) to (2+(ya*3)) do     {columns}
          begin
           xn:=(I+(xa*3));    {rows}

           j:= (xa*3)+(ya);    {box}


           if ( (digitRCB[n,yn+9] * digitrcb[n,j+18] )
           +    (digitRCB[n,xn] * digitrcb[n,j+18] )
           =    (digitRCB[n,j+18]) )

         and  ( DigitRCB[n,j+18] <> [] )
         and  ((digitRCB[n,yn+9] * digitrcb[n,j+18] ) - DigitRCB[n,xn]  <> [])
         and  ((digitRCB[n,xn] * digitrcb[n,j+18] ) - DigitRCB[n,yn+9]  <> [])

            then
            begin

             for xn2:= 0 to  8 do
               if  (R[xn2,n]=2  )
               and (DigitRCB[n,xn2] * DigitRCB[n,j+18] = [])
               and (DigitRCB[n,xn2] * DigitRCB[n,yn+9] <> [])

              then
                 for yn2:= 0 to 8 do
                  if ((DigitRCB[n,yn2+9] * DigitRCB[n,xn2] ) <> (DigitRCB[n,yn+9] * DigitRCB[n,xn2]))
                   and (DigitRCB[n,yn2+9] * DigitRCB[n,xn2] <> [])
                   and (DigitRCB[n,yn2+9] * DigitRCB[n,xn] <> [])
                   and (DigitRCB[n,yn2+9] * DigitRCB[n,j+18] = [])
                    then
                      begin
                        active:=true;

                        Covered2[n]:=Covered2[n] - ( ( DigitRCB[n,yn2+9] * DigitRCB[n,xn] ) - (DigitRCB[n,j+18] * digitrcb[n,yn+9]) );

                      end;

              for xn2:= 0 to  8 do
               if  (C[xn2,n]=2  )
               and (DigitRCB[n,xn2+9] * DigitRCB[n,j+18] = [])
               and (DigitRCB[n,xn2+9] * DigitRCB[n,xn] <> [])

              then
                 for yn2:= 0 to 8 do
                  if ((DigitRCB[n,yn2] * DigitRCB[n,xn2+9] ) <> (DigitRCB[n,xn] * DigitRCB[n,xn2]))
                   and (DigitRCB[n,yn2] * DigitRCB[n,xn2+9] <> [])
                   and (DigitRCB[n,yn2] * DigitRCB[n,yn+9] <> [])
                   and (DigitRCB[n,yn2] * DigitRCB[n,j+18] = [])
                    then
                      begin
                        active:=true;

                        Covered2[n]:=Covered2[n] - ( ( DigitRCB[n,yn2]* DigitRCB[n,yn+9] ) - (DigitRCB[n,j+18]* digitrcb[n,xn]) );

                      end;

             end;


       end;

end;{empty rectangle}


Sword Fish
Hidden Text: Show
Code: Select all
{sword fish}
procedure Swordfish(k:integer);
var
xn,xn2,xn3,xn4,yn,n,z:integer;
begin

For n:= 1 to 9 do

For xn:= 0 to 6 do
 for xn2:= (xn+1) to 7 do
  for xn3:= (xn2+1) to 8 do

       begin

         If   (R[xn,n] > 0) and (R[xn,n] < 4 )
           and (R[xn2,n] > 0) and (R[xn2,n] < 4 )
           and (R[xn3,n] > 0) and (R[xn3,n] < 4 )
            then
              for yn:= 45 to 128 do
                if Rn[xn,n] + Rn[xn2,n] + Rn[xn3,n]= comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if (z in comboset2[yn])
                        then
                         for xn4:= 0 to 8 do
                          if not (xn4 in [xn,xn2,xn3])
                           then
                             exclude( covered[Rset[xn4,z]],n);

                  end;

        If   (C[xn,n] > 0) and (C[xn,n] < 4 )
           and (C[xn2,n] > 0) and (C[xn2,n] < 4 )
           and (C[xn3,n] > 0) and (C[xn3,n] < 4 )
            then
              for yn:= 45 to 128 do
                if Cn[xn,n] + Cn[xn2,n] + Cn[xn3,n] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if (z in comboset2[yn])
                        then
                         for xn4:= 0 to 8 do
                          if not (xn4 in [xn,xn2,xn3])
                           then
                             exclude( covered[Cset[xn4,z]],n);

                    end;


        end;
end;{swordfish}


Finned Sashimi Sword fish
Hidden Text: Show
Code: Select all
{Finned Sashimi sword fish}
procedure smashiSwords(k:integer);
var
xn,xn2,xn3,xn4,yn,n,z:integer;
Finn:RCBnums;
finns:numberset;

begin

For n:= 1 to 9 do

For xn:= 0 to 6 do
 for xn2:= xn+1 to 7 do
  for xn3:= (xn2+1) to 8 do
        begin

         If   (R[xn,n] > 0) and (R[xn,n] < 6 )
           and (R[xn2,n] > 0) and (R[xn2,n] < 6 )
           and (R[xn3,n] > 0) and (R[xn3,n] < 6 )

            then
              for yn:= 45 to 128 do
                if (( Rn[xn,n] + Rn[xn2,n] + Rn[xn3,n]) * comboset2[yn] = comboset2[yn] )

                 then
                   begin

                    active:= true;

                    finn:= (Rn[xn2,n] + Rn[xn,n] + Rn[xn3,n]) - comboset2[yn];

                    Finns:=[];

                     for z:= 0 to 8 do
                       if z in finn
                         then
                         begin

                         if (Rn[xn3,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Rset[xn3,z]);

                         if (Rn[xn2,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Rset[xn2,z]);

                          if (Rn[xn,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Rset[xn,z]);

                         end;

                      for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn4:= 0 to 8 do
                           if not (xn4 in [xn,xn2,xn3])
                            and  ( finns * peer[Rset[xn4,z]] = finns )
                             then
                              exclude(covered[Rset[xn4,z]],n);


                  end;

        If   (C[xn,n] > 0) and (C[xn,n] < 6 )
           and (C[xn2,n] > 0) and (C[xn2,n] < 6 )
           and  (C[xn3,n] > 0) and (C[xn3,n] < 6 )

            then
              for yn:= 45 to 128 do
                if ((Cn[xn,n] + Cn[xn2,n] + Cn[xn3,n]) * comboset2[yn] = comboset2[yn])
                 and (Cn[xn,n] - comboset2[yn] = [])

                 then
                   begin
                    active:= true;

                    finn:= (Cn[xn2,n] + Cn[xn,n]+ Cn[xn3,n]) - comboset2[yn];

                    Finns:=[];

                     for z:= 0 to 8 do
                       if z in finn
                         then
                          begin

                         if (Cn[xn3,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Cset[xn3,z]);

                         if (Cn[xn2,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Cset[xn2,z]);

                          if (Cn[xn,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Cset[xn,z]);

                          end;

                    for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn4:= 0 to 8 do
                           if not (xn4 in [xn,xn2,xn3])
                            and  ( finns * peer[Cset[xn4,z]] = finns )
                             then
                              exclude(covered[Cset[xn4,z]],n);
                  end;
        end;
end;{SMASHIswords}


Jelly Fish
Hidden Text: Show
Code: Select all
{jelly fish}
procedure jellyfish(k:integer);
var
xn,xn2,xn3,xn4,xn5,yn,n,z:integer;
begin

For n:= 1 to 9 do

For xn:= 0 to 5 do
 for xn2:= (xn+1) to 6 do
  for xn3:= (xn2+1) to 7 do
   for xn4:= (xn3+1) to 8 do
       begin

         If   (R[xn,n] > 0) and (R[xn,n] < 5 )
           and (R[xn2,n] > 0) and (R[xn2,n] < 5 )
           and (R[xn3,n] > 0) and (R[xn3,n] < 5 )
           and (R[xn4,n] > 0) and (R[xn4,n] < 5 )
            then
              for yn:= 129 to 254 do
                if Rn[xn,n] + Rn[xn2,n] + Rn[xn3,n] + Rn[xn4,n]= comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if (z in comboset2[yn])
                        then
                         for xn5:= 0 to 8 do
                          if not (xn5 in [xn,xn2,xn3,xn4])
                           then
                             exclude( covered[Rset[xn5,z]],n);

                  end;

        If   (C[xn,n] > 0) and (C[xn,n] < 5 )
           and (C[xn2,n] > 0) and (C[xn2,n] < 5 )
           and (C[xn3,n] > 0) and (C[xn3,n] < 5 )
           and (C[xn4,n] > 0) and (C[xn4,n] < 5 )
            then
              for yn:= 129 to 254 do
                if Cn[xn,n] + Cn[xn2,n] + Cn[xn3,n] + Cn[xn4,n] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if (z in comboset2[yn])
                        then
                         for xn5:= 0 to 8 do
                          if not (xn5 in [xn,xn2,xn3,xn4])
                           then
                             exclude( covered[Cset[xn5,z]],n);

                    end;


        end;
end;{jelly fish}


Finned/ Sashimi Jelly Fish
Hidden Text: Show
Code: Select all
{Finned Sashimi jelly fish}
procedure smashijelly(k:integer);

var
xn,xn2,xn3,xn4,xn5,yn,n,z:integer;
Finn:RCBnums;
finns:numberset;

begin

For n:= 1 to 9 do

For xn:= 0 to 5 do
 for xn2:= (xn+1)  to 6 do

  for xn3:= xn2+1 to 7 do
   for xn4:= (xn3+1) to 8 do
       begin

         If   (R[xn,n] > 0) and (R[xn,n] < 7 )
           and (R[xn2,n] > 0) and (R[xn2,n] < 7 )
           and (R[xn3,n] > 0) and (R[xn3,n] < 7 )
            and (R[xn4,n] > 0) and (R[xn4,n] < 7 )

            then
              for yn:= 129 to 254 do
                if (( Rn[xn,n] + Rn[xn2,n] + Rn[xn3,n] + Rn[xn4,n]) * comboset2[yn] = comboset2[yn] )

                 then
                   begin

                    active:= true;

                    finn:= (Rn[xn2,n] + Rn[xn,n] + Rn[xn3,n] + Rn[xn4,n]) - comboset2[yn];

                    Finns:=[];

                     for z:= 0 to 8 do
                       if z in finn
                         then
                         begin

                            if (Rn[xn,n] - comboset2[yn] <> [])
                           then
                            include(finns,Rset[xn,z]);

                           if (Rn[xn2,n] - comboset2[yn] <> [])
                           then
                            include(finns,Rset[xn2,z]);

                          if (Rn[xn4,n] - comboset2[yn] <> [])
                           then
                            include(finns,Rset[xn4,z]);

                           if (Rn[xn3,n] - comboset2[yn] <> [])
                           then
                            include(finns,Rset[xn3,z]);
                          end;

                      for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn5:= 0 to 8 do
                           if not (xn5 in [xn,xn2,xn3,xn4])
                            and  ( finns * peer[Rset[xn5,z]] = finns )
                             then
                              exclude(covered[Rset[xn5,z]],n);


                  end;

        If   (C[xn,n] > 0) and (C[xn,n] < 7 )
           and (C[xn2,n] > 0) and (C[xn2,n] < 7 )
           and  (C[xn3,n] > 0) and (C[xn3,n] < 7 )
           and  (C[xn4,n] > 0) and (C[xn4,n] < 7 )

            then
              for yn:= 129 to 254 do
                if ((Cn[xn,n] + Cn[xn2,n] + Cn[xn3,n] + Cn[xn4,n]) * comboset2[yn] = comboset2[yn])
                { and (Cn[xn,n] - comboset2[yn] = [])
                 and (Cn[xn2,n] -  comboset2[yn] = [] ) }

                 then
                   begin
                    active:= true;

                    finn:= (Cn[xn2,n] + Cn[xn,n]+ Cn[xn3,n] + Cn[xn4,n]) - comboset2[yn];

                    Finns:=[];

                     for z:= 0 to 8 do
                       if z in finn
                         then
                          begin

                          if (Cn[xn2,n] - comboset2[yn] <> [])
                           then
                            include(finns,Cset[xn2,z]);

                          if (Cn[xn,n] - comboset2[yn] <> [])
                           then
                            include(finns,Cset[xn,z]);

                          if (Cn[xn4,n] - comboset2[yn] <> [])
                           then
                            include(finns,Cset[xn4,z]);

                          if (Cn[xn3,n] - comboset2[yn] <> [])
                           then
                            include(finns,Cset[xn3,z]);

                          end;

                    for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn5:= 0 to 8 do
                           if not (xn5 in [xn,xn2,xn3,xn4])
                            and  ( finns * peer[Cset[xn5,z]] = finns )
                             then
                              exclude(covered[Cset[xn5,z]],n);

                  end;


        end;


end;{SMASHIjellies}


N x (N + K) Fish finder
Hidden Text: Show
Code: Select all
{fish finder}
procedure fishfinder;
type
 hold = array of integer;
 hold2 = array of integer;

 base2 = array of numberset;
 base3 = array of numberset;
 base4 = array of numberset;
 base5 = array of numberset;
 base6 = array of numberset;
 base7 = array of numberset;
 base8 = array of numberset;
 base9 = array of numberset;
 base10 = array of numberset;

 Rcover2 = array of numberset;
 Bcover2 = array of numberset;
 Ccover2 = array of numberset;

 Cover2 = array of numberset;

 used2 = array of rcbpeer;
 used3 = array of rcbpeer;
 used4 = array of rcbpeer;
 peered = array of rcbpeer;

var
 a1,b1,a2,b2,a3,b3,z,n,w,w2,w3,p,p2,p3,q,q2,q3,x,s,s2,s3,f,f2,f3,k,k2,l,m,m2:integer;
 output:text;


h:hold;
h2:hold2;
h3:hold2;

use:used2;
use2:used3;
use3:used4;

Base: base2;
basei: base3;
pbasei: base4;
Mbase: base7;

Rbase:base8;
Cbase:base9;
bbASE:base10;

mi: base5;
pmi: base6;

Cover:cover2;
Rcover:rcover2;
Ccover:Ccover2;
Bcover:bcover2;

peers:peered;

sector:rcbpeer;
sector2: array [0..26] of rcbpeer;

begin

 setlength(use,0);
 setlength(h,0);
 setlength(base,0);
 setlength(Cbase,0);
 setlength(Rbase,0);
 setlength(Bbase,0);

 setlength(basei,0);
 setlength(pbasei,0);
 setlength(peers,0);
 setlength(use2,0);
 setlength(h2,0);
 setlength(cover,0);
 setlength(Rcover,(0));
 setlength(Ccover,(0));
 setlength(Bcover,(0));
 setlength(h3,0);
 setlength(use3,0);
 setlength(mbase,0);

 setlength(mi,0);
 setlength(pmi,0);

z:=12;

setlength(h,(z));      { stores the active sectors }
setlength(use,z);
setlength(base,z);
setlength(Cbase,z);
setlength(Rbase,z);
setlength(Bbase,z);
setlength(basei,z);
setlength(pbasei,z);
setlength(peers,z);
setlength(mi,z+3);
setlength(pmi,z+3);

setlength(h2,z+3);
setlength(h3,z+3);
setlength(use2,z+3);
setlength(cover,z+3);    {cover area's}
setlength(Rcover,z+3);   {specific cover area's }
setlength(Ccover,z+3);
setlength(Bcover,z+3);

 setlength(use3,z+3);
 setlength(mbase,z+3);


for n:= 7 to 7 do    {digits 1 - 9}
 for z:= 6 to  6 do


    {sector size}
  begin

     sector:=[];

      for s:= 0 to 26 do
       sector2[s]:=[];

       F2:=0;
       A1:=0;
       b1:=0;

        for s:= 26 downto 0 do
         begin

          if (digitRCB[n,s] <> [])   {makes sure the sector actually has active cells}
          and (sec[s,n] < z+5)
          then
            begin

              for s2:= 26 downto 0 do
               if  (s2 in peerRCB[s])
               and (digitRCB[n,s2] <> [])
               and ((digitRCB[n,s2] * digitRCB[n,s]) <> [] )
                 then
                   begin
                     include(sector,s);
                     include(sector2[s],s2);
                   end;
            end;

          if (s in sector) and (sector2[s] <> [])
           then
            begin
             inc(f2);

             if s > a1 then
              A1:=s;

              B1:=s;


            end;
    end;


  if (f2 >= z )
   then
    for s:= a1 downto b1+(z-1) do
     if ( s in  (sector *[1,11,14,15,23,26]) )
        and (f2 >=z-1)
        then
          begin { first base untit}

           w:=0;    {sector count}

           dec(f2);

           q:=f2;

           h[w]:= s;  {sets the inial base sector}

               repeat

                   for p:= h[w] downto b1 do     {iterate from starting base down to 0}

                     if
                        (DigitRCB[n,p] - base[w] <> []) {makes sure the base sector actually has active cells}
                        and (q >= (z-1-w))
                        and  ( p in ( (sector*[1,11,14,15,23,26])  - use[w]))

                         then

                          begin {Activate nth unit used}

                             inc(w);   {increases sector count}

                             dec(q);

                             h[w]:= p-1;     {sets the next sector value}

                             use[w]:= use[w-1] + [p];                    {set the used values}
                             base[w]:= base[w-1] + digitRCB[n,p];            {sets the base value}
                             peers[w]:=peers[w-1] + sector2[p];

                             basei[w]:= basei[w-1] + (base[w-1] * digitrcb[n,p]);

                              if (base[w-1] * digitRCB[n,p])  <> []
                                then
                                  begin
                                   for x:= 0 to 80 do
                                    if peer[x] * basei[w] = basei[w]
                                     then
                                       include(pbasei[w],x);
                                  end
                                 else
                                   pbasei[w]:= pbasei[w-1];

                               if p in [0..8]
                              then
                               Rbase[w]:= Rbase[w-1] +digitRCB[n,p]
                              else
                                Rbase[w]:= Rbase[w-1];

                             if p in [9..17]
                              then
                               Cbase[w]:= Cbase[w-1] + digitRCB[n,p]
                              else
                                Cbase[w]:= Cbase[w-1];

                             if p in [18..26]
                              then
                               Bbase[w]:= Bbase[w-1] + digitRCB[n,p]
                              else
                               Bbase[w]:= Bbase[w-1];



                             break;  {exit from loop to iterate forward from the new H[w] value}

                          end {end finding nth unit}
                          else
                           begin
                           if w > 0
                             then
                                dec(h[w]);  { if we are in new starting sector and above logic is false advance the step couny}

                            if( w > 0) and (Q < (z-1-w))
                              then
                                h[w]:=-1;
                            end;



if( w = z)  {smallest recursion function starting}

and ( ( basei[w] = [] )
  or  ( ( basei[w] <> [] ) and  ( ( pbasei[w] - base[w] ) <> [] ) ) )

then
 begin
 k:=0;

 repeat

  l:=0;


   if (w = z)
     then
        begin
       F:=0;
       A2:=0;
       B2:=0;

          for x:=  26 downto 0 do
            if (x in (( peers[w]) - use[w])  )
               and (digitrcb[n,x] * base[w] <> [])

               then
                begin

                inc(f);

                 if X > a2
                   then
                    a2:=x;

                    b2:=x;

                end;
      end;


   if (w = z) and (F >= (z+k)) {find cover set}
       then


        for s2:= a2 downto (b2+(z+k-1)) do
          if (digitRCB[n,s2] * base[w] <> [] )
          and (S2 in( ( peers[w]*[0,5,6,8,10,12,16,25]) - use[w]))

           and(f>=(z+k)-1)
        then

          begin { first base unit }


           w2:=0;
           dec(f);

           h2[w2]:= s2;
           q2:=f;

               repeat

                   for p2:= h2[w2] downto b2 do

                     if (digitRCB[n,p2] * base[w] <> [])
                       and (p2 in ( ( peers[w]*[0,5,6,8,10,12,16,25])  - use[w] - use2[w2]  )  )
                        and (q2 >= ((z+k)-1-w2))
                         then

                          begin {Activate nth unit used}

                             inc(w2);
                             dec(q2);


                             h2[w2]:= p2-1;

                             use2[w2]:= use2[w2-1] + [p2];
                             cover[w2]:= cover[w2-1] + digitRCB[n,p2];

                             if p2 in [0..8]
                              then
                               Rcover[w2]:= Rcover[w2-1] +digitRCB[n,p2]
                              else
                                Rcover[w2]:= Rcover[w2-1];

                             if p2 in [9..17]
                              then
                               Ccover[w2]:= Ccover[w2-1] + digitRCB[n,p2]
                              else
                                Ccover[w2]:= Ccover[w2-1];

                             if p2 in [18..26]
                              then
                               Bcover[w2]:= Bcover[w2-1] + digitRCB[n,p2]
                              else
                               Bcover[w2]:= Bcover[w2-1];

                             break;

                          end {end finding nth unit}
                         else
                          begin

                           if w2 > 0
                             then
                                dec(h2[w2]);

                             if( w2 > 0) and (Q2 < ((z+k)-1-w2))
                              then
                                h2[w2]:=-1;

                           end;



                  if (w2 = z+k) and  (basei[w] = []) and (k <3)
                    and ( ( cover[w2] * base[w] ) = base[w] )    {checks that base cells out side the cover*base has no candidates}
                    and (  ( ( cover[w2] - base[w] <> [] ) and (w2 = z))

                     or     (   ( w2 <= z+1 )
                       and  ( (  ( ( Rcover[w2] * Ccover[w2] )  + ( Rcover[w2] * Bcover[w2] ) + ( Ccover[w2] * Bcover[w2] ) )  - base[w] ) <> [] ) )

                     or     (   ( w2 > z+1 )
                       and  ( ( ( Rcover[w2] * Ccover[w2] * Bcover[w2] ) - base[w] ) <> [] ) )

                       )
                   then
                     begin

                    active:=true;
                     
                    if (w2 = z)
                        then
                         covered2[n]:= covered2[n] - (cover[w2] - base[w]);

                    if  ((w2 = z+1) or ( w2 = z))  { 1 or 0 fin sectors - elimiantions in overlaps of cover sectors not in base }
                      then
                       covered2[n]:= covered2[n] -  (( (Rcover[w2] * Ccover[w2]) + (Rcover[w2] * Bcover[w2]) + ( Ccover[w2] * Bcover[w2]) ) - base[w]) ;

                    if (w2 = z+2)  { 2 fin sector - elimiantions in overlaps of cover sectors not in base }
                      then
                         covered2[n]:=COvered2[n] - ((Rcover[w2] * Bcover[w2] * Ccover[w2])- base[w]);
                     
                   end;


                  if (w2 =z+k) and (basei[w] <> [])  and (k <3)
                     and (  (cover[w2] * base[w])  = base[w])

                     and (  (  (pbasei[w] * ( cover[w2] - base[w]) <> [] ) and (w2 = z))

                     or     (   ( w2 <= z+1 )
                       and  ( ( pbasei[w] * ( (Rcover[w2] * Ccover[w2]) + (Rcover[w2] * Bcover[w2]) + ( Ccover[w2] * Bcover[w2] ) ) - base[w] ) <> [] ) )

                     or     (   (w2 > z+1)
                     and ( ( ( pbasei[w] * (Rcover[w2] * Ccover[w2] * Bcover[w2]) ) - base[w] ) <> []) )
                    )

                      then
                         begin
                          active:= true;
                         

                      if (w2=z)
                       then
                         covered2[n]:=covered2[n] -(  (pbasei[w] * cover[w2]) - base[w]);

                      if  ((w2 = z+1) or ( w2 = z))  { 1 or 0 fin sectors - elimiantions in overlaps of cover sectors not in base }
                         then
                           covered2[n]:=covered2[n] -( (pbasei[w] * ((Rcover[w2] * Ccover[w2]) + (Rcover[w2] * Bcover[w2]) + ( Ccover[w2] * Bcover[w2]))) - base[w]);

                      if (w2 = z+2)     { 2 fin sector - elimiantions in overlaps of cover sectors not in base }
                         then
                           covered2[n]:=covered2[n] -((pbasei[w] * (Rcover[w2]*Bcover[w2]*Ccover[w2])) - base[w]);                     

                       end;
                     

                 if   ( (h2[w2] < b2 ) and (w2 > 0 ) )                   {if any of the follow conditioins are true, then backtrack to previous W2}
                   or    ( ( cover[w2] * base[w] )  = base[w])

                   or ( (w2 = z+1) and (basei[w] = []) and  ( ( ( Rcover[w2] * Bcover[w2] ) + ( Ccover[w2] * Bcover[w2]) + ( Ccover[w2] * Rcover[w2] ) - base[w] )=[] )  )
                   or ( (w2 = z+2) and (basei[w] = []) and  ( ( ( Rcover[w2] * Bcover[w2] * Ccover[w2] ) - base[w]) = [] )  )

                  or ( (w2 = z+1) and (basei[w] <> []) and  ( (pbasei[w]* ( ( Rcover[w2] * Bcover[w2] ) + ( Ccover[w2] * Bcover[w2]) + ( Ccover[w2] * Rcover[w2] )) - base[w] )=[] )  )
                  or ( (w2 = z+2) and (basei[w] <> []) and  ( ( ( pbasei[w] * ( Rcover[w2] * Bcover[w2] * Ccover[w2] )) - base[w]) = [] )  )

                   or (w2 = z+k)
                   or (( q2 < ((z+k)-1-w2)) and (w2 > 0))
                    then

                      repeat
                        begin
                         dec(w2);
                         inc(q2);

                         use2[w2+1]:=[];
                         Cover[w2+1]:=[];
                         rcover[w2+1]:=[];
                         Ccover[w2+1]:=[];
                         bcover[w2+1]:=[];

                         if w2 > 0
                           then
                             dec(h2[w2]);

                         end;

                      until ( Q2 >= ((z+k) - 1 - w2)) or (w2 = 0)


               until  (w2 = 0)
         end;{starting cover untis}

 if (L = 0)
  then
   inc(k);

 until  ( (k>4)  ) or (l=1) or ((k=1) and (z=1)) ; {smallest recursion function end}
 end;

              if ( ( h[w] < b1 ) and (w > 0 ))    {if any of the follow conditioins are true, then backtrack to previous W}
                   or (w = z)
                   or ( ( q < ( z-1-w) ) and (w > 0)  )
                   or (( basei[w] <> []) and (pbasei[w] = []))
                     then
                      repeat
                      begin

                         dec(w);
                         inc(q);

                         base[w+1]:=[];

                         Rbase[w+1]:=[];
                         Cbase[w+1]:=[];
                         Bbase[w+1]:=[];

                         basei[w+1]:=[];
                         pbasei[w+1]:=[];
                         use[w+1]:=[];
                         peers[w+1]:=[];


                         if w > 0
                           then
                             dec(h[w]);
                      end;
                     until ( q >=  (z - 1 - w)) or (w = 0)

               until  (w = 0)

      end;{starting base untis}


 end;
end; {fish finder}


W-Wing
Hidden Text: Show
Code: Select all
procedure Wwing(K:integer);
var
xn,xn2,n,n2,yn:integer;
begin

 for xn:= 0 to 79 do
  if( nm[xn] = 2 )
   then
     for xn2:= xn+1 to 80 do
      if( nm[xn2] = 2 ) and (pm[xn] = pm[xn2])
       then
         begin

          for n:= 1 to 9 do
           if N in (pm[xn])
            then

              for yn:= 0 to 26 do

                if (Digitrcb[n,yn] <> [] )
                and ((digitrcb[n,yn] * peer[xn]) + (digitrcb[n,yn] * peer[xn2] )  = digitrcb[n,yn] )

                 then
                  begin
                    active:= true;

                     for n2:= 1 to 9 do
                      if( n2 <> n) and (N2 in (pm[xn]) )
                        then
                         covered2[n2]:=covered2[n2]  - (peer[xn] * peer[xn2] );

                  end;
         end;


end;  {end W-wing}


M-Wing
Hidden Text: Show
Code: Select all
procedure Mwing(k:integer);
var
xn,xn2,n,n2,yn,yn2,z:integer;
begin

for xn:= 0 to 80 do
  if (nm[xn] = 2)
    then
     for xn2:= 0  to 80 do
      if (pm[xn] * pm[xn2] = pm[xn]) and (xn2 <> xn)
       then

         for n:= 1 to 9 do
          if n in (pm[xn]*pm[xn2])
           then

            for yn:= 0 to 26 do
             begin
                   {row,box,col}
                   if (digitrcb[n,yn] <> [] )
                   and(digitrcb[n,yn] * ( peer[xn] + [xn2] )  = digitrcb[n,yn] )
                    then
                      begin

                       for  n2:= 1 to 9 do
                          if (n2 in (pm[xn]*pm[xn2])) and (n2 <> n)
                            then
                              begin

                              {row}
                               for yn2:= 0 to 26 do
                                begin
                                 if  (digitrcb[n2,yn2] <> [] )
                                 and ((digitrcb[n2,yn2] * peer[xn2]) + [xn2] = digitrcb[n2,yn2] )

                                  then
                                    begin
                                     active:=true;
                                    for z:= 0 to 80 do
                                     if peer[z] *  ([xn] +( digitrcb[n2,yn2] - [xn2]) )= ([xn] +( digitrcb[n2,yn2] - [xn2]) )
                                      then
                                       covered2[n2]:=covered2[n2] - [z];

                                     end;
                                end;{end row,box,col}

                              end; {end #'s for rows,cols,boxs}
                       end; {end  row,col,box}

            end;

end;{Mwing}


S-Wing
Hidden Text: Show
Code: Select all
Procedure Swing(K:integer);
var
xn,n,n2,j,j2,yn,yn2,z,z2,q,count,count2:integer;
begin

for xn:= 0 to 80 do
 if nm[xn] = 2
  then
   for n:= 1 to 8 do
    if n in pm[xn]
     then
      for n2:= n+1 to 9 do
       if n2 in pm[xn]
        then

         for J:= 0 to 26 do
          if (digitrcb[n,j] <> [])
           and (xn in digitrcb[n,j])
            then

              for yn:= 0 to 26 do
               if (yn in  peerrcb[j] )
                and (digitrcb[n,yn] <> [])
                and not (xn in digitrcb[n,yn])
                and (digitrcb[n,yn] * digitrcb[n,j] <> [])
                and ( (Digitrcb[n,yn] * digitrcb[n,j])  = ( peer[xn] * digitrcb[n,yn] ) )
                 then

                  for z:= 0 to 26 do
                   if (z in peerrcb[yn])
                    and (digitrcb[n,z] <> [] )
                    and not (xn in digitrcb[n,z])
                    and (digitrcb[n,z] * digitrcb[n,yn] <> [])
                    and ((digitrcb[n,z] * digitrcb[n,yn]) + (digitrcb[n,yn] * digitrcb[n,j] ) = digitrcb[n,yn])
                    then

         for J2:= 0 to 26 do
          if (digitrcb[n2,j2] <> [])
           and (xn in digitrcb[n2,j2])
            then

              for yn2:= 0 to 26 do
               if (yn2 in  (peerrcb[j2]-[yn]) )
                and (digitrcb[n2,yn2] <> [])
                and not (xn in digitrcb[n2,yn2])
                and (digitrcb[n2,yn2] * digitrcb[n2,j2] <> [])
                and ( (Digitrcb[n2,yn2] * digitrcb[n2,j2])  = ( peer[xn] * digitrcb[n2,yn2] ) )
                 then

                  for z2:= 0 to 26 do
                   if (z2 in (peerrcb[z] * peerrcb[yn2]) )
                    and (digitrcb[n2,z2] <> [] )
                    and not (xn in digitrcb[n2,z2])
                    and (digitrcb[n2,z2] * digitrcb[n2,yn2] <> [])
                    and ((digitrcb[n2,z2] * digitrcb[n2,yn2]) + (digitrcb[n2,yn2] * digitrcb[n2,j2] ) = digitrcb[n2,yn2])
                    then

                    if  ( (digitrcb[n2,yn] * digitrcb[n2,z2] ) = (digitrcb[n2,yn] * digitrcb[n2,z2]) )
                     and ( (digitrcb[n,yn2] * digitrcb[n,z] ) = (digitrcb[n,yn2] * digitrcb[n,z]) )
                     and (( digitrcb[n,yn] * digitrcb[n,z] ) * (digitrcb[n2,yn2] * digitrcb[n2,z2] ) = [])

                     then

         begin
          Count:=0;
          count2:=0;

          For q:= 0 to 80 do
           begin
           if q in (digitrcb[n,yn] * digitrcb[n,z])
             then
              inc(count);

              if q in (digitrcb[n2,yn2] * digitrcb[n2,z2])
               then
                inc(count2);

           end;

          if ((count in [1])  and ((digitrcb[n2,yn] * Digitrcb[n2,z]) * (digitrcb[n,yn] * Digitrcb[n,z]) <> []) )
          or ((count2 in [1])  and ((digitrcb[n,yn2] * Digitrcb[n,z2]) * (digitrcb[n2,yn2] * Digitrcb[n2,z2]) <> []))

          then
           begin

             active:=true;

            for q:= 0 to 80 do
             begin

             if  (count in [1])
              and ((digitrcb[n2,yn] * Digitrcb[n2,z]) * (digitrcb[n,yn] * Digitrcb[n,z]) <> [] )
              and (( digitrcb[n,yn] * digitrcb[n,z])  = [q])
              and (peer[q] * (digitrcb[n2,yn2] * digitrcb[n2,z2])  =  (digitrcb[n2,yn2] * digitrcb[n2,z2]))
               then
                covered2[n2]:= covered2[n2] -(digitrcb[n,yn] * Digitrcb[n,z]);

             if (count2 in [1])
              and ((digitrcb[n,yn2] * Digitrcb[n,z2]) * (digitrcb[n2,yn2] * Digitrcb[n2,z2]) <> [])
               and (( digitrcb[n2,yn2] * digitrcb[n2,z2])  = [q])
              and (peer[q] * (digitrcb[n,yn] * digitrcb[n,z])  =  (digitrcb[n,yn] * digitrcb[n,z]))
               then
                covered2[n]:= covered2[n] -(digitrcb[n2,yn2] * Digitrcb[n2,z2]);

             end;

          end;
         end;

end;{swing}


L-Wing
Hidden Text: Show
Code: Select all
Procedure Lwing(k:integer);
var
n,n2,xn,xn2,j,j2,j3,j4,j5,xj:integer;
output:text;
begin

for n:= 1 to 9 do
 for j:= 0 to 26 do
   if (digitrcb[n,j] <> [])
    and (sec[j,n] <5)
     then
       for xn:= 0 to 80 do
         if (xn in digitrcb[n,j] )
         then
           for j2:= 0 to 26 do
            if (j2 in peerrcb[j])
             and (digitrcb[n,j2] <> [] )
             and ( (digitrcb[n,j2]* digitrcb[n,j]) + [xn] = digitrcb[n,j])
              then

              for n2:= 1 to 9 do
               if (n2 <> n )
                then

               for j3:=  0 to 26 do

               if (j3 in peerrcb[j2] - [j] )
                and ( digitrcb[n,j3] <> [] )
                and ( Digitrcb[n2,j3] <> [] )
                and ( ( Digitrcb[n,j3] * digitrcb[n,j2] ) <> [] )
                and ( ( Digitrcb[n,j3] * digitrcb[n,j2] ) <> ( digitrcb[n,j] * digitrcb[n,j2] ) )
                and ( digitrcb[n,j3] * digitrcb[n,j2]  * digitrcb[n,j] = [])
                 then

                  for j4:= 0 to 26 do
                   if (j4 in ((peerrcb[j3]+[j3] ) - [j]) )
                   and (Digitrcb[n,j4] <> [] )
                   and (digitrcb[n2,j4] <> [])
                   and ((digitrcb[n,j4] * digitrcb[n,j3]) <> (Digitrcb[n,j3] * digitrcb[n,j2] ) )
                    then

                    for xn2:= 0 to 80 do
                     if  (xn2 in (digitrcb[n,j3] * digitrcb[n2,j3]))
                     and ((digitrcb[n,j3] * digitrcb[n,j2]) + [xn2] = digitrcb[n,j3])

                    then
                     for j5:= 0 to 26 do
                      if (j5 in ((peerrcb[j4]* peerrcb[j]))  )
                        and ( digitrcb[n2,j5] <> [])
                        and ( ( digitrcb[n2,j5] * digitrcb[n2,j4] )  <> [] )
                        and ( ( ( digitrcb[n2,j4] * digitrcb[n2,j5] ) + [xn2] )= digitrcb[n2,j4] )
                        and (xn in digitrcb[n,j5])
                        and not (xn in (digitrcb[n2,j4] * digitrcb[n2,j5]) )
                        then

                        {elimination check}
                        if (( (peer[xn] * (digitrcb[n2,j5] * digitrcb[n2,j4] )) =  (digitrcb[n2,j5] * digitrcb[n2,j4] ))
                        and (n2 in pm[xn]))
                        or  ((((digitrcb[n,j5] * digitrcb[n,j4]) - [xn2] ) * ((digitrcb[n2,j5] * digitrcb[n2,j4]) - [xn2] ) <> [])
                        and (sec[j4,n2] = 2)  )


                          then
                          begin
                           active:=true;                   

                           if ((peer[xn] * (digitrcb[n2,j5]*digitrcb[n2,j4] )) =  (digitrcb[n2,j5]*digitrcb[n2,j4] ))
                            and (n2 in pm[xn])
                            then
                            begin
                           

                             covered2[n2]:= covered2[n2] - [xn];
                            end;

                          if  (sec[j4,n2] = 2)

                            and (((digitrcb[n,j5] * digitrcb[n,j4]) - [xn2] ) * ((digitrcb[n2,j5] * digitrcb[n2,j4]) - [xn2] ) <> [])

                             then
                               begin
                                 covered2[n]:= covered2[n] - ((digitrcb[n2,j5] * digitrcb[n2,j4]) - [xn2] );
                           
                               end;

                         

                         end;
end; {L2 wings}


XY - Wing
Hidden Text: Show
Code: Select all
 barns(1,3,1)


XYZ - Wing
Hidden Text: Show
Code: Select all
 barns(1,3,2)


WXYZ - wing
Hidden Text: Show
Code: Select all
 barns(1,4,0)


Barn(s)
Hidden Text: Show
Code: Select all
procedure Barns(K,M,Q:integer);
type

hold = array of integer;
base = array of numberset;
base2 = array of integer;
hold2 = array of RCBpeer;

var
p,S,F,C,w,j,a,b,z,lx,x,g,l,r,count:integer;

xs:nums;
z1:nums;

p2:numberset;
lx1:numberset;

h: hold;
step: base;
loc: base2;
List: hold2;

begin

 If M = 0
  then
   L:= 2
  else
  L:=M;

repeat

for p:= 0 to 80 do
  if  ( (q = 1) and (nm[p] = 2 ) )
  or ( (q = 2) and (nm[p] = 3 ) )
  or ( (q = 0) and (nm[p] <=l ) )
   then
  begin
  case L of
       1: begin s:=0; F:=8; end;
       2: begin s:=9;  F:=44; end;
       3: begin s:=45;  F:=128; end;
       4: begin s:=129; F:=254;  end;
       5: begin s:=255; F:=380; end;
       6: begin s:=381; F:=464; end;
       7: begin s:=465; F:=500; end;
       8: begin s:=501; F:=509; end;
       9: begin s:=510; F:=511; end;
      end; {Case L}

  for C:= s to f do

   if  ( pm[p] * Comboset[c] =  pm[p] )
   and ( Pm[P] - Comboset[C] = [] )
   and ( pm[p] <> [])

     then

      begin

        w:=0; { step count}

        setlength(h,w+1);

        H[w]:=19;   {starting cell position}

        setlength(step,(w+1));   {set the array size to w}
        setlength(list,(W+1));    {sets the array size to w}

      // setlength(loc,(w+1));  {starting cell}
     // loc[w]:=p;

       list[w]:=  [Rx[p]] + [(Cy[p]+9)]+ [(Bxy[P]+18)] ; {records active sectors}
       step[w]:=[p];  { keeps track of what cells are used at each step W }


           repeat

            for J:= h[w] downto 0 do
             begin
               if  ( pm[peer2[p,j]] * Comboset[c] =  pm[peer2[p,j]] )
               and ( Pm[Peer2[p,j]] - Comboset[C] = [] )
               and ( pm[peer2[p,j]] <> [])
               and ( [peer2[p,j]] * step[w] = [])
               and ( nm[peer2[p,j]] <= l)
                  then
                   begin

                   inc(w);  {increase step count}

                   setlength(h,w+1);   {increase lenght of step starting point array}

                  // setlength(loc,(w+1));  {starting cell}
                  // loc[w]:=peer2[loc[w-1],j];

                  setlength(list,(W+1));
                   list[w]:=list[w-1] + [Rx[peer2[p,j]]] + [Cy[peer2[p,j]]+9] + [BXY[peer2[p,j]]+18];
                   H[w]:=j-1;

                   setlength(step,(w+1));   {set the array size to w}
                   step[w]:=step[w-1] + [ peer2[p,j] ] ;  { keeps track of what cells are used at each step W }

                   end

                  else
                   dec(H[w]);

               if W = (l-1)
                then
                 begin

                     for a:= 0 to 25 do
                      if (RCBnum[a]*step[w] <> [] )
                        and (A in list[w] )
                        then
                         begin
                         for B:=  a+1 to 26 do
                         if (B in List[w] )
                           then
                           if  ( RCBnum[B] * step[w] <> [])
                           and (( (RCBnum[b]  + RCBnum[a] ) * step[w]) = step[w])
                           and ( (RCBnum[a] - RCBnum[b]) * step[w] <> [] )
                           and ( (RCBnum[b] - RCBnum[a]) * step[w] <> [] )
                            then
                             begin

                               lx1:=[];
                               z1:=[];

                              for Z in comboset[c]  do
                              if  ( ( (digitrcb[z,a] * step[w] ) <> [])
                                 or ( (digitrcb[z,b] * step[w] ) <> [])      )
                                   then
                                     for  lx in ( LIST[W] ) do
                                      if
                                         ( ( (digitRCB[z,a] * digitRCB[z,lx] * step[w]) <> [])
                                         or
                                           ( (digitRCB[z,b] * digitRCB[z,lx] * step[w]) <> []) )

                                      and ( (( DigitRCB[z,b] + DigitRCB[z,a]) * digitrcb[z,lx] * step[w])   =  ( (digitrcb[z,a] + digitrcb[z,b]) * step[w] ) )
                                        then
                                          begin
                                           lx1:=lx1+[lx];
                                           z1:=z1+[z];
                                          end;

                                       if (L - (popcnt(dword(z1)) )  = 1  )
                                        then
                                        begin

                                          xs:=[];
                                          p2:=[];

                                         for x in (comboset[c]  - z1)  do
                                         if  ( (digitrcb[x,a] * step[w] ) <> [])
                                           and  ( (digitrcb[x,b] * step[w] ) <> [])
                                            then
                                             begin
                                             xs:=xs+[x];
                                             p2:= p2 + (( DigitRCB[x,a] + digitrcb[x,b] )*step[w]) ;
                                             end;

                                         if (p2  <> [] ) and (xs <> [])  and (z1 <> [])      {rule 1, peer cells visbile to all + candidates may be elimianted}
                                          then
                                          begin   

                                        for g in ([0..80] - step[w] ) do
                                         if ( peer[g] * p2 = p2)
                                          and (pm[g] * xs <> [])
                                          then
                                           begin
                                             active:=true;
                                            covered[g]:=covered[g] - xs;                                         
                                           end;
                                           end;

                                           {rule 2
                                            when  any cell that contains a RCC and contains only  the + candidate and it directly sees all + candidtes; then
                                             all cells visible to all the RCC of that number may be excluded for that number. }


                                           if (p2 <> []) and (xs <> [])
                                           then
                                             for G in (p2) do
                                               for x in z1 do
                                                  if (pm[g] = xs + [x])
                                                   and( (peer[g] * p2 ) + [g] = p2  )
                                                   then
                                                    begin
                                                     for  r in ([0..80] - step[w] ) do
                                                      if (peer[r] * ((digitRcb[x,a] + digitrcb[x,b]) * (step[w] ) ) =  ((digitRcb[x,a] + digitrcb[x,b]) * (step[w] ) ))
                                                     and (x in pm[r]   )
                                                      then
                                                      begin
                                                    active:= true;

                                                    covered[r]:= covered[r] - [x];

                                                      end;

                                                    end;

                                       end;  {end count =1}


                       if (popcnt(dword(z1))  = L )  and (Z1  = comboset[c])
                             then
                                begin
                                    active:=true;
                               
                                        for G in (z1*comboset[c]) do
                                           begin                                           
                                            p2:=(digitrcb[g,a]+digitrcb[g,b])*step[w];

                                            for x in  ([0..80] - step[w]) do
                                               if (peer[x] * p2  = p2  )
                                              and  (g in pm[x] )
                                              then
                                               begin
                                                covered[x]:= covered[x] - [g];
                                           
                                               end;

                                              end;
                                  end; {count = 0 }

                                 end; {b}
                              end;  {a}
                 end;

               if (W = (L-1)) or (( W>0) and (H[w]= -1))   {back track sequence}
                 then
                 begin

                   repeat
                   Dec(w);  {decrese step count}
                   setlength(h,w+1);   {reduce lenght of step starting point array}
                   //setlength(loc,(w+1));  {starting cell}
                   setlength(list,(w+1));
                   dec(h[w]);
                   setlength(step,(w+1));   {set the array size to w}

                   until   (H[w]> -1) or (w=0)
                 end;

              end;

             until  (h[W] = -1)
       end;

    end;

 if m = 0
  then
  inc(L);

 until (L = m) or (L > 9);

  end; {bent almost naked sets}


Unique Rectangles type 1-6
Hidden Text: Show
Code: Select all
 Code not implemented in current build

Hidden Unique Rectangles
Hidden Text: Show
Code: Select all
 Code not implemented in current build


ALS - xz & double linked rule
Hidden Text: Show
Code: Select all
procedure alsxz(k:integer);
var
q,xn,xn2,L,l2,J,j2,s,s2,s3,s4,f,f2,f3,f4,yn,yn2,yn3,yn4,n,z,x,ACT,ACT2,g,r:integer;

A:nums;
a2:numberset;
B:nums;
B2:numberset;
z1:nums;
lx1: rcbpeer;

begin

 for xn:= 0 to 26 do
    for L:= 1 to 8 do
      begin

       J:= l+1;

      case L of
       1: begin s:=0; F:=8; end;
       2: begin s:=9; F:=44; end;
       3: begin s:=45; F:=128; end;
       4: begin s:=129; F:=254; end;
       5: begin s:=255; F:=380; end;
       6: begin s:=381; F:=464; end;
       7: begin s:=465; F:=500; end;
       8: begin s:=501; F:=509; end;
       9: begin s:=510; F:=511; end;
      end; {Case L}

      for yn:= S to f do
       begin
         A:=[];
         a2:=[];
         ACT:=0;
         lx1:=[];

         for n:= 0 to 8 do
          if (n in comboset2[yn] )
             and (Sectorrc[xn,n] <> [])
              then
               begin
               A:= a+ sectorRC[xn,n]; {#'s}
               INC(ACT);

               a2:=a2+ sectorrcb[xn,n]; {cell's}

               lx1:= lx1 + peerrcb[Rx[secset[xn,n]]] + peerrcb[Cy[secset[xn,n]]] + peerrcb[Bxy[secset[xn,n]]];
               end;


      case J of
       1: begin s2:=0; F2:=8; end;
       2: begin s2:=9; F2:=44; end;
       3: begin s2:=45; F2:=128; end;
       4: begin s2:=129; F2:=254; end;
       5: begin s2:=255; F2:=380; end;
       6: begin s2:=381; F2:=464; end;
       7: begin s2:=465; F2:=500; end;
       8: begin s2:=501; F2:=509; end;
       9: begin s2:=510; F2:=511; end;
      end; {Case J}

if  (ACT = L)
 then
   for yn2:= S2 to F2 do
       if A = comboset[yn2]
         then
           begin

             for xn2 in ( lx1)   do

                for L2:= 1 to 8 do
      begin

       J2:= l2+1;

      case L2 of
       1: begin s3:=0; F3:=8; end;
       2: begin s3:=9; F3:=44; end;
       3: begin s3:=45; F3:=128; end;
       4: begin s3:=129; F3:=254; end;
       5: begin s3:=255; F3:=380; end;
       6: begin s3:=381; F3:=464; end;
       7: begin s3:=465; F3:=500; end;
       8: begin s3:=501; F3:=509; end;
       9: begin s3:=510; F3:=511; end;
      end; {Case L}

      for yn3:= S3 to f3 do
      begin
         B:=[];
         B2:=[];
         act2:=0;


         for n:= 0 to 8 do
            if (n in comboset2[yn3])
              AND (sectorRC[xn2,n] <> [])
              then
               begin
               b:= b+ sectorRC[xn2,n];

               inc(act2);

               b2:=b2+ sectorrcb[xn2,n];
             end;

      case J2 of
       1: begin s4:=0; F4:=8; end;
       2: begin s4:=9; F4:=44; end;
       3: begin s4:=45; F4:=128; end;
       4: begin s4:=129; F4:=254; end;
       5: begin s4:=255; F4:=380; end;
       6: begin s4:=381; F4:=464; end;
       7: begin s4:=465; F4:=500; end;
       8: begin s4:=501; F4:=509; end;
       9: begin s4:=510; F4:=511; end;
      end; {Case J}

  if
  ( A2 - b2 <> [])
  and ( b2 - a2 <> [])

  and (act2 = l2)
   then
    for yn4:= S4 to F4 do
    if  (popcnt(dword((comboset2[yn4]*Comboset2[yn2]) ) )   >1 ) {checks that 2nd set of digits shares >=2 digits with first set}
       then
       if b = comboset[yn4]
         then
           begin
            z1:=[];

           z1:=[];

              for q in (peerrcb[xn] + peerrcb[xn2] )  do

                 for z in (comboset[yn4]*comboset[yn2]  ) do

                   if  ( ((digitrcb[z,xn] * a2) * (digitrcb[z,q])) - (a2*b2)  <> []  )
                   and  ( ((digitrcb[z,xn2] * b2) * digitrcb[z,q]) - (a2*b2) <> []  )
                   and   ( ( digitRCB[z,q] * (a2+b2 ) - (a2*b2)  ) = ( (DigitRCB[z,xn]*a2 ) + (Digitrcb[z,xn2]*b2) ) )
                   then
                      begin
                        z1:=z1+[z];                 

                      for R in ((comboset[yn4] * comboset[yn2])  - [z]) do
                       if (DigitRCB[R,xn] *A2 <> []  )
                       and (DigitRCB[R,xn2] * B2 <> [] )
                        then
                         begin
                         active:=true;
                         

                         for x in [0..80] - (A2+B2)  do
                          if  (peer[x]  * ( ( DigitRCB[R,xn] + DigitRCB[R,xn2] ) * (A2+B2)) =  (( DigitRCB[R,xn] + DigitRCB[R,xn2] ) * (A2+B2)) )
                          and ( R in pm[x] )
                             then
                              begin
                              active:=true;
                              covered[x]:= covered[x] - [r];
                           
                              end;

                         end;
                     
                   end;   {mutiple q sectors for mutiple restircted commons}

          if popcnt(dword(z1)) >1
          then
           begin

         
              for R in ((comboset[yn4] + comboset[yn2])  - z1) do
                       if (DigitRCB[R,xn] *A2 <> []  )
                       or (DigitRCB[R,xn2] * B2 <> [] )
                        then
                         begin
                         active:=true;                       

                         for x in [0..80] - (A2+B2)  do
                          begin

                          if  (peer[x]  * ( ( DigitRCB[R,xn] + DigitRCB[R,xn2] ) * (A2+B2)) =  (( DigitRCB[R,xn] + DigitRCB[R,xn2] ) * (A2+B2)) )
                            and ( R in pm[x] )
                             then
                              begin
                              covered[x]:= covered[x] - [r];
                         
                              end;

                          if  (peer[x] *  ( DigitRCB[R,xn]  * A2) =  ( DigitRCB[R,xn]  * A2) )
                            and ( R in pm[x] )
                            and (DigitRCB[R,xn] * A2 <> [])
                             then
                              begin
                              active:=true;
                              covered[x]:= covered[x] - [r];
                           
                              end;

                           if  (peer[x]  *  ( DigitRCB[R,xn2]  * b2) =  ( DigitRCB[R,xn2]  * B2) )
                            and ( R in pm[x] )
                            and (DigitRCB[R,xn2] * B2 <> [])
                             then
                              begin
                              active:=true;
                              covered[x]:= covered[x] - [r];
                           
                              end;


                          end;
                           end;

             end; {dual link elimiantions}

           end; {yn4}
        end;{yn3}
       end;{xn2}

      end;    {yn2}
   end; {yn}
 end;  {xn}

end;{als -xz rule}


AHS - XZ & double linked rule
Hidden Text: Show
Code: Select all
 Code not implemented in current build


Als - xy rule
Hidden Text: Show
Code: Select all
procedure alsxy(k:integer);
var
q,xn,xn2,xn3,L,l2,l3,J,j2,j3,s,s2,s3,s4,s5,s6,f,f2,f3,f4,f5,f6,yn,yn2,yn3,yn4,yn5,yn6,n,z,x,ACT,ACT2,act3,g,r,q2,z2:integer;

A:nums;
a2:numberset;
B:nums;
B2:numberset;
c:nums;
c2:numberset;
z1:nums;
lx1: rcbpeer;
lx2: rcbpeer;

begin

 for xn:= 0 to 26 do
    for L:= 1 to 8 do
      begin

       J:= l+1;

      case L of
       1: begin s:=0; F:=8; end;
       2: begin s:=9; F:=44; end;
       3: begin s:=45; F:=128; end;
       4: begin s:=129; F:=254; end;
       5: begin s:=255; F:=380; end;
       6: begin s:=381; F:=464; end;
       7: begin s:=465; F:=500; end;
       8: begin s:=501; F:=509; end;
       9: begin s:=510; F:=511; end;
      end; {Case L}

      for yn:= S to f do
       begin
         A:=[];
         a2:=[];
         ACT:=0;
         lx1:=[];

         for n:= 0 to 8 do
          if (n in comboset2[yn] )
             and (Sectorrc[xn,n] <> [])
              then
               begin
               A:= a+ sectorRC[xn,n]; {#'s}
               INC(ACT);

               a2:=a2+ sectorrcb[xn,n]; {cell's}

               lx1:= lx1 + peerrcb[Rx[secset[xn,n]]] + peerrcb[Cy[secset[xn,n]]] + peerrcb[Bxy[secset[xn,n]]];
               end;


      case J of
       1: begin s2:=0; F2:=8; end;
       2: begin s2:=9; F2:=44; end;
       3: begin s2:=45; F2:=128; end;
       4: begin s2:=129; F2:=254; end;
       5: begin s2:=255; F2:=380; end;
       6: begin s2:=381; F2:=464; end;
       7: begin s2:=465; F2:=500; end;
       8: begin s2:=501; F2:=509; end;
       9: begin s2:=510; F2:=511; end;
      end; {Case J}

if  (ACT = L)
 then
   for yn2:= S2 to F2 do
       if A = comboset[yn2]
         then
           begin

             for xn2 in (lx1)   do

                for L2:= 1 to 8 do
      begin

       J2:= l2+1;

      case L2 of
       1: begin s3:=0; F3:=8; end;
       2: begin s3:=9; F3:=44; end;
       3: begin s3:=45; F3:=128; end;
       4: begin s3:=129; F3:=254; end;
       5: begin s3:=255; F3:=380; end;
       6: begin s3:=381; F3:=464; end;
       7: begin s3:=465; F3:=500; end;
       8: begin s3:=501; F3:=509; end;
       9: begin s3:=510; F3:=511; end;
      end; {Case L}

      for yn3:= S3 to f3 do
      begin
         B:=[];
         B2:=[];
         act2:=0;
          lx2:=[];

         for n:= 0 to 8 do
            if (n in comboset2[yn3])
              AND (sectorRC[xn2,n] <> [])
              then
               begin
               b:= b+ sectorRC[xn2,n];

               inc(act2);

               b2:=b2+ sectorrcb[xn2,n];

            lx2:= lx2 + peerrcb[Rx[secset[xn2,n]]] + peerrcb[Cy[secset[xn2,n]]] + peerrcb[Bxy[secset[xn2,n]]];
             end;

      case J2 of
       1: begin s4:=0; F4:=8; end;
       2: begin s4:=9; F4:=44; end;
       3: begin s4:=45; F4:=128; end;
       4: begin s4:=129; F4:=254; end;
       5: begin s4:=255; F4:=380; end;
       6: begin s4:=381; F4:=464; end;
       7: begin s4:=465; F4:=500; end;
       8: begin s4:=501; F4:=509; end;
       9: begin s4:=510; F4:=511; end;
      end; {Case J}

  if
  ( A2 - b2 <> [])
  and ( b2 - a2 <> [])

  and (act2 = l2)
   then
    for yn4:= S4 to F4 do
    if  (popcnt(dword((comboset2[yn4]*Comboset2[yn2]) ) )   >=1 ) {checks that 2nd set of digits shares >=2 digits with first set}
       then
       if b = comboset[yn4]
         then
           begin

              for q in (peerrcb[xn] + peerrcb[xn2] )  do

                 for z in (comboset[yn4]*comboset[yn2]  ) do

                   if  ( ((digitrcb[z,xn] * a2) * (digitrcb[z,q])) - (a2*b2)  <> []  )
                   and  ( ((digitrcb[z,xn2] * b2) * digitrcb[z,q]) - (a2*b2) <> []  )
                   and   ( ( digitRCB[z,q] * (a2+b2 ) - (a2*b2)  ) = ( (DigitRCB[z,xn]*a2 ) + (Digitrcb[z,xn2]*b2) ) )
                   then
                      begin

                    for xn3 in ([0..26] {lx2 })   do

                for L3:= 1 to 8 do
      begin

       J3:= l3+1;

      case L3 of
       1: begin s5:=0; F5:=8; end;
       2: begin s5:=9; F5:=44; end;
       3: begin s5:=45; F5:=128; end;
       4: begin s5:=129; F5:=254; end;
       5: begin s5:=255; F5:=380; end;
       6: begin s5:=381; F5:=464; end;
       7: begin s5:=465; F5:=500; end;
       8: begin s5:=501; F5:=509; end;
       9: begin s5:=510; F5:=511; end;
      end; {Case L}

      for yn5:= S5 to f5 do
      begin
         C:=[];
         C2:=[];
         act3:=0;

         for n:= 0 to 8 do
            if (n in comboset2[yn5])
              AND (sectorRC[xn3,n] <> [])
              then
               begin
               C:= C+ sectorRC[xn3,n];

               inc(act3);

               C2:=C2+ sectorrcb[xn3,n];

             end;

      case J3 of
       1: begin s6:=0; F6:=8; end;
       2: begin s6:=9; F6:=44; end;
       3: begin s6:=45; F6:=128; end;
       4: begin s6:=129; F6:=254; end;
       5: begin s6:=255; F6:=380; end;
       6: begin s6:=381; F6:=464; end;
       7: begin s6:=465; F6:=500; end;
       8: begin s6:=501; F6:=509; end;
       9: begin s6:=510; F6:=511; end;
      end; {Case J}

      if  (( C2 -  b2 ) <> [])
        and (( C2 - A2 ) <> [] )

        and (act3 = l3)
   then
    for yn6:= S6 to F6 do
    if  (popcnt(dword((comboset2[yn6]*Comboset2[yn4]) ) )   >=1 ) {checks that 2nd set of digits shares >=2 digits with 2nd set}
   and (popcnt(dword((comboset2[yn6]*Comboset2[yn2]) ) )   >=1 ) {checks that 2nd set of digits shares >=2 digits with 1st set}
       then
       if c = comboset[yn6]
         then
           begin   
                             for q2 in (peerrcb[xn2] + peerrcb[xn3])  do

                                 for z2 in (comboset[yn6]*comboset[yn4] - [z] ) do

                   if  ( ((digitrcb[z2,xn3] * C2) * (digitrcb[z2,q2])) - (C2*b2)  <> []  )
                   and  ( ((digitrcb[z2,xn2] * b2) * digitrcb[z2,q2]) - (C2*b2) <> []  )
                   and   ( ( digitRCB[z2,q2] * (C2+b2 ) - (C2*b2)  ) = ( (DigitRCB[z2,xn3]*C2 ) + (Digitrcb[z2,xn2]*b2) ) )
                   then
                      begin
                         

                           for R in ((Comboset[yn2]*comboset[yn6]) -[z2,z] ) do
                             if (DigitRCB[R,xn] * A2 <> []  )
                            and (DigitRCB[R,xn3] * C2 <> [] )
                        then
                         begin
                         active:=true;
                       
                         for x in [0..80] - (A2+B2+C2)  do
                          if  (peer[x]  * ( ( DigitRCB[R,xn] + DigitRCB[R,xn3] ) * (A2+C2)) =  (( DigitRCB[R,xn] + DigitRCB[R,xn3] ) * (A2+C2)) )
                          and ( R in pm[x] )
                             then
                              begin
                              active:=true;
                              covered[x]:= covered[x] - [r];                           

                              end;

                         end;



                         end;   {q2 }

                         end; {yn6 }
                        end; {yn5}
                      end; {xn3}

                   end;   {mutiple q sectors for mutiple restircted commons}



           end; {yn4}
        end;{yn3}
       end;{xn2}

      end;    {yn2}
   end; {yn}
 end;  {xn}

end;{als -xy rule}

[/hidden]



XY- Chain {remote pairs } [hidden]
Code: Select all
 
procedure xychain;  {also hits remote pairs}
type
act = array of integer;
hold = array of integer;
base = array of integer;
digit = array of integer;

var
xn,w,p,p2,p3,n,n2:integer;

a:act;
h:hold;
step: base;
z:digit;

begin

setlength(a,0);
setlength(h,0);
setlength(step,0);
setlength(z,0);

for xn:= 80 downto 0 do    {startin cell}
 if (nm[xn] = 2)
  then
     for n:= 1 to 9 do
       if  N in pm[xn]
         then

 begin

  w:=0;    {step count}

  setlength(z,(w+1));

  z[w]:=n;

  setlength(h,(w+1));  {set the array size to w}

  h[w]:=19;        {keeps track of what peer is being used for step W }

  setlength(step,(w+1));   {set the array size to w}

  step[w]:=xn;  { keeps track of what cells are used at each step W }

  setlength(a,0);  {resets the grid as its a "new starting point" }

  setlength(a,81);
   a[xn]:=1;   {keeps track of what grid digs have been selected already}

   repeat

    for p:= h[w] downto 0 do    {iteration of peers}

      if (a[peer2[step[w],p]] = 0)
      and (nm[peer2[step[w],p]]=2)        { if grid digit is not used }
      and ( Z[w] in pm[peer2[step[w],p]] )
       then

         begin

           n2:=0;
           repeat
             n2:=n2+1;
           until ((n2 <> z[w]) and (N2 in pm[peer2[step[w],p]]));


          h[w]:=h[w]-1;    { advance the peer count for step w}

          inc(w);        {increase the step count}

          setlength(z,(w+1));
          z[w]:=n2;

          setlength(h,(w+1));
          setlength(step,(w+1));     {increse the array size  to w}

          step[w]:=peer2[step[(w-1)],p];   {set the step cell active for the newly created step w}

          a[peer2[step[(w-1)],p]]:=1;   {activate the cell as used on the grid}

          h[w]:=19;  {set the peer count for the new step w as 19}

          break;

        end


       else

         h[w]:=h[w]-1;  {if the above is fasle then advance the peer number}


    if ((h[w] < 0 ) and (w > 0))       {applies eliminations}
      and (z[w] in pm[xn] )  and (z[w] <> n)

         then
            for p2:= 0 to 19 do
              for p3:= 0 to 19 do

                 if ((peer2[xn,p2]) = (peer2[step[w],p3]))  and (a[peer2[xn,p2]]=0)
                  then
                   begin

                    active:=true;

                    covered[peer2[xn,p2]]:= covered[peer2[xn,p2]]  - [ z[w] ] ;

                   end;

  { if ((h[w] < 0 ) and (w > 0))
      and (z[w] in pm[xn])  and (z[w] <> n) and ( z[w-1] in pm[step[w]] )
         then
          for p2:= 0 to 19 do
           if peer2[xn,p2] = step[w]
            then
             begin

                writexy(2,60,'xy - loop');

                determins if the found chains is actually a loop
                elimination code  is not added
                 as its covered by succesive runs of the chain code as is:


             end;    }

    if ((h[w] < 0 )  and (w > 0 ))  {the following resets the step to the previous state}
     then
      begin

       w:=(w-1);

       setlength(z,(w+1));

       setlength(h,(w+1));

       setlength(step,(w+1));

       setlength(a,0);
       setlength(a,81);

        for p:= 0 to w do
         a[step[p]]:=1;

      end;

    until (w = 0) and (h[w] < 0)

 end;

end;


Sue De Coq
Hidden Text: Show
Code: Select all
procedure Suedecoq(K,M,Q:integer);
type

hold = array of integer;
base = array of numberset;
base2 = array of integer;
hold2 = array of RCBpeer;

var
p,S,F,C,w,j,a,b,z,lx,x,g,l:integer;

z1:nums;

p2,lx1:numberset;

h: hold;
step: base;
loc: base2;
List: hold2;

begin

 If M = 0
  then
   L:= 2
  else
  L:=M;

repeat

for p:= 0 to 80 do
 if  ( (q = 1) and (nm[p] = 2 ) )
  or ( (q = 2) and (nm[p] = 3 ) )
  or ( (q = 0) and (nm[p] <= L ) )

  then

  begin
  case L of
       1: begin s:=0; F:=8; end;
       2: begin s:=9;  F:=44; end;
       3: begin s:=45;  F:=128; end;
       4: begin s:=129; F:=254;  end;
       5: begin s:=255; F:=380; end;
       6: begin s:=381; F:=464; end;
       7: begin s:=465; F:=500; end;
       8: begin s:=501; F:=509; end;
       9: begin s:=510; F:=511; end;
      end; {Case L}

  for C:= s to f do

   if  ( pm[p] * Comboset[c] =  pm[p] )
   and ( Pm[P] - Comboset[C] = [] )
   and ( pm[p] <> [])
     then
      begin
        w:=0; { step count}
        setlength(h,w+1);
        H[w]:=19;   {starting cell position}
        setlength(step,(w+1));   {set the array size to w}
        setlength(list,(W+1));    {sets the array size to w}
       // setlength(loc,(w+1));  {starting cell}
       list[w]:=  [Rx[p]] + [(Cy[p]+9)]+ [(Bxy[P]+18)] ; {records active sectors}
       step[w]:=[p];  { keeps track of what cells are used at each step W }
        //loc[w]:=p;

           repeat

            for J:= h[w] downto 0 do
             begin
               if  ( pm[peer2[p,j]] * Comboset[c] =  pm[peer2[p,j]] )
               and ( Pm[Peer2[p,j]] - Comboset[C] = [] )
               and ( pm[peer2[p,j]] <> [])
               and ( [peer2[p,j]] * step[w] = [])
               and ( nm[peer2[p,j]] <=l)
                  then
                   begin

                   inc(w);  {increase step count}

                   setlength(h,w+1);   {increase lenght of step starting point array}

                 //  setlength(loc,(w+1));  {starting cell}
                 // loc[w]:=peer2[loc[w-1],j];

                   setlength(list,(W+1));
                   list[w]:=list[w-1] + [Rx[peer2[p,j]]] + [Cy[peer2[p,j]]+9] + [BXY[peer2[p,j]]+18];

                   H[w]:=j-1;

                   setlength(step,(w+1));   {set the array size to w}
                   step[w]:=step[w-1] + [ peer2[p,j] ] ;  { keeps track of what cells are used at each step W }

                   end

                  else
                   dec(H[w]);



               if W = (l-1)
                then
                 begin
               {   writexy(2,25,'cells used');

                  for g:= 0 to 80 do
                   if g in step[w]
                    then write(' ,',g);   }

                     for a in list[w] do
                      if (RCBnum[a]*step[w] <> [] )
                        then
                         begin
                         for B in ( List[w]-[a] )  do
                           if ( RCBnum[B] * step[w] <> [])
                           then
                           if (( (RCBnum[b]  + RCBnum[a] ) * step[w]) = step[w])
                           and ( (RCBnum[a] - RCBnum[b]) * step[w] <> [] )
                           and ( (RCBnum[b] - RCBnum[a]) * step[w] <> [] )
                            then
                             begin

                               lx1:=[];
                               z1:=[];

                              for Z in comboset[c]  do
                                 if ( ( (digitrcb[z,a] * step[w] ) <> [])
                                 or  ( (digitrcb[z,b] * step[w] ) <> [])     )
                                   then
                                     for  lx in list[w]  do

                                       if
                                        (  ( (digitRCB[z,a] * digitRCB[z,lx] * step[w]) <> [])
                                        or
                                      ( (digitRCB[z,b] * digitRCB[z,lx] * step[w]) <> [])  )

                                      and ( (( DigitRCB[z,b] + DigitRCB[z,a]) * digitrcb[z,lx] * step[w])  =  ( (digitrcb[z,a] + digitrcb[z,b]) * step[w] ) )
                                        then
                                          begin
                                           lx1:=lx1+[lx];
                                           z1:=z1+[z];
                                          end;

                       if (popcnt(dword(z1))   = L )  and (Z1 = comboset[c])
                             then
                                begin
                                    active:=true;
                                 {   writexy(2,60,' Sue De Coq');
                                         writexy(2,26,'Sector A: ');
                                         write(A);
                                         writexy(2,27,'Sector B: ');
                                         write(B,' ');

                                         writexy(2,28,'resticted common: ');
                                         for g:= 1 to 9 do
                                         if g in z1 then  write(g,' ');

                                         writexy(2,29,'L sector: ');
                                         for g:= 0 to 26 do
                                          if g in lx1 then  write(g,' ');
                                         writeln('z:= ');   }
                                         for G in (z1*comboset[c] )   do
                                           begin
                                          {  write(G,'  @: ');  }
                                            p2:=(digitrcb[g,a]*step[w]) +( digitrcb[g,b]*step[w]);
                                            for x in ([0..80] - step[w])  do
                                            if (peer[x] * p2  = p2  )
                                            and  (g in pm[x] )
                                              then
                                               begin
                                                covered[x]:= covered[x] - [g];
                                               { write(x,' ');  }
                                               end;
                                           end;
                                  end; {count = 0 }
                                 end; {b}
                              end;  {a}
                 end;
               if (W = (L-1)) or (( W>0) and (H[w]= -1))   {back track sequence}
                 then
                 begin
                   repeat
                   Dec(w);  {decrese step count}
                   setlength(h,w+1);   {reduce lenght of step starting point array}
                  // setlength(loc,(w+1));  {starting cell}
                  setlength(list,(w+1));
                   dec(h[w]);
                   setlength(step,(w+1));   {set the array size to w}

                   until   (H[w]> -1) or (w=0)
                 end;

              end;

             until  (h[W] = -1)
       end;
    end;
 if m = 0
  then
  inc(L);
 until (L = m) or (L > 9);
  end; {sue de coq}
Last edited by StrmCkr on Fri Feb 10, 2017 7:54 am, edited 12 times in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

timer function, and main body code

Postby StrmCkr » Wed Mar 02, 2016 6:25 pm

Function Timer for solving technique execution times
Hidden Text: Show
Code: Select all
//  command functions
Procedure time(v:char);
var
 st,et,hz:int64;
      ms:double;
begin

sbrc;
queryperformancecounter (st);

case v of

#59: Hs(1);
#84: Ns(1);

#61: Hp(1);
#86: Np(1);

#62: Ht(1);
#87: Nt(1);

#63: Hq(1);
#88: Nq(1);

#89: barns(1,3,1); {xy-wing}
#90: barns(1,3,2); {xyz-wing}
#91: barns(1,4,0); {wxyz-wing}

#60: blr(1);
#85: xwing(1);
#64: smashi(1);  {skyscrappers, finned & shashimi x-wings}
#65: er(1);
#66: kyte(1);

#67: Swordfish(1);
#92: smashiswords(1);

#68: jellyfish(1);
#93: smashijelly(1);

#133: Wwing(1);
#134: mwing(1);
#135: swing(1);
#136: Lwing(1);{

#117: URt12456;
#104: HUR; }

#120: XYchain;

#97: alsxz(1);
#104: Ahsxz(1);
#121: alsxy(1);

#98: Barns(1,0,0);
#100: Suedecoq(1,0,0);

#102:fishfinder;
//#116: fishfinder2(5,5);

#96:  solve;
#126: solve;

#99: issomorph('0','s','f');

end;
      queryperformancecounter (et);
      queryperformancefrequency (hz);


      ms := (et - st) * 1000.0 / hz;
      gotoxy(1,54);
      write( 'Total cpu time = ');
      gotoxy(1,55);
      write(ms:16:8,' millieseconds');

      ms := 1 * 1000.0 / ms;

      gotoxy(1,57);
      write( 'Solving rate = ');
      gotoxy(1,58);
      write(ms:16:8,' puzzles / second');

if active= true
then
 begin
  sbrc;
  wpm(1);
 end;

end;


Main program:
Hidden Text: Show
Code: Select all
program test;
  uses crt,windows;
//main body
begin

Clrscr;
window(1,1,220,80);

peers;
RCBpeers;
combo;
lookupSectorRBC;

initiate;
setpm;
sbrc;


TextBackGround(COLBG);
viewgiven;
viewpm;
help;

wpm(0);

x:=0; y:=0;

 repeat
     curser( rset[x,y] ,COLBG);

     ch:=readkey;

    if( ch=' ' )then ch:='0';

    if( ch in ['1'..'9']) then
      begin

       if s[rset[x,y]] <> []
        then
         begin
                rd[rx[rset[x,y]]]:= rd[rx[rset[x,y]]] + s[rset[x,y]];
                cd[cy[rset[x,y]]]:= cd[cy[rset[x,y]]] + s[rset[x,y]];
                bd[bxy[rset[x,y]]]:= bd[bxy[rset[x,y]]] + s[rset[x,y]];
                s[rset[x,y]]:=[ord(ch) - ord('0')];

          end

        else
           s[rset[x,y]]:= [ord(ch) - ord('0')];

        setpm;
        sbrc;
        wpm(0);


      end;

        {functions}

      {delete charcter in cell}
    if ( ch=#8 ) or ( ch=#83 ) or (ch='0')
     then
      begin

          rd[rx[rset[x,y]]]:=rd[rx[rset[x,y]]]+s[rset[x,y]];
          cd[cy[rset[x,y]]]:=cd[cy[rset[x,y]]]+s[rset[x,y]];
          bd[bxy[rset[x,y]]]:=bd[bxy[rset[x,y]]]+s[rset[x,y]];
          s[rset[x,y]]:=[];

         setpm;
         sbrc;
         wpm(0);


      end;

     {import file}
    if( ch=#105 ) then import;

     {save grid to file}
    if( ch=#83 ) then begin save; end;

     {load from saved grid }
    if( ch=#76 ) then begin load;  setpm; sbrc; wpm(1); end;

      {save pm to file}
    if( ch=#115) then begin  savepm; end;

     {load pm from saved  }
    if( ch=#108 ) then begin  loadpm;  setpm; sbrc; wpm(1); end;

    {reset everything}
    If( ch=#114 ) then begin initiate; setpm; sbrc; wpm(1); end;

     {batch solve mode}
    if( ch=#98) then {batch};

      {bruteforce mode}
    if (ch = #102) then begin {bruteforce;  wpm(0);} end;

      {solving buttons}
    if ch in [#59,#60,#61,#62,#63,#64,#65,#66,#67,#68,#84,#85,#86,#87,#88,#89,#90,#91,#92,#93,#96,#97,#98,#99,#100,#102,#104,#109,#116,#120,#121,#126,#133,#134,#135,#136]
           then
             time(ch);

    { arrow keys }
    if( ch=#75 ) then Y:=Y-1;
    if( ch=#77 ) then Y:=Y+1;
    if( ch=#72 ) then x:=x-1;
    if( ch=#80 ) then x:=x+1;

    { home - end }
    if( ch=#71 ) then y:=0;
    if( ch=#79 ) then y:=8;

    { pageup - pagedown }
    if( ch=#73 ) then x:=0;
    if( ch=#81 ) then x:=8;

    { check position }
    if( y<0 ) then y:=8;
    if( y>8 ) then begin y:=0; x:=x; end;
    if( x<0 ) then x:=8;
    if( x>8 ) then x:=0;


    { tabs into the pm grid }

    if (ch =#9 ) or (ch=#15)
      then
       repeat

        curserpm (rset[x,y],Colbg);
        ch:=readkey;

        { delete pms }
        if( ch in ['1'..'9']) then
         begin
           for iter:= 1 to 9 do
            if iter = ord(ch) - ord('0')
             then
              delpm[ rset[x,y] ]:=delpm[ rset[x,y] ] - [iter];

            sbrc;
            wpm(0);

         end;

           {resest the pm deletions }
         if ( ch=#8 ) or ( ch=#83 ) or (ch='0') then
            begin

             delpm[ rset[x,y] ]:=[1..9];
             Ipm[Rset[x,y]]:=[1..9];
             sbrc;
             wpm(0);

            end;

        { arrow keys }
       if( ch=#75 ) then Y:=Y-1;
       if( ch=#77 ) then Y:=Y+1;
       if( ch=#72 ) then x:=x-1;
       if( ch=#80 ) then x:=x+1;

        { home - end }
       if( ch=#71 ) then y:=0;
       if( ch=#79 ) then y:=8;

        { pageup - pagedown }
       if( ch=#73 ) then x:=0;
       if( ch=#81 ) then x:=8;

        { check position }
       if( y<0 ) then y:=8;
       if( y>8 ) then begin y:=0; x:=x; end;
       if( x<0 ) then x:=8;
       if( x>8 ) then x:=0;

     until (ch=#9) or (ch=#15) or (ch=#27);


    until (ch=#27);


end.


Solve function
Hidden Text: Show
Code: Select all
Procedure solve;
var
Count2,Countpm2: integer;
begin

repeat

Countpm2:=countpm;
count2:= count;

 if  (countpm2 = countpm)  and (count2=count)
  then
   begin
    Hs(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    Ns(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    BLR(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    hp(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    np(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    xwing(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    ht(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    nt(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    hq(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    barns(1,3,1);  {xy-wing}
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    barns(1,3,2);  {xyz-wing}
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    barns(1,4,0);  {xyz-wing}
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    nq(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    smashi(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    kyte(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    er(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    swordfish(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    jellyfish(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    smashiswords(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;
if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    smashijelly(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    wwing(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    mwing(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    swing(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    lwing(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    xychain;
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    barns(1,0,0);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    suedecoq(1,0,0);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    alsxz(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    alsxy(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;


if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    fishfinder;
     if active= true
      then
       begin
        sbrc;
       end;
   end;


until  (countpm2=countpm) or (count = 80)

end;
Last edited by StrmCkr on Fri Feb 10, 2017 7:57 am, edited 4 times in total.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Re: StormDuko

Postby StrmCkr » Sun Dec 11, 2016 9:50 pm

updated
2-string kyte, Empty rectangles

i also tweaked the following sections:

index constraints
help screen
function timer
als-xz
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Re: StormDuko

Postby StrmCkr » Thu Jan 05, 2017 12:38 pm

updated:

added
Barns,
sue de coq,
isomorphic transformation,
xy,xyz,wxyz - wings {via barns coding}

added some missing sections:
strong/ weak link detection
Sector Row/Col/Box lookup

modified the following:
Data storage Space
help screen info
Sets all subset data spaces used by solver
Function Timer for solving technique execution times
Main program
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Re: StormDuko

Postby StrmCkr » Tue Jan 24, 2017 10:26 am

updates:

added a .pass file to first post containing all current source code.

modified
help screen,
function Timer
main body,
Skyscaper {improved run time}
Box line reduction - found a coding error improved run time

Added
finned/sashimi swordfish { rows & cols types}
Finned/sashimi jellyfish {Rows & cols types}
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Re: StormDuko

Postby StrmCkr » Wed Jan 25, 2017 7:57 am

Rebuilt

Box line reduction code - massive code improvements on run time, simplified elimination procedure and reduced cycle counts drastically.
1300 ~ puzzles/second vs 53~k puzzles/second {is my single cycle timer change on a fixed example grid. }

source file changed to include new code:

notes:
sue de cog's and Barns + affiliated types seem to only work on example grids but not singular construction on an empty grid.
have to rebuild the code to sort that issue out.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Re: StormDuko

Postby StrmCkr » Sat Jan 28, 2017 7:27 am

tweaked :
empty rectangle section

{minor bug fix }

row or Col with 2 cells ending in same band/stack as the box incorrectly applying eliminations from the selected box

:note code link not updated

added 2 lines of code only.
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Re: StormDuko

Postby StrmCkr » Sat Jan 28, 2017 9:05 pm

updated:
source file

debugging:
sue de coq's
barn

found the errors in both codes ->> had an extra ";" which bugged the whole elimination section of the code
debugging also found cases that are skipping potential eliminations

Added:
Solve function


modified:

help screen
timer
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Re: StormDuko

Postby StrmCkr » Mon Jan 30, 2017 11:38 am

rebuilt

als-xz code - simplified and speed up the code

notes: source not updated yet
Some do, some teach, the rest look it up.
User avatar
StrmCkr
 
Posts: 603
Joined: 05 September 2006

Next

Return to Software