StormDoku

Programs which generate, solve, and analyze Sudoku puzzles

StormDoku

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

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

Screen size for the application:
width: 240
height: 360
Font size: 8*12
Font type: Raster Fonts

I have always release my code and software under Licensing

Current code posted here in is designed for Windows operating system.
Source Files, testing txt files and Stormdoku8.88.exe

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
MAin body
Issomorphic
PatternOverlayMethod
Hidden/Naked subsets
Fishing
Named wings
A.L.S
Chains
D.D.S
Transport
MSLS

previous builds
7.69
6.8 build
Last edited by StrmCkr on Wed Oct 19, 2022 8:08 am, edited 28 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Grid space index

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

Constants: 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: 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) );

{looks up a sector,cell and returns its rcb position} {note 9 = blank sice this is not a generated list}
    SecSet2: array [0..26,0..80] of integer =(
(0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,3,4,5,6,7,8),
(0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9,9,9,9,9,9,9,9),
(9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9,9,9,9,9,9,9),
(9,9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9,9,9,9,9,9),
(9,9,9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9,9,9,9,9),
(9,9,9,9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9,9,9,9),
(9,9,9,9,9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9,9,9),
(9,9,9,9,9,9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9,9),
(9,9,9,9,9,9,9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8,9),
(9,9,9,9,9,9,9,9,0,9,9,9,9,9,9,9,9,1,9,9,9,9,9,9,9,9,2,9,9,9,9,9,9,9,9,3,9,9,9,9,9,9,9,9,4,9,9,9,9,9,9,9,9,5,9,9,9,9,9,9,9,9,6,9,9,9,9,9,9,9,9,7,9,9,9,9,9,9,9,9,8),
(0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8,9,9,9),
(9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,0,1,2,9,9,9,9,9,9,3,4,5,9,9,9,9,9,9,6,7,8)
);

   secRCb: array [0..26] 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);

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

   Csec: array[0..8] of integer =
   (9,10,11,12,13,14,15,16,17);

   bsec: array[0..8] of integer =
   (18,19,20,21,22,23,24,25,26);

cell reference guide: Show
Code: Select all

      1  2  3  4  5  6  7  8  9   Col
   ---------------------------
  1 | 0  1  2  3  4  5  6  7  8
  2 | 9 10 11 12 13 14 15 16 17
  3 |18 19 20 21 22 23 24 25 26
  4 |27 28 29 30 31 32 33 34 35
  5 |36 37 38 39 40 41 42 43 44
  6 |45 46 47 48 49 50 51 52 53
  7 |54 55 56 57 58 59 60 61 62
  8 |63 64 65 66 67 68 69 70 71
  9 |72 73 74 75 76 77 78 79 80
 Row
Last edited by StrmCkr on Tue Oct 18, 2022 10:37 pm, edited 7 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Data sets and type cast

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

Type: Show
Code: Select all
type
 {Definition for data space}
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}

Sgrid = array of nums;
numSector = array of nums;
deletePm = array of nums;
importPM = array of nums;

Cov = array of nums;
cov2 = array of numberset;

Rnumsector = array of array[1..9] of RCBnums;
SectorRowCol = array of array[0..8] of Nums;
Secs = array of array[1..9] of integer;
nakedMarks = array of integer;
pencilmarks = array of nums;

sectornums = array of nums; //[sector] of nums; {function listing all  digits for sector }
solvedsector = array of nums; //[sector] of nums; {function listing all solved digits for sector}

digitcells = array of numberset;
DigitRowColBox = array of array[1..9] of numberset;

BoxnCol = array of array[1..9] of RCBnums;
BoxnRow = array of array[1..9] of RCBnums;
ColnBox = array of array[1..9] of RCBnums;
RownBox = array of array[1..9] of RCBnums;

emptyRecint = array of array[1..9] of RCBnums;

ComboCells = array of numberset;
Combosubsets = array of numberset;

Combonums = array of array[0..26] of nums;
Hcombonums = array of array[0..26] of rcbnums;

almostlockedset = array of array of integer;
almosthiddenset = array of array of integer;

strongLk = array of array of array of array[0..11] of numberset;

tech= array of array of numberset;

Var: Show
Code: Select all
Var
      X,Y           : integer; {coridinals}
      Grid          : String ; {imported grid string}
      Count,Countpm,Scount: integer; {counts the given clues and pms}
      active,unique,table,unique2,zero: boolean;
      ch            : char;
      iter          : integer;
      //variation     : boolean;
   
     Acell: numberset; {on cells}
     Ocell: numberset;  { off cells}
   
     S: sgrid;      {the solved grid}
     NSector: numsector;  { removed sectors by s cells solved }
      delpm: deletepm ; {manual deletion of pencilmarks}
     Ipm:importpm; {loaded copy of pencilmarks}
   
      SectorN:sectornums; //[sector] of nums; {function listing all  digits for sector }
       Ssector:solvedsector; //[sector] of nums; {function listing all solved digits for sector}
   
     covered: cov; //  [cell] of nums;  - technique removals by cell for n
      covered2: cov2; // [digits] of numberset; - technique removals by digits for cells

     techwrite:  tech;  {array holding technique data for writing to screen}

 {builds sets of N size digits/rcb  }
comboset: array [0..510] of nums;        { 1-9 used for digits}
comboset2: array [0..510] of RCbnums;    { 0-8 used for R/C/B & position }

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

{looks up the sectors a cell is from}
CellSec: array [cell] of RCBpeer; { a quick call version for sectors a cell is in}

{displays all cells for the sector used or not}
 RCBnum: array[sector] of numberset; {RCB call function listing all potential cells for easier use}

 {displays the intersecting sectors for each sector selected}
 peerRCB: array[sector] of rcbpeer; {RCB peer sectors of selected sector}

{displays the sector of a combos set}
 SectorRCB: array[Sector,0..510] of numberset;   {sector by combset2, looks up RCB for the comboset and displays the cells.}
 combosetS: array [sector,0..510] of numberset;  {listing cells for sector based on digit combination set}
 
 secover: array[sector,sector] of RCBnums; {marks which "positions" overlap for 2 sectors}

{hidden sets}
RnSector: RNumSector; // [sector,Digits] of RCBnums;  {saves RCB}

{Mini row/Col}
BnC: BoxnCol;// [Rcb,digits] of RCBnums;   {nums represet  col used in a box  }
BnR: BoxnRow;// [Rcb,digits] of RCBnums;   {nums represet  row used in a box  }

CnB: ColnBox;//  [Rcb,digits] of RCBnums;   {nums represet Box  used inside a col }
RnB: RownBox;// [Rcb,digits] of RCBnums;   {nums represet Box  used inside a row }

{empty rectangle intersection}
ERI:emptyRecint; // [RCB,digits] of RCBnums; {square  x digit saving box }

{Naked sets}
SectorRC:SectorRowCol; //[sector,rcb] of nums; {# in row x col with in sector}

{counts each digit}
Sec:Secs; // [sector,digits] of integer; {exact number of unassigned cells for # givens in a sector}
NM: nakedmarks;  // [cell] of integer; { # of digits found in cell}
PM: pencilmarks; // [cell] of nums;  {pm combined view of nsector - dpm,Ipm,covered,covered2}

{postions listings by area}
 DigitCell: digitcells; //[digits] of numberset; { listing every cell with n candidate}
 DigitRCB: DigitRowColBox;//[sector,digits] of numberset; {RBC function listing active cells for digit N}

{combination sets for cells,sectors}
combocell: ComboCells; //[0..510] of numberset; { combosets in specific cells Naked whole grid}
ComboSubset: Combosubsets; //[0..510] of numberset; {subset combo in specific cells  whole grid}

ComboNum: Combonums;//[0..510,sector] of nums; {sector looking up postion set saving all numbers in those cells} {naked}
HComboNum: Hcombonums; // [0..510,sector] of RCBnums; {sector looking up Digit set saving all position of those cells} {hidden}

{als & ahs data base}
als: almostlockedset;  {sector,cell size, digit size, position listed by comboset for the sector, digits used listed by comboset}
ahs: almosthiddenset;  {sector,cell size, digit size, digits listed by comboset for the sector, position used listed by comboset}

{link type data base}
Linkset : stronglk; // array [ 0..9][0..6][0..9] of numberset[0..80]//setwise
{digit selected[1..9]}
{0: bivavel,
1:  2 cells in a sector
2: cell in sector , grouped link to another = all digits in that sector
3: cells in sector, as a grouped link to a single cell = all digits in that sector
4: cells in sector, as a grouped link to a grouped node = all digits in that sector
5: ERI max
6: ERI all styles
7: ALS}
{ internal data as:
 0 starting digit,
 1 active cell,
 2 linked cells,
 3 link digit,
 4 sector start cells  are in,
 5 sector the link cells are is in.
 6 start - digit swap is applicable 0 = off
 7 end digit swap is applicable 0 = off
 8 potential elimination cells ..start cell
 9 potential elimination for  ...end cell
 10 als stuff
 11 als stuff
 12 - sister link
 }

chain display: Show
Code: Select all
procedure Chaindisplay(K:char;J:integer);
var
n,q,p,g,h,w,f,m:integer;
l:char;
begin
{for q:=0 to 66 do
For p:=0 to 23 do
 begin
gotoxy(118+q,35+p);
write(space);
end;}
techclear(0);

l:=K;
n:= 0;
gotoxy(117,35);
case k of
 
#11,#13,
#20,#22,#24,#25,#26,
#59,
#60,#61,#62,#63,#64,#66,#67,#68,#69,
#74,#78,
#84,#85,#86,#87,#88,
#92,#93,#94,#95,#97,
#100,#106,#109,#110,#111,
#120,#121,
#133,#134,#135,#136,#137,#138: begin
      textcolor(10);
      
       if l = #84 then writexy(118,35,'Naked Single');
      if l = #86 then writexy(118,35,'Naked Pair');
      if l = #87 then writexy(118,35,'Naked Tripple');
      if l = #88 then writexy(118,35,'Naked Quad');
      
      if l = #59 then writexy(118,35,'Hidden Single');
      if l = #61 then writexy(118,35,'Hidden Pair');
      if l = #62 then writexy(118,35,'Hidden Tripple');
      if l = #63 then writexy(118,35,'Hidden Quad');

      if l = #60 then writexy(118,35,'Box Line Reduction');
      if l = #85 then writexy(118,35,'X - Wing - Basic | Franken | Mutant');
      if l = #20 then writexy(118,35,'X - Wing   - Smashi | Finned');
      if l = #64 then writexy(118,35,'Skyscraper');
      if l = #66 then writexy(118,35,'2 - String Kyte');
      if l = #67 then writexy(118,35,'Swordfish - Basic');
      if l = #92 then writexy(118,35,'Swordfish  - Smashi | Finned');
      if l = #68 then writexy(118,35,'Jelly Fish - Basic');
      if l = #93 then writexy(118,35,'Jellyfish  - Smashi | Finned');
      
      if l = #97 then writexy(118,35,'Almost Locked Set - XZ');
      if l = #121 then writexy(118,35,'Almost Locked Set - XY');
      if l = #25 then writexy(118,35,'Almost almost Locked Set - 2RC Rule');
      if l = #22 then writexy(118,35,'N^A.L.S - N^RC Rule');
      if l = #106 then writexy(118,35,'Distributed Disjointed Subsets');
      if l = #111 then writexy(118,35,'Almost Distributed Disjointed Subsets');
      
      if l = #100 then writexy(118,35,'Sue de Coq');
      if l = #69 then writexy(118,35,'Death Blossom');
      
      if l = #24 then writexy(118,35,'X - Chain');
      if l = #120 then writexy(118,35,'XY - Chain');
      if l = #26 then writexy(118,35,'Alternating Interface Chain');
      if l = #11 then writexy(118,35,'ALS - Chain');
      if l = #13 then writexy(118,35,'A.I.C + ALS - Chain');
      
      if l = #133 then writexy(118,35,'W - Wings | Rings');
      if l = #135 then writexy(118,35,'M - Wings | Rings');
      if l = #134 then writexy(118,35,'Split - Wing');
      if l = #136 then writexy(118,35,'Local Type 2 Wing');
      if l = #138 then writexy(118,35,'Local Type 3 Wing');
      if l = #94 then writexy(118,35,'Strong - Wings | Rings');
      
      if l = #95 then writexy(118,35,'Hybrid Type 1 - Wings');
      if l = #110 then writexy(118,35,'Hybrid Type 2 - Wings');
      if l = #78 then writexy(118,35,'Hybrid Type 3 - Wings');
      
      if l = #137 then writexy(118,35,'Inverted W Wings | Rings');
      
      if l = #109 then writexy(118,35,'Sk Loop');
      if l = #74 then writexy(118,35,'Multi Sector Locked Set');
      
       textcolor(8);
       if j = 0 then writexy(118,36,'Found : 0 ');

       if j > 0
        then
         begin
         repeat
          textcolor(8);
          writexy(118,36,'Displaying : ');
          write(n+1,' Of ',J,'  ');

          textcolor(white);
          gotoxy(118,37);       
G:=0;
H:=0;
F:=0;

for q in techwrite[n,0] do
      G:=q;
    
for q in techwrite[n,1] do
      h:=q;

if l in [#11,#13,#24,#26,#120] 
  then    
   for q in techwrite[n,1] do
      h:=(q+1)*4; 

if l in [#22]
  then
   for q in techwrite[n,1] do
      h:=(q+1)*2; 


if g = 0 then //naked subset
    begin
   textcolor(white);
       gotoxy(118,37);
       Write('Set ',char(ord(65+f)),' [ ');
       textcolor(3);
      
       for q in techwrite[n,2] do
       write(q,' ');
       textcolor(white);
       write('] @ ');
       textcolor(9);
       for q in techwrite[n,3] do
        write(q,' ');
      textcolor(white);
    end;

if g = 1 then // hidden subset
    begin
   textcolor(white);
       gotoxy(118,37);
       Write('Set [ ');
       textcolor(9);
      
       for q in techwrite[n,2] do
       write(q,' ');
       textcolor(white);
       write('] @ ');
       textcolor(3);
       for q in techwrite[n,3] do
        write(q,' ');
      textcolor(white);
    end;
   
if g = 2 then //fish
begin 
textcolor(white);
          gotoxy(118,37);
write('(');
          textcolor(3);
          for q in techwrite[n,2] do
           write(q);
           textcolor(white);
           write('): Base: ');

           textcolor(6);
           for  p in techwrite[n,3] do
             write(p,' ');

            textcolor(white);
             write('Cover: ');
             textcolor(6);
           for p in techwrite[n,4] do
           write(p,' ');
           textcolor(white);
    end;

if g = 3 then //als types
 begin
    w:=2;
   f:=0;
     repeat     
      begin
       textcolor(white);
       gotoxy(118,37+F);
       Write('Set ',char(ord(65+f)),' [ ');
       textcolor(3);
      
       for q in techwrite[n,w] do
       write(q,' ');
       textcolor(white);
       write('] @ ');
       textcolor(9);
       for q in techwrite[n,w+1] do
        write(q,' ');
      textcolor(white);
      F:=F+1;
      w:=w+2;       
    end   
    until w >=(3+h-2);
   
    gotoxy(118,37+f);
        Write('RC: ');textcolor(3);
       for q in techwrite[n,3+h-1] do      
       write(q,' '); textcolor(white);
       Write('Z: '); textcolor(3);
       for q in techwrite[n,3+h] do
       write(q,' ');textcolor(white);

end; 

if g = 4 
  then
    begin        
   w:=2;
   f:=0;
   m:=0;
     repeat     
      begin
       textcolor(white);
       gotoxy(118+m,37+f);
       Write(' (');
       textcolor(3);   
       for q in techwrite[n,w] do
       write(q);
       textcolor(white);
       Write(') ');
       textcolor(9);
       for q in techwrite[n,w+1] do
        write(q,' ');
      textcolor(white);
       Write('= ');
       textcolor(9);
       for q in techwrite[n,w+2] do
        write(q,' ');
        textcolor(white);
        Write('(');
       textcolor(3);      
       for q in techwrite[n,w+3] do
       write(q);
       textcolor(white);
       Write(')');    
      
        m:=m+32;      
      w:=w+4;
      if w <(3+(h)-2) then write(' - ');
      if m > 64 then begin  m:=0; f:=f+1;end;      
    end   
    until w >(3+(h)-2);
   
   end;

if g = 5 then //msls types
 begin
       textcolor(white);
       gotoxy(118,37);
       Write('Away Set [ ');
       textcolor(3);
      
       for q in techwrite[n,2] do
       write(q,' ');
       textcolor(white);
       write('] @ ');
       textcolor(6);
       for q in techwrite[n,3] do
        write(q,' ');
      textcolor(white);         
            
       textcolor(white);
       gotoxy(118,38);
       Write('Home Set [ ');
       textcolor(3);
      
       for q in techwrite[n,4] do
       write(q,' ');
       textcolor(white);
       write('] @ ');
       textcolor(6);
       for q in techwrite[n,5] do
        write(q,' ');
      textcolor(white);
      
   
    gotoxy(118,39+f);
        Write('covers: ');textcolor(3);
       for q in techwrite[n,6] do      
       write(q,' '); textcolor(white);
       Write('cells: '); textcolor(3);
       for q in techwrite[n,7] do
       write(q,' ');textcolor(white);
F:=F+3;
end; 

   
   //elimimimination cells     
    write(' =>> ');   
   
    for p:= 1 to 9 do
        if techwrite[n,p+h+3] <> [] then
        begin
        gotoxy(118,38+F+p);
        textcolor(red);
        for q in techwrite[n,p+h+3] do
        write(q,' ');
        textcolor(white);
        write(' <> '); textcolor(3);write(p);
        textcolor(white);
        end;
           
          gotoxy(118,39+f+9);
           ch:=readkey;

if (ch=#43) or (ch=#45 ) then techclear(1);

           if ch=#43 then n:=n+1;
           if ch=#45 then n:=n-1;

           if (n) > j-1 then n:=0;
           if (n) < 0 then n:=j-1;
           
          until (ch =#13)
        end;

end;       

end;
textcolor(col2);
end; //chaindisplay      

Tech clear: Show
Code: Select all
{clearing function for writting techniques}

procedure techclear(s:integer);
var
p,q:integer;
begin
for q:=0 to 106 do
For p:=0 to 23 do
 begin
gotoxy(118+q,35+p+s);
write(space);
end;
end;


Tech Display: Show
Code: Select all
{writing function for technique sets}
procedure techdisplay(K:char;J:integer);
var
n,q,p:integer;
l:char;
begin

for q:=0 to 66 do
For p:=0 to 14 do
 begin
gotoxy(118+q,35+p);
write(space);
end;

l:=K;
n:= 0;
gotoxy(117,35);
case k of

#65,#102:   begin
       textcolor(10);
      
      if l = #65 then writexy(118,35,'Empty Rectangle');
      if l = #102 then writexy(118,35,'Fish Finder');
      

       textcolor(8);
       if j = 0 then writexy(118,36,'Found : 0 ');

       if j > 0
        then
         begin
         repeat
       textcolor(10);
        if l = #65 then writexy(118,35,'Empty Rectangle');
         if l = #102 then writexy(118,35,'Fish Finder');
      
          textcolor(8);
          writexy(118,36,'Displaying : ');
          write(n+1,' Of ',J,'  ');

          textcolor(white);

          gotoxy(118,37);

          write('(');
          textcolor(3);
          for q in techwrite[n,11] do
           write(q);
           textcolor(white);
           write('): Base: ');

           textcolor(6);
           for  p in techwrite[n,0] do
             write(p,' ');

            textcolor(white);
             write('Cover: ');
             textcolor(6);
           for p in techwrite[n,10] do
           write(p,' ');
           textcolor(white);
          if L = #102 then begin
         textcolor(white);
         if techwrite[n,12] <> [] then begin
             write('Extra Covers: ');
             textcolor(6);
           for p in techwrite[n,12] do
           write(p,' ');
         end;
           textcolor(white);
         end;
         
           gotoxy(118,38);      
            write(' =>> ');

          for p:= 1 to 9 do
        if techwrite[n,p] <> [] then
        begin
        gotoxy(118,39+p);
        textcolor(red);
        for q in techwrite[n,p] do
        write(q,' ');
        textcolor(white);
        write(' <> '); textcolor(3);write(p);
        textcolor(white);
        end;
           gotoxy(118,49);
           ch:=readkey;

if (ch=#43) or (ch=#45 ) then techclear(0);

           if ch=#43 then n:=n+1;
           if ch=#45 then n:=n-1;

           if (n) > j-1 then n:=0;
           if (n) < 0 then n:=j-1;


          until (ch =#13)

          end;

      end;







#104: begin
      textcolor(10);
       writexy(118,35,'AHS-XZ');

       textcolor(8);
       if j = 0 then writexy(118,36,'Found : 0 ');

       if j > 0
        then
         begin
         repeat
       textcolor(10);
       writexy(118,35,'AHS-XZ');
          textcolor(8);
          writexy(118,36,'Displaying : ');
          write(n+1,' Of ',J,'  ');

          textcolor(white);

        gotoxy(118,37);
       Write('Set A) [ ');
       textcolor(9);
      for q in techwrite[n,11] do
       write(q,' ');
       textcolor(white);
       write('] @ ');
       textcolor(3);
       for q in techwrite[n,0] do
        write(q,' ');
      textcolor(white);
         gotoxy(118,38);
       Write('Set B) [ ');
       textcolor(9);
      for q in techwrite[n,12] do
       write(q,' ');
       textcolor(white);
       write('] @ ');
       textcolor(3);
       for q in techwrite[n,10] do
        write(q,' ');
      textcolor(white);
        gotoxy(118,39);
       Write('X: ');
       for q in techwrite[n,13] do
       textcolor(9);
       write(q,' '); textcolor(white);
       Write('Z: '); textcolor(9);
       for q in techwrite[n,14] do
       write(q,' ');textcolor(white);
       write(' =>> ');

       for p:= 1 to 9 do
        if techwrite[n,p] <> [] then
        begin
        gotoxy(118,39+p);
        textcolor(red);
        for q in techwrite[n,p] do
        write(q,' ');
        textcolor(white);
        write(' <> '); textcolor(3);write(p);
        textcolor(white);
        end;

         gotoxy(118,49);
           ch:=readkey;

if (ch=#43) or (ch=#45 ) then techclear(0);

           if ch=#43 then n:=n+1;
           if ch=#45 then n:=n-1;

           if (n) > j-1 then n:=0;
           if (n) < 0 then n:=j-1;

          until (ch =#13)
              end;

end;



#23: begin
      textcolor(10);
    if l = #23  then writexy(118,35,'ALS - W - Wings & Rings');
   

       textcolor(8);
       if j = 0 then writexy(118,36,'Found : 0 ');

       if j > 0
        then
         begin
         repeat
       textcolor(10);
       if l = #23  then writexy(118,35,'ALS - W - Wings & Rings');
          textcolor(8);
          writexy(118,36,'Displaying : ');
          write(n+1,' Of ',J,'  ');

          textcolor(white);
          gotoxy(118,37);

if [0] * techwrite[n,17] <> []  then begin       
Write('Set A) [ ');
textcolor(3); for p in (techwrite[n,0]) do write(p,' '); textcolor(white); write('] @ ' ); {numbers}
textcolor(9); for p in (techwrite[n,11]) do write(p,' '); textcolor(white);   {cells}
gotoxy(118,38);
Write('Set B) [ ');
textcolor(3); for p in (techwrite[n,10]) do write(p,' '); textcolor(white); write('] @ '); {numbers}
textcolor(9); for p in (techwrite[n,12]) do write(p,' '); textcolor(white);  {cells}
gotoxy(118,39);write('RC: ( ');
textcolor(3); for p in (techwrite[n,16]) do write(p,' '); textcolor(white); write(') , linked: ,( '); {numbers}
textcolor(3); for p in (techwrite[n,15]) do write(p,' '); textcolor(white); write(') ' ); {number}
textcolor(9); for p in (techwrite[n,13]) do write(p,' '); textcolor(white); write(' = ' ); {cells}
textcolor(9);  for p in techwrite[n,14] do write(p,' '); textcolor(white); write(' ( ');  {cells}
textcolor(3); for p in (techwrite[n,15]) do write(p,' '); textcolor(white); write(') ' ); {number}
end;

if [1] * techwrite[n,17] <> []  then begin    
gotoxy(118,40);
textcolor(3); for p in (techwrite[n,19]) do write(p,' '); textcolor(white); write(') ' ); {number}
textcolor(9); for p in (techwrite[n,18]) do write(p,' '); textcolor(white); write(' = ' ); {cells}
textcolor(9); for p in techwrite[n,20] do write(p,' '); textcolor(white); write(' ( ');  {cells}
textcolor(3); for p in (techwrite[n,19]) do write(p,' '); textcolor(white); write(') ' ); {number}   

end;


write(' =>> ');

for p:= 1 to 9 do
        if techwrite[n,p] <> [] then
        begin
        gotoxy(118,40+p);
        textcolor(red);
        for q in techwrite[n,p] do
        write(q,' ');
        textcolor(white);
        write(' <> ');textcolor(3); write(p); textcolor(white);
        end;
   
      
          gotoxy(140,50);
           ch:=readkey;

if (ch=#43) or (ch=#45 ) then techclear(0);

           if ch=#43 then n:=n+1;
           if ch=#45 then n:=n-1;

           if (n) > j-1 then n:=0;
           if (n) < 0 then n:=j-1;

          until (ch =#13)
              end;

end;




#1: begin
      textcolor(10);
       
      if l=#1 then writexy(118,35,'ALS - M - Wings & Rings');

       textcolor(8);
       if j = 0 then writexy(118,36,'Found : 0 ');

       if j > 0
        then
         begin
         repeat
       textcolor(10);
       if l=#1 then writexy(118,35,'ALS - M - Wings & Rings');

          textcolor(8);
          writexy(118,36,'Displaying : ');
          write(n+1,' Of ',J,'  ');

          textcolor(white);
          gotoxy(118,37);

write('(');  textcolor(3);  for p in techwrite[n,10] do write(p); textcolor(white); write(') - ');
textcolor(9); for p in (techwrite[n,11]) do write(p,' '); textcolor(white); write('-(' );
textcolor(3); for p in (techwrite[n,0]) do write(p); textcolor(white); write(')- ' );
textcolor(9); for p in (techwrite[n,13]) do write(p,' '); textcolor(white); write('=(');
textcolor(3); for p in (techwrite[n,0]) do write(p); textcolor(white); write(')= ');
textcolor(9); for p in (techwrite[n,12]) do write(p,' '); textcolor(white); write('=(');
textcolor(3); for p in (techwrite[n,10]) do write(p); textcolor(white); write(')= ' );
textcolor(9); for p in (techwrite[n,14]) do write(p,' '); textcolor(white); write('- (' );
textcolor(3);  for p in techwrite[n,10] do write(p); textcolor(white); write(')');
write(' =>> ');

for p:= 1 to 9 do
        if techwrite[n,p] <> [] then
        begin
        gotoxy(118,39+p);
        textcolor(red);
        for q in techwrite[n,p] do
        write(q,' ');
        textcolor(white);
        write(' <> ');textcolor(3); write(p); textcolor(white);
        end;
   
      
          gotoxy(118,49);
           ch:=readkey;

if (ch=#43) or (ch=#45 ) then techclear(0);

           if ch=#43 then n:=n+1;
           if ch=#45 then n:=n-1;

           if (n) > j-1 then n:=0;
           if (n) < 0 then n:=j-1;

          until (ch =#13)
              end;
end;

#4: begin
      textcolor(10);     
      if l=#4 then writexy(118,35,'ALS -Split - Wings');
   
       textcolor(8);
       if j = 0 then writexy(118,36,'Found : 0 ');

       if j > 0
        then
         begin
         repeat
       textcolor(10);     
      if l=#4 then writexy(118,35,'ALS -Split - Wings');
          textcolor(8);
          writexy(118,36,'Displaying : ');
          write(n+1,' Of ',J,'  ');

          textcolor(white);
          gotoxy(118,37);

textcolor(9); for p in (techwrite[n,12]) do write(p,' '); textcolor(white); write(' =(' );
textcolor(3); for p in (techwrite[n,10]) do write(p); textcolor(white); write(')= ' );
textcolor(9); for p in (techwrite[n,13]) do write(p,' '); textcolor(white); write('-(');
textcolor(3); for p in (techwrite[n,10]) do write(p); textcolor(white); write(')- ');

textcolor(9); for p in (techwrite[n,0]) do write(p,' '); textcolor(white); write('-(');
textcolor(3); for p in (techwrite[n,11]) do write(p); textcolor(white); write(')- ');
textcolor(9); for p in (techwrite[n,14]) do write(p,' '); textcolor(white); write('= (' );
textcolor(3);  for p in techwrite[n,11] do write(p); textcolor(white); write(')= ' );
textcolor(9); for p in (techwrite[n,15]) do write(p,' '); textcolor(white);
write(' =>> ');

for p:= 1 to 9 do
        if techwrite[n,p] <> [] then
        begin
        gotoxy(118,39+p);
        textcolor(red);
        for q in techwrite[n,p] do
        write(q,' ');
        textcolor(white);
        write(' <> ');textcolor(3); write(p); textcolor(white);
        end;
   
      
          gotoxy(118,49);
           ch:=readkey;

if (ch=#43) or (ch=#45 ) then techclear(0);

           if ch=#43 then n:=n+1;
           if ch=#45 then n:=n-1;

           if (n) > j-1 then n:=0;
           if (n) < 0 then n:=j-1;

          until (ch =#13)
              end;


end;




#14: begin
      textcolor(10);
       writexy(118,35,'Hybrid (Type 4 & 5) - Wings');

       textcolor(8);
       if j = 0 then writexy(118,36,'Found : 0 ');

       if j > 0
        then
         begin
         repeat
       textcolor(10);
       writexy(118,35,'Hybrid (Type 4 & 5) - Wings');
          textcolor(8);
          writexy(118,36,'Displaying : ');
          write(n+1,' Of ',J,'  ');

          textcolor(white);
          gotoxy(118,37);


write('(' );
textcolor(3); for p in ((techwrite[n,16] -(techwrite[n,11]+ techwrite[n,12])) ) do write(p); textcolor(white); write(')- ' );
textcolor(9); for p in (techwrite[n,14]) do write(p,' '); textcolor(white); write('=(');
textcolor(3); for p in (techwrite[n,11]) do write(p); textcolor(white); write(')= ' );
textcolor(9); for p in (techwrite[n,0]) do write(p,' '); textcolor(white); write('-(' );
textcolor(3); for p in (techwrite[n,11]) do write(p); textcolor(white); write('=');
textcolor(3); for p in (techwrite[n,12]) do write(p); textcolor(white); write(')- ' );
textcolor(9); for p in (techwrite[n,10]) do write(p,' '); textcolor(white);write('=(');
textcolor(3); for p in (techwrite[n,12]) do write(p); textcolor(white); write(')= ' );
textcolor(9); for p in (techwrite[n,15]) do write(p,' '); textcolor(white); write('-(' );
textcolor(3); for p in (techwrite[n,11]) do write(p); textcolor(white);write(')');
write(' =>> ');

for p:= 1 to 9 do
        if techwrite[n,p] <> [] then
        begin
        gotoxy(118,39+p);
        textcolor(red);
        for q in techwrite[n,p] do
        write(q,' ');
        textcolor(white);
        write(' <> ');textcolor(3); write(p); textcolor(white);
        end;
   
      
          gotoxy(118,49);
           ch:=readkey;

if (ch=#43) or (ch=#45 ) then techclear(0);

           if ch=#43 then n:=n+1;
           if ch=#45 then n:=n-1;

           if (n) > j-1 then n:=0;
           if (n) < 0 then n:=j-1;

          until (ch =#13)
              end;

end;

END;
textcolor(col2);

end;
Last edited by StrmCkr on Tue Oct 18, 2022 10:23 pm, edited 9 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Displaying txt fuctions

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

Txt Writing function: Show
Code: Select all
procedure writexy(x,y:integer; s:string);
begin
  gotoxy(x,y);
  write(s);
end;

Curser position in grid: Show
Code: Select all
procedure Curser(A,c,d:integer);
var
xr,yr,i:integer;
begin

  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);

if D = 1 then Location(a);
gotoxy(xr,yr);
end;

Moves the Curser in the pm box: Show
Code: Select all
{moves the curser on screen in the pm's box}
procedure curserpm(A,c,d:integer);
var
xr,yr:integer;

begin

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

  textbackground(c);

if d=1 then location(a);
  gotoxy(xr,yr);

end;

Write PM's to screen: Show
Code: Select all
procedure Wpm(R,D,H:integer);
var
A,Xw,Yw,i:integer;
B:numberset;
begin

 if D = 0 {whole grid}
 then
 B:=[0..80];

 if D = 1 then  {only updates the affected cell + peers}
 B:= peer[h] + [h];

 if D = 2 then  {updates the pm cells directly changed}
   B:= [h];

for a in b do

 begin

  textcolor(col2);

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

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

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

 For I:= 1 to 9 do
    if not (I in  (nsector[rx[a]] + nsector[cy[a]+9] + nsector[bxy[a]+18]) + delpm[a] + Ipm[a] + covered[a])//* covered[a] * pm[a]  ))
   and not (a in covered2[i])
  and  (s[a]=[])
    then
       write(I)
      else
       write(space);

 end;
 
textcolor(col2);
writexy(20,23,'   ');
gotoxy(20,23);
write(scount);
writexy(22,24,'   ');
gotoxy(22,24);
write(count);
writexy(17,25,'   ');
gotoxy(17,25);
write(countpm);   
 
if (d<>2) and (table = true) then viewspace;
// only updates view space when it leaves the pm board
end;

tech display screen: Show
Code: Select all
procedure displayTechnique;
var
n:integer;
begin
textcolor(6);
writexy(162,33,'Technique Applied');
textcolor(COL1);
writexy(116, 34,'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');
for n:= 0 to 25 do
 begin
 writexy(116,(35+n),'º');
 writexy(225,(35+n),'º');
 end;
writexy(116, 60,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
textcolor(col2);

end;

view givens: 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(8);
  writexy(42,23,'Build 8');
  writexy(42,24,'Vrs .88');
  textcolor(COL1);
end;

View PM: Show
Code: Select all
procedure ViewPM; { pm grid }
begin
textcolor(27);
writexy(50,33,'Pencil Mark');
textcolor(19);
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, 'º-----------+-----------+-----------º-----------+-----------+-----------º-----------+-----------+-----------º');
writexy( 1 , up+47, 'º           |           |           º           |           |           º           |           |           º');
writexy( 1 , up+48, 'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
textcolor(col2);
end;

Extended Tables: Show
Code: Select all
procedure viewspace;
var
n,xn,q:integer;
begin
textcolor(67);
writexy(1,66,' Extension Tables: ');
textcolor(darkgray);
write('updates while out of PM grid');
textcolor(6);
writexy(50,68,'Row - # x Col');
textcolor(19);
writexy( 1 , 69, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1,70+xn); write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then  write(' | ');

  textcolor(8);
  for q:= 0 to 8 do
   if q in Rnsector[xn,n]  then
       write(q)
      else
      write(space);

textcolor(19);
   if n = 9 then write(' º');

   end;
   if xn = 8 then  writexy( 1 , 71+xn,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;
textcolor(6);
writexy(50,68+12,'Col - # x Row');
textcolor(19);
writexy( 1, 69+12, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1,70+xn+12);
write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then write(' | ');

    textcolor(8);
  for q:= 0 to 8 do
   if q in Rnsector[xn+9,n]  then
       write(q)
      else
      write(space);
   textcolor(19);
   if n = 9 then write(' º');
   end;
   if xn = 8 then writexy( 1 , 71+xn+12,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;

textcolor(6);
writexy(50,68+24,'Box - # x square');
textcolor(19);
writexy( 1 , 69+24, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1,70+xn+24); write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then  write(' | ');

  textcolor(8);
  for q:= 0 to 8 do
   if q in Rnsector[xn+18,n]  then
       write(q)
      else
      write(space);

textcolor(19);
   if n = 9 then write(' º');

   end;
   if xn = 8 then  writexy( 1 , 71+xn+24,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;

textcolor(6);
writexy(50,68+36,'Mini Row - # x Col');
textcolor(19);
writexy( 1 , 69+36, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1,70+xn+36); write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then  write(' | ');

  textcolor(8);
  for q:= 0 to 8 do
   if q in BnR[xn,n]  then
       write(q)
      else
      write(space);

textcolor(19);
   if n = 9 then write(' º');

   end;
   if xn = 8 then  writexy( 1 , 71+xn+36,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;

textcolor(6);
writexy(50+110,68,'Mini Col - # x Row');
textcolor(19);
writexy( 1+110 , 69, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1+110,70+xn); write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then  write(' | ');

  textcolor(8);
  for q:= 0 to 8 do
   if q in BnC[xn,n]  then
       write(q)
      else
      write(space);

textcolor(19);
   if n = 9 then write(' º');

   end;
   if xn = 8 then  writexy( 1+110 , 71+xn,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;
textcolor(6);
writexy(50+110,68+12,'Mini Row - # x Box');
textcolor(19);
writexy( 1+110 , 69+12, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1+110,70+xn+12); write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then  write(' | ');

  textcolor(8);
  for q:= 0 to 8 do
   if q in RnB[xn,n]  then
       write(q)
      else
      write(space);

textcolor(19);
   if n = 9 then write(' º');

   end;
   if xn = 8 then  writexy( 1+110 , 71+xn+12,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;

textcolor(6);
writexy(50+110,68+24,'Mini Col - # x Box');
textcolor(19);
writexy( 1 +110, 69+24, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1+110,70+xn+24); write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then  write(' | ');

  textcolor(8);
  for q:= 0 to 8 do
   if q in CnB[xn,n]  then
       write(q)
      else
      write(space);

textcolor(19);
   if n = 9 then write(' º');

   end;
   if xn = 8 then  writexy( 1+110 , 71+xn+24,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;

textcolor(6);
writexy(50+110,68+36,'ERI(Box) - # x position');
 write('                    Note:'); textcolor(red); write(' pseudo eri');
textcolor(19);
writexy( 1+110 , 69+36, 'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');

for xn:= 0 to 8 do  begin
gotoxy(1+110,70+xn+36); write('º ');
for n:= 1 to 9 do
 begin
  if n <> 1 then  write(' | ');

  textcolor(8);
  for q:= 0 to 8 do
   if q in ERI[xn,n]
    then
     begin
     if pm[secset[xn+18,q]] * [N] = [] then textcolor(red) else textcolor(8);
       write(q);
      end
      else
      write(space);

textcolor(19);
   if n = 9 then write(' º');

   end;
   if xn = 8 then  writexy( 1+110 , 71+xn+36,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');

end;

   textcolor(col2);
   Gotoxy(1,1);
end;

help Menu: 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,'Unsolved:');
  writexy(12,25,'PMs:');

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

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

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

  textcolor(green);
  writexy(50,3,'Arrows    - Direction');
  writexy(50,4,'Home      - Goto Col 1 on Row');
  writexy(50,5,'End       - Goto Col 9 on Row');
  writexy(50,6,'Page up   - Goto Row 1 on Col');
  writexy(50,7,'Page down - Goto Row 9 on Col');
  writexy(50,8,'Backspace - Delete # in cell');
  writexy(50,9,'Delete    - Delete # in cell');
  Writexy(50,10,'Tab       - Switch PM | Grid');
  writexy(50,11,'CRTL + \  - Extended Grids');
  writexy(50,12,'1 - 9     - Enter # into cell');

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

  textcolor(green);

  writexy(50,15,'`         - Solve');
  writexy(50,16,'~         - Batch solve');
  writexy(50,17,'R         - Reset Grid');
  writexy(50,18,'E         - Empty Pm Grid');
  writexy(50,19,'Ctrl  + S - Save Grid String');
  writexy(50,20,'S         - Save Pm state');
  writexy(50,21,'Shift + L - Load Saved Grid');
  writexy(50,22,'L         - Load Saved Pm');
  writexy(50,23,'I         - Import a Grid');
  writexy(50,24,'C         - Isomorphic');
  writexy(50,25,'Crtl + Q  - Automorphic');
  writexy(50,26,'P         - P.O.M');
  writexy(50,27,'Crtl + G  - Generate');
  // writexy(50,29,'CRTl  + F - Brute Force');
  writexy(50,28,'Shift  + F - Dancing Links');

  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,'Crtl + T    - Finned/Sashimi Xwing');
  writexy(81,20,'Shift + F9  - Finned/Sashimi Sword');
  writexy(81,21,'Shift + F10 - Finned/Sashimi Jelly');

   //writexy(81,30,'T          - N x N Fish');

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

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

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

  writexy(116,28, 'D          - Sue De Coq');
  writexy(116,29, 'Shift + E  - Death Blossom');
  writexy(116,30, 'J          - D.D.S');
  writexy(116,31, 'O          - A.D.D.S');

  textcolor(24);
  writexy(160,18,'Cover Set Techniques:');
  textcolor(green);
  writexy(156,19,'F          - N x ( N + K ) Fish');
  writexy(156,20,'M          - SK Loop');
  writexy(156,21,'Shift + J  - Muti Sector Locked Set');

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

  writexy(116,2, 'F11         - W - Wing & Ring');
  writexy(116,3, 'Shift + F11 - M - Wing & Ring');
  writexy(116,4, 'F12         - S - Wing');
  writexy(116,5, 'Shfit + F12 - L2 - Wing');
  writexy(116,6, 'Crtl  + F12 - L3 - Wing');
  writexy(116,7, 'Crtl  + F1  - Strong - Wing & Ring'); 
  writexy(116,8, 'Crtl  + F2  - H 1 - Wing');
  writexy(116,9, 'N           - H 2 - Wing');
  writexy(116,10,'Shift + N   - H 3 - Wing');
  writexy(116,11,'Crtl  + N   - H 4 & 5 - Wing');
  writexy(116,12,'Crtl  + F11 - iW - Wing & Ring');

  textcolor(24);
  writexy(160,1,'Chain Techniques:');
  textcolor(green);
  writexy(156,2,'Crtl + X    - X - Chain ');
  writexy(156,3,'X           - XY - Chain');
  writexy(156,4,'Crtl + Z    - A.I.C ');
  writexy(156,5,'Crtl + K    - ALS  - Chain');
  writexy(156,6,'Crtl + M    - A.I.C + ALS - Chain');

  textcolor(24);
  writexy(160,8,'Symetrical Placement Techniques: semi functioning');
  textcolor(green);
  writexy(156,9, 'Crtl + J     -Fixed Boxes');
  writexy(156,10,'Crtl + F     -Boxes move in bands');
  writexy(156,11,'Crtl + P     -Boxes move Triangular');
  writexy(156,12,'Crtl + U     -Rotational Symmetries');
  writexy(156,13,'Crtl + R     -Diagonal Symmetries');
  writexy(156,14,'Crtl + E     -Stick Symmetries');
  writexy(156,15,'*            -All Symmetries');

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

  writexy(116,16,'A           - ALS  - XZ rule ');
  writexy(116,17,'H           - AHS  - XZ rule ');
  writexy(116,18,'Y           - ALS  - XY rule ');
  writexy(116,19,'Crtl + Y    - AALS - 2RC rule');
  writexy(116,20,'Crtl + V    - N^ALS - N^RC rule');
 
  textcolor(24);
  writexy(120,22,'Named ALS + Chain Techniques:');
  textcolor(green);
 
  writexy(116,23,'Crtl + W    - ALS  - W - Wing & Ring');
  writexy(116,24,'Crtl + A    - ALS  - M - Wing & Ring');
  writexy(116,25,'Crtl + D    - ALS  - S - Wing & Ring');
 

  textcolor(24);
  writexy(160,23,'Transport  Techniques:');
  textcolor(green);
  writexy(156,24,'Z           - T - XY - Wing');
  writexy(156,25,'U           - T - XYZ - Wing');
  writexy(156,26,'Q           - T - WXYZ - Wing');
  writexy(156,27,'T           - T - Barns');
  writexy(156,28,'W           - T - XY-Chain');
  writexy(156,29,'G           - T - ALS-XZ');
  writexy(156,30,'K           - T - ALS-XY');
  writexy(156,31,'V           - T - A.D.D.S');

  writexy(50,56,' PM keystroke ');
  textcolor(24);
  writexy(39,57,'Movment:');
  textcolor(green);
  writexy(39,58,'Arrows    - Direction');
  writexy(39,59,'Home      - Goto Col 1 on Row');
  writexy(39,60,'End       - Goto Col 9 on Row');
  writexy(39,61,'Page up   - Goto Row 1 on Col');
  writexy(39,62,'Page down - Goto Row 9 on Col');
  writexy(39,63,'Backspace - Resets PM #s in cell');
  writexy(39,64,'Delete    - Resets PM #s in cell');
  writexy(39,65,'1 - 9     - Delete # from cell');
 
  textcolor(67);
  writexy(162,61,'Technique Trace ');
  textcolor(24);
  writexy(162,62,'Movment:');
  textcolor(green);
  writexy(162,63,'+          - Next in list');
  writexy(162,64,'-          - Previous in List');
  writexy(162,65,'Enter      - Exit List');
  writexy(162,66,'Colour     =');
  textcolor(3); write(' Digit,');
  textcolor(6); write(' Sector,');
  textcolor(9); write(' Cell,');
  textcolor(red); write(' Exclusion Cell ');

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

Displays curser location & uniqueness: Show
Code: Select all
Procedure location(a:integer); {writes on the screen the Box/Row/Col  & sector }
var
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(bsec[BXY[a]],' ',Rsec[Rx[a]],' ',Csec[Cy[a]],' ');

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

  for i:= 1 to 9 do
   if  not (i in ((nsector[rx[a]] + nsector[cy[a]+9] + nsector[bxy[a]+18]) + Delpm[a] + Ipm[a] + covered[a]))
   and  (s[a]=[]) and not (a in covered2[i])
 
     then
      write(I)
     else
      write(space);
    
if unique = false
  then
   begin
   textcolor(4);
   writexy(28,24,'Error');
   end;
 if unique = True
  then
   begin
   textcolor(6);
   writexy(28,24,'Valid');
   end;
 
if (unique2 = True)
  then
   begin
    textcolor(5);
   writexy(24,25,'Unique Solution');
   end;

if (Zero = True)
  then
   begin
    textcolor(5);
   writexy(24,25,'Zero   Solutions');
   end;
   

 if (unique2 = False) and (zero = false)
  then
   begin
    textcolor(5);
   writexy(24,25,'               ');
   end;   
   
textcolor(col2);
    
end;
Last edited by StrmCkr on Wed Oct 19, 2022 7:24 am, edited 25 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

initiate, load, save , & functions

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

sets all basic data storage: Show
Code: Select all
{resets the starting variables to zero or filled}
procedure initiate;
begin
setlength(S,0);
setlength(S,81);

setlength(Nsector,0);
setlength(Nsector,27);

setlength(delpm,0);
setlength(delpm,81);

setlength(Ipm,0);
setlength(Ipm,81);

setlength(covered,0);
setlength(covered,81);

setlength(covered2,0);
setlength(covered2,10);

Acell:=[];
Ocell:=[0..80];

end;

Erase PM: Show
Code: Select all
procedure emptypm;
var
xn,n:integer;
begin

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

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

      end;

   end;
end;

Arrange: 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
      begin
      S[xa]:=[dig3];
      include(nsector[Rx[xa]],dig3);
     include(nsector[Cy[xa]+9],dig3);
     include(nsector[Bxy[xa]+18],dig3);
        exclude(ocell,xa);
      include(Acell,xa);
     end;
        end;

end;

Import: 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;
   sbrc;
   wpm(1,0,0);
   end;
      writexy(2,26,'                                       ');
end;

save: 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);
 textcolor(yellow );
        writexy(2,15,'Save Grid');
        delay(300);
        writexy(2,15,'         ');
        textcolor(col2);
end;

Load from save: 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]);
     if s[xl] <> []
      then
         begin
      nsector[Rx[xl]]:=nsector[rx[xl]] + s[xl];
      nsector[Cy[xl]+9]:=nsector[cy[xl]+9] + s[xl];
      nsector[bxy[xl]+18]:=nsector[Bxy[xl]+18] + s[xl];
    
        exclude(ocell,xl);
      include(Acell,xl);
      end;
     end;
     close(f);
 end;
 textcolor(yellow );
        writexy(2,15,'Load Grid');
        delay(300);
        writexy(2,15,'         ');
        textcolor(col2);
end;

save PM: Show
Code: Select all
procedure savepm;
var
f: file of nums;
xs,i:integer;
j:nums;
begin

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

{save current pm and grid state}

for xs:= 0 to 80 do
  if  s[xs] = []
   then
    write(F,([1..9]-pm[xs]))
   else
    write(F, ([1..9]-s[xs]));
close(f);

 textcolor(yellow );
        writexy(2,15,'Save PM');
        delay(300);
        writexy(2,15,'       ');
        textcolor(col2);
end;

load PM: 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])) = 8   
       then
       begin
        S[xl]:=[1..9] - ipm[xl];
      nsector[Rx[xl]]:=nsector[rx[xl]] + s[xl];
        nsector[Cy[xl]+9]:=nsector[cy[xl]+9] + s[xl];
        nsector[bxy[xl]+18]:=nsector[Bxy[xl]+18] + s[xl];
      
        exclude(ocell,xl);
      include(Acell,xl);
      end;       
     end;
     close(f);
 end;
 textcolor(yellow );
        writexy(2,15,'Load PM');
        delay(300);
        writexy(2,15,'       ');
        textcolor(col2);
end;

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

active:= false;

countpm:=0;
count:=0;
Scount:=0;

setlength(Rnsector,0);
setlength(Rnsector,27);

setlength(sectorRC,0);
setlength(sectorRC,27);

setlength(Sec,0);
setlength(Sec,27);

setlength(nm,0);
setlength(nm,81);

setlength(pm,0);
setlength(pm,81);

setlength(digitcell,0);
setlength(digitcell,10);

setlength(digitrcb,0);
setlength(Digitrcb,81);

setlength(BnR,0);
setlength(BnR,9);

setlength(BnC,0);
setlength(BnC,9);

setlength(RnB,0);
setlength(RnB,9);

setlength(CnB,0);
setlength(CnB,9);

setlength(sectorN,0);
setlength(sectorN,27);

setlength(Ssector,0);
setlength(Ssector,27);

for xn in ocell do
 begin
     for n:= 1 to 9 do
      if not(N in (nsector[rx[xn]] + nsector[cy[xn]+9] + nsector[bxy[xn]+18] + delpm[xn]  + IPM[xn] + covered[xn]) )
       and not (xn in covered2[n])
       then
        begin       

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

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

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

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

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

       include(sectorN[Rx[xn]],n);
         include(sectorN[Cy[xn]+9],n);
         include(sectorN[Bxy[xn]+18],n);
            
       include(digitcell[n],xn);
         include(PM[xn],n);
         inc(nm[xn]);

         inc(countpm)       

     end;   
        inc(count);   
   end;
 
 for xn in acell do
 if S[xn] <> [] then
  begin 
  inc(scount); 
      sSector[rx[xn]]:= sSector[rx[xn]] +s[xn];
      sSector[cy[xn]+9]:= sSector[cy[xn]+9] +s[xn];
      sSector[bxy[xn]+18]:= sSector[bxy[xn]+18] +s[xn];
  end;
     ERIntersection;
   
{changed these to call from the programs that need them speeding up others that do not use it}
 // cellcombo;
 // links;
 // wLinks;
  //alsfinder;
  //ahsfinder;
end;

Link builder: Show
Code: Select all
Procedure links;{rebuild}
var
N,xn,xn2,q,j,a,b,c,d,e,m,n2,f,l,w,yn,f2,count,count2:integer;
 output: text;
 used,x,x2,z,z2:numberset;
begin
cellcombo;
setlength(Linkset,10,8,0);

for n:= 1 to 9 do
begin
q:=-1;
A:=-1;
b:=-1;
c:=-1;
D:=-1;
e:=-1;
l:=-1;
w:=-1;
used:=[];
 for xn:= 0 to 26 do
   begin

    {bivavle cell}
    if DigitRCB[xn,n] <> []
     then
      begin
           for J in (DigitRCB[xn,n]-used) do
        if nm[j] = 2
          then
              begin
              include(used,j);
           inc(q);         
           setlength(linkset[n][0],q+1);
         
           include(linkset[n][0][q,0],n);
           include(linkset[n][0][q,1],j);

              linkset[n][0][q,2]:=[j];
             
           for m in (pm[j]-[n]) do
            begin
              include(linkset[n][0][q,3],m);          
            linkset[n][0][q,9]:= peer[j] * digitcell[m];
            end;             

              linkset[n][0][q,4]:=cellsec[j];
              linkset[n][0][q,5]:=CellSec[j];          
          
              linkset[n][0][q,6]:=[n];
           linkset[n][0][q,7]:=[m];
              linkset[n][0][q,8]:= peer[j] * digitcell[n] ;   
       
            linkset[n][0][q,10]:=[];
           linkset[n][0][q,11]:=[];
          
           end;
        end;{bivavle}
      
      {bi local}       
      if (sec[xn,n] = 2 )               
         then       
    for J in DigitRCB[xn,n] do
            begin
            
            inc(a);
            
             setlength(linkset[n][1],a+1);
            include(linkset[n][1][a,0],n);
             include(linkset[n][1][a,1],j);
            linkset[n][1][a,2]:= Digitrcb[xn,n] - [j];
            include(linkset[n][1][a,3],n);
            //include(linkset[n,1,a,4],xn);
             linkset[n][1][a,4]:=cellsec[j] {- [xn]};
            // xn  on to sectors  might need to add it again
            for m in digitRCB[xn,n] -[j] do
             linkset[n][1][a,5]:=cellsec[m]{-[xn]};            
               // xn  on to sectors  might need to  add it again
              linkset[n][1][a,6]:=pm[j]-[n];
             linkset[n][1][a,7]:=pm[m]-[n];
             linkset[n][1][a,8]:=peer[j]*digitcell[n] {-[m]};                 
             linkset[n][1][a,9]:=peer[m]*digitcell[n] {-[j]};
            
             linkset[n][1][a,10]:=[];
             linkset[n][1][a,11]:=[]
                end; {bilocal}
            
      { single + grouped & Grouped + single}       
      if (sec[xn,n] <5) and (Sec[xn,n] >2)
          then
            for J in DigitRCB[xn,n] do
              for m in peerRCB[xn] do
                 if  ((DigitRCB[m,n] * DigitRCB[xn,n])  + [j] = DigitRCB[xn,n] )
                     and not ( J in DigitRCB[m,n])   
                      then                
                   begin
            { single + grouped}       
                  inc(b);
            setlength(linkset[n][2],b+1);
            include(linkset[n][2,b,0],n);
             include(linkset[n][2,b,1],j);
            linkset[n][2,b,2]:= Digitrcb[xn,n] - [j];
            include(linkset[n][2,b,3],n);
            linkset[n][2,b,4]:=cellsec[j] {- [xn]};
            include(linkset[n][2,b,5],m);            
             linkset[n][2,b,6]:=pm[j]-[n];
             linkset[n][2,b,7]:=[0];
             linkset[n][2,b,9]:= Digitrcb[m,n]- (DigitRCB[m,n] * DigitRCB[xn,n]) ;
             linkset[n][2,b,8]:= peer[j]* digitcell[n]-(DigitRCB[m,n] * DigitRCB[xn,n]);
            
             linkset[n][2][b,10]:=[];
             linkset[n][2][b,11]:=[];
                 { grouped + single}
                  inc(c);
            setlength(linkset[n][3],c+1);
            include(linkset[n][3,c,0],n);
            linkset[n][3,c,1]:= Digitrcb[xn,n] - [j];
             include(linkset[n][3,c,2],j);            
            include(linkset[n][3,c,3],n);
            include(linkset[n][3,c,4],m);
            linkset[n][3,c,5]:= cellsec[j] {- [xn] };             
            linkset[n][3,c,6]:=[0];
            linkset[n][3,c,7]:=pm[j]-[n];
            linkset[n][3,c,9]:= peer[j] * digitcell[n]-(DigitRCB[m,n] * DigitRCB[xn,n]);
            linkset[n][3,c,8]:= DigitRCB[m,n]  -(DigitRCB[m,n] * DigitRCB[xn,n]) ;
            
            linkset[n][3][c,10]:=[];
            linkset[n][3][c,11]:=[];
                  end;
                  
   {Grouped + grouped}       
if (sec[xn,n] <7) and (Sec[xn,n] >3)
    then
       for J in peerrcb[xn] do
        for m in (peerrcb[xn]-[0..j]) do
        if ((DigitRCB[j,n] * DigitRCB[xn,n]) + (DigitRCB[m,n] * DigitRCB[xn,n]) = (DigitRCB[xn,n]))
           and (DigitRCB[j,n] * DigitRCB[m,n] = [] )               
            then
               begin
            count:= 0;
            count2:=0;
            
              for f2 in (DigitRCB[j,n] * DigitRCB[xn,n]) do
               inc(count);
               
              for f2 in (DigitRCB[m,n] * DigitRCB[xn,n]) do
               inc(count2);
               
         if (count > 1) and (count2 >1)
             then          
           begin
          
               inc(d);
            setlength(linkset[n][4],d+1);
            include(linkset[n][4,d,0],n);
            linkset[n][4,d,1]:=(DigitRCB[xn,n] * Digitrcb[j,n]);
            linkset[n][4,d,2]:=(DigitRCB[xn,n] * DigitRCB[m,n]);
            include(linkset[n][4,d,3],n);
            include(linkset[n][4,d,4],J);
            include(linkset[n][4,d,5],m);            
               linkset[n][4,d,6]:=[0];   
            linkset[n][4,d,7]:=[0];
            linkset[n][4,d,9]:= DigitRCB[m,n] - (DigitRCB[xn,n] * DigitRCB[m,n]);
            linkset[n][4,d,8]:= DigitRCB[j,n] - (DigitRCB[xn,n] * DigitRCB[j,n]);
            
            linkset[n][4][d,10]:=[];
            linkset[n][4][d,11]:=[];
            
            inc(d);
            setlength(linkset[n][4],d+1);
            include(linkset[n][4,d,0],n);
            linkset[n][4,d,2]:=(DigitRCB[xn,n] * Digitrcb[j,n]);
            linkset[n][4,d,1]:=(DigitRCB[xn,n] * DigitRCB[m,n]);
            include(linkset[n][4,d,3],n);
            include(linkset[n][4,d,4],m);
            include(linkset[n][4,d,5],j);            
            linkset[n][4,d,6]:=[0];
            linkset[n][4,d,7]:=[0];   
               linkset[n][4,d,9]:= DigitRCB[j,n] - (DigitRCB[xn,n] * DigitRCB[j,n]);   
               linkset[n][4,d,8]:= DigitRCB[m,n] - (DigitRCB[xn,n] * DigitRCB[m,n]);
            
            linkset[n][4][d,10]:=[];
            linkset[n][4][d,11]:=[];

              end;
         end;

//  max er as others are covered in class 1,2,3,4         
if (sec[xn,n] <6) and (Sec[xn,n] >4) and (xn in [18..26])
 and (popcnt(dword(eri[xn-18,n])) = 1)
  then
   for J in eri[xn-18,n] do     
         begin      
      inc(w);
      setlength(linkset[n][5],w+1);
      include(linkset[n][5,w,0],n);
      linkset[n][5,w,1]:=(DigitRCB[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][5,w,2]:=(DigitRCB[xn,n] * DigitRCB[Cy[secset[xn,j]]+9,n]);
      include(linkset[n][5,w,3],n);
      include(linkset[n][5,w,4], rx[secset[xn,j]]);
      include(linkset[n][5,w,5],  Cy[secset[xn,j]]+9);
       linkset[n][5,w,6]:=[0];
      linkset[n][5,w,7]:=[0];
      linkset[n][5,w,8]:= DigitRCB[Rx[secset[xn,j]],n]  - (Digitrcb[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][5,w,9]:= DigitRCB[Cy[secset[xn,j]]+9,n]  - (Digitrcb[xn,n] * Digitrcb[Cy[secset[xn,j]]+9,n]);
      
               linkset[n][5][w,10]:=[];
            linkset[n][5][w,11]:=[];      
      
      inc(w);
      setlength(linkset[n][5],w+1);
      include(linkset[n][5,w,0],n);
      linkset[n][5,w,2]:=(DigitRCB[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][5,w,1]:=(DigitRCB[xn,n] * DigitRCB[Cy[secset[xn,j]]+9,n]);
      include(linkset[n][5,w,3],n);
      include(linkset[n][5,w,5], rx[secset[xn,j]]);
      include(linkset[n][5,w,4],  Cy[secset[xn,j]]+9);       
       linkset[n][5,w,6]:=[0];
      linkset[n][5,w,7]:=[0];
      linkset[n][5,w,9]:= DigitRCB[Rx[secset[xn,j]],n]  - (Digitrcb[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][5,w,8]:= DigitRCB[Cy[secset[xn,j]]+9,n]  - (Digitrcb[xn,n] * Digitrcb[Cy[secset[xn,j]]+9,n]);

               linkset[n][5][w,10]:=[];
            linkset[n][5][w,11]:=[];
 end;
//end;    
         
// (2 cells)min -> (5cells) max er for "er code"          
if (sec[xn,n] <6) and (Sec[xn,n] >1) and (xn in [18..26])
   then
     for J in eri[xn-18,n] do
      begin      
      inc(e);
      setlength(linkset[n][6],e+1);
      include(linkset[n][6,e,0],n);
      linkset[n][6,e,1]:=(DigitRCB[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][6,e,2]:=(DigitRCB[xn,n] * DigitRCB[Cy[secset[xn,j]]+9,n]);
      include(linkset[n][6,e,3],n);
      include(linkset[n][6,e,4], rx[secset[xn,j]]);
      include(linkset[n][6,e,5],  Cy[secset[xn,j]]+9);
       linkset[n][6,e,6]:=[0];
      linkset[n][6,e,7]:=[0];
      linkset[n][6,e,8]:= DigitRCB[Rx[secset[xn,j]],n]  - (Digitrcb[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][6,e,9]:= DigitRCB[Cy[secset[xn,j]]+9,n]  - (Digitrcb[xn,n] * Digitrcb[Cy[secset[xn,j]]+9,n]);
      
               linkset[n][6][e,10]:=[];
            linkset[n][6][e,11]:=[];      
      
      inc(e);
      setlength(linkset[n][6],e+1);
      include(linkset[n][6,e,0],n);
      linkset[n][6,e,2]:=(DigitRCB[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][6,e,1]:=(DigitRCB[xn,n] * DigitRCB[Cy[secset[xn,j]]+9,n]);
      include(linkset[n][6,e,3],n);
      include(linkset[n][6,e,5], rx[secset[xn,j]]);
      include(linkset[n][6,e,4],  Cy[secset[xn,j]]+9);       
       linkset[n][6,e,6]:=[0];
      linkset[n][6,e,7]:=[0];
      linkset[n][6,e,9]:= DigitRCB[Rx[secset[xn,j]],n]  - (Digitrcb[xn,n] * Digitrcb[Rx[secset[xn,j]],n]);
      linkset[n][6,e,8]:= DigitRCB[Cy[secset[xn,j]]+9,n]  - (Digitrcb[xn,n] * Digitrcb[Cy[secset[xn,j]]+9,n]);

               linkset[n][6][e,10]:=[];
            linkset[n][6][e,11]:=[];
 end;
 
 // strong link builder for als
// not reversable as this code generates the reverse automatically 
  for  F:= high(als) downto 0 do
      if (als[F,0] = xn) and (n in comboset[als[f,4]])
     and (als[f,1] >1 ) // no bivavles
     //and (als[f,1] <8 )  // disable this during testing
       and  (als[F,1]+1 = als[F,2])  // n cells can only n+1 digits
      
        then
       for J in (comboset[als[f,4]] - [n]) do       
            begin
           inc(l);
          
            setlength(linkset[n][7],L+1);
            
            include(linkset[n][7][L][0],n);
            linkset[n][7][L][1]:= digitcell[n] * Combosets[als[f][0],als[f][3]];
            linkset[n][7][L][2]:= digitcell[j] * Combosets[als[f][0],als[f][3]];
            include(linkset[n][7][L][3],j);
            
            x:=[0..26];             
                     for m in digitcell[n] * Combosets[als[f][0],als[f][3]] do
                           x:= x * cellsec[m];
            linkset[n,7,l,4]:=x;
            
            x2:=[0..26];             
                     for m in digitcell[j] * Combosets[als[f][0],als[f][3]] do
                           x2:= x2 * cellsec[m];   
                     
            linkset[n,7,l,5]:=x2;   

            linkset[n][7,l,6]:=[0];
              linkset[n][7,l,7]:=[0];
            
        z:=[];
        z2:=[];
       
        for m in [0..80] do
           if peer[m] * (digitcell[n] * Combosets[als[f][0],als[f][3]])
           = (digitcell[n] * Combosets[als[f][0],als[f][3]])
            then
                  include(z,m);
             
             linkset[n,7,l,8]:=linkset[n,7,l,8]+z;
      
        for m in [0..80] do
           if peer[m] * (digitcell[j] * Combosets[als[f][0],als[f][3]])
           = (digitcell[j] * Combosets[als[f][0],als[f][3]])
            then
              include(z2,m);
            
            linkset[n,7,l,9]:=linkset[n,7,l,9]+z2;          
         
                linkset[n][7][l][10]:=Combosets[als[f][0],als[f][3]];
            
            linkset[n][7][l][11]:=comboset[als[f,4]];
         
         
            end;          

end;
end;

//delete(linkset[1,1],1,1);
for n2 in [1..9] do
for xn in [1..1] do
 begin
 for J:= low(linkset[n2][xn]) to ((high(linkset[n2][xn]))-1) do   
   for M:= j+1 to high(linkset[n2][xn]) do         
      if (linkset[n2][xn][j][1] * linkset[n2][xn][m][1] = linkset[n2][xn][j][1])
       and (linkset[n2][xn][j][2] * linkset[n2][xn][m][2] = linkset[n2][xn][j][2])
       then
         begin       
             delete(linkset[n2,xn],m,1);
        break;
       end;          
end;

// writting txt file output to verify manually
assign(output,'C:\sudoku\stronglink.txt');
erase(output);
rewrite(output);
close(output);

for n2 in [1..9] do
for xn in [0..7] do
 for J:= low(linkset[n2][xn]) to high(linkset[n2][xn]) do
 begin
   append(output);
      writeln(output);   
         write(output,'#',n2,' | ');
          write(output,'type:',xn,' | ');      
      for n:= low(linkset[n2][xn,j]) to high(linkset[n2][xn,j]) do
       begin
          for M in linkset[n2][xn,j,n] do
        write(output,m,',');
        write(output,' | ');
      end; 
      close(output);      
 end;

end;{strong link builder}

error checker: Show
Code: Select all
{CHECKS THE GRID FOR INVALID STATES}
procedure errorcheck;
var
XN,N,YN,counting,s,f,k:INTEGER;
count2:RCBnums;
Begin
UNIQUE:= TRUE;

  {redundant checks as they are found below}
{FOR XN:= 0 TO 80 Do
 BEGIN

 //no cell and pm can be empty
 IF (s[XN] = [])  AND (nm[XN] =0 )
  THEN
    UNiQUE:= FALSE;

 //no peer cell of xn, can have the same solved digit
 FOR N IN S[XN] Do
 FOR YN IN PEER[XN] DO
   IF N IN S[YN]
     THEN
       UNIQUE:= FALSE;
END;  }

For xn:= 0 to 26 do
begin

if (sectorN[xn] <>  [1..9]-ssector[xn] )  { and (sectorN[xn] <> [])} {shows mutiple digits pms are missing in full}
 then
  unique:=false;

if (sectorN[xn] <> []) and (sectorN[xn] = [1..9] - ssector[xn]) then
 begin
 Counting:= 0;
 count2:=[];

{no sector can have less digits then unsolved cells
no sector can have more digits then unsolved cells}
   for n in sectorN[xn] do
     begin
      inc(counting);
      count2:= Rnsector[xn,n] + count2;
      end;
     if popcnt(dword((count2))) <> counting
      then
      unique:= false;
 
end;   
   { no subset can have less cells then the subset digit count}

For f in [1..8] do
for yn:= slist[F] to flist[F] do
  if comboset[yn] * sectorN[xn] = comboset[yn]
    then
    begin
     S:= 0;
      count2:=[];

   for n in sectorN[xn] * comboset[yn] do
     begin
      inc(S);
      count2:= Rnsector[xn,n] + count2;
      end;
     if popcnt(dword((count2))) < S
      then
        unique:= false;
    end;
end;
END;

Cell combinations: Show
Code: Select all
procedure Cellcombo;      { builds a list of active cells for specific comboset}
var
xn,n,j:integer;

begin

setlength(combocell,0);
setlength(Combocell,511);

setlength(Combosubset,0);
setlength(Combosubset,511);

setlength(Combonum,0);
setlength(Combonum,511);

setlength(HCombonum,0);
setlength(HCombonum,511);

   for xn:= 0 to 510 do
  begin
 
   for n in [0..26] do
    begin
   
    for j in comboset2[xn] do
    combonum[xn,n]:=combonum[xn,n] + SectorRC[n,j];
   
    for j in comboset[xn] do
     Hcombonum[xn,n]:=Hcombonum[xn,n] + RNSector[n,j];

   end;   

for n in ocell do
   begin

     if (pm[n] * comboset[xn] = pm[n]  )
      and (pm[n] - comboset[xn] = [])
      and (pm[n] <> [])
       then
        include(combocell[xn],n);

     if (pm[n] * Comboset[xn] <> [] )
     and( pm[n] <> [])
      then
       include(combosubset[xn],n);
      end;

     end;

end;

ERI finder: Show
Code: Select all
{builds the data base for ERi}
procedure ERIntersection;
var
n,yn,xn,xa,ya,I,j:integer;
begin

setlength(ERi,0);
setlength(ERi,9);

 for xa:= 0 to 8 do
 For n:= 1 to 9 do
   ERi[xa,n]:=[];

 for n:= 1 to 9 do
    for xa:=0 to 2 do
     for ya:=0 to 2 do
   
     if   (Sec[xa*3+ya+18,n] < 6) and (sec[xa*3+ya+18,n] > 1 )
   then    
       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[yn+9,n] * digitrcb[j+18,n] )
           +    (digitRCB[xn,n] * digitrcb[j+18,n] )
           =    (digitRCB[j+18,n]) )

         and  ( DigitRCB[j+18,n] <> [] )
         and  ((digitRCB[yn+9,n] * digitrcb[j+18,n] ) - DigitRCB[xn,n]  <> [])
         and  ((digitRCB[xn,n] * digitrcb[j+18,n] ) - DigitRCB[yn+9,n]  <> [])
          then
      
           eri[j,n]:=ERI[j,n]+ [bxyn[Rset[xn,yn]]]; { box,n saving position}
      

       end;

end;

ALS finder: Show
Code: Select all
procedure alsfinder;
 var
 xn,yn,yn2,l,j,m,r,s,f:integer;
 output: text;

 begin
cellcombo;

{assign(output,'C:\sudoku\combotest.txt');
erase(output);
rewrite(output);
close(output);}

R:=-1;
setlength(als,r+1,5);
 for xn:= 0 to 26 do  {"A" sector search}
  for L:= 1 to 8 do  { N cell  postion  size max is 8 for +1 digits}
  if popcnt(dword(sectorN[xn])) >= 2 then  {skips sectors that have less then 2 digits}
         if ((L < 2) and (xn in [18..26] ) )
           or ( l > 1)
            then

 for M:= 0 to (8-L) do {sets the digit count  flex range and links required based on l}
  begin
  J:= M+L +1; {sets the digit count size}
 if popcnt(dword(sectorN[xn])) >= j then  {skips sectors with less then j digit}

   for yn:= Slist[l] to flist[l] do {position size}
   if not((xn in [0..17]) and (  yn in [9,10,17,30,31,35,42,43,44] ) and (l =2)) {duplicate skipping code}
   and not( (xn in [0..17]) and (yn in [45,109,128]) and (l =3))
    then
   if ( combocell[510] * combosets[xn,yn] = combosets[xn,yn] )  {checks that all active cells for the selected set are active}
    then
   if  (popcnt(dword(Combonum[yn,xn])) = j)     {checks that the # of active cells only have J digit}
    then
   for yn2:= Slist[j] to flist[j] do  {digit count}
   if (sectorN[xn] * comboset[yn2] = comboset[yn2] )  {checks the set selected has all digits }
    then
       if  (combocell[yn2] * combosetS[xn,yn]  = combosetS[xn,yn])  {digit count matches position size}
     then
      begin
      r:=r+1;
      setlength(als,R+1,5);
      als[R,0]:=xn;
      als[R,1]:=l;
      als[R,2]:=j;
      als[R,3]:=yn;
      als[R,4]:=yn2;   
     { append(output);
      if R > 0 then  writeln(output);
       write(output,als[r,0],' ',als[r,1],' ',als[r,2],' ',als[r,3],' ',als[r,4]);   
      close(output);}      
      end;      
end;
{
writexy(2,60,' ');
write(r,' ');
write(high(als));}
end;

AHS finder: Show
Code: Select all
procedure aHsfinder;
 var
 xn,yn,yn2,l,j,m,r,s,f:integer;
 output: text;
 begin

assign(output,'C:\sudoku\combotest.txt');
erase(output);
rewrite(output);
close(output);      

Cellcombo;
 
 r:=-1;
 setlength(ahs,r+1,5);

 for xn:= 0 to 26 do
    for L:= 1 to 8 do {digits}
   if (popcnt(dword(sectorN[xn])) >= l)
    then
     for m:= 0 to (8 - L) do  {sets the Cell count  flex range and links required based on l}
       begin
       J:= (M+L)+1; {cell size}

 for yn:= Slist[l] to flist[l] do  {digit set used}
if (sectorN[xn]*comboset[yn]) = comboset[yn]  {digit set must match exactly}
 then
   for yn2:= Slist[j] to flist[j] do  {cells} {cycles the positions listing based on the set}
    if not((xn in [18..26]{[0..17]}) and (  yn2 in [9,10,17,30,31,35,42,43,44] ) and (J =2)) {duplicate skipping code}
   and not( (xn in [18..26]{[0..17]}) and (yn2 in [45,109,128]) and (J =3))
    then
       if   hcombonum[yn,xn]  = comboset2[yn2] {position count matchs, j size}
         then
           begin
          R:=R+1;
           setlength(ahs,R+1,5);
            ahs[R,0]:=xn; {sector}
            ahs[R,1]:=l;  {Digit size}
            ahs[R,2]:=j;  {cell size}
            ahs[R,3]:=yn; {digits}
            ahs[R,4]:=yn2; {cells position}
         
       append(output);
      if R > 0 then  writeln(output);
       write(output,ahs[r,0],' ',ahs[r,1],' ',ahs[r,2],' ',ahs[r,3],' ',ahs[r,4]);   
      close(output);   
         end;

        end;
end;
Last edited by StrmCkr on Tue Oct 18, 2022 10:58 pm, edited 13 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Peer building functions

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

Combination set: 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: Show
Code: Select all
procedure combo;
var
vx : array [0..8] of integer;
   n,l,m,count,xn : 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]) ];

      for xn:= 0 to 8 do
       begin
       combosetS[xn,count]:= combosetS[xn,count] + [Rset[xn,(vx[l])]];
       combosetS[xn+9,count]:= combosetS[xn+9,count] + [Cset[xn,(vx[l])]];
       combosetS[xn+18,count]:= combosetS[xn+18,count] + [Bset[xn,(vx[l])]];
       end;

     end;

     inc(count);

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

  end;
end;

peers: Show
Code: Select all
{compiles a list of cells each cell can visibly see}

procedure peers;
var
xa,xa2,z:integer;
number1:numberset;
number2:RCBpeer;

begin

for xa:= 0 to 80 do
  begin

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

     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;
              number2:=number2 + [Rx[xa2]]+[cY[XA2]+9]+[bXY[XA2]+18];

              inc(z);

             end;

       peer[xa]:=number1;

 end;

end;

RCBpeers: 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;


         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: Show
Code: Select all
procedure lookupSectorRBC;
var
xn,n,r:integer;
a: numberset;
begin

for xn:= 0 to 26 do
for r:= 0 to 510 do
 begin
 a:=[];
  for n in comboset2[r] do
    begin
       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]];      
     end;
   SectorRCB[xn,r]:= A;
end;
end;

set cell sector: Show
Code: Select all
procedure setCellsec;
var
xn:integer;
begin

for xn:= 0 to 80 do
  cellsec[xn]:= [Rsec[Rx[xn]]] + [Csec[Cy[xn]]] + [Bsec[Bxy[xn]]];

end;

sector overlaps marker: Show
Code: Select all
procedure sectoroverlap;{marks the overlaping "positions" within 2 sectors}
var
xn,yn,n,n2:integer;
begin

for xn:=0 to 26 do
  for yn:= 0 to 26 do
   secover[xn,yn]:=[];

for xn:=0 to 26 do
  for yn:= 0 to 26 do

     for n:= 0 to 8 do
      for n2:= 0 to 8 do
   
      if secset[xn,n] = secset[yn,n2]
          then
          begin

         secOver[xn,yn]:=secOver[xn,yn]+ [n,n2];
                  
         end;    

end; {marks the overlaping "positions" within 2 sectors}
Last edited by StrmCkr on Tue Oct 18, 2022 11:05 pm, edited 7 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Main Body & controllers

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

Timer Control: Show
Code: Select all
{Timmer for executing solving commands}
//  command functions
Procedure time(v:char);
var
 st,et,hz:int64;
      ms:double;
begin

setlength(techwrite,0,0);

sbrc;

queryperformancecounter (st);

case v of

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

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

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

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

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

#60: blr(0);

#85: xwing(0);
#20:smashi(0); {finned/sashi x-wings}
#64: sky(0);  {skyscrappers}
#65: er(0);
#66: kyte(0);
#67: Swordfish(0);
#92: smashiswords(0);

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

#122: transbarns(1,3,1,3); {T-xy-wing}
#117: transbarns(1,3,2,3); {T-xyz-wing}
#113: transbarns(1,4,0,4); {T-wxyz-wing}

#133: Wwing(1);
#137: iWwing(1);
#135: mwing(1);
#134: swing(1);
#136: L2wing(1);
#0138: l3wing(1);

#94: Strongwing(1);

#095: H1wing(1);
#110: H2wing(1);
#78:  H3wing(1);
#14:  H45wing(0);
{

#117: URt12456;
#104: HUR; }

#24: xchain(1);
#120: XYchain(1);
#26: AIC(1);
#13: AICWals(1);

#97: alsxz(0);
#104: Ahsxz(0);
#121: alsxy(0);
#25: AAls2RC(0);
#11:AlsME(1);
#22:NalsNRC(1);

#23: alsWwing(0);
#1: alsMwing(0);
#4: alsSwing(0);

#98: Barns(1,0,0,6);

#116: transbarns(1,0,0,6);
#103: transalsxz(1);
#107: transalsxy(1);

#100: Suedecoq(1,1,2);
#69: DeathBlossom(1,2,3);

#106: DDS(1,0,9);
#111: ADDS(1,0,9);

#109: skloop(1);
#74:  msls(1);

#118: TransADDS(1,0,6);

#119: Transxychain(0);

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

#96:  solve;
//#06: bruteforce;

#99: issomorph('0','s','f'); // manual puzzle swapping.
#10: Symetricalplacements(#10);// FixedBoxes;
#6:  Symetricalplacements(#6);// BoxesMnBands;
#16: Symetricalplacements(#16);// boxesMTri;
#21: Symetricalplacements(#21);// rotsym;
#18: Symetricalplacements(#22);// diasym;
#5:  Symetricalplacements(#5);//sticks;
#42: Symetricalplacements(#42);//all;
#17: Symetricalplacements(#17);// automorph finder;

#112: potential;

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;
  errorcheck;
  wpm(0,0,0);
 
 end;

if v =#96 then wpm(0,0,0);
if v = #99 then wpm(1,0,0);
end;

Main Body: Show
Code: Select all
program stormdoku;                           //notes  popcnt(dword(set variable))); // counts # elments in a set
 uses crt,windows,Largesets,generics.collections;//,Dialogs;

{$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  {$include Global.pas} //virables
  {$include writexy.pas} // screen writing tool
  {$include location.pas} // writes sector/b/r/c locations per cell
  {$include Curser.pas}   // moves around the grid screen
  {$include Curserpm.pas} // moves around the pm screen
  {$include viewtables.pas} // extended table view
  {$include WPM.pas} // displaying data function
  {$include techdisplay.pas} // write to screen functions for technique sets
  {$include chaindisplay.pas} // writting function for chain codes{upgrading techdisplay}
  {$include Griddisplay.pas} // grid layout setup
  {$include help.pas} // information for keystrokes
  {$include tools.pas}// builds the peers list and combination sets
  {$include errorcheck.pas} // checks the grid for invalid states
  {$include startuptools.pas} // intiation tools for grid starting points
  {$include CellCombo.pas} // {runs after sbrc calls} builds data tables for the 0..510 combinations for sets in sectors and cells
  {$include ERIfinder.pas} // builds the ERI tables
  {$include alsbuilder.pas} // {runs after sbrc calls} als & ahs data builder}
  {$include Stronglinkbuilder.pas} // runs after sbrc call,: strong link data builder
  {$include sbrc.pas} // calculator tool for setting variables
  {$include Load.pas} // loads a saved data file
  {$include save.pas} // save a grid to data file
  {$include import.pas} // imports a 81 character string and aranges it on the grid
  {$include SymetricalPlacement.pas} // collection of gurths symetrical methods for solving
  {$include solvingtechniques.pas} // all solving tools added todate
  {$include Solve.pas} // solving code that searches all techniques on a given grid
  {$include BatchSolve.pas} // batch - solving code for a txt file containing puzzles
  {$include TimeControl.pas} // controls the execution of solving commands
  {$include dlx_solve.pas} // dancing links unique proticals
  {$include GenSolver.pas} // solving techniques added to generator
  {$include DLX.pas} // dancing links execution calls
  {$include generator.pas} // grid generator  - has a odd glitch and will crash sometimes
 
//main body
begin
Clrscr;

Window(1,1,240,240);

table:=false;
Unique:=true;

TextBackGround(COLBG);

peers;
RCBpeers;
combo;
setCellsec;
lookupSectorRBC;
sectoroverlap;

viewgiven;
viewpm;
Help;
displayTechnique;

initiate;
wpm(0,0,0);

x:=0; y:=0;

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

     ch:=readkey;

{add a digit to cell }
    if( ch=' ') then ch:='0';
   
      if( ch in ['1'..'9']) then
      begin

       if s[rset[x,y]] <> []
        then
         begin
                  nsector[rx[rset[x,y]]]:= Nsector[rx[rset[x,y]]] - s[rset[x,y]];
                nsector[cy[rset[x,y]]+9]:= nsector[cy[rset[x,y]]+9] - s[rset[x,y]];
                nsector[bxy[rset[x,y]]+18]:= nsector[bxy[rset[x,y]]+18] - s[rset[x,y]];   
                     
            s[rset[x,y]]:=[ord(ch) - ord('0')];
            
            nsector[rx[rset[x,y]]]:= Nsector[rx[rset[x,y]]] + [ord(ch) - ord('0')];
                nsector[cy[rset[x,y]]+9]:= nsector[cy[rset[x,y]]+9] + [ord(ch) - ord('0')];
                nsector[bxy[rset[x,y]]+18]:= nsector[bxy[rset[x,y]]+18] + [ord(ch) - ord('0')];
            
            for iter in peer[rset[x,y]] do
             if s[iter]<> []
             then
              begin
              nsector[rx[iter]]:= Nsector[Rx[iter]] + s[iter];
              nsector[cy[iter]+9]:= Nsector[cy[iter]+9] + s[iter];
              nsector[bxy[iter]+18]:= Nsector[bxy[iter]+18] + s[iter];
              end;
                    
            
          end

        else
      begin            
      
        nsector[rx[rset[x,y]]]:= Nsector[rx[rset[x,y]]] +[ord(ch) - ord('0')];
          nsector[cy[rset[x,y]]+9]:= nsector[cy[rset[x,y]]+9] + [ord(ch) - ord('0')];
          nsector[bxy[rset[x,y]]+18]:= nsector[bxy[rset[x,y]]+18] + [ord(ch) - ord('0')];   
      
        s[rset[x,y]]:= [ord(ch) - ord('0')];
      
        exclude(ocell,rset[x,y]);
        include(Acell,rset[x,y]);
        end;
      
      sbrc;
      errorcheck;
      wpm(0,1,rset[x,y]);
      
      end;

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

          for iter in peer[rset[x,y]]  do
           Ipm[iter]:= ipm[iter] - S[rset[x,y]];

           ipm[rset[x,y]]:=[];
   
           nsector[rx[rset[x,y]]]:= Nsector[rx[rset[x,y]]] - s[rset[x,y]];
            nsector[cy[rset[x,y]]+9]:= nsector[cy[rset[x,y]]+9] - s[rset[x,y]];
            nsector[bxy[rset[x,y]]+18]:= nsector[bxy[rset[x,y]]+18] - s[rset[x,y]];
         
        s[rset[x,y]]:=[];
      
        for iter in peer[rset[x,y]] do
             if s[iter]<> []
             then
              begin
              nsector[rx[iter]]:= Nsector[Rx[iter]] + s[iter];
              nsector[cy[iter]+9]:= Nsector[cy[iter]+9] + s[iter];
              nsector[bxy[iter]+18]:= Nsector[bxy[iter]+18] + s[iter];
              end;
      
       exclude(Acell,rset[x,y]);
       include(ocell,rset[x,y]);
      
       sbrc;
       errorcheck;
        wpm(0,1,rset[x,y]);      
      end;   

        {functions}

    { 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 y:=0;
    if( x < 0 ) then x:=8;
    if( x > 8 ) then x:=0;
   
    if( ch=#105 ) then import;
   
    {load from saved grid }
    if( ch=#76 ) then begin load; sbrc; wpm(1,0,0); errorcheck; end;
   
      {load pm from saved  }
    if( ch=#108 ) then begin  loadpm; sbrc; wpm(1,0,0); errorcheck;  end; {import file}
   
     {save grid to file}
    if( ch=#19 ) then  save;    
   
   {save pm to file}
    if( ch=#115) then begin  savepm; end;

    {reset everything}
    If( ch=#114 ) then begin initiate; sbrc; wpm(1,0,0); end;
   
     {clears the pencil mark space to blank }
    if (ch = #101) then begin emptypm;  wpm(1,0,0) end;
   
      {turn on or off extended table generation}
    if (ch=#28) then
         begin
           if table = true then table:=false else table:= True;
         
          if table = true then begin sbrc; viewspace; end;
          textcolor(darkgray);
          if table = true then  writexy(6,67,' Enabled ');
          if table = false then writexy(6,67,' Disabled ');
          textcolor(col2);
         
       end;
      
       {batch solve mode}
    if( ch=#126) then batch;
   
   {dancing links}
    if (ch = #70) then begin dlx; end;  {shift F}
   
   {generate a grid}
    if (ch=#7) then begin  generator; sbrc; wpm(1,0,0) end;
   
   {solving buttons}
    if ch in [#1,#4,#5,#6,#10,#11,#13,#14,#16,#17,#18,#20,#21,#22,#23,#24,#25,#26]+
            [#42,#59,#60,#61,#62,#63,#64,#65,#66,#67,#68,#69] +
            [#74,#78,#84,#85,#86,#87,#88,#89,#90,#91,#92,#93,#94,#95]+
          [#96,#97,#98,#99,#100,#102,#103,#104,#106,#107,#109]+
          [ #110,#111,#112,#113,#116,#117,#118,#119,#120,#121]+
          [#122,#133,#134,#135,#136,#137,#0138]
           then
             time(ch);
   

    { tabs into the pm grid }

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

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

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

         end;

           {resest the pm deletions }
         if ( ch=#8 ) or ( ch=#83 ) or (ch='0') then
            begin
              delpm[ rset[x,y] ]:=[];
           Ipm[ rset[x,y] ]:=[];
         
           sbrc;
           errorcheck;
            wpm(0,2,rset[x,y]);
            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;

      if (ch=#9 ) or (ch =#15) or (ch=#27 )
       then
        begin
          if table = true then begin sbrc; viewspace; end;
      end;    

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


    until (ch=#27);


end.

solver: Show
Code: Select all
Procedure solve;
var
Count2,Countpm2: integer;
begin

repeat

Countpm2:=countpm;
count2:= count;

if scount = 0  then break; {solved is empty grid is empty}

if count = 0 then break;   {no more empty cells}

if unique = false then break; {errors on the grid}

 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,3);  //xy-wing
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    barns(1,3,2,3);  //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
    barns(1,4,0,4);  //xyz-wing
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    sky(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
    smashi(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(0);
     if active= true
      then
       begin
        sbrc;
       end;

   end;


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

   if  (countpm2 = countpm)  and (count2 = count)
  then
   begin
    transbarns(1,3,2,3);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

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


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


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

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


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

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

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


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

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

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

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

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

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

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

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


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

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

   end;

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

   end;

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

   end;

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

   end;

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


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

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

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

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

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

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

   end;

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

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

   end;

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


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

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

errorcheck;

until  (countpm2=countpm) or (scount = 81) or (unique=false);
end;

Generator sovler: Show
Code: Select all
Procedure solve2(K:integer);
var
Count2,Countpm2: integer;
begin
 
repeat

Countpm2:=countpm;
count2:= count;

if count = 81 then break;

if  (countpm2 = countpm)  and (count2 = count)  and (k >0 )
  then
   begin
    BLR(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;
{
if  (countpm2 = countpm)  and (count2 = count)  and (k >8 )
  then
   begin
    hp(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

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

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

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

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

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

if  (countpm2 = countpm)  and (count2 = count)   and (k >10 )
  then
   begin
    barns(1,3,1,3);  //xy-wing
     if active= true
      then
       begin
        sbrc;
       end;
   end;

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

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

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

if  (countpm2 = countpm)  and (count2 = count)  and (k >15 )
  then
   begin
    sky(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

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

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

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

if  (countpm2 = countpm)  and (count2 = count)  and (k >16 )
  then
   begin
    jellyfish(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)  and (k >16)
  then
   begin
    smashiswords(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;

if  (countpm2 = countpm)  and (count2 = count) and (k >16)
  then
   begin
    smashijelly(1);
     if active= true
      then
       begin
        sbrc;
       end;
   end;}
until  (countpm2=countpm) or (count = 81)
end;

batch solver: Show
Code: Select all
{batch solve a file}
procedure batch;
var

myfile:text;
ior:integer;
filename:string;
verifygrid:integer;
G2,S2:real;
st,et,hz:int64;
ms:double;

Begin

initiate;
sbrc;
wpm(0,0,0);

G2:=0;
S2:=0;

    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;

     queryperformancecounter (st);
      repeat
        begin
          initiate;

           readln(myfile,Grid);

           Verifygrid:= length(Grid);

          if verifygrid = 81
            then
             begin         
               arange;
               
            sbrc;
            errorcheck;
            
               g2:=g2+1;

          if unique = true
              then
               solve;

                if sCount=81
                   then
                     s2:=s2+1;

                if (unique = false) then begin wpm(1,0,0); break; end;

                end;

           end;
         until eof(myfile);

        close(myfile);

      queryperformancecounter (et);
      queryperformancefrequency (hz);

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

      ms := G2 * 1000.0 / ms;

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

   gotoxy(2,30);
   write('Solved ',round(S2),' | ',round(G2),' Puzzles');

 end;{batch solve}

Technique linker: Show
Code: Select all
// all solving techniques added in 1 file instead a massive list on the main program {with notes}
{$include HiddenSingle.pas} //
{$include HiddenPair.pas} //
{$include HiddenTripple.pas} //
{$include HiddenQuad.pas}//
{$include NakedSingle.pas}//
{$include NakedPair.pas}//
{$include NakedTripple.pas}//
{$include NakedQuad.pas}//
{$include BoxLineReduction.pas}//
{$include XWing.pas}//
{$include FinnedSmashiXwing.pas}//
{$include Skyscraper.pas}//
{$include EmptyRectangle.pas}
{$include 2stringKyte.pas}//
{$include SwordFish.pas}//
{$include FinnedSmashiSword.pas}//
{$include JellyFish.pas}//
{$include FinnedSmashiJelly.pas}//
{$include Nx(N+k)FishFinder.pas}
{$include POm.pas} 
{$include BARNs.Pas}// rebuild from ground up
{$include TransBARNs.pas}// rebuild from ground up
{$include XYChain.pas}//
{$include TransXYchain.pas}// rebuild from ground up  // redundant really with aic chains.
{$include Wwing.pas}//
{$include Mwing.pas}//
{$include Swing.pas}//
{$include L3wing.pas}//
{$include L2wing.pas}//
{$include strongwing.pas}//
{$include H1wing.pas}//
{$include H2wing.pas}//
{$include H3wing.pas}//
{$include H45wing.pas}  // rebuild from ground up
{$include iWwing.pas}//
{$include ALSxz.pas}//
{$include TransALSxz.pas}// rebuild from ground up
{$include ALSxy.pas}//
{$include TransALSxy.pas}// rebuild from ground up
{$include ALSWwing.pas}   //upgrade using chain lookup
{$include ALSMwing.pas} //upgrade using chain lookup
{$include ALSSwing.pas} //upgrade using chain lookup
{$Include AHSxz.pas}// missing eliminations as the shared cell is keyed to shared digit when it shouldnt be
{$include Aals2RC.pas}//
{$include ALSchain.pas}//
{$include NalsNRC.pas}//  -< update
{$include Suedecoq.pas}//
{$include Deathblossom.pas}
{$include DDS.pas} //
{$include ADDS.pas}// rebuild from ground up
{$include TrnsADDS.pas}// rebuild from ground up
{$include xchain.pas}//
{$include aic.pas}//
{$include aicWals.pas}//
{$include skloop.pas}//
{$include msls.pas}//

DLX: Show
Code: Select all
procedure DLX; {code provied by Paul from http://forum.enjoysudoku.com/member2928.html}
var
xn,n:integer;

begin
  e := exact_alloc ();
  dlx_init_declare ();

for xn:=0 to 66 do
For n:=0 to 14 do
 begin
gotoxy(118+xn,35+n);
write(space);
end;

for xn in [0..80] do   
      begin     
       
        vdlxa[xn] := undef;      

        if (s[xn] <> [] ) then
          begin
       
         for n in s[xn] do           
            vdlxa[xn] := n-1;
          end;
      end;
    
   if (dlx_solve (vdlxa) <> 1) then
        begin
          unique2:= false;
          if dlx_solve(vdlxa) = 0 then zero:=true;        
          exit;
        end
      else
       begin
         unique2:=true;
         zero:=false;
       end;       

 
if unique2 = true then
begin
 textcolor(10);
writexy(118,35,'DLX Unique Solution:');
textcolor(8);
for xn:= 0 to 8 do
 BEGIN
  gotoxy(118,37+xn);
 for n:= 0 to 8 do
    write(vdlxA[XN*9+N]+1);
END;
   end;
  textcolor(col2);
 

end;

Dlx_solve: Show
Code: Select all
{$include exact.pas}
{$link exact.o}
{$linklib msvcrt}

const
  undef = -1;

var
  e : pexact_t;
  nvdlxh, nvdlxe : longint;
  vdlxa : array [0..80] of integer;
  vdlxh : array [0..729+324] of longint;
  vdlxe : array [0..4*729] of longint;

procedure dlx_init_declare ();

var
  n, r, c, b, d : integer;

begin
  for n := 0 to 728 do
    vdlxh[n] := (exact_col shl 16) or n;

  for n := 0 to 324 do
    vdlxh[729+n] := (exact_row shl 16) or n;

  nvdlxh := 729 + 324;
  nvdlxe := 0;

  for r := 0 to 8 do
    for c := 0 to 8 do
      begin
        b := 3 * (r div 3) + (c div 3);
        for d := 0 to 8 do
          begin
            vdlxe[nvdlxe] := (    (9*r+c) shl 16) or (81*r+9*c+d); inc (nvdlxe);
            vdlxe[nvdlxe] := ( (81+9*r+d) shl 16) or (81*r+9*c+d); inc (nvdlxe);
            vdlxe[nvdlxe] := ((162+9*c+d) shl 16) or (81*r+9*c+d); inc (nvdlxe);
            vdlxe[nvdlxe] := ((243+9*b+d) shl 16) or (81*r+9*c+d); inc (nvdlxe);
          end;
      end;
end;

function dlx_solve (var a : array of integer) : integer;

var
  n, r, c, d, i : integer;
  sp : ^longint;

begin
  exact_reset (e);
  exact_declare (e, nvdlxh, nvdlxe, vdlxh, vdlxe);

  for r := 0 to 8 do
    begin
      for c := 0 to 8 do
        begin
          if a[9*r+c] <> undef then
            begin
              n := 81*r+9*c+a[9*r+c];
              if (exact_pushable (e, n) = 0) then
                begin
                    {writeln (stderr, 'conflicting input at r', r+1, 'c', c+1, 'd', a[9*r+c]+1);}
                  exit (0);
                end;
              exact_push (e, n);
            end;
        end;
    end;

  sp := exact_solve (e, @n);
  if (sp = nil) then
    exit (0);

  for i := 0 to n-1 do
    begin
      r := sp[i] div 81;
      c := (sp[i] div 9) mod 9;
      d := sp[i] mod 9;
      a[9*r+c] := d;
    end;

  sp := exact_solve (e, @n);
  if (sp <> nil) then
    exit (2);

  exit (1);
end;

exact used by dlx: Show
Code: Select all
{$ifndef exact_read}
{$define exact_read}

const
  exact_row = 1;
  exact_col = 2;

type
  row_bitmap = bitpacked array [0..728] of boolean;
  col_bitmap = bitpacked array [0..728] of boolean;
  ent_bitmap = bitpacked array [0..531440] of boolean;

  pexact_rchead_t = ^exact_rchead_t;
  pexact_lrudrc_t = ^exact_lrudrc_t;

  exact_lrudrc_t = record
    left  : pexact_lrudrc_t;
    right : pexact_lrudrc_t;
    up    : pexact_lrudrc_t;
    down  : pexact_lrudrc_t;
    row   : pexact_rchead_t;
    col   : pexact_rchead_t;
  end;

  exact_rchead_t = record
    links : exact_lrudrc_t;
    id    : longint;
    count : longint;
    b     : longint;
  end;

  exact_t = record
    root  : exact_rchead_t;

    rchead_count : longint;
    lrudrc_count : longint;

    rchead_chunk : pexact_rchead_t;
    lrudrc_chunk : pexact_lrudrc_t;

    rowid_to_rowhead : ^longint;
    colid_to_colhead : ^longint;

    rowid_map : ^row_bitmap;
    colid_map : ^col_bitmap;
    entry_map : ^ent_bitmap;

    num_cols : longint;
    num_rows : longint;
    sum_b    : longint;

    simple   : longint;

    can_declare           : longint;
    iteration_in_progress : longint;
    lock                  : longint;

    level                 : longint;
    soln_stack            : ^longint;
    soln_stack_capacity   : longint;
    num_push              : longint;
    col_stack             : pointer;
    filter_pos            : ^longint;
    filter_stack          : pointer;
    filter_stack_capacity : longint;

    cache                  : pexact_rchead_t;
    cache_branching_factor : longint;

    level_f               : pointer;
    level_p               : pointer;
    filter_f              : pointer;
    filter_p              : pointer;
  end;

  pexact_t  = ^exact_t;

  exact_level_t = function (param : longint; sz : longint; var soln : array of longint) : longint; cdecl;
  exact_filter_t = function (param : longint; sz : longint; var soln : array of longint; colid : longint) : longint; cdecl;

  pexact_filter_t  = ^exact_filter_t;
  pexact_level_t  = ^exact_level_t;

function exact_alloc: pexact_t; cdecl; external;
procedure exact_free (e:pexact_t); cdecl; external;
procedure exact_reset (e:pexact_t); cdecl; external;
function exact_declare_row (e:pexact_t; i:longint; b:longint): longint; cdecl; external;
function exact_declare_col (e:pexact_t; j:longint; u:longint): longint; cdecl; external;
function exact_declare_entry (e:pexact_t; i:longint; j:longint): longint; cdecl; external;
function exact_declare (e:pexact_t; nh:longint; nv:longint; h:plongint; v:plongint): longint; cdecl; external;
function exact_can_declare (e:pexact_t): longint; cdecl; external;
function exact_solve (e:pexact_t; n:plongint): plongint; cdecl; external;
function exact_reset_solve (e:pexact_t): longint; cdecl; external;
function exact_is_row (e:pexact_t; i:longint): longint; cdecl; external;
function exact_is_col (e:pexact_t; j:longint): longint; cdecl; external;
function exact_is_entry (e:pexact_t; i:longint; j:longint): longint; cdecl; external;
function exact_num_rows (e:pexact_t): longint; cdecl; external;
function exact_num_cols (e:pexact_t): longint; cdecl; external;
function exact_get_rows (e:pexact_t; i:plongint): longint; cdecl; external;
function exact_get_cols (e:pexact_t; j:plongint): longint; cdecl; external;
function exact_push (e:pexact_t; j:longint): longint; cdecl; external;
function exact_pop (e:pexact_t): longint; cdecl; external;
function exact_pushable (e:pexact_t; j:longint): longint; cdecl; external;
function exact_can_push (e:pexact_t): longint; cdecl; external;
function exact_num_push (e:pexact_t): longint; cdecl; external;
function exact_get_push (e:pexact_t; j:plongint): longint; cdecl; external;
function exact_level (e:pexact_t; l:pexact_level_t; p:longint): longint; cdecl; external;
function exact_filter (e:pexact_t; f:pexact_filter_t; p:longint): longint; cdecl; external;
function exact_check (e:pexact_t): longint; cdecl; external;

{$endif}

Generator: Show
Code: Select all
procedure generator;
type
hold= array of integer;
Solved2 = array of nums;
using = array of numberset;

Var

q,n,k,g2,w,j,iter:integer;
used:using;
attempt: nums;

h:hold;
s2: solved2;
output: text;

begin


initiate;

begin
q:=81;
 Sbrc;
 w:=0;
 
setlength(used,0);
setlength(used,w+1);
setlength(h,0);
setlength(s2,0);
setlength(s2,81);
 
 repeat
 randomize;
   repeat     
    //while not (q in (ocell-used[w])) and ((ocell-used[w]) <> []) do
      begin
          
      q:=random(82)-1;   
     end;    
 write('            ');     
    until  (pm[q] <> []) and (nm[q]> 1) or ((ocell-used[w])=[]);
 
     attempt:=pm[q];    
   
     repeat 
      if attempt <> []
        then
         begin         
           while not (n in attempt) do
            n:=random(10);          
         end;
    
     S[q]:=[n];
     nsector[Rx[q]]:=nsector[rx[q]] + [n];
     nsector[Cy[q]+9]:=nsector[Cy[q]+9] + [n];
     nsector[Bxy[q]+18]:=nsector[Bxy[q]+18] + [n];
    
     include(Acell,q);
     exclude(ocell,q);
         
    //writexy(2,60,'');
   // write(q,' ',n,' ',unique,' ',w);
    
     Sbrc;
     errorcheck;       
        
         if unique = false
              then 
                 begin
             attempt:=attempt -[n];
     S[q]:=[];
     nsector[Rx[q]]:=nsector[rx[q]] - [n];
     nsector[Cy[q]+9]:=nsector[Cy[q]+9] - [n];
     nsector[Bxy[q]+18]:=nsector[Bxy[q]+18] - [n];
    
     include(ocell,q);
     exclude(acell,q);   
    
      for iter in peer[q] do
       if s[iter] <> [] then
        begin
        for J in s[iter] do
        nsector[Rx[iter]]:=nsector[rx[iter]] + [j];
         nsector[Cy[iter]+9]:=nsector[Cy[iter]+9] + [j];
         nsector[Bxy[iter]+18]:=nsector[Bxy[iter]+18] + [j];
       end;              
       sbrc;
         end;    
      
     until (unique = true) or (attempt = []);
    
     if (attempt = [] )    
      then include(used[w],q);
    
     if unique = true
         then
          begin
          inc(w);
          setlength(h,w+1);
          setlength(used,w+1);
           h[w]:=q;
         end;       
 
      
if (unique = false) and (attempt = []) {back track down a level if this step cant add a digit}
         then 
        begin
          q:=h[w];          
     include(ocell,q);
     exclude(acell,q);     
     nsector[Rx[q]]:=nsector[rx[q]] - S[q];
     nsector[Cy[q]+9]:=nsector[Cy[q]+9] - s[q];
     nsector[Bxy[q]+18]:=nsector[Bxy[q]+18] - s[q];
    
      for iter in peer[q] do
       if s[iter] <> [] then
        begin
        for J in s[iter] do
        nsector[Rx[iter]]:=nsector[rx[iter]] + [j];
         nsector[Cy[iter]+9]:=nsector[Cy[iter]+9] + [j];
         nsector[Bxy[iter]+18]:=nsector[Bxy[iter]+18] + [j];
       end;         
       S[q]:=[];
      
         dec(w);
         setlength(h,w+1);
         setlength(used,w+1);
         sbrc;          
         end;
         
if ( ocell * used[w] = ocell) or (zero = true) {back track down two levels if all cells cant add a digit}
         then 
        begin
          for k:= 0 to 1 do
begin          
          q:=h[w];          
     include(ocell,q);
     exclude(acell,q);     
     nsector[Rx[q]]:=nsector[rx[q]] - S[q];
     nsector[Cy[q]+9]:=nsector[Cy[q]+9] - s[q];
     nsector[Bxy[q]+18]:=nsector[Bxy[q]+18] - s[q];
    
      for iter in peer[q] do
       if s[iter] <> [] then
        begin
        for J in s[iter] do
        nsector[Rx[iter]]:=nsector[rx[iter]] + [j];
         nsector[Cy[iter]+9]:=nsector[Cy[iter]+9] + [j];
         nsector[Bxy[iter]+18]:=nsector[Bxy[iter]+18] + [j];
       end;         
       S[q]:=[];
         dec(w);
         setlength(h,w+1);
         setlength(used,w+1);
         sbrc;          
         end;          
       end;   
      
    //writexy(2,61,'');
   // write(q,' ',n,' ',unique,' ',w);
   
    dlx;
   
    // if zero = true then writexy(2,66,'zero solutions');
 
until (unique = true) and (unique2 = true);    

 wpm(1,0,0);   
end;

gotoxy(2,60);
assign(output,'C:\sudoku\Generator\Generated.txt');
 append(output);
  writeln(output);
       for k:= 0 to 80 do
        if s[k] <> []
         then
           begin
             for G2:= 1 to 9 do
               if g2 in s[k]
                then
                 write(output,g2)
           end
        else
          write(output,'.');


       close(output);

end;
Last edited by StrmCkr on Wed Oct 19, 2022 1:21 am, edited 20 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Issomorphic

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

Issomorph changing tool: Show
Code: Select all
procedure issomorph( K2,B2,F2:Char);
var
K,B,F:char;
xn,xl,n:integer;
S2: array [cell] of nums;  {solved grid copy}

begin

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

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

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

if not (K in ['d','t','s','b','c','r','m','p'])
 then
   begin
writexy(2,29,' Which area to move?');
writexy(2,30,' D{igit},R{ow},C{ol},S{tack},B{and},T{ranspose},M{irror},P{ivot}');
K:=readkey;
gotoxy(23,29); write(': ',K);
   end;

 case K of

{R} #114:
 begin

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

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

   case B of
    #49,#50,#51 : write(' 1,2,3');
    #52,#53,#54 : write(' 4,5,6');
    #55,#56,#57 : 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,31,' Which Col to move? {1..9}');
   B:=readkey;  write(': ',B);
     end;

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

   case B of
    #49,#50,#51 : write(' 1,2,3');
    #52,#53,#54 : write(' 4,5,6');
    #55,#56,#57 : 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,31,' Which Band to Swap? {1..3}');
   B:=readkey;  write(': ',B);
     end;

    if not (F in ['1'..'3'])
    then
     begin
   writexy(2,32,' 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,31,' Which Stack to Swap? {1..3}');
   B:=readkey;  write(': ',B);
     end;

    if not (F in ['1'..'3'])
    then
     begin
   writexy(2,32,' 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,31,' Transposing Grid (Diagonal reflection & Anti Diagonal Reflection)');
 if not (b in ['1'..'2'] )
  then begin
 writexy(2,32,' Diagonal / Anti Diagonal ? {1,2} ');
   B:=readkey;  write(': ',B);
   end;

  if b = '1' then
  begin
 for xn:= 0 to 8 do
  for n:= 0 to 8 do
   begin

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

    end;
 end;

  if b = '2' then 
  begin
  for xn:= 8 downto 0 do
   for n:= 8 downto 0 do
   begin

   S[Rset[n,xn]]:=s2[Cset[8-n,8-xn]];
      
   end;
   end;

 end; {Transpose}

{D} #100:
 begin

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

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

   For xn:= 0 to 80 do
   begin

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

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

 end;

 {Mirror} #109: begin
 if not(k2 in['m'])
 then
 writexy(2,31,' Mirror Grid (Reflection)');
 if not (b in ['1'..'2'] )
  then begin
 writexy(2,32,' Horizontal / Vertical ? {1,2}');
   B:=readkey;  write(': ',B);
   end;
   
    if B ='1'
     then    
     begin    
      for n:= 0 to 8 do
      for xn:= 0 to 8 do
      S[rset[xn,n]]:=S2[Rset[(8-xn),n]];
     end;

   if B ='2'
     then   
     begin
      for n:= 0 to 8 do
      for xn:= 0 to 8 do
      S[Cset[xn,n]]:=S2[Cset[(8-xn),n]];
     end;

 end;

 {Pivot/quater turn} #112:
 begin

 if not(k2 in['p'])
 then
 writexy(2,31,' Pivot Grid ( 1/4 turn)');
 if not (b in ['1'..'2'] )
  then begin
 writexy(2,32,' Left / Right ? {1,2}');
   B:=readkey;  write(': ',B);
   end;

  if b = '1' then begin
 for xn:= 0 to 8 do
  for n:= 8 downto 0 do
   begin

     S[Cset[xn,(8-n)]]:=s2[Rset[xn,n]];

    end;
 end;

  if b = '2' then begin
  for xn:= 8 downto 0 do
   for n:= 0 to 8 do
   begin

   S[Cset[xn,n]]:=s2[Rset[(8-xn),n]];

   end;
   end;

 end; {pivit}
   end;

if not (K2 in ['d','t','s','b','c','r','m','p'])
 then
   begin
writexy(2,29,'                                                ');
writexy(2,30,'                                                                  ');
writexy(2,31,'                                                                  ');
writexy(2,32,'                                      ');
end;

for xL:=0 to 80 do
 if s[xl] <> [] then
    begin
      nsector[Rx[xl]]:=nsector[rx[xl]] + s[xl];
      nsector[Cy[xl]+9]:=nsector[cy[xl]+9] + s[xl];
      nsector[bxy[xl]+18]:=nsector[Bxy[xl]+18] + s[xl];
    
        exclude(ocell,xl);
      include(Acell,xl);      
     end;
   
{sbrc;
errorcheck;
wpm(1,0,0);}   

end;  {issomorphic transformation}

isso morpher 2: Show
Code: Select all
{used by codes for faster translations}
procedure issomorph2( K2,b2,f2:Char{b2,f2:char});
var
K:char;
xn,yn,xl,n,n2,b,f:integer;
S5: array [cell] of nums;  {solved grid copy}

c2: array [rcb] of numberset; {col}
r2: array [rcb] of numberset; {row}
d2: array [digits] of numberset; {digits}
temp: numberset;
begin

 for xn in rcb do
   begin
    r2[xn]:=rcbnum[xn];
    c2[xn]:=rcbnum[xn+9];   
    d2[xn+1]:=[];   
   end;   
   
for xn:= 0 to 80 do
 begin
  for n in s[xn] do
     include(d2[n],xn);   
 s5[xn]:=S[xn];
 end;
 
initiate;
 
k:=k2;
b:=ord(b2)-49;
f:=ord(f2)-49;

case K of

{R} #114:
 begin
      temp:=r2[b];    
      r2[b]:=r2[f];
      r2[f]:=temp;    
 end; 
      {row}

{C} #99:
 begin
      temp:=c2[b];    
      c2[b]:=c2[f];
      c2[f]:=temp;
 end;
    {col}

{Band} #98:
 begin
for n:= 0 to 2 do
    begin    
        temp:=r2[((b)*3)+n];   
       r2[((b)*3)+n]:=r2[((f)*3)+n];
         r2[((f)*3)+n]:=temp;
      end;
 end;  {Band}

{stack} #115:
 begin
    for n:= 0 to 2 do
    begin
           temp:=c2[((b)*3)+n];   
       c2[((b)*3)+n]:=c2[((f)*3)+n];
         c2[((f)*3)+n]:=temp;
      end;
 end; {stack}

{Transpose} #116:
 begin
  if b = 0
   then   
     for xn:= 0 to 8 do 
      begin
       temp:=r2[xn];
       R2[xn]:=C2[xn];
       c2[xn]:=temp;
      end;
  if b = 1 then
   for xn:= 8 downto 0 do   
    begin
    n:= (8-xn);
     temp:=r2[xn];
    r2[xn]:=c2[n];
    c2[n]:=temp; 
    end;
 end; {Transpose}
 
  {Mirror} #109: 
 begin
 temp:=[];
  if b = 0
  then
    begin 
       for xn:= 0 to 3 do       
    begin
    n:=(8 - xn);
     temp:=R2[xn];       
    R2[xn]:=R2[n];    
    R2[n]:=temp; 
    end;
 end;
 
    if b = 1
  then
    begin 
    
   for xn:= 0 to 3 do       
    begin
    n:=(8 - xn);
     temp:=C2[xn];       
    C2[xn]:=C2[n];    
    C2[n]:=temp; 
    end;
 end;   
   
 end; {Mirror}
 
 {Pivot/quater turn} #112:
 begin
 
   if b = 0 {Left}
  then
    begin 
       for xn:= 0 to 8 do       
    begin
   n:=8-xn;
     R2[xn]:=rcbnum[n+9];     
    c2[xn]:=rcbnum[xn];
    end;   
 end;
 
  if b = 1 {right}
  then
    begin 
       for xn:= 0 to 8 do       
    begin
   n:=8-xn;
     R2[xn]:=rcbnum[xn+9];     
    c2[xn]:=rcbnum[n];
    end;   
 end;
 
 end;
 
{D} #100:
 begin
     temp:= d2[b+1];
     d2[b+1]:=d2[f+1];
     d2[f+1]:=temp;
 end;

 end;{cases}
 
//sets the grid up after changes
 for xn:= 0 to 8 do
  for yn:= 0 to 8 do
    for n in (r2[xn] * c2[yn]) do
      for n2 in [1..9] do
           if n in d2[n2] then
              s[rset[xn,yn]]:= [n2];
 
 
for xL:=0 to 80 do
 if s[xl] <> [] then
    begin
      nsector[Rx[xl]]:=nsector[rx[xl]] + s[xl];
      nsector[Cy[xl]+9]:=nsector[cy[xl]+9] + s[xl];
      nsector[bxy[xl]+18]:=nsector[Bxy[xl]+18] + s[xl];
    
        exclude(ocell,xl);
      include(Acell,xl);      
     end;
   
{sbrc;
errorcheck;
wpm(1,0,0);}
   
 end;

Symetrical program: Show
Code: Select all
//this code finds everything {automoprhs, and symetrcial identities}
procedure Symetricalplacements(m:char);
     {symetrical placement sequence of morphs(none,12,23,12,23,12)}
const
s1: array [0..5] of integer = (0,49,50,49,50,49);

var
a,b,c,d,e,f,g,h,i,xn,yn,n,n2:integer;
check:boolean;
 
S7:  array [cell] of nums;  {solved grid copy}
s4:  array [cell] of nums; {temp copy}

 begin
 yn:=0;
   
  for xn:= 0 to 80 do
   s7[xn]:=s[xn];
 
  issomorph2(#100,chr(50),chr(54)); {tanspose}
 
 for a:= 0 to 1 do
  begin
 
  if a > 0 then
       issomorph2(#116,chr(s1[a]),chr(s1[a]+1)); {tanspose}
    
  for b:= 0 to 5 do 
   begin
     if b > 0 then
        issomorph2(#115,chr(s1[b]),chr(s1[b]+1)); {stack}
    
   for c:= 0 to 5 do
    begin
     if c > 0 then
        issomorph2(#98,chr(s1[c]),chr(s1[c]+1)); {band}
      
 for d:= 0 to 5 do
   begin
    if d > 0 then
       issomorph2(#114,chr(s1[d]),chr(s1[d]+1)); {Row 123}
   
 for e:= 0 to 5 do
   begin
    if e > 0 then
       issomorph2(#114,chr(s1[e]+3),chr(s1[e]+4)); {Row 456}
      
   for f:= 0 to 5 do
   begin
    if f > 0 then
       issomorph2(#114,chr(s1[f]+6),chr(s1[f]+7)); {Row 789 }
      
  for g:= 0 to 5 do
   begin
    if g > 0 then
       issomorph2(#99,chr(s1[g]),chr(s1[g]+1)); {col 123 }
   
 for h:= 0 to 5 do
   begin
    if h > 0 then
       issomorph2(#99,chr(s1[h]+3),chr(s1[h]+4)); {col 456 }
      
  for i:= 0 to 5 do
   begin
    if i > 0 then
       issomorph2(#99,chr(s1[i]+6),chr(s1[i]+7)); {col 789 }
      
case m of    // individuals   
#10: if ((g+h+i) = 0) then FixedBoxes;
#6: if (b = 0) then  BoxesMnBands;
#16: if((b+c) = 0)then boxesMTri;
#21: if (a = 0) then rotsym;
#18: if (a = 0) then diasym;
 #5: if (b+(g+h+i)= 0) then sticks;
 end;
 
 if m = #42 {looks for all of them}
  then
   begin   
 if ((g+h+i) = 0) then FixedBoxes;
 if (b = 0) then BoxesMnBands;
 if ((b+c) = 0) then boxesMTri;
 if (a = 0) then rotsym;
 if (a = 0) then diasym;
 if (b+(g+h+i)= 0) then  sticks;
  end;
 
 { this next section checks for auto-morphs need to issolate to its own code}

if m = #17  // finds the automorphs.
  then
  begin
 
 for xn:=0 to 80 do
  s4[xn]:=s[xn];
     
  for xn:= 0 to 80 do
     for  n in s[xn] do
        for n2 in s7[xn] do           
           issomorph2(#100,chr(48+n),chr(48+n2));      
 
 check:= True;
 
for xn:= 0 to 80 do
 begin
  if  ((s7[xn] = []) and (S[xn] <> []) )
  or  ((s7[xn] <> []) and(S[xn] = []))
  or  (s[xn] <> s7[xn])
   then
    Check:=false;

    if check = false then break;   
   
   if xn = 80
    then
   begin
     inc(yn);
      gotoxy(2,66+yn);
       write('automorph (',yn,'): ',a,',',b,',',c,',',d,',',e,',',f,',',g,',',h,',',i);
      sbrc;
      wpm(1,0,0);
    //  delay(150);
   end;
   
   end;
 
  for xn:= 0 to 80 do
     for  n in s[xn] do
        for n2 in s4[xn] do           
           issomorph2(#100,chr(48+n),chr(48+n2));   
         
  end;
 
  gotoxy(2,63);
       write(a,',',b,',',c,',',d,',',e,',',f,',',g,',',h,',',i);
      
 if i = 5 then
 issomorph2(#99,chr(50+6),chr(50+7)); {col 789 }
 end;
 
 if h = 5 then
 issomorph2(#99,chr(50+3),chr(50+4)); {col 456 }
 end;
 
 if g = 5 then 
 issomorph2(#99,chr(50),chr(50+1));   {col 123 }
 end;
 
 if f = 5 then
  issomorph2(#114,chr(50+6),chr(50+7)); {Row 789 }
 end;
 
 if e = 5 then
 issomorph2(#114,chr(50+3),chr(50+4)); {Row 456 }
 end;
 
 if d = 5 then
 issomorph2(#114,chr(50),chr(50+1)); {Row 123 }
 end;
 
 if c = 5 then
 issomorph2(#98,chr(50),chr(50+1)); {band}
 end;
 
 if b = 5 then
 issomorph2(#115,chr(50),chr(50+1)); {stack}
 end;
 {a}
 if a = 1 then
 issomorph2(#116,chr(49),chr(49+1)); {issomorph}
 end;
     
 wpm(1,0,0); 
end;

RotationSym: Show
Code: Select all
procedure Rotsym;{symetrical placement}
var
xn,n,n2,n3:integer;

S3:  array [cell] of nums;  {solved grid copy}
Dj: array [digits] of nums; { digit exchange listing}
use:nums;

check: boolean;
 begin

 for xn:= 0 to 80 do
   s3[xn]:=s[xn];

{Half-Turn}

{tanspose diagonal}
  for n:= 49 to 49  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;
{transpose anti-diagonal}   
 for n:= 50 to 50  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;
   
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Rotational symmetries: Half-Turn');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{reversion}
for n:= 50 to 50  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;
   
{quater Turn}
{  for n:= 49 to 49  do
    begin
     n2:=n+2;
      issomorph2(#98,chr(n),chr(n2));
     end;
   
for n:= 49 to 49  do
 for n3:= 0 to 2 do
    begin
     n2:=n+2 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;}
   
{the above 2 translates into a horrizontal mirror move}
for n:= 49 to 49  do
    begin
     n2:=n+2;
      issomorph2(#109,chr(n),chr(n2));
     end;      
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Rotational symmetries: Quater-Turn');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{reversion}

{for n:= 49 to 49  do
 for n3:= 2 downto 0 do
    begin
     n2:=n+2 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;

  for n:= 49 to 49  do
    begin
     n2:=n+2;
      issomorph2(#98,chr(n),chr(n2));
     end;}

for n:= 49 to 49  do
    begin
     n2:=n+2;
      issomorph2(#109,chr(n),chr(n2));
     end;
   
  for n:= 49 to 49  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;
   
end;

diagonalsym: Show
Code: Select all
procedure diasym;{symetrical placement}
var
xn,n,n2,n3:integer;

S3:  array [cell] of nums;  {solved grid copy}
Dj: array [digits] of nums; { digit exchange listing}
use:nums;

check: boolean;
 begin

 for xn:= 0 to 80 do
   s3[xn]:=s[xn];

{Diagonal-Mirror}
  for n:= 49 to 49  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Diagonal symmetries: Diagonal-Mirror');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{Dm +JD}
  for n:= 49 to 50  do
    begin
     n2:=n+1;
      issomorph2(#115,chr(n),chr(n2));
     end;
   
 for n:= 49 to 50  do
    begin
     n2:=n+1;
      issomorph2(#98,chr(n),chr(n2));
     end;

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Diagonal symmetries: DM + JD');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;
  {reversion}
  for n:= 50 downto 49  do
    begin
     n2:=n+1;
      issomorph2(#98,chr(n),chr(n2));
     end;
   
 for n:= 50 downto 49  do
    begin
     n2:=n+1;
      issomorph2(#115,chr(n),chr(n2));
     end;
   
{DM + mD}
   for n:= 49 to 50  do
    for n3:= 0 to 2 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
   for n:= 49 to 50  do
    for n3:= 0 to 2 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Diagonal symmetries: DM + MD');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{reversion}
   for n:= 50 downto 49  do
    for n3:= 2 downto 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;
   
   for n:= 50 downto 49  do
    for n3:= 2 downto 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
for n:= 49 to 49  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;

{anti-Diagonal-Mirror}
  for n:= 50 to 50  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Diagonal symmetries: anti-Diagonal-Mirror');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{reversion}
  for n:= 50 to 50  do
    begin
     n2:=n+1;
      issomorph2(#116,chr(n),chr(n2));
     end;

end;

sticks: Show
Code: Select all
procedure sticks;{symetrical placement}
var
xn,n,n2,n3:integer;

S3:  array [cell] of nums;  {solved grid copy}
Dj: array [digits] of nums; { digit exchange listing}
use:nums;

check: boolean;
 begin

 for xn:= 0 to 80 do
   s3[xn]:=s[xn];


{Col - sticks}
  for n:= 49 to 49  do
    begin
     n2:=n+2;
      issomorph2(#98,chr(n),chr(n2));
     end;
   
for n:= 49 to 49  do
 for n3:= 0 to 2 do
    begin
     n2:=n+2 + (n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Sticks symmetries: Column Sticks');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

  {cs + mc}
for n:= 49 to 50  do
 for n3:= 0 to 2 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Sticks symmetries: CS + MC');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

   {reversion}
for n:= 50 downto 49  do
 for n3:= 2 downto 0 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
{cs + Jr}    
for n:= 49 to 50  do
 for n3:= 0 to 0 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#115,chr(n+(n3*3)),chr(n2));
     end;
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Sticks symmetries: CS + JR');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

   {cs + Gr/band2, Jr/B13}
for n:= 49 to 50  do
 for n3:= 1 to 1 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;   
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Sticks symmetries: CS + GR/B2, JR/B13');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{reversion}
for n:= 50 downto 49  do
 for n3:= 1 to 1 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;      

{Cs + GR}
for n:= 49 to 50  do
 for n3:= 0 to 2 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Sticks symmetries: CS + GR');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{cs + JR/B2, GR/B13} {notes - turned off "mid R swap from above step}   
for n:= 50 downto 49  do
 for n3:= 1 to 1 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Sticks symmetries: CS + JR/B2, GR/B13');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

 { Reversion}

for n:= 49 to 50  do  {do not reverse this one! it corrects the last step to run a 3 cycle below}
 for n3:= 1 to 1 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
for n:= 50 downto 49  do
 for n3:= 2 downto 0 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
for n:= 50 downto 49  do
 for n3:= 0 to 0 do
    begin
     n2:=n+1 + (n3*3);
      issomorph2(#115,chr(n+(n3*3)),chr(n2));
     end;
   
for n:= 49 downto 49  do
 for n3:= 2 downto 0 do
    begin
     n2:=n+2 + (n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;
   
  for n:= 49 downto 49  do
    begin
     n2:=n+2;
      issomorph2(#98,chr(n),chr(n2));
     end;   

{row - sticks}
  for n:= 49 to 49  do
    begin
     n2:=n+2;
      issomorph2(#115,chr(n),chr(n2));
     end;
   
for n:= 49 to 49  do
 for n3:= 0 to 2 do
    begin
     n2:=n+2 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Sticks symmetries: Row Sticks');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;
 { Reversion}
for n:= 49 downto 49  do
 for n3:= 2 downto 0 do
    begin
     n2:=n+2 + (n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
  for n:= 49 downto 49  do
    begin
     n2:=n+2;
      issomorph2(#115,chr(n),chr(n2));
     end;      

end;

boxMnbands: Show
Code: Select all
procedure BoxesMnBands; {symetrical placement}
var
xn,n,n2,n3:integer;

S3:  array [cell] of nums;  {solved grid copy}
Dj: array [digits] of nums; { digit exchange listing}
use:nums;

check: boolean;
 begin

 for xn:= 0 to 80 do
   s3[xn]:=s[xn];

{jumping - Rows}
  for n:= 49 to 50  do
    begin
     n2:=n+1 ;
      issomorph2(#115,chr(n),chr(n2));
     end;


For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: Jumping Rows ');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{2 Jr  1 GR}
  for n:= 49 to 50  do
    for n3:= 0 to 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: 2JR - 1 GR ');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{1 Jr  2 GR}
  for n:= 49 to 50  do
    for n3:= 1 to 1 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: 1JR - 2 GR ');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{ Gliding Row}
  for n:= 49 to 50  do
    for n3:= 2 to 2 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: Gliding Row');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{Waveing Rows}
  for n:= 49 to 50  do
    begin
     n2:=n+1;
      issomorph2(#99,chr(n),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: Waveing Row ');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{1 Fr, 2 wr}
 for n:= 50 downto 49  do
    for n3:= 2 downto 2 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;   

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: 1 FR, 2 WR');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{2 FR, 1 WR }
 for n:= 50 downto 49  do
    for n3:= 1 downto 1 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;   

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: 2 FR, 1 WR');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{Full - Row }
 for n:= 50 downto 49  do
    for n3:= 0 downto 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;   

For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move in bands: Full Row');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{Reversion}
for n:= 50 downto 49  do
    for n3:= 0 downto 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;

  for n:= 50 downto 49  do
    begin
     n2:=n+1;    
      issomorph2(#115,chr(n),chr(n2));
     end;


end;

boxMtri: Show
Code: Select all
procedure boxesMTri;{symetrical placement}
var
xn,n,n2,n3:integer;

S3:  array [cell] of nums;  {solved grid copy}
Dj: array [digits] of nums; { digit exchange listing}
use:nums;

check: boolean;
 begin

 for xn:= 0 to 80 do
   s3[xn]:=s[xn];

{jumping - Diagonals}
  for n:= 49 to 50  do
    begin
     n2:=n+1;
      issomorph2(#98,chr(n),chr(n2));
     end;
   
 for n:= 49 to 50  do
    begin
     n2:=n+1;
      issomorph2(#115,chr(n),chr(n2));
     end;
   
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Boxes move Triangular: Jumping Diagonal');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{Broken - Cols}
  for n:= 49 to 50  do
    begin
     n2:=n+1 ;
      issomorph2(#114,chr(n),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;
end;
if check = true then begin
writexy(2,64,'Boxes move Triangular: Broken Cols');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{Full Diagonals}
  for n:= 49 to 50  do
    for n3:= 0 to 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;

    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;
end;
if check = true then begin
writexy(2,64,'Boxes move Triangular: Full Diagonal');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{reversion}
 for n:= 50 downto 49  do
     begin
     n2:=n+1 ;
      issomorph2(#99,chr(n),chr(n2));
     end;

 for n:= 50 downto 49  do
    begin
     n2:=n+1 ;
      issomorph2(#114,chr(n),chr(n2));
     end;

 for n:= 50 downto 49  do
    begin
     n2:=n+1 ;
      issomorph2(#115,chr(n),chr(n2));
     end;
   
 for n:= 50 downto 49  do
    begin
     n2:=n+1;
      issomorph2(#98,chr(n),chr(n2));
     end;   

end;

Fixedboxes: Show
Code: Select all
Procedure FixedBoxes; {symetrical placement technique}
var
xn,n,n2,n3:integer;

S3:  array [cell] of nums;  {solved grid copy}
Dj: array [digits] of nums; { digit exchange listing}
use:nums;

check: boolean;
 begin

 for xn:= 0 to 80 do
   s3[xn]:=s[xn];

  {Fixed boxes: Mini Row/Col}
   for n:= 49 to 50  do
    for n3:= 0 to 2 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;
   
    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Fixed boxes: Mini-Row/Col ');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

  {Fixed boxes: 2 MR  1 MD}
     
  for n:= 49 to 50  do
    for n3:= 0 to 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;
   
    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Fixed boxes: 2 Mini-Row/Col + MD');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

{fixed boxes 1 mr 2md}
     
  for n:= 49 to 50  do
    for n3:= 1 to 1 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;
   
    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Fixed boxes: 1 Mini-Row/Col + 2 MD');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;

 {fixed boxes md}
     
  for n:= 49 to 50  do
    for n3:= 2 to 2 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
   
For n:= 1 to 9 do
 dj[n]:=[];

check:= True;
for xn:= 0 to 80 do
 begin
  if  ((s3[xn] = []) and (S[xn] <> []) ) or ((s3[xn] <> []) and (S[xn] = []))
   then
    Check:=false;
   
    if check = false then break;

   if (S3[xn] <> [] ) and (S[xn] <> [] )  and (S3[xn] * s[xn] <> s3[xn])
    then
           for n in s3[xn] do
            for n2 in s[xn] do
         begin
              dj[n]:= dj[n] + [n2] +[n] ;
           dj[n2]:= dj[n2] + [n] + [n2];
            end;

 end;

if check = true then begin
writexy(2,64,'Fixed boxes:  Mini Diagonals');
use:=[];
gotoxy(2,65);
 For n:= 1 to 9  do
 if [n] *  use = [] then
  begin
  write('( ',n,' ');
   for n2 in Dj[n]-[n] do
   begin
    write(n2,' ');   
   use:=use +[n,n2];
   end;
  write('),');
  end;
end;
   {revert grid}
   for n:= 50 Downto 49  do
    for n3:= 2 downto 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#99,chr(n+(n3*3)),chr(n2));
     end;
   
  for n:= 50 downto 49  do
    for n3:= 2 downto 0 do
    begin
     n2:=n+1 +(n3*3);
      issomorph2(#114,chr(n+(n3*3)),chr(n2));
     end;
   
 end;

inclusion file: Show
Code: Select all
{$include isso2.pas} //faster version of issomorph
{$include issomorph.pas} // program to morph the grid
{$include FixedBoxes.pas}
{$include BoxesMnBands}
{$include BoxesMTri.pas}
{$include Rotsym.pas}
{$include diasym.pas}
{$include sticks.pas}
{$include Symetricalplacements.pas} // does automoprhs etc
Last edited by StrmCkr on Wed Oct 19, 2022 1:56 am, edited 14 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Pattern Overlay Method

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

large sets: Show
Code: Select all
 // this is a test code for attempting to get POM to work correctly as free pascal is limited to set sizes  of 256 and pom needs more
 {$mode objfpc}{$inline on}
 
    { A simple way to implement large or huge sets.
     (c) 2019 Thaddy de Koning. No license and not
     re-licensable: free for all to use.
     Copyright holds:
     You can not claim license nor copyrigths
    }
    {* added by strmck 2022}
    unit largesets;
    { Operator      Action
      ---------------------------------------------
      +             Union
      -             Difference
      *             Intersection
      ><        Symmetric difference
      <=        Contains
     >=        Left hand side set is a superset of the one on the right *
       =         equality:  use function  equality( which does (><) and evaultes if its empty)*
       <>        inequality:  use function inequality( which does (><) and evaulates if its not empty)*
      include2   Include an element in the set
      exclude2   Exclude an element from the set
      in         Check if an single element is in a set
   
   notes: Twordset can be modifed for Tdwordset/Tqwordset
   include & exclude renamed to allow for inherinted function include/exclude to function normally
   }
    interface
    uses
      generics.collections;
     
    type
      TWordSet  = specialize TSortedHashSet<word >;
      
      { union }
      operator + (const a,b:TWordset):TWordSet;   
     
      { difference }
      operator - (const a,b:Twordset ):TWordSet;   
     
      { intersection }
      operator * (const a,b:TwordSet ):TWordSet; 
     
      { symmetric difference }
      operator >< (const a,b:TWordSet ):TWordSet;
   
      { contains }
      operator <= (const a,b:TWordSet ):Boolean;
 
        { Left hand side set is a superset of the one on the right }
      operator >= (const a,b:TWordSet ):Boolean;     
       
      { in }
      operator in (const a:word; const b:TWordset ):Boolean; 
     
      { include }
      procedure include2(const a:TWordSet; const b:Word); 
     
      { exclude }
      procedure exclude2(const a:TWordSet;const  b:Word);   
     
    function Equality(const A,B:TWordSet):Boolean;
    function inEquality(const A,B:TWordSet):Boolean;
   
    implementation
 Var
  D: TwordSet;
 
      { union }
      operator + (const a,b:Twordset):TWordSet;
      begin
     d.Free;
     D := TWordSet.Create;
       D.unionWith(A);
      D.unionWith(B);     
        Result := D;      
      end;     
         
      { difference }
      operator -(const a,b:Twordset):TWordSet;
      begin
      d.Free;
       D := TWordSet.Create;
       D.unionWith(A);
      D.ExceptWith(B);       
        result:=D;
      end;   
         
      { intersection }
      operator *(const a,b:TwordSet):TWordSet;
      begin
     d.Free;
     D := TWordSet.Create;
     D.unionWith(a);
     D.IntersectWith(b);     
        Result := D;
      end;         
     
      { symmetric difference }
      operator ><(const a,b:TWordSet):TWordSet;
      begin
     d.Free;
     D := TWordSet.Create;
     D.unionWith(a);
     D.SymmetricExceptWith(b);       
        Result := D;
      end;         
     
      { contains }
      operator <=(const a,b:TWordSet):Boolean;
      var
        c:word;
      begin
        Result := true;
        for c in a do
        if not b.contains(c) then
        begin
          Result := False;
          break;
        end;
      end;   
        
      { Left hand side set is a superset of the one on the right }
      operator >=(const a,b:TWordSet):Boolean;
      var
        c:word;
      begin
        Result := true;
        for c in b do
        if not a.contains(c) then
        begin
          Result := False;
          break;
        end;
      end;   
    
 {equality} { first checks if either set has diffrent values}
 Function Equality(const A, B: TWordSet): Boolean;
var
  c:word;
begin
d.Free;
Result := true;
D := TWordSet.Create;
D.unionWith(a);
D.SymmetricExceptWith(b);             
  for c in D do
     begin 
    result:= False;
      break;   
     end;    
end;

 Function inEquality(const A, B: TWordSet): Boolean;
var
  c:word;
begin
d.Free;
Result := false;
D := TWordSet.Create;
D.unionWith(a);
D.SymmetricExceptWith(b);             
  for c in D do
     begin 
    result:= True;
      break;   
     end;    
end;      
      { in }
      operator in (const a:word;const b:TWordset):Boolean;
      begin
        Result := b.Contains(a);
      end;
     
      { include }
      procedure include2(const a:TWordSet;const b:Word);
      begin
        a.Add(b);
      end;   
         
      { exclude }
      procedure exclude2(const a:TWordSet;const b:Word);
      begin
        a.Remove(b);
      end;     
     
  {counting function}   
function GetCount(const aSet: TWordSet): SizeInt;
  begin
    Exit(aSet.Count);   
    end;
   
end.

POM: Show
Code: Select all
// 46,656 potential  single digit grids.

procedure potential;
 
type
hold = array of integer;
base = array of numberset;
digit = array of numberset;


var
   w1,w2,w3:TWordSet; 

setstuff: array [digits] of Twordset;
Cellsetstuff: array [ digits,cell] of twordset;
 
locked:  array [digits] of numberset;
deleted:  array [digits] of numberset;

stuff: array [digits] of numberset;

alist:array[digits] of word;

xn,w,p,n,n2,xn2,q,g,L,j,m,o,xn3,xn4,xn5:integer;
output: text;

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

begin

for n:=1 to 9 do
 begin
 setstuff[n]:= twordset.create;
   for q in digitcell[n] do     
    cellsetstuff[n,q]:=twordset.create;    
end;

  for n:= 1 to 9 do
    alist[n]:=0;
   
for N:= 1 to 9 do
begin
locked[n]:=[];
deleted[n]:=[];
stuff[n]:= [];

for xn:= 0 to 80 do
 begin

  if s[xn] = [n]
   then
      locked[n]:= locked[n]+ [xn];

   if (s[xn] <> [n] ) and not( n in pm[xn])
    then
     deleted[n]:= deleted[n] + [xn];

  end;
 end;

{startin cell}

  {delete the exsiting output if you want to rebuild it unhash this section}
{assign(output,'C:\sudoku\pom\output.txt');
erase(output);
rewrite(output);
close(output);  }

assign(output,'c:\sudoku\pom\exclusions.txt');
erase(output);
rewrite(output);
close(output);


{smashes all prebuilt  txt files  of potential solutions for digits 1-9  }
 for n:= 1 to 9 do
  begin
    case n of
      1: assign(output,'C:\sudoku\pom\1.txt');
      2: assign(output,'C:\sudoku\pom\2.txt');
      3: assign(output,'C:\sudoku\pom\3.txt');
      4: assign(output,'C:\sudoku\pom\4.txt');
      5: assign(output,'C:\sudoku\pom\5.txt');
      6: assign(output,'C:\sudoku\pom\6.txt');
      7: assign(output,'C:\sudoku\pom\7.txt');
      8: assign(output,'C:\sudoku\pom\8.txt');
      9: assign(output,'C:\sudoku\pom\9.txt');
     end;

erase(output);
rewrite(output);
close(output);
end;

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

 for xn:= 80 downto 72 do

  begin

  w:=0;    {step count}

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

  h[w]:=xn;        {starting point for first substep}

  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(z,w+1);  {prevent occupy "new starting point" }

  z[w]:= peer[xn] + [xn]; {used cells  starting point}

   repeat

    for p:= h[w] downto (72-((w+1)*9)) do    {iteration of peers}

      if  p in ([0..80] - z[w] ) // added check used state
       then
         begin

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

          inc(w);        {increase the step count}

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

          step[w]:= step[w-1] + [p] ;   {set the step cell active for the newly created step w}

          h[w]:= 71 - ((w)*9) ;  {set the new step w as 71 potential choice cells}

          setlength(z,w+1);  { increase size to w}

          z[w]:= z[w-1] +  peer[p] + [p]; {used cells  new  point}

          break;

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


if w = 8
  then
   begin


{ generate the whole list to a specific file}
{assign(output,'C:\sudoku\pom\output.txt');
append(output);
for n in step[w] do
    write(output,n,' ');

    writeln(output);

    close(output); }

 for n:= 1 to 9 do
  begin
 
    case n of
      1: assign(output,'C:\sudoku\pom\1.txt');

      2: assign(output,'C:\sudoku\pom\2.txt');

      3:  assign(output,'C:\sudoku\pom\3.txt');

      4: assign(output,'C:\sudoku\pom\4.txt');

      5: assign(output,'C:\sudoku\pom\5.txt');

      6: assign(output,'C:\sudoku\pom\6.txt');

      7: assign(output,'C:\sudoku\pom\7.txt');

      8:  assign(output,'C:\sudoku\pom\8.txt');

      9:  assign(output,'C:\sudoku\pom\9.txt');
       end;

  if ( step[w]  * locked[n] = locked[n] )
  and ( step[w] * deleted[n] = [] )
   then
     begin
    inc(alist[n]);
       append(output);

       for q in (step[w] - locked[n])  do
        begin
          write(output, q,' ');
       
        include2(cellsetstuff[n,q],alist[n]);
        include2(setstuff[n],alist[n]);
        end;

        writeln(output);
        close(output);

        stuff[n]:= stuff[n] + (step[w] - locked[n]);

     end;


end; { N choice}

 end;   {w=8}


    if ((h[w] < 0 )  and (w > 0 ))
      or (w=8)
      or ( ( [0..80] - z[w] = [] ) and (W < 8) and (w > 0) )
       or ( (h[w] < (72 - ( (w+1)*9) ) )  and (w > 0)  )

    {the following resets the step to the previous state}
     then
      repeat
      begin
       w:=(w-1);
       setlength(h,(w+1));
       h[w]:= h[w];
       setlength(step,(w+1));
       setlength(z,w+1);

        end;
       until   ( w = 0 ) or (h[w] > ((71 - (w+1)*9))  )

    until ((w = 0) and (h[w] < 0) ) or  ( ( w = 0) and (h[w] < (72 -( (w+1)*9) ) ) )
 
 end;
 {size printing of all sets}
 for n:= 1 to 9 do
 begin
 gotoxy(2,60+n);
  write(n,':=  ',alist[n]);
  end;
 
 {size 1}
  for n:= 1 to 9 do
 if  (stuff[n] <> [])
 and (stuff[n] *  (digitcell[n]  -  (locked[n] + deleted[n]) ) = stuff[n])
 and (  ((digitcell[n]  -  (locked[n] + deleted[n]) ) - stuff[n])  <> [] )
  then
    begin
     assign(output,'C:\sudoku\pom\exclusions.txt');
     append(output);
        write(output,n, ' @: ');
         // cell has no templates out of all of them.    
        for  xn  in  ((digitcell[n]  -  (locked[n] + deleted[n])) - stuff[n])do
          begin
            write(output,xn,' ');
          covered2[n]:=covered2[n]+[xn];
          active:=true;
         end;
         
         //cell is exclusivly in all sets
        for xn in digitcell[n] do 
         if equality(cellsetstuff[n,xn],setstuff[n])
           then 
              begin
              active:=true;
                 covered[xn]:=covered[xn] + (pm[xn]-[n]);
             write(output,'*',xn,'<>( ');
            for o in pm[xn]-[n] do
             write(output,o,' ');
              write(output,') ')
                end;                 
         
         
           writeln(output);
           close(output);
         
         
     end; {size 1}
 
 {size 2}
 for n in [1..9] do
    for xn in digitcell[n] do
      for xn2 in digitcell[n]*[(xn+1)..80] do   
     begin
       w1:=twordset.create;
      
       w1:= cellsetstuff[n,xn] + cellsetstuff[n,xn2];
 
         if  setstuff[n]<=w1
           then
          begin          
           for q in [1..9]-[n] do
            begin
                 for g in setstuff[q] do
                  if [xn,xn2] * digitcell[q] = [xn,xn2]
                then             
                if (g in (cellsetstuff[q,xn]))
                 and (g in (cellsetstuff[q,xn2]))
                  then
                   begin                                      
                        w2:=twordset.create;
                  
                  for L in digitcell[q] do
                    if (g in cellsetstuff[q,l])
                     then
                       begin
                       exclude2(cellsetstuff[q,L],g);   
                      include2(w2,l);
                      end;

 
   assign(output,'C:\sudoku\pom\exclusions.txt');
     append(output);
     write(output,'(',n,')',xn,',',xn2,':(');
       for m in setstuff[n] do write(output,' ',m); write(output,' ) & ');
         write(output,'(',q,')',xn,',',xn2,':(');
              for o in (setstuff[q]) do write(output,' ',o); write(output,' ) ');
              write(output,'RT: ', G,' @ Digit: ',q, ' =>> <> ');
          
           exclude2(setstuff[q],g);          
                                     
                   for L in digitcell[q] do
                      begin
                        {no templates left for cells}
                              w3:= setstuff[q] - cellsetstuff[q,l];                             
                        if equality(w3,cellsetstuff[q,l])
                           then
                            begin
                              write(output,L,' ');
                             active:=true;
                             covered2[q]:=covered2[q] + [L];
                             end;
                        {digits are locked to all sets}     
                        if equality(cellsetstuff[q,l],setstuff[q])
                                   then 
                                     begin
                            active:=true;
                                      covered[l]:=covered[l] + (pm[l]-[q]);
                             write(output,'*',L,'<>( ');
                              for o in pm[l]-[q] do
                                write(output,o,' ');
                               write(output,') ')
                                     end;                                 
                      end;
                     
                     
                     
        writeln(output);
           close(output);   
         
         include2(setstuff[q],g);
         for L in w2 do
              begin
            include2(cellsetstuff[q,L],g);   
            end;
         w2.free;
                         break;                  

                 end;                   
               end;                 
                 end;
             w1.free;
            
            end;    {size 2}        


end;
Last edited by StrmCkr on Tue Oct 18, 2022 10:53 pm, edited 4 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Hidden & Naked Subsets

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

Hidden single: Show
Code: Select all
{finds hidden singles}
procedure Hs(K:integer);
var
xn,yn,n,g:integer;
begin

if k=0 then begin  g:=0; setlength(techwrite,g+1,14); end;

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

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

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

                include(nsector[xn],n);
                include(nsector[yn+9],n);
                include(nsector[bxy[rset[xn,yn]]+18],n);
               
             exclude(ocell,rset[xn,yn]);
               include(Acell,rset[xn,yn]);
            
                if k = 0 then
                 begin
                  techwrite[g,0]:=[1];
              techwrite[g,1]:=[0];
              techwrite[g,3]:=[n];
              techwrite[g,2]:=[Rset[xn,yn]];
                  techwrite[g,n+3]:=peer[rset[xn,yn]] * digitcell[n];                 
                  G:=g+1;
                  setlength(techwrite,g+1,14);
                  end;
             end;


      if sec[xn+9,n] = 1
       then
        For yn:= 0 to 8 do
          if Rnsector[xn+9,n] = [yn]
           then
             begin
              active:=true;

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

                include(nsector[yn],n);
                include(nsector[xn+9],n);
                include(nsector[bxy[rset[yn,xn]]+18],n);
            
             exclude(ocell,Cset[xn,yn]);
               include(Acell,Cset[xn,yn]);
            

                 if k = 0 then
                 begin
                  techwrite[g,0]:=[1];
              techwrite[g,1]:=[0];
              techwrite[g,3]:=[n];
              techwrite[g,2]:=[Rset[xn,yn]];
                  techwrite[g,n+3]:=peer[rset[xn,yn]] * digitcell[n];                 
                  G:=g+1;
                  setlength(techwrite,g+1,14);
                  end;
             end;

      if sec[xn+18,n] = 1
       then
        For yn:= 0 to 8 do
         if Rnsector[xn+18,n] = [yn]
           then
             begin
              active:=true;

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

                include(nsector[Rx[bset[xn,yn]]],n);
                include(nsector[cy[bset[xn,yn]]+9],n);
                include(nsector[xn+18],n);
            
                 exclude(ocell,bset[xn,yn]);
               include(Acell,bset[xn,yn]);
            
                if k = 0 then
                 begin

                  techwrite[g,0]:=[1];
              techwrite[g,1]:=[0];
              techwrite[g,2]:=[Rset[xn,yn]];
              techwrite[g,3]:=[n];             
                  techwrite[g,n+3]:=peer[rset[xn,yn]] * digitcell[n];                 
                  G:=g+1;
                  setlength(techwrite,g+1,14);


                  end;

             end;


       end;

    if k = 0 then
     chaindisplay(#59,G);

end;  {hidden singles}

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

if k =0 then begin g:=0; setlength(techwrite,g+1,14);  end;
For xn:= 0 to 8 do

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

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

                     for z in comboset2[yn] do
                         begin
                           covered[rset[xn,z]]:= covered[rset[xn,z]] + (sectorRC[xn,z] - [n,n2]);

                         if k = 0 then
                          begin

                           for q in (sectorRC[xn,z] - [n,n2])do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [rset[xn,z]];

                          end;
                         end;

                    if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [rset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;

                  end;

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

                     for  z in comboset2[yn] do                       
                   begin
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] + (sectorRC[xn+9,z] - [n,n2]) ;
                    if k = 0 then
                          begin

                           for q in (sectorRC[xn+9,z] - [n,n2]) do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [Cset[xn,z]];

                          end;
                         end;

 if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [cset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;

                  end;

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

                     for z in comboset2[yn] do                         
                   begin
                           covered[bset[xn,z]]:= covered[bset[xn,z]] +(sectorRC[xn+18,z] - [n,n2]);
                     
                  if k = 0 then
                          begin

                           for q in (sectorRC[xn+18,z] - [n,n2]) do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [bset[xn,z]];

                          end;
                         end;

 if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [bset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;


                  end;

        end;

if k = 0 then chaindisplay(#61,g);

end;{hidden pair}

Hidden Tripple: Show
Code: Select all
{hidden triples}
procedure HT(k:integer);
var
xn,yn,n,n2,n3,z,g,q:integer;
begin
if k =0 then begin g:=0; setlength(techwrite,g+1,14);  end;

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   (sec[xn,n] > 0) and (sec[xn,n] < 4 )
           and (sec[xn,n2] > 0) and (sec[xn,n2] < 4 )
           and (sec[xn,n3] > 0) and (sec[xn,n3] < 4 )
            then
              for yn:= 45 to 128 do
                if Rnsector[xn,n] + Rnsector[xn,n2] + Rnsector[xn,n3] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z in comboset2[yn] do                       
                    begin
                           covered[rset[xn,z]]:= covered[rset[xn,z]] + (sectorRC[xn,z]-[n,n2,n3] );

                     if k = 0 then
                          begin

                           for q in ( sectorRC[xn,z]-[n,n2,n3]) do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [rset[xn,z]];

                          end;
                         end;

                    if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [rset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2,n3];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;

                  end;

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

                     for z in comboset2[yn] do                       
                   begin
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] +( sectorRC[xn+9,z]-[n,n2,n3]);

                     if k = 0 then
                          begin

                           for q in ( sectorRC[xn+9,z]-[n,n2,n3]) do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [Cset[xn,z]];

                          end;
                         end;

                    if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [cset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2,n3];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;


                  end;

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

                     for z in comboset2[yn] do
                       
                   begin
                           covered[bset[xn,z]]:= covered[bset[xn,z]] + ( sectorRC[xn+18,z]-[n,n2,n3]);

                       if k = 0 then
                          begin

                           for q in ( sectorRC[xn+18,z]-[n,n2,n3]) do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [bset[xn,z]];

                          end;
                         end;

                    if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [bset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2,n3];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;


                  end;

        end;
if k = 0 then chaindisplay(#62,g);
end;{hidden tripple}

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

if k= 0 then begin g:=0; setlength(techwrite,g+1,14); end;
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    (sec[xn,n] > 0) and (sec[xn,n] < 5 )
           and (sec[xn,n2] > 0) and (sec[xn,n2] < 5 )
           and (sec[xn,n3] > 0) and (sec[xn,n3] < 5 )
           and (sec[xn,n4] > 0) and (sec[xn,n4] < 5 )
            then
              for yn:= 129 to 254 do
                if Rnsector[xn,n] + Rnsector[xn,n2] + Rnsector[xn,n3] + Rnsector[xn,n4] = comboset2[yn]
                 then
                   begin
                    active:= true;

                     for z:= 0 to 8 do
                       if z in comboset2[yn]
                        then
                   begin
                           covered[rset[xn,z]]:= covered[rset[xn,z]] +(sectorRC[xn,z]- [n,n2,n3,n4]) ;
                     
                     if k = 0 then
                          begin

                           for q in (sectorRC[xn,z] - [n,n2,n3,n4]) do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [rset[xn,z]];

                          end;
                         end;

                    if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [rset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2,n3,n4];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;

                  end;

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

                     for z in comboset2[yn] do                       
                   begin
                           covered[Cset[xn,z]]:= covered[Cset[xn,z]] + (sectorRC[xn+9,z] - [n,n2,n3,n4]);
                     
                     if k = 0 then
                           begin

                           for q in (sectorRC[xn+9,z]- [n,n2,n3,n4]) do
                            techwrite[g,q+3]:=techwrite[g,q+3]+ [Cset[xn,z]];

                          end;
                         end;

                    if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [cset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2,n3,n4];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;


                  end;

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

                     for z in comboset2[yn] do                         
                  begin
                           covered[bset[xn,z]]:= covered[bset[xn,z]] + (sectorRC[xn+18,z]- [n,n2,n3,n4]);
                     
                     if k = 0 then
                           begin
                             for q in (sectorRC[xn+18,z]- [n,n2,n3,n4]) do
                             techwrite[g,q+3]:=techwrite[g,q+3]+ [bset[xn,z]];

                           end;
                         end;

                    if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                     then
                       begin
                   techwrite[g,0]:=[1];
                  techwrite[g,1]:=[0];
                  
                        for q in comboset2[yn] do
                          techwrite[g,2]:=techwrite[g,2] + [bset[xn,q]];
                   
                          techwrite[g,3]:=[n,n2,n3,n4];

                          g:=g+1;
                          setlength(techwrite,g+1,14);

                       end;

                  end;

        end;
if k = 0 then chaindisplay(#63,g);
end;{hidden Quad}

Naked Single: Show
Code: Select all
{naked singles}
procedure NS(K:integer);
var
xn,n,g:integer;
begin

if k=0 then begin  g:=0; setlength(techwrite,g+1,14); end;

for xn in ocell do //:= 0 to 80 do
   if nm[xn]=1
    then
      begin
       active:=true;

         s[xn]:=SectorRC[Rx[xn],cy[xn]];

         nsector[Rx[xn]]:= nsector[rx[xn]] + SectorRC[Rx[xn],cy[xn]];
         nsector[Cy[xn]+9]:= nsector[cy[xn]+9] + SectorRC[Rx[xn],cy[xn]];
         nsector[Bxy[xn]+18]:= nsector[bxy[xn]+18] + SectorRC[Rx[xn],cy[xn]];
      
        exclude(ocell,xn);
        include(Acell,xn);

         if k = 0
          then
         for n in SectorRC[Rx[xn],cy[xn]] do
            begin
               techwrite[g,0]:=[0];
              techwrite[g,1]:=[0];
                  techwrite[g,2]:=[n];
              techwrite[g,3]:=[xn];
                  techwrite[g,n+3]:=peer[xn] * digitcell[n];                 
                  G:=g+1;
                  setlength(techwrite,g+1,14);

            end;

      end;

   if k = 0 then
     Chaindisplay(#84,G);

end; {naked singles}

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

if k = 0 then begin g:=0; setlength(techwrite,g+1,14); end;

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

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

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn,z] - [ Rset[xn,n] , Rset[xn,n2] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+4] + (DigitRCB[xn,z] - [ Rset[xn,n] , Rset[xn,n2] ] );
                     end;
                   
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                  techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];
                  techwrite[g,2]:=comboset[yn];
                       techwrite[g,3]:=[rset[xn,n]]+[rset[xn,n2]];                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);

                      end;

                  end; {rows}
{cols}
           if(sectorRC[xn+9,n] <> []) and (sectorRC[xn+9,n2] <> [])
           and (nm[Cset[xn,n]] <3) and (nm[Cset[xn,n2]] <3)
            then
             for yn:= 9 to 44 do
              if ( sectorRC[xn+9,n] + sectorRC[xn+9,n2] = comboset[yn])
               then
                   begin
                     active:= true;

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn+9,z] - [ Cset[xn,n] , Cset[xn,n2] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn+9,z] - [ Cset[xn,n] , Cset[xn,n2] ] );
                     end;
                  
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                       techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];
                  techwrite[g,2]:=comboset[yn];
                       techwrite[g,3]:=[cset[xn,n]]+[cset[xn,n2]];                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);
                      end;

                  end; {cols}
{boxes}
           if(sectorRC[xn+18,n] <> []) and (sectorRC[xn+18,n2] <> [])
           and (nm[Bset[xn,n]] <3) and (nm[Bset[xn,n2]] <3)
            then
             for yn:= 9 to 44 do
              if ( sectorRC[xn+18,n] + sectorRC[xn+18,n2] = comboset[yn])
               then
                   begin
                     active:= true;

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn+18,z] - [Bset[xn,n] , Bset[xn,n2] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn+18,z] - [ Bset[xn,n] , Bset[xn,n2] ] );
                     end;
                   
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                       techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];
                  techwrite[g,2]:=comboset[yn];
                       techwrite[g,3]:=[bset[xn,n]]+[bset[xn,n2]];                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);
                      end;

                  end; {boxes}

        end;
if k = 0 then chaindisplay(#86,g);
end;{naked pair}

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

if k = 0 then begin g:=0; setlength(techwrite,g+1,14); end;

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
{Row}
           if (sectorRC[xn,n] <> []) and (sectorRC[xn,n2] <> []) and (sectorRC[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 (sectorRC[xn,n] + sectorRC[xn,n2] + sectorRC[xn,n3] = comboset[yn] )
                 then
                   begin
                    active:= true;

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn,z] - [ Rset[xn,n] , Rset[xn,n2], Rset[xn,n3] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn,z] - [ Rset[xn,n] , Rset[xn,n2],Rset[xn,n3] ] );
                     end;
                   
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+4] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                 techwrite[g,0]:=[0];
                 techwrite[g,1]:=[0];
                 techwrite[g,2]:=comboset[yn];
                 techwrite[g,3]:=[rset[xn,n]]+[rset[xn,n2]]+[Rset[xn,n3]];                     
                       g:=g+1;
                       setlength(techwrite,g+1,14);

                      end;

                  end;{rows}

{Col}
           if (sectorRC[xn+9,n] <> []) and (sectorRC[xn+9,n2] <> []) and (sectorRC[xn+9,n3] <> [])
           and (nm[Cset[xn,n]] <4) and (nm[Cset[xn,n2]] <4) and (nm[Cset[xn,n3]] < 4 )
            then
              for yn:= 45 to 128 do
               if (sectorRC[xn+9,n] + sectorRC[xn+9,n2] + sectorRC[xn+9,n3] = comboset[yn] )
                 then
                   begin
                    active:= true;

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn+9,z] - [ Cset[xn,n] , Cset[xn,n2], Cset[xn,n3] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn+9,z] - [ Cset[xn,n] , Cset[xn,n2],Cset[xn,n3] ] );
                     end;
                   
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                  techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];
                  techwrite[g,2]:=comboset[yn];
                       techwrite[g,3]:=[Cset[xn,n]]+[Cset[xn,n2]]+[Cset[xn,n3]];                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);

                      end;

                  end;{Col}

{Box}
           if (sectorRC[xn+18,n] <> []) and (sectorRC[xn+18,n2] <> []) and (sectorRC[xn+18,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 (sectorRC[xn+18,n] + sectorRC[xn+18,n2] + sectorRC[xn+18,n3] = comboset[yn] )
                 then
                   begin
                    active:= true;

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn+18,z] - [ Bset[xn,n] , Bset[xn,n2], Bset[xn,n3] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn+18,z] - [ Bset[xn,n] , Bset[xn,n2],Bset[xn,n3] ] );
                     end;
                   
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                  techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];   
                  techwrite[g,2]:= comboset[yn];
                       techwrite[g,3]:= [Bset[xn,n]]+[Bset[xn,n2]]+[Bset[xn,n3]];                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);

                      end;

                  end;{rows}

        end;
if k = 0 then chaindisplay(#87,g);
end;{naked triple}

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

if k = 0 then begin  g:=0; setlength(techwrite,g+1,14); end;
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
{Row}
           if (sectorRC[xn,n] <> []) and (sectorRC[xn,n2] <> []) and (sectorRC[xn,n3] <> []) and (sectorRC[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 (sectorRC[xn,n] + sectorRC[xn,n2] + sectorRC[xn,n3] + sectorRC[xn,n4] = comboset[yn] )

                then
                   begin
                    active:= true;                 

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn,z] - [ Rset[xn,n] , Rset[xn,n2], Rset[xn,n3] , Rset[xn,n4] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn,z] - [ Rset[xn,n] , Rset[xn,n2], Rset[xn,n3], Rset[xn,n4] ] );
                     end;
                   
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                  techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];
                  techwrite[g,2]:=comboset[yn];
                       techwrite[g,3]:= [rset[xn,n]]+[rset[xn,n2]]+[rset[xn,n3]] +[rset[xn,n4]];
                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);

                      end;
                
                  end;{row}

{Col}
           if (sectorRC[xn+9,n] <> []) and (sectorRC[xn+9,n2] <> []) and (sectorRC[xn+9,n3] <> []) and (sectorRC[xn+9,n4] <> [])
           and (nm[Cset[xn,n]] <5) and (nm[Cset[xn,n2]] <5) and (nm[Cset[xn,n3]] < 5 ) and (nm[Cset[xn,n4]] <5)
            then
             for yn:= 129 to 254 do
              if (sectorRC[xn+9,n] + sectorRC[xn+9,n2] + sectorRC[xn+9,n3] + sectorRC[xn+9,n4] = comboset[yn] )

                then
                   begin
                    active:= true;                 

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn+9,z] - [ Cset[xn,n] , Cset[xn,n2], Cset[xn,n3] , Cset[xn,n4] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn+9,z] - [ Cset[xn,n] , Cset[xn,n2], Cset[xn,n3], Cset[xn,n4] ] );
                     end;
                   
                    end;

                  if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                  techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];
                  techwrite[g,2]:=comboset[yn];
                       techwrite[g,3]:= [cset[xn,n]]+[cset[xn,n2]]+[cset[xn,n3]] +[cset[xn,n4]];
                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);

                      end;
                
                  end;{col}
{Box}
           if (sectorRC[xn+18,n] <> []) and (sectorRC[xn+18,n2] <> []) and (sectorRC[xn+18,n3] <> []) and (sectorRC[xn+18,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 (sectorRC[xn+18,n] + sectorRC[xn+18,n2] + sectorRC[xn+18,n3] + sectorRC[xn+18,n4] = comboset[yn] )

                then
                   begin
                    active:= true;                 

                    for z in comboset[yn] do
                   begin
                    covered2[z]:= covered2[z]  + (DigitRCB[xn+18,z] - [ Bset[xn,n] , Bset[xn,n2], Bset[xn,n3] , Bset[xn,n4] ] ) ; 

                        if k= 0
                            then
                             begin
                      techwrite[g,z+3]:=techwrite[g,z+3] + (DigitRCB[xn+18,z] - [ Bset[xn,n] , Bset[xn,n2], Bset[xn,n3], Bset[xn,n4] ] );
                     end;
                   
                    end;

                   if (k = 0) and (techwrite[g,1+3] + techwrite[g,2+3] + techwrite[g,3+3] + techwrite[g,4+3] + techwrite[g,5+3] + techwrite[g,6+3] + techwrite[g,7+3] + techwrite[g,8+3]+ techwrite[g,9+3] <> [])
                    then
                      begin
                  techwrite[g,0]:=[0];
                  techwrite[g,1]:=[0];
                  techwrite[g,2]:=comboset[yn];
                       techwrite[g,3]:= [bset[xn,n]]+[bset[xn,n2]]+[bset[xn,n3]] +[bset[xn,n4]];
                       
                       g:=g+1;
                       setlength(techwrite,g+1,14);

                      end;
                
                  end;{Box}
        end;
if k=0 then chaindisplay(#88,g);
end;{naked quad}
Last edited by StrmCkr on Tue Oct 18, 2022 11:11 pm, edited 1 time in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Fishing

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

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

if k=0 then begin  g:=0; setlength(techwrite,g+1,15); end;
For n:= 1 to 9 do

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

       begin

         If   (sec[xn,n] > 0) and (sec[xn,n] < 3 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 3 )
            then
              for yn:= 9 to 44 do
                if (Rnsector[xn,n] + Rnsector[xn2,n])  =  comboset2[yn]
                 then
                  begin
                    active:= true;
               
                     for z in comboset2[yn] do 
                 if  (digitRCB[z+9,n] - (DigitRCB[xn,n]+DigitRCB[xn2,n]) <> []) then                     
                         begin
                           active:=true;
                         covered2[n]:= covered2[n] + (DigitRCB[z+9,n]  - (DigitRCB[xn,n]+DigitRCB[xn2,n]));

                              if k=0 then techwrite[g,n+4]:= techwrite[g,n+4]+ (DigitRCB[z+9,n]  - (DigitRCB[xn,n]+DigitRCB[xn2,n]));                     

                         end;

 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn,xn2];
  for z in comboset2[yn] do
    techwrite[g,4]:=techwrite[g,4] + [z+9];
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;

                  end;

 If   (sec[xn,n] > 0) and (sec[xn,n] < 7 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 7 )
           and (Bxy[xn] = bxy[xn2])
            then
              for yn:= 9 to 44 do
                if (RnB[xn,n] + RnB[xn2,n])  =  comboset2[yn]
                 then
                  begin
                    active:= true;                     

                    for z in comboset2[yn] do
                      begin
                       
                       for xn3:= 0 to 8 do
                        if ([Rx[bset[z,xn3]]] * [xn,xn2] = [] ) and (n in sectorRC[z+18,xn3])
                          then
                           begin
                           include(covered[Bset[z,xn3]],n);

                           if k = 0 then techwrite[g,n+4]:=techwrite[g,n+4] +[ bset[z,xn3]];

                           end;

                      end;

 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn,xn2];
  for z in comboset2[yn] do
    techwrite[g,4]:=techwrite[g,4] + [z+18];
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;

end;

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

                     for z in comboset2[yn] do 
                 if  (digitRCB[z,n] - (DigitRCB[xn+9,n]+DigitRCB[xn2+9,n]) <> []) then
                         begin                       

                          active:=true;
                         covered2[n]:= covered2[n] + (DigitRCB[z,n]  - (DigitRCB[xn+9,n]+DigitRCB[xn2+9,n]));

                              if k=0 then techwrite[g,n+4]:= techwrite[g,n+4]+ (DigitRCB[z,n]  - (DigitRCB[xn+9,n]+DigitRCB[xn2+9,n]));                     

                         end;

 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn+9,xn2+9];
  for z in comboset2[yn] do
    techwrite[g,4]:=techwrite[g,4] + [z+9];
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;


end;

If   (sec[xn+9,n] > 0) and (sec[xn+9,n] < 7 )
           and (sec[xn2+9,n] > 0) and (sec[xn2+9,n] < 7 )
           and (Bxy[xn] = bxy[xn2])
            then
              for yn:= 9 to 44 do
                if (CnB[xn,n] + CnB[xn2,n])  =  comboset2[yn]
                 then
                  begin
                    active:= true;

                    for z in comboset2[yn] do
                      begin                     

                       for xn3:= 0 to 8 do
                        if ([CY[bset[z,xn3]]] * [xn,xn2] = [] )  and (n in sectorRC[z+18,xn3])
                          then
                           begin
                           include(covered[Bset[z,xn3]],n);

                           if k = 0 then techwrite[g,n+4]:=techwrite[g,n+4] +[ bset[z,xn3]];
                           end;

                      end;

 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn+9,xn2+9];
  for z in comboset2[yn] do
    techwrite[g,4]:=techwrite[g,4] + [z+18];
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;

end;


     If   (sec[xn+18,n] > 0) and (sec[xn+18,n] < 7 )
           and (sec[xn2+18,n] > 0) and (sec[xn2+18,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
                       begin
                       for z:= 0 to 8 do
                        if (Cy[bset[xn3,z]] in comboset2[yn])  // and( n in SectorRC[xn3+18,z])
                          then
                           begin
                            if ( n in sectorRC[xn3+18,z]) then
                                include(covered[bset[xn3,z]],n);

                            if (k =0) and( n in sectorRC[xn3+18,z])
                      then techwrite[g,n+4]:=techwrite[g,n+4]+ [Bset[xn3,z]];
                           

                           end;                     
                                          
                     end;
 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn+18,xn2+18];
 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
    techwrite[g,4]:=techwrite[g,4] + [Cy[bset[xn3,z]]+9];
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;


 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
                        begin
                       for z:= 0 to 8 do
                        if (Rx[bset[xn3,z]] in comboset2[yn]) // and (n in sectorRC[xn3,z])
                          then
                           begin
                              if (n in sectorRC[xn3+18,z])
                                then
                                 include(covered[bset[xn3,z]],n);

                             if (k =0) and (n in sectorRC[xn3+18,z])
                       then techwrite[g,n+4]:=techwrite[g,n+4]+ [Bset[xn3,z]];

                                                     
                             end;
end;
 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn+18,xn2+18];
 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
    techwrite[g,4]:=techwrite[g,4] + [Rx[bset[xn3,z]]+9];
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;


                   end;


             end;

        end;

if k = 0 then chaindisplay(#85,g);
end;{x-wing}

Skyscrapers: Show
Code: Select all
{ Skyscrapers }
procedure sky(k:integer);
var
xn,xn2,xn3,yn,n,z,q,g:integer;
Finn:RCBnums;
finns:numberset;

begin

if k = 0 then begin g:=0; setlength(techwrite,g+1,15); end;

For n:= 1 to 9 do

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

       begin
         If (sec[xn,n] > 0) and (sec[xn,n] < 3 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 3 )
             then             

                if (Rnsector[xn,n]  * Rnsector[xn2,n]  <> [])
                 then
                   begin

                    finn:= (Rnsector[xn2,n] * Rnsector[xn,n]);

                     Finns:=[];
                     for z in  finn do
                      begin
                        Finns:=[];
                        if k =0 then techwrite[g,10]:=[];

                       for q in ((Rnsector[xn,n] + Rnsector[xn2,n])  - [z] ) do
                          begin

                          if q in (rnsector[xn,n])
                           then
                            include(Finns,Rset[xn,q]);

                          if q in (rnsector[xn2,n])
                           then include(finns,Rset[xn2,q]);

                   
                           end;

                       if (Finns <> [] )
                        then
                          begin

                           for xn3 := 0 to 80 do

                            if ((Peer[xn3] * Finns )= Finns)
                            and (xn3 in digitcell[n])
                              then
                                begin
                                 include(covered[xn3],n);
                                 if k = 0 then techwrite[g,n+4]:=techwrite[g,n+4] + [xn3];
                                 active:= true;
                                end;

                          end;

 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 Techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn,xn2];
 
 for xn3 in (Rnsector[xn,n] + Rnsector[xn2,n]) do
 techwrite[g,4]:=techwrite[g,4] + [xn3+9];
 
 for xn3 in ((Rnsector[xn,n] + Rnsector[xn2,n])-(Rnsector[xn,n] * Rnsector[xn2,n])) do
   techwrite[g,4]:=techwrite[g,4] + [bxy[secset[xn,xn3]]+18]+[bxy[secset[xn2,xn3]]+18];
 
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;

 end; {Finn z sector}

 end;  {yn start}
      
            
         If (sec[xn+9,n] > 0) and (sec[xn+9,n] < 3 )
           and (sec[xn2+9,n] > 0) and (sec[xn2+9,n] < 3 )
             then
             

                if  (Rnsector[xn,n]  * RnSector[xn2,n]  <> [])
                 then
                   begin

                    finn:= (rnsector[xn2+9,n] * Rnsector[xn+9,n]);

                     Finns:=[];
                     for z in  finn do
                      begin
                        Finns:=[];
                        if k =0 then techwrite[g,10]:=[];

                       for q in ((Rnsector[xn+9,n] + Rnsector[xn2+9,n])  - [z] ) do
                          begin

                          if q in (Rnsector[xn+9,n])
                           then
                            include(Finns,Cset[xn,q]);

                          if q in (Rnsector[xn2+9,n])
                           then include(finns,Cset[xn2,q]);

                   
                           end;

                       if (Finns <> [] )
                        then
                          begin

                           for xn3 := 0 to 80 do

                            if ((Peer[xn3] * Finns )= Finns)
                            and (xn3 in digitcell[n])
                              then
                                begin
                                 include(covered[xn3],n);
                                 if k = 0 then techwrite[g,n+4]:=techwrite[g,n+4] + [xn3];
                                 active:= true;
                                end;

                          end;

 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 Techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];
 techwrite[g,2]:=[n];
 techwrite[g,3]:=[xn+9,xn2+9];
 for xn3 in (Rnsector[xn+9,n] + Rnsector[xn2+9,n]) do
 techwrite[g,4]:=techwrite[g,4] + [xn3];
 
 for xn3 in ((Rnsector[xn+9,n] + Rnsector[xn2+9,n])-(Rnsector[xn+9,n] * Rnsector[xn2+9,n])) do
  techwrite[g,4]:=techwrite[g,4] + [bxy[secset[xn+9,xn3]]+18]+ [bxy[secset[xn2+9,xn3]]+18];
 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;

 end; {Finn z sector}

 end;  {yn start}

end; {xn2,xn}
if k =0 then chaindisplay(#64,g);
end;{Skyscraper}

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

if k = 0 then begin g:=0; setlength(techwrite,g+1,15); end;
 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[j+18,n] * DigitRCB[xn,n] <> [] )     {mini row contains cells}
          and (DigitRCB[J+18,n] * DigitRCB[yn+9,n] <> [])    {mini col contains cells}
          and ( DigitRCB[xn,n] * DigitRcb[yn+9,n] = [] )     {r&c intersection = []}

          and (DigitRCB[xn,n] - (DigitRCB[j+18,n]*DigitRCB[xn,n]) <> [] )      {row has digits out side the box}
          and (DigitRCB[yn+9,n] - (DigitRCB[j+18,n]*DigitRCB[yn+9,n]) <> [] )   {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[xn,n] = (   DigitRCB[xn,n] * DigitRCB[j+18,n]) +  (DigitRCB[xn,n] * DigitRCB[yn2+9,n]) )
                 and (   DigitRCB[yn+9,n] = (   DigitRCB[yn+9,n] * DigitRCB[j+18,n]) +  (DigitRCB[yn+9,n] * DigitRCB[xn2,n]) )
             and ((DigitRCB[xn2,n] * DigitRCB[yn2+9,n]) <> [])
                 then
                  begin
                  active:= true;

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

               if (k = 0)
               then
                begin
               techwrite[g,0]:=[2];
               techwrite[g,1]:=[1];
               techwrite[g,2]:=[n];
               techwrite[g,3]:=[yn+9] + [xn];               
                    techwrite[g,4]:=[j+18] + [xn2] + [yn2+9];
               
               techwrite[g,n+4]:= (DigitRCB[xn2,n] * DigitRCB[yn2+9,n]);
               
               g:=g+1;
               setlength(techwrite,g+1,15);
               end;
               
                 end;

          end;

if k = 0 then chaindisplay(#66,g);       
            
end; {2-string kite}

Empty Rectangle: Show
Code: Select all
{Empty Rectangle}
procedure ER(K:integer);
var
g,a,xn,xn2,xn3,u:integer;
begin
links;
if k = 0 then begin u:=0; setlength(techwrite,u+1,12);  end;

for g in [1..9] do
 for xn:=low(linkset[g][6]) to high(linkset[g][6]) do
   for xn2:=low(linkset[g,1]) to high(linkset[g][1]) do
   
   if (linkset[g,6,xn,5] * linkset[g,1,xn2,4] <>[])
   and ((linkset[g,6,xn,1]+linkset[g,6,xn,2]) * (linkset[g,1,xn2,2]+linkset[g,1,xn2,1]) = [])   

 then
 begin
    {basic}
  if (linkset[g,6,xn,8] * linkset[g,1,xn2,9] <> [])
   then   
    begin
   active:=true;   
   covered2[g]:=covered2[g] + (linkset[g,6,xn,8] * linkset[g,1,xn2,9])
    end;
   
   {+ 1 link for rings/crabby}
   for a in[1,6] do
   for xn3:= low(linkset[g,a]) to high(linkset[g][a]) do
       if  ((linkset[g,6,xn,1]+linkset[g,6,xn,2]) * (linkset[g,a,xn3,2]+linkset[g,a,xn3,1]) = [])
      and ((linkset[g,1,xn2,1]+linkset[g,1,xn2,2]) * (linkset[g,a,xn3,2]+linkset[g,a,xn3,1]) = [])
       and (linkset[g,6,xn,4] * linkset[g,a,xn3,4] <> [])
 
          then
             begin
               { crabby  + }
                active:=true;
              covered2[g]:=covered2[g] + (linkset[g,6,xn,9] * linkset[g,a,xn3,9]);
           covered2[g]:=covered2[g] + (linkset[g,1,xn2,9] * linkset[g,a,xn3,9]);

           if (a =5) and (linkset[g,a,xn3,5] * linkset[g,1,xn2,5] <> []) {linked er}
             then
              begin
              covered2[g]:=covered2[g] + (linkset[g,1,xn2,8] * linkset[g,6,xn,9]);
              covered2[g]:= covered2[g] +(linkset[g,6,xn,8] * linkset[g,a,xn3,8]);
              covered2[g]:=covered2[g] + (linkset[g,a,xn3,8] * linkset[g,1,xn2,8])
              end;
             
           exit;
              end;
            
   
end;   
     

 if k = 0 then techdisplay(#65,u);
end;{empty rectangle}

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

if k = 0 then begin g:=0; setlength(techwrite,g+1,15); end;
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   (sec[xn,n] > 0) and (sec[xn,n] < 4 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 4 )
           and (sec[xn3,n] > 0) and (sec[xn3,n] < 4 )
            then
              for yn:= 45 to 128 do
                if Rnsector[xn,n] + Rnsector[xn2,n] + Rnsector[xn3,n]= comboset2[yn]
                 then
                   begin
                   
                     for z in comboset2[yn] do                       
                         begin                         

                          active:=true;
                         covered2[n]:= covered2[n] + (DigitRCB[z+9,n]  - (DigitRCB[xn,n]+DigitRCB[xn2,n]+DigitRCB[xn3,n]));

                              if k=0 then techwrite[g,n+4]:= techwrite[g,n+4]+ (DigitRCB[z+9,n]  - (DigitRCB[xn,n]+DigitRCB[xn2,n]+DigitRCB[xn3,n]));                     

                         end;

                if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
              techwrite[g,0]:=[2];
              techwrite[g,1]:=[1];
              techwrite[g,2]:=[n];
              techwrite[g,3]:=[xn,xn2,xn3];
              for z in comboset2[yn] do
               techwrite[g,4]:=techwrite[g,4] + [z+9];
                  g:=g+1;
                  setlength(techwrite,g+1,15);

                  end;

                  end;


        If   (Sec[xn+9,n] > 0) and (sec[xn+9,n] < 4 )
           and (sec[xn2+9,n] > 0) and (sec[xn2+9,n] < 4 )
           and (sec[xn3+9,n] > 0) and (sec[xn3+9,n] < 4 )
            then
              for yn:= 45 to 128 do
                if Rnsector[xn+9,n] + Rnsector[xn2+9,n] + Rnsector[xn3+9,n] = comboset2[yn]
                 then
                   begin


                     for z in comboset2[yn] do
                     
                         begin
                            active:=true;
                         covered2[n]:= covered2[n] + (DigitRCB[z,n]  - (DigitRCB[xn+9,n]+DigitRCB[xn2+9,n]+DigitRCB[xn3+9,n]));

                              if k=0 then techwrite[g,n+4]:= techwrite[g,n+4]+ (DigitRCB[z,n]  - (DigitRCB[xn+9,n]+DigitRCB[xn2+9,n]+DigitRCB[xn3+9,n]));
                     
                         end;

                if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
              techwrite[g,0]:=[2];
              techwrite[g,1]:=[1];
              techwrite[g,2]:=[n];
              techwrite[g,3]:=[xn+9,xn2+9,xn3+9];
              for z in comboset2[yn] do
               techwrite[g,4]:=techwrite[g,4] + [z];
                  g:=g+1;
                  setlength(techwrite,g+1,15);

                  end;

              end;

        end;

 if k =0 then chaindisplay(#67,g);
end;{swordfish}

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

if k = 0 then begin g:=0; setlength(techwrite,g+1,15); end;

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   (sec[xn,n] > 0) and (sec[xn,n] < 5 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 5 )
           and (sec[xn3,n] > 0) and (sec[xn3,n] < 5 )
           and (sec[xn4,n] > 0) and (sec[xn4,n] < 5 )
            then
              for yn:= 129 to 254 do
                if Rnsector[xn,n] + Rnsector[xn2,n] + Rnsector[xn3,n] + Rnsector[xn4,n]= comboset2[yn]
                 then
                   begin
                              
                     for z in comboset2[yn] do                         
                   begin                   
                   active:=true;
                  covered2[n]:= covered2[n] + (DigitRCB[z+9,n]  - (DigitRCB[xn,n]+DigitRCB[xn2,n]+DigitRCB[xn3,n]+DigitRCB[xn4,n]));

                         if k=0 then techwrite[g,n+4]:= techwrite[g,n+4]+ (DigitRCB[z+9,n]  - (DigitRCB[xn,n]+DigitRCB[xn2,n]+DigitRCB[xn3,n]+DigitRCB[xn4,n]));
                        
                       end;
   if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
              techwrite[g,0]:=[2];
              techwrite[g,1]:=[1];
              techwrite[g,2]:=[n];
              techwrite[g,3]:=[xn,xn2,xn3,xn4];
              for z in comboset2[yn] do   
              techwrite[g,4]:=techwrite[g,4] + [z+9];
                  g:=g+1;
                  setlength(techwrite,g+1,15);

                  end;
            
                  end;

        If   (sec[xn+9,n] > 0) and (sec[xn+9,n] < 5 )
           and (sec[xn2+9,n] > 0) and (sec[xn2,n] < 5 )
           and (sec[xn3+9,n] > 0) and (sec[xn3+9,n] < 5 )
           and (sec[xn4+9,n] > 0) and (sec[xn4+9,n] < 5 )
            then
              for yn:= 129 to 254 do
                 if Rnsector[xn+9,n] + Rnsector[xn2+9,n] + Rnsector[xn3+9,n] + Rnsector[xn4+9,n]= comboset2[yn]
                 then
                   begin
               
                     for z in comboset2[yn] do
                       
                   begin               
                  
                           active:=true;
                     covered2[n]:= covered2[n] + (DigitRCB[z,n]  - (DigitRCB[xn+9,n]+DigitRCB[xn2+9,n]+DigitRCB[xn3+9,n]+DigitRCB[xn4+9,n]));

                          if k=0 then techwrite[g,n+4]:= techwrite[g,n+4]+ (DigitRCB[z,n]  - (DigitRCB[xn+9,n]+DigitRCB[xn2+9,n]+DigitRCB[xn3+9,n]+DigitRCB[xn4+9,n]));
                     
                       
                  end;

if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
              techwrite[g,0]:=[2];
              techwrite[g,1]:=[1];
              techwrite[g,2]:=[n];
              techwrite[g,3]:=[xn+9,xn2+9,xn3+9,xn4+9];
              for z in comboset2[yn] do   
              techwrite[g,4]:=techwrite[g,4] + [z];
                  g:=g+1;
                  setlength(techwrite,g+1,15);

                  end;
               

                    end;


        end;
if k = 0 then chaindisplay(#68,g);
end;{jelly fish}

Finned & Sashimi x-wing: Show
Code: Select all
{ Finned and or Sashimi x-wings}
procedure smashi (k:integer);
var
xn,xn2,xn4,xn3,yn,n,z,g,q:integer;
Finn:RCBnums;
finns:numberset;

begin
if k = 0 then begin g:=0; setlength(techwrite,g+1,15); end;
For n:= 1 to 9 do

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

        begin

         If   (sec[xn,n] > 0) and (sec[xn,n] < 5 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 5 )

            then
              for yn:= 9 to 44 do
                if (( Rnsector[xn,n] + Rnsector[xn2,n] ) * comboset2[yn] = comboset2[yn] ) then
               if( (Rnsector[xn2,n] + Rnsector[xn,n] ) - comboset2[yn] <> [] )
                 then
                   begin

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

                    Finns:=[];
               
   if k = 0 then techwrite[g,4]:= [];      
   
                     for z:= 0 to 8 do
                       if z in finn
                         then
                         begin

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

                          if (Rnsector[xn,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Rset[xn,z]);
                   
             if k = 0 then
                     begin
               for  q in (Rnsector[xn2,n] + Rnsector[xn,n] ) - finn do
                 techwrite[g,4]:=techwrite[g,10] + [q+9];
               
                     for q in [18..26] do
                 if digitrcb[q,n] * finns = finns
                   then
                    techwrite[g,4]:=techwrite[g,4] + [q];
                  
                     techwrite[g,2]:=[n];
                     techwrite[g,3]:=[xn] + [xn2];
                     end;          
             
                     end;                         

                      for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn4:= 0 to 8 do
                     if n in sectorRC[xn4,z] then
                           if not (xn4 in [xn,xn2])
                            and  ( finns * peer[Rset[xn4,z]] = finns )
                             then
                       begin
                       active:= true;
                              include(covered[Rset[xn4,z]],n);                     
                       if k = 0 then techwrite[g,n+4]:=Techwrite[g,n+4] + [Rset[xn4,z]];
                       end;
                     
 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 Techwrite[g,0]:=[2];
 techwrite[g,1]:=[1];   
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;

                  end;

        If   (sec[xn+9,n] > 0) and (sec[xn+9,n] < 5 )
           and (sec[xn2+9,n] > 0) and (sec[xn2+9,n] < 5 )

            then
              for yn:= 9 to 44 do
                if ((Rnsector[xn+9,n] + RnSector[xn2+9,n] ) * comboset2[yn] = comboset2[yn]) then
                 if  ((Rnsector[xn2+9,n] + rnsector[xn+9,n] ) - comboset2[yn] <> []) then

                   begin

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

                    Finns:=[];
               
if k = 0 then techwrite[g,4]:= [];

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

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

                          if (Rnsector[xn+9,n] - comboset2[yn] <> [] )
                          then
                          include(finns,Cset[xn,z]);
                   
                  if k = 0 then
                     begin
                for  q in (Rnsector[xn2+9,n] + Rnsector[xn+9,n] ) - finn do
                 techwrite[g,4]:=techwrite[g,4] + [q];

                     for q in [18..26] do
                 if digitrcb[q,n] * finns = finns
                   then
                    techwrite[g,4]:=techwrite[g,4] + [q];

                     techwrite[g,2]:=[n];
                     techwrite[g,3]:=[xn+9] + [xn2+9];
                     end;             


                          end;

                    for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn4:= 0 to 8 do
                     if n in SectorRC[xn4+9,z] then
                           if not (xn4 in [xn,xn2])
                            and  ( finns * peer[Cset[xn4,z]] = finns )
                             then
                       begin
                       active:= true;
                              include(covered[Cset[xn4,z]],n);
                        if k = 0 then techwrite[g,n+4]:=Techwrite[g,n+4] + [cset[xn4,z]];
                        end;
                     
 if (k = 0) and (techwrite[g,n+4] <> [])
 then
 begin
 Techwrite[g,0]:=[2];
 techwrite[g,1]:=[1]; 
 g:=g+1;
 setlength(techwrite,g+1,15);
 end;
             
                 
end;

        end;
if k = 0 then chaindisplay(#20,g);
end;{SMASHI x-wings}

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

begin
if k = 0 then begin g:=0; setlength(techwrite,g+1,15); end;
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   (sec[xn,n] > 0) and (sec[xn,n] < 6 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 6 )
           and (sec[xn3,n] > 0) and (sec[xn3,n] < 6 )

            then
              for yn:= 45 to 128 do
                if (( Rnsector[xn,n] + Rnsector[xn2,n] + Rnsector[xn3,n]) * comboset2[yn] = comboset2[yn] ) then
               if( (Rnsector[xn2,n] + Rnsector[xn,n] + Rnsector[xn3,n]) - comboset2[yn] <> [] )
                 then
                   begin

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

                    Finns:=[];
               
if k = 0 then techwrite[g,10]:= [];

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

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

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

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

              if k = 0 then
                     begin
               for  q in (Rnsector[xn2,n] + Rnsector[xn,n] + Rnsector[xn3,n]) - finn do
                 techwrite[g,4]:=techwrite[g,10] + [q+9];
               
                     for q in [18..26] do
                 if digitrcb[q,n] * finns = finns
                   then
                    techwrite[g,4]:=techwrite[g,4] + [q];
                  
                     techwrite[g,2]:=[n];
                     techwrite[g,3]:=[xn] + [xn2] + [xn3];
                     end;
                         end;

                      for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn4:= 0 to 8 do
                     if n in sectorRC[xn4,z] then
                           if not (xn4 in [xn,xn2,xn3])
                            and  ( finns * peer[Rset[xn4,z]] = finns )
                             then
                       begin
                       active:= true;
                              include(covered[Rset[xn4,z]],n);
                     
                       if k = 0 then techwrite[g,n+4]:=Techwrite[g,n+4] + [Rset[xn4,z]];
                       end;
                     
   if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
              techwrite[g,0]:=[2];
              techwrite[g,1]:=[1];
                  g:=g+1;
                  setlength(techwrite,g+1,15);

                  end;

                  end;

        If   (sec[xn+9,n] > 0) and (sec[xn+9,n] < 6 )
           and (sec[xn2+9,n] > 0) and (sec[xn2+9,n] < 6 )
           and  (sec[xn3+9,n] > 0) and (sec[xn3+9,n] < 6 )

            then
              for yn:= 45 to 128 do
                if ((Rnsector[xn+9,n] + Rnsector[xn2+9,n] + Rnsector[xn3+9,n]) * comboset2[yn] = comboset2[yn]) then
                 if  ((Rnsector[xn2+9,n] + Rnsector[xn+9,n]+ Rnsector[xn3+9,n]) - comboset2[yn] <> []) then

                   begin

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

                    Finns:=[];
               
if k = 0 then techwrite[g,4]:= [];

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

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

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

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

                if k = 0 then
                     begin
                for  q in (Rnsector[xn2+9,n] + Rnsector[xn+9,n] + Rnsector[xn3+9,n]) - finn do
                 techwrite[g,4]:=techwrite[g,4] + [q];

                     for q in [18..26] do
                 if digitrcb[q,n] * finns = finns
                   then
                    techwrite[g,4]:=techwrite[g,4] + [q];

                     techwrite[g,2]:=[n];
                     techwrite[g,3]:=[xn+9] + [xn2+9]+[xn3+9];
                     end;

                          end;

                    for z:= 0 to 8 do
                        if z in comboset2[yn]
                         then
                          for xn4:= 0 to 8 do
                     if n in SectorRC[xn4+9,z] then
                           if not (xn4 in [xn,xn2,xn3])
                            and  ( finns * peer[Cset[xn4,z]] = finns )
                             then
                       begin
                       active:= true;
                              include(covered[Cset[xn4,z]],n);
                        if k = 0 then techwrite[g,n+4]:=Techwrite[g,n+4] + [cset[xn4,z]];
                        end;
                     
   if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
              techwrite[g,0]:=[2];
              techwrite[g,1]:=[1];
                  g:=g+1;
                  setlength(techwrite,g+1,15);

                  end;
             
                  end;


        end;
   if k = 0 then chaindisplay(#92,g);   
end;{SMASHIswords}

finned & sashimi Jelly fish: Show
Code: Select all
{Finned Sashimi jelly fish}
procedure smashijelly(k:integer);

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

begin
if k = 0 then begin g:=0; setlength(techwrite,g+1,15); end;

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   (sec[xn,n] > 0) and (sec[xn,n] < 7 )
           and (sec[xn2,n] > 0) and (sec[xn2,n] < 7 )
           and (sec[xn3,n] > 0) and (sec[xn3,n] < 7 )
            and (sec[xn4,n] > 0) and (sec[xn4,n] < 7 )

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

if ((Rnsector[xn2,n] + Rnsector[xn,n] + Rnsector[xn3,n] + Rnsector[xn4,n]) - comboset2[yn] <> [])
                 then
                   begin

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

                    Finns:=[];

if k = 0 then techwrite[g,4]:= [];

                     for  z in finn do

                         begin

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

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

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

                           if (Rnsector[xn3,n] - comboset2[yn] <> [])
                           then
                            include(finns,Rset[xn3,z]);
                     
            if k = 0 then
                     begin
                 for  q in (rnsector[xn2,n] + rnsector[xn,n] + rnsector[xn3,n] + rnsector[xn4,n]) - finn do
                 techwrite[g,4]:=techwrite[g,4] + [q+9];

                     for q in [18..26] do
                 if digitrcb[q,n] * finns = finns
                   then
                    techwrite[g,4]:=techwrite[g,10] + [q];

                     techwrite[g,2]:=[n];
                     techwrite[g,3]:=[xn+9] + [xn2+9]+[xn3+9] +[xn4+9];
                     end;

                          end;

                      for z in comboset2[yn] do
                          for xn5:= 0 to 8 do
                           if n in sectorRC[xn5,z] then
                           if not (xn5 in [xn,xn2,xn3,xn4])
                            and  ( finns * peer[Rset[xn5,z]] = finns )
                             then
                       begin
                        active:= true;
                              include(covered[Rset[xn5,z]],n);
                       if k=0
                           then
                             techwrite[g,n+4]:= techwrite[g,n+4]+  ([rset[xn5,z]]);
                       end;

if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
              techwrite[g,0]:=[2];
              techwrite[g,1]:=[1];
                  g:=g+1;
                  setlength(techwrite,g+1,15);

                  end;
            
                  end;

if (sec[xn+9,n] > 0) and (sec[xn+9,n] < 7 )
           and (sec[xn2+9,n] > 0) and (sec[xn2+9,n] < 7 )
           and (sec[xn3+9,n] > 0) and (sec[xn3+9,n] < 7 )
            and (sec[xn4+9,n] > 0) and (sec[xn4+9,n] < 7 )

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

if ((Rnsector[xn2+9,n] + Rnsector[xn+9,n] + Rnsector[xn3+9,n] + Rnsector[xn4+9,n]) - comboset2[yn] <> [])
                 then
            
                   begin

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

                    Finns:=[];

if k=0 then techwrite[g,4]:= [];

                     for z in finn do

                          begin

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

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

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

                          if (Rnsector[xn3+9,n] - comboset2[yn] <> [])
                           then
                            include(finns,Cset[xn3,z]);
                     
                     
            if k = 0 then
                     begin
                 for  q in (Rnsector[xn2+9,n] + Rnsector[xn+9,n] + Rnsector[xn3+9,n] + Rnsector[xn4+9,n]) - finn do
                 techwrite[g,4]:=techwrite[g,4] + [q];

                     for q in [18..26] do
                 if digitrcb[q,n] * finns = finns
                   then
                    techwrite[g,4]:=techwrite[g,10] + [q];               

                     techwrite[g,2]:=[n];
                     techwrite[g,3]:=[xn+9] + [xn2+9]+[xn3+9] +[xn4+9];
                     end;            
                     
                          end;                  


                    for z in comboset2[yn] do
                          for xn5:= 0 to 8 do
                     if n in SectorRC[xn5+9,z] then
                           if not (xn5 in [xn,xn2,xn3,xn4])
                            and  ( finns * peer[Cset[xn5,z]] = finns )
                             then
                       begin
                       active:=true;
                              include(covered[Cset[xn5,z]],n);
                       if k=0
                           then
                             techwrite[g,n+4]:= techwrite[g,n+4]+ ([Cset[xn5,z]]);
                       end;
                     
if (k = 0) and (techwrite[g,n+4] <> [])
                 then
                  begin
               Techwrite[g,0]:=[2];
                   techwrite[g,1]:=[1];
                  g:=g+1;             
                  setlength(techwrite,g+1,15);

                  end;
            
                  end;

        end;
if k = 0 then chaindisplay(#93,g);

end;{SMASHIjellies}

N x (N + K) Fish finder
NxN+K fish finder: Show
Code: Select all
{fish finder}
procedure fishfinder(R1,E1,t:integer);
type
 hold = array of integer;
 hold2 = array of integer;
 hold3 = 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;

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

 Cover2 = array of numberset;

 used2 = array of rcbpeer;
 used3 = array of rcbpeer;

 peered = array of rcbpeer;

var
 a1,b1,a2,b2,z,n,w,w2,p,p2,q,q2,x,s,s2,f,f2,k,l,m,g,v,u,j,d:integer;
 output:text;
 E,R:integer;

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

use:used2;
use2:used3;

use3:rcbpeer;
use4:rcbpeer;

Base: base2;

Bbase:base5;
Rbase:base6;
Cbase:base7;

basei: base3;
pbasei: base4;

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

scover:numberset;
srcover:numberset;
sccover:numberset;
sbcover:numberset;

peers:peered;

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

begin

 setlength(h3,0);
 setlength(use,0);
 setlength(h,0);
 setlength(base,0);
 setlength(Bbase,0);
 setlength(Cbase,0);
 setlength(Rbase,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(h,(8));      { stores the active sectors }
setlength(use,8);
setlength(base,8);
setlength(basei,8);
setlength(pbasei,8);
setlength(peers,8);

setlength(Bbase,8);
setlength(Cbase,8);
setlength(Rbase,8);

setlength(h3,27);
setlength(h2,10);
setlength(use2,10);
setlength(cover,10);    {cover area's}
setlength(Rcover,10);   {specific cover area's }
setlength(Ccover,10);
setlength(Bcover,10);

 if R1 = 0 then 
 begin
writexy(2,28,'minimal Fish size to search?');
R:=ord(readkey)-48;
write(': ',R);
 end
   else R:=R1;
 
 if E1 = 0 then 
 begin
writexy(2,29,'Maximum Fish size to search?');
E:=ord(readkey)-48;
write(': ',E);
 end
   else E:=E1;

if t=0 then begin  u:=0; setlength(techwrite,u+1,13); end;

for n:= 1 to 9 do    {digits 1 - 9}
 for z:= R to E  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[s,n] <> [])   {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[s2,n] <> [])
               and ((digitRCB[s2,n] * digitRCB[s,n]) <> [] )
                 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 ) )
        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[p,n] - base[w] <> []) {makes sure the newly selected base sector actually has active cells to add}
                        and (q >= (z-1-w))
                        and  ( p in ( (sector ) - 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[p,n];        {sets the base value}
                             peers[w]:=peers[w-1] + sector2[p];

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

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

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

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


                              if (base[w-1] * digitRCB[p,n])  <> []
                                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];


                             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)  and  ((Rbase[w] * Cbase[w] * Bbase[w] ) * Base[w] = [] )
 {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;
       m:=0;
       setlength(h3,0);
       setlength(h3,27);

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

               then
                begin

                 inc(f);

                 if  ( ((Rbase[w] * Cbase[w]) + (Rbase[w] * Bbase[w]) +(Bbase[w] * Cbase[w])) *  DigitRCB[x,n]  <> [] )
                  then
                    begin
                     inc(m);
                     h3[m]:=x;
                     end;

                 if (X > a2 )
                   then
                    a2:=x;

                    b2:=x;

                end;


      end;

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


        for s2:= a2 downto (b2+(z+k-1)) do
          if (digitRCB[s2,n] * base[w]  <> [] )
          and (S2 in( ( peers[w] ) - use[w] ))
           and(f>=(z+k)-1)
           and (s2 >= h3[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[p2,n] * (base[w] - cover[w2]) <> [])
                       and (p2 in ( ( peers[w])  - use[w] - use2[w2]  )  )
                        and (q2 >= ((z+k)-1-w2))
                        and (p2 >= h3[w2+1])
                         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[p2,n];

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

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

                             if p2 in [18..26]
                              then
                               Bcover[w2]:= Bcover[w2-1] + digitRCB[p2,n]
                              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 ( ( 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;

                       l:=1;
                           
                  use3:=[];
                  scover:=[];
                  srcover:=[];
                  sccover:=[];
                  sbcover:=[];
               
                  {checks for overlaping cover sectors that can swap 1 for 1}
                  for j in use2[w2] do
                    for d in (peerRCB[j] - (use[w]+use2[w2])) do
                    if (base[w] * digitRCB[d,n] =  base[w] * digitrcb[j,n] )
                     and (base[w] * digitrcb[d,n] <> [])
                      then
                      begin
                      // writexy(2,60,'found ');                     
                     
                       use3:= use3 + [D];
                       Scover:=Scover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                     
                      if d in [0..8]
                       then                     
                       Srcover:=srcover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                     
                       if d in [9..17]
                        then
                       Sccover:=sccover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                     
                       if d in [18..26]
                       then
                       sbcover:=sbcover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                     
                     end;
         
                    if (w2 = z)
                        then
                         covered2[n]:= covered2[n] + ((cover[w2]+scover) - 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+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]+Srcover) * (Ccover[w2]+sccover)) + ((Rcover[w2]+srcover) * (Bcover[w2]+sbcover)) + ( (Ccover[w2]+sccover) * (Bcover[w2]+sbcover)) ) - 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]);
                  
               if (w2 = z+2)  { 2 fin sector - elimiantions in overlaps of cover sectors not in base }
                      then
                         covered2[n]:=COvered2[n] + (((Rcover[w2]+SRcover) * (Bcover[w2]+Sbcover) * (Ccover[w2]+Sccover))- base[w]);   
               
            
               

 if t = 0
       then
       begin
      techwrite[u,11]:=[n];
      techwrite[u,0]:=use[w] ;
      techwrite[u,10]:= use2[w2];
      techwrite[u,12]:= use3;
      
      {if (w2 = z) and (use3 <> [])
         then
      techwrite[u,n]:=techwrite[u,n] + (scover   - base[w]);}
      
      if (w2 = z)
         then
      techwrite[u,n]:=techwrite[u,n] + ((cover[w2]+scover) - base[w]);
      
      if  ((w2 = z+1) or ( w2 = z))  { 1 or 0 fin sectors - elimiantions in overlaps of cover sectors not in base }
        then
      techwrite[u,n]:=techwrite[u,n] + (( (Rcover[w2] * Ccover[w2]) + (Rcover[w2] * Bcover[w2]) + ( Ccover[w2] * Bcover[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
      techwrite[u,n]:=techwrite[u,n] + (( ((Rcover[w2]+Srcover) * (Ccover[w2]+sccover)) + ((Rcover[w2]+srcover) * (Bcover[w2]+sbcover)) + ( (Ccover[w2]+sccover) * (Bcover[w2]+sbcover)) ) - base[w]) ;
               
      
      if (w2 = z+2)  { 2 fin sector - elimiantions in overlaps of cover sectors not in base }
                      then
      techwrite[u,n]:= techwrite[u,n] + ((Rcover[w2] * Bcover[w2] * Ccover[w2])- base[w]);
   
      if (w2 = z+2)  { 2 fin sector - elimiantions in overlaps of cover sectors not in base }
                      then
                         techwrite[u,n]:= techwrite[u,n] + (((Rcover[w2]+SRcover) * (Bcover[w2]+Sbcover) * (Ccover[w2]+Sccover))- base[w]);   
   
   
      
   if techwrite[u,n]  <> []
      then
       begin
         u:= u+1;
         setlength(techwrite,u+1,13);
        end;    
      
if u = 32767    {max array size error code safty exit}
 then
 begin
  if t = 0 then
     techdisplay(#102,u);
   
    setlength(techwrite,0,0);
    u:=0; setlength(techwrite,u+1,13)
   
 //exit;
end;      
            
      
      end;   
                         


end;

                  if (w2 =z+k) and (basei[w] <> [])
                     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;
                          l:=1;
                  use3:=[];
                  scover:=[];
                  srcover:=[];
                  sccover:=[];
                  sbcover:=[];
               
                  {checks for overlaping cover sectors that can swap 1 for 1}
                  for j in use2[w2] do
                    for d in (peerRCB[j] - (use[w]+use2[w2])) do
                    if (base[w] * digitRCB[d,n] =  base[w] * digitrcb[j,n] )
                     and (base[w] * digitrcb[d,n] <> [])
                      then
                      begin
                      // writexy(2,60,'found ');                     
                     
                       use3:= use3 + [D];
                       Scover:=Scover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                     
                      if d in [0..8]
                       then                     
                       Srcover:=srcover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                     
                       if d in [9..17]
                        then
                       Sccover:=sccover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                     
                       if d in [18..26]
                       then
                       sbcover:=sbcover + (digitrcb[d,n] - (digitrcb[d,n]*digitrcb[j,n]));
                                                       
                     
                     end;



                      if (w2=z)
                       then
                         covered2[n]:=covered2[n] +(  (pbasei[w] * cover[w2]* scover) - 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]+srcover) * (Ccover[w2]+sccover)) + ((Rcover[w2]+srcover) * (Bcover[w2]+sbcover)) + ( (Ccover[w2]+sccover) * (Bcover[w2]+sbcover)))) - 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]+srcover)*(Bcover[w2]+sbcover)*(Ccover[w2]+sccover))) - base[w]);
                  
               
                  
      
 if t = 0
       then
       begin
      techwrite[u,11]:=[n];
      techwrite[u,0]:=use[w] ;
      techwrite[u,10]:= use2[w2];
      techwrite[u,12]:=use3;
      
      if (w2 = z)
         then
      techwrite[u,n]:=techwrite[u,n] + (  (pbasei[w] * cover[w2]* scover) - base[w]);
      if  ((w2 = z+1) or ( w2 = z))  { 1 or 0 fin sectors - elimiantions in overlaps of cover sectors not in base }
                      then
      techwrite[u,n]:=techwrite[u,n] + ( (pbasei[w] * (((Rcover[w2]+srcover) * (Ccover[w2]+sccover)) + ((Rcover[w2]+srcover) * (Bcover[w2]+sbcover)) + ( (Ccover[w2]+sccover) * (Bcover[w2]+sbcover)))) - base[w]);

      if (w2 = z+2)  { 2 fin sector - elimiantions in overlaps of cover sectors not in base }
                      then
      techwrite[u,n]:= techwrite[u,n] + ((pbasei[w] * ((Rcover[w2]+srcover)*(Bcover[w2]+sbcover)*(Ccover[w2]+sccover))) - base[w]);
      
   if techwrite[u,n]  <> []
      then
       begin
         u:= u+1;
         setlength(techwrite,u+1,13);
        end;
      
if u = 32767    {max array size error code safty exit}
 then
 begin
  if t = 0 then
     techdisplay(#102,u);
   
    setlength(techwrite,0,0);
    u:=0; setlength(techwrite,u+1,13)
   
 //exit;
end;   
            
      
      end;   

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>2) or (l=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] = []))
                   or ((Rbase[w] * Cbase[w] * Bbase[w] ) * Base[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;
 

 if t = 0 then techdisplay(#102,u);
 
  if R1 = 0 then   
writexy(2,28,'                                   ');
   
 if E1 = 0 then 
 writexy(2,29,'                                   ');
 

end; {fish finder}
Last edited by StrmCkr on Tue Oct 18, 2022 11:22 pm, edited 2 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Named Wings

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

W-wing
W - Wing: Show
Code: Select all
 procedure Wwing(K:integer); {rebuilt to issolate N}
var
xn,xn2,xn3,xn4,n,u,a,b,g,h,i:integer;
used:numberset;
begin
//u:=0;
links;
if k=1 then begin  u:=0; setlength(techwrite,u+1,27); end;

for g in [1..9] do
for xn:= low(linkset[g][0]) to high(linkset[g][0]) do   
   {basic code}
   for h in linkset[g,0,xn,7] do 
    for a in [1..5] do
     for xn2:= low(linkset[h][a]) to high(linkset[h][a]) do         
         if (linkset[g][0,xn,3] = linkset[h][a,xn2,0]   )
        and ( (linkset[g][0,xn,5] * linkset[h][a,xn2,4] )<> [])
         and ( (linkset[g][0,xn,2] * linkset[h][a,xn2,1])  = [])
         and ( (linkset[g][0,xn,2] * linkset[h][a,xn2,2])  = []) {cant have cells from the first spot}
        then       
         for xn3:= low(linkset[h][0]) to high(linkset[h][0]) do            
           if  (linkset[h][a,xn2,3] = linkset[h][0,xn3,0])
           and (linkset[g][0,xn,0] = linkset[h][0,xn3,3])
            and (linkset[h][a,xn2,3] = linkset[h][0,xn3,0])
           and ( linkset[h][a,xn2,5] * linkset[h][0,xn3,4] <> [] )
           and ( (linkset[h][a,xn2,2] * linkset[h][0,xn3,1])  = [])
           and ( (linkset[h][a,xn2,1] * linkset[h][0,xn3,1])  = []){cant have cells from the previous link}
                      
            then       
             begin
         
             if  (linkset[g][0,xn,8] * linkset[h][0,xn3,8] <> [] )
            then
             begin {eliminations}
                    active:= true;
               
                For n in (linkset[g][0,xn,0] * linkset[h][0,xn3,3])  do
                        begin                
                 covered2[n]:=covered2[n]  + (linkset[g][0,xn,8] * linkset[h][0,xn3,9]);
                          if k = 1
                            then
                              techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[g][0,xn,8] * linkset[h][0,xn3,9]);                     
                    end;

if (k = 1) and (techwrite[u,1+13]+ (techwrite[u,2+13])+ (techwrite[u,3+13] )
+ (techwrite[u,4+13] ) + (techwrite[u,5+13])+ (techwrite[u,6+13] )
+ (techwrite[u,7+13] ) + (techwrite[u,8+13])+ (techwrite[u,9+13] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[10];
   
   techwrite[u,2]:=linkset[g,0][xn][0];
   techwrite[u,3]:=linkset[g,0][xn][1];
   techwrite[u,4]:=linkset[g,0][xn][2];
   techwrite[u,5]:=linkset[g,0][xn][3];
   
   techwrite[u,6]:=linkset[h,a][xn2][0];
   techwrite[u,7]:=linkset[h,a][xn2][1];
   techwrite[u,8]:=linkset[h,a][xn2][2];
   techwrite[u,9]:=linkset[h,a][xn2][3];
   
   techwrite[u,10]:=linkset[h,0][xn3][0];
   techwrite[u,11]:=linkset[h,0][xn3][1];
   techwrite[u,12]:=linkset[h,0][xn3][2];
   techwrite[u,13]:=linkset[h,0][xn3][3];

   u:=u+1;
   setlength(techwrite,u+1,27);   
   
   end;      
               
               end;
            

    for b in [1..5] do   
      for xn4:= low(linkset[g][b]) to high(linkset[g][b]) do        
          if   
          {first link of xn4 to xn3 cell}       
         (linkset[g][b,xn4,0]  = linkset[h][0,xn3,3] )  {have the same digit}
          and (linkset[g][b,xn4,4] * linkset[h][0,xn3,5]  <> [])   {be visible peers}
          and ((linkset[g][b,xn4,1] + linkset[g][b,xn4,2] )  *   (linkset[h][0,xn3,1]+linkset[h][0,xn3,2])  = []   )  {no overlaping cells}
        {2nd link of xn4 to xn cell}   
        and (linkset[g][b,xn4,3]  = linkset[g][0,xn,0] )
        and (linkset[g][b,xn4,5] * linkset[g][0,xn,4] <> [])
       and ((linkset[g][b,xn4,1] + linkset[g][b,xn4,2] )  *   (linkset[g][0,xn,1]+linkset[g][0,xn,2])  = []   )
               
            then
            begin
                     
           active:= true;         
           used:= ( linkset[g][0,xn,1]+linkset[g][0,xn,2]
                  + linkset[h][a,xn2,1]+linkset[h][a,xn2,2]
                +  linkset[h][0,xn3,1]+linkset[h][0,xn3,2]
                 +  linkset[g][b,xn4,1]+linkset[g][b,xn4,2] );
                
               //basic
                For n in (linkset[g][0,xn,3] * linkset[h][0,xn3,0])  do
                 begin
                 covered2[n]:=covered2[n]  +( (linkset[g][0,xn,8] * linkset[h][0,xn3,9]) );
                  if k= 1
                     then
                    techwrite[u,n+17]:=techwrite[u,n+17] +( (linkset[g][0,xn,8] * linkset[h][0,xn3,9]) );
                   
                 end;
               
                    // ring                 
                 for n in linkset[g][0,xn,3] * linkset[h][a,xn2,0] do
                  begin
                 covered2[n]:= covered2[n] + ( (linkset[g][0,xn,9] * linkset[h][a,xn2,8])-used );
                   if k= 1
                     then
                    techwrite[u,n+17]:=techwrite[u,n+17] +( (linkset[g][0,xn,9] * linkset[h][a,xn2,8])-used );
                   
                 end;
                
                 for n in linkset[h][a,xn2,3] * linkset[h][0,xn3,0] do
                  begin
                 covered2[n]:= covered2[n] + ( (linkset[h][a,xn2,9] * linkset[h][0,xn3,8])-used);
                  if k= 1
                     then
                    techwrite[u,n+17]:=techwrite[u,n+17] +( (linkset[h][a,xn2,9] * linkset[h][0,xn3,8])-used);
                  end;
                
                 for n in linkset[h][0,xn3,3] * linkset[g][b,xn4,0] do
                  begin
                 covered2[n]:= covered2[n] + ( (linkset[h][0,xn3,9] * linkset[g][b,xn4,8])-used);
                  if k= 1
                     then
                    techwrite[u,n+17]:=techwrite[u,n+17] +( (linkset[h][0,xn3,9] * linkset[g][b,xn4,8])-used);
                  end;
                
                  for n in linkset[g][b,xn4,3] * linkset[g][0,xn,0] do
                   begin
                 covered2[n]:= covered2[n] + ( (linkset[g][b,xn4,9] * linkset[g][0,xn,8])-used);
                  if k= 1
                     then
                    techwrite[u,n+17]:=techwrite[u,n+17] + ( (linkset[g][b,xn4,9] * linkset[g][0,xn,8])-used);
   
                      end;
if (k = 1) and (techwrite[u,1+17]+ (techwrite[u,2+17])+ (techwrite[u,3+17] )
+ (techwrite[u,4+17] ) + (techwrite[u,5+17])+ (techwrite[u,6+17] )
+ (techwrite[u,7+17] ) + (techwrite[u,8+17])+ (techwrite[u,9+17] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[14];
   
   techwrite[u,2]:=linkset[g,0][xn][0];
   techwrite[u,3]:=linkset[g,0][xn][1];
   techwrite[u,4]:=linkset[g,0][xn][2];
   techwrite[u,5]:=linkset[g,0][xn][3];
   
   techwrite[u,6]:=linkset[h,a][xn2][0];
   techwrite[u,7]:=linkset[h,a][xn2][1];
   techwrite[u,8]:=linkset[h,a][xn2][2];
   techwrite[u,9]:=linkset[h,a][xn2][3];
   
   techwrite[u,10]:=linkset[h,0][xn3][0];
   techwrite[u,11]:=linkset[h,0][xn3][1];
   techwrite[u,12]:=linkset[h,0][xn3][2];
   techwrite[u,13]:=linkset[h,0][xn3][3];
   
   techwrite[u,14]:=linkset[g,b][xn4][0];
   techwrite[u,15]:=linkset[g,b][xn4][1];
   techwrite[u,16]:=linkset[g,b][xn4][2];
   techwrite[u,17]:=linkset[g,b][xn4][3];

   u:=u+1;
   setlength(techwrite,u+1,27);   
   
   end;                     
                     
                 
            end; {ring finder}
            
              end;
       
  if k = 1 then chaindisplay(#133,u);
 
end; {w-wing/rings}

M-wing
M - Wing: Show
Code: Select all
procedure Mwing(k:integer);
var
xn,xn2,xn3,a,b,u,n,g,h,r:integer;
begin
links;
if k = 1 then begin  u:=0; setlength(techwrite,u+1,23)   end;    

for g in [1..9] do
for xn:= low(linkset[g][0]) to high(linkset[g][0] ) do
  for h in linkset[g][0,xn,7] do
   for a in [1,2,3] do
    for xn2:= low(linkset[h][a]) to high(linkset[h][a]) do
   
    if  (linkset[h][a,xn2,1] * linkset[g][0,xn,2] = [])
   and (linkset[g][0,xn,3] * linkset[h][a,xn2,0] <> [])   
   and (linkset[h][a,xn2,4] * linkset[g][0,xn,5] <> [])   
   and (linkset[h][a,xn2,2] * linkset[g][0,xn,2] = []) { linking 2nd cells cant land on the first cell}
     then
       for b in [1,2,3] do
         for xn3:= low(linkset[g][b]) to high(linkset[g][b]) do
         
             if (linkset[g][b,xn3,1] = linkset[h][a,xn2,2] )            
             and (linkset[g][b,xn3,2] * linkset[g][0,xn,1] = [])
            and (linkset[g][b,xn3,6] <> [0] )  // links must be linkable
           then
            begin
                 
             if  (linkset[g][0,xn,8] * linkset[g][b,xn3,8] <> [] )
             then
              begin
              active:=true;   
             
                 For n in (linkset[g][0,xn,0] * linkset[g][b,xn3,3])  do   
                         begin                
                  covered2[n]:=covered2[n]  + (linkset[g][0,xn,8] * linkset[g][b,xn3,9]);
               if k = 1 then   techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[g][0,xn,8] * linkset[g][b,xn3,9]);
                        end;             
            
            if (linkset[g][0,xn,4] * linkset[g][b,xn3,5] <> [])
                  then
                    begin                      
                  active:=true;
                  
                  for n in (linkset[g][0,xn,3] * linkset[h][a,xn2,0]) do
                     begin
                    covered2[n]:=covered2[n] + (linkset[g][0,xn,9] * linkset[h][a,xn2,8]);
                    if k = 1 then   techwrite[u,n+13]:=techwrite[u,n+13]  + (linkset[g][0,xn,9] * linkset[h][a,xn2,8]);
                     end;
                  
                        for n in (linkset[h][a,xn2,2] * linkset[g][b,xn3,1]) do
                    begin
                         covered[n]:= covered[n] + (pm[n] - (linkset[h][a,xn2,3] + linkset[g][b,xn3,0]) );
                          if k = 1 then
                     begin
                      for r in (pm[n] - (linkset[h][a,xn2,3] + linkset[g][b,xn3,0]) ) do
                       techwrite[u,r+13]:=techwrite[u,r+13] + [N];
                      end;
                   end;
                  
                   
               end;    
                                 
            end;

if (k = 1) and (techwrite[u,1+13]+ (techwrite[u,2+13])+ (techwrite[u,3+13] )
+ (techwrite[u,4+13] ) + (techwrite[u,5+13])+ (techwrite[u,6+13] )
+ (techwrite[u,7+13] ) + (techwrite[u,8+13])+ (techwrite[u,9+13] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[10];
   
   techwrite[u,2]:=linkset[g,0][xn][0];
   techwrite[u,3]:=linkset[g,0][xn][1];
   techwrite[u,4]:=linkset[g,0][xn][2];
   techwrite[u,5]:=linkset[g,0][xn][3];
   
   techwrite[u,6]:=linkset[h,a][xn2][0];
   techwrite[u,7]:=linkset[h,a][xn2][1];
   techwrite[u,8]:=linkset[h,a][xn2][2];
   techwrite[u,9]:=linkset[h,a][xn2][3];
   
   techwrite[u,10]:=linkset[g,b][xn3][0];
   techwrite[u,11]:=linkset[g,b][xn3][1];
   techwrite[u,12]:=linkset[g,b][xn3][2];
   techwrite[u,13]:=linkset[g,b][xn3][3];   

   u:=u+1;
   setlength(techwrite,u+1,23);   
   
   end; 
           end;
          
         
   if k = 1 then chaindisplay(#135,u);   
end;

Split Wing
S-Wing: Show
Code: Select all
{split wing}
Procedure Swing(K:integer);
var
xn,a,xn2,b,xn3,n,u,g,h:integer;
begin
links;
if k = 1 then begin  u:=0; setlength(techwrite,u+1,23)   end;

for g in [1..9] do
for a in [1..2] do
 for xn:= low(linkset[g][a]) to high(linkset[g][a]) do 
 
    for xn2:= low(linkset[g][0] )to high(linkset[g][0]) do
      if  (linkset[g][0,xn2,4] * linkset[g][a,xn,5] <> [])
     and (linkset[g][0,xn2,1] * linkset[g][a,xn,2] = [])
     and (linkset[g][0,xn2,1] * linkset[g][a,xn,1] = [])   
       then
       for h in linkset[g,0,xn2,7] do
       for b in[1..5] do
        for xn3:= low(linkset[h][b] ) to high(linkset[h][b]) do                  
          if ( linkset[h][b,xn3,4] * linkset[g][0,xn2,5] <> [])
          and (linkset[h][b,xn3,5] * linkset[g][a,xn,4] <> [])
          and (linkset[g][a,xn,1] * linkset[h][b,xn3,2] = [])
          and (linkset[h][b,xn3,2] * linkset[g][0,xn2,2] = [])         
          and (linkset[h][b,xn3,1] * linkset[g][0,xn2,2] = [])
                             
          then
           begin    
          
            active:=true;             
            if h in linkset[g][a,xn,6]
             then
             for n in linkset[h][b,xn3,3] do
              begin
               covered2[n]:=covered2[n] + (linkset[g][a,xn,1] );
               
               if k = 1 then techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[g][a,xn,1] );
               end;
               
          if g in linkset[h][b,xn3,7]
            then
             for n in linkset[g][a,xn,0] do
               begin
               covered2[n]:=covered2[n] + (linkset[h][b,xn3,2] ) ;
               
                      if k = 1 then techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[h][b,xn3,2] ) ;
                end;   
               
if (k = 1) and (techwrite[u,1+13]+ (techwrite[u,2+13])+ (techwrite[u,3+13] )
+ (techwrite[u,4+13] ) + (techwrite[u,5+13])+ (techwrite[u,6+13] )
+ (techwrite[u,7+13] ) + (techwrite[u,8+13])+ (techwrite[u,9+13] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[10];
   
   techwrite[u,2]:=linkset[g,a][xn][0];
   techwrite[u,3]:=linkset[g,a][xn][1];
   techwrite[u,4]:=linkset[g,a][xn][2];
   techwrite[u,5]:=linkset[g,a][xn][3];
   
   techwrite[u,6]:=linkset[g,0][xn2][0];
   techwrite[u,7]:=linkset[g,0][xn2][1];
   techwrite[u,8]:=linkset[g,0][xn2][2];
   techwrite[u,9]:=linkset[g,0][xn2][3];
   
   techwrite[u,10]:=linkset[h,b][xn3][0];
   techwrite[u,11]:=linkset[h,b][xn3][1];
   techwrite[u,12]:=linkset[h,b][xn3][2];
   techwrite[u,13]:=linkset[h,b][xn3][3];   

   u:=u+1;
   setlength(techwrite,u+1,23);   
   
   end;             
             
           end;
             
if k= 1 then chaindisplay(#134,u);
end;

Local 2 wing
L2-wing: Show
Code: Select all
{local 2 wing }
Procedure L2wing(K:integer);
var
xn,a,xn2,b,xn3,c,n,u,g,h:integer;
begin
links;
if k = 1 then begin u:=0; setlength(techwrite,u+1,23);  end;

for g in [1..9] do
for a in[1,3] do
 for xn:= low(linkset[g][a]) to high(linkset[g][a]) do 
 for h in (linkset[g,a,xn,7]) do 
 for b in[1,2] do
    for xn2:= low(linkset[h][b]) to high(linkset[h][b]) do   
      if (linkset[h,b,xn2,6] * linkset[g,a,xn,7] <> [] )   { cell can overlap}
      and (linkset[h,b,xn2,4] * linkset[g,a,xn,5] <> [] )  { a & b share sector }
        and (linkset[h,b,xn2,1] = linkset[g,a,xn,2] )      {a end, b start share exact cell}
        and (linkset[h,b,xn2,2] * linkset[g,a,xn,1] = [] ) // a & b cant be duplicates       
     then
       for c in [1,2,3,5] do
       for xn3:=low(linkset[h][c]) to high(linkset[h][c]) do
        if (linkset[h,c,xn3,4] * linkset[h,b,xn2,5] <> []) { end and start share sectors}
        and ((linkset[h,c,xn3,1] + linkset[h,c,xn3,2])*(linkset[h,b,xn2,1] + linkset[h,b,xn2,2]) =[]){cant contain a duplicate}
        and ((linkset[h,c,xn3,1] + linkset[h,c,xn3,2])*(linkset[g,a,xn,1] + linkset[g,a,xn,2]) =[]){cant contain a duplicate}
        and ((linkset[h,c,xn3,5] * linkset[g,a,xn,4] <> []) {share  a sector}
          {or (linkset[h,c,xn3,9] * linkset[g,a,xn,8] <> [])})  {eliminations are common} // probably removable
            {end point of c and start of a must share sector}    
                  then
         
               begin
                                     
            active:=true;    
            
            if h in linkset[g][a,xn,6]
             then
             for n in linkset[h][c,xn3,3] do
               begin
               covered2[n]:=covered2[n] + (linkset[g][a,xn,1] );
               if k = 1 then techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[g][a,xn,1] );
               end;
               
          if g in linkset[h][c,xn3,7]
            then
             for n in linkset[g][a,xn,0] do
              begin
               covered2[n]:=covered2[n] + (linkset[h][c,xn3,2] ) ;                    
                   if k = 1 then techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[h][c,xn3,2] );
               end;

if (k = 1) and (techwrite[u,1+13]+ (techwrite[u,2+13])+ (techwrite[u,3+13] )
+ (techwrite[u,4+13] ) + (techwrite[u,5+13])+ (techwrite[u,6+13] )
+ (techwrite[u,7+13] ) + (techwrite[u,8+13])+ (techwrite[u,9+13] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[10];
   
   techwrite[u,2]:=linkset[g,a][xn][0];
   techwrite[u,3]:=linkset[g,a][xn][1];
   techwrite[u,4]:=linkset[g,a][xn][2];
   techwrite[u,5]:=linkset[g,a][xn][3];
   
   techwrite[u,6]:=linkset[h,b][xn2][0];
   techwrite[u,7]:=linkset[h,b][xn2][1];
   techwrite[u,8]:=linkset[h,b][xn2][2];
   techwrite[u,9]:=linkset[h,b][xn2][3];
   
   techwrite[u,10]:=linkset[h,c][xn3][0];
   techwrite[u,11]:=linkset[h,c][xn3][1];
   techwrite[u,12]:=linkset[h,c][xn3][2];
   techwrite[u,13]:=linkset[h,c][xn3][3];   

   u:=u+1;
   setlength(techwrite,u+1,23);   
   
   end;
   
   
               end;

if k = 1 then chaindisplay(#136,u);

end;{local 2 wing}

Local 3 wing
L3-wing: Show
[code
{local 3 wing also known as a hybrid 1 wing}
Procedure L3wing(K:integer);
var
xn,xn2,xn3,c,n,u,g,h,i:integer;
begin
links;
if k = 1 then begin u:=0; setlength(techwrite,u+1,23); end;

for g in [1..9] do
for xn:= low(linkset[g][1]) to high(linkset[g][1]) do
for h in linkset[g,1,xn,7]-[g] do
for xn2:= low(linkset[h][1]) to high(linkset[h][1]) do
if (linkset[g][1,xn,2] = linkset[h][1,xn2,1] )
and (linkset[g][1,xn,5] * linkset[h][1,xn2,4] <> [])
and(linkset[g][1,xn,1] * linkset[h][1,xn2,1] = [])
and (linkset[g][1,xn,1] * linkset[h][1,xn2,2] = [])
then
for I in (linkset[h,1,xn2,7] -[g,h]) do
for c in [1..2] do
for xn3:=low(linkset[i][c]) to high(linkset[i][c]) do

if (linkset[i][c,xn3,1] = linkset[h][1,xn2,2])
and (linkset[i][c,xn3,4] * linkset[h][1,xn2,5] <> [])
and (linkset[i][c,xn3,5] * linkset[g][1,xn,4] <> [])

and (linkset[i][c,xn3,2] * linkset[h][1,xn2,2] = [])

and (linkset[i][c,xn3,2] * linkset[g][1,xn,1] = [])
and (linkset[i][c,xn3,2] * linkset[g][1,xn,2] = [])

and (linkset[i][c,xn3,1] * linkset[g][1,xn,1] = [])
and (linkset[i][c,xn3,1] * linkset[g][1,xn,2] = [])

then

begin

active:=true;
if i in linkset[g][1,xn,6]
then
for n in linkset[i][c,xn3,3] do
begin
covered2[n]:=covered2[n] + (linkset[g][1,xn,1] );
if k = 1 then techwrite[u,n+13]:=techwrite[u,n+13] +(linkset[g][1,xn,1] );
end;

if g in linkset[i][c,xn3,7]
then
for n in linkset[g][1,xn,0] do
begin
covered2[n]:=covered2[n] + (linkset[i][c,xn3,2] ) ;
if k = 1 then techwrite[u,n+13]:=techwrite[u,n+13] +(linkset[i][c,xn3,2] ) ;
end;


if (k = 1) and (techwrite[u,1+13]+ (techwrite[u,2+13])+ (techwrite[u,3+13] )
+ (techwrite[u,4+13] ) + (techwrite[u,5+13])+ (techwrite[u,6+13] )
+ (techwrite[u,7+13] ) + (techwrite[u,8+13])+ (techwrite[u,9+13] ) <> [])
then

begin
techwrite[u,0]:=[4];
techwrite[u,1]:=[10];

techwrite[u,2]:=linkset[g,1][xn][0];
techwrite[u,3]:=linkset[g,1][xn][1];
techwrite[u,4]:=linkset[g,1][xn][2];
techwrite[u,5]:=linkset[g,1][xn][3];

techwrite[u,6]:=linkset[h,1][xn2][0];
techwrite[u,7]:=linkset[h,1][xn2][1];
techwrite[u,8]:=linkset[h,1][xn2][2];
techwrite[u,9]:=linkset[h,1][xn2][3];

techwrite[u,10]:=linkset[i,c][xn3][0];
techwrite[u,11]:=linkset[i,c][xn3][1];
techwrite[u,12]:=linkset[i,c][xn3][2];
techwrite[u,13]:=linkset[i,c][xn3][3];

u:=u+1;
setlength(techwrite,u+1,23);

end;


end;

if k = 1 then chaindisplay(#138,u);

end;{local 3 wing}[/code]

hybrid wings
H1-wing: Show
Code: Select all
{hybrid type 1 wing}
procedure H1wing(K:integer);
var
n,n2,n3,xn,xn2,xn3,j,j3,j2,g:integer;
begin

if k = 1 then begin g:=0; setlength(techwrite,g+1,26); end;

for n:= 1 to 9 do
 for j:= 0 to 26 do

 if sec[j,n]= 2
  then

   for xn in DigitRCB[j,n] do
    for xn2 in DigitRCB[j,n] -[xn] do
     for j2 in (([rx[xn]] + [Cy[xn]+9] + [bxy[xn]+18])-([j]) ) do
      for n2 in (pm[xn] - [n]) do
       if sec[j2,n2] = 2
         then
          for xn3 in (DigitRCB[j2,n2] - ([xn]+[xn2])) do

           for j3 in  (([rx[xn2]] + [Cy[xn2]+9] + [bxy[xn2]+18]) -([j]+[j2]) ) do
            for n3 in (pm[xn2] - ([n]+[n2]) ) do
             if (sec[j3,n3] <5) and (sec[j3,n3] > 1)  and
              (((DigitRCB[j3,n3] * peer[xn3])  + [xn2])  = DigitRCB[j3,n3] )
               then
                begin
                 active:= true;
            
             if (pm[xn3] * [n3] <> [])
              then
               begin
                   covered2[n3]:= covered2[n3] + [xn3];
                    if k=1 then   techwrite[g,n3+15]:= [xn3];
               end;

               if sec[j3,n3] = 2
                   then
                begin
                      covered2[n2]:=covered2[n2] + ((peer[xn3] * DigitRCB[j3,n3] ) * Digitrcb[j3,n2]);

       if k = 1 then techwrite[g,n2+15]:= ((peer[xn3] * DigitRCB[j3,n3] )* Digitrcb[j3,n2]);

                    end;

   if (k = 1) and
   (techwrite[g,1+15] + techwrite[g,15] + techwrite[g,3+15]
   + techwrite[g,4+15] + techwrite[g,5+15] + techwrite[g,6+15]
   + techwrite[g,7+15] + techwrite[g,8+15]+ techwrite[g,9+15] <> [])

                then
                  begin
         
techwrite[g,0]:=[4];
techwrite[g,1]:=[12];
techwrite[g,2]:=[n3];
techwrite[g,3]:=digitrcb[j3,n3] - [xn2];
techwrite[g,4]:=[xn2];
techwrite[g,5]:=[n3];

techwrite[g,6]:=[n];
techwrite[g,7]:=[xn2];
techwrite[g,8]:=[xn];
techwrite[g,9]:=[n];

techwrite[g,10]:=[n2];
techwrite[g,11]:=[xn];
techwrite[g,12]:=[xn3];
techwrite[g,13]:=[n2];
            
                   g:=g+1;
                  setlength(techwrite,g+1,26);
                  end;

                 end;

if k= 1 then chaindisplay(#95,g);

end; {h1 wing}

H2-wing: Show
Code: Select all
{hybrid type 2 wing}
procedure H2wing(k:integer);
var
xn,xn2,xn3,a,b,u,n,g,h,i:integer;

begin
links;
if k = 1 then begin u:=0; setlength(techwrite,u+1,23); end;

for g in [1..9] do
for xn:= low(linkset[g][0]) to high(linkset[g][0] ) do
  for h in linkset[g][0,xn,7] do
   for a in [1,3] do
    for xn2:= low(linkset[h][a]) to high(linkset[h][a]) do
   
    if  (linkset[h][a,xn2,1] * linkset[g][0,xn,2] = [])
   and (linkset[g][0,xn,3] * linkset[h][a,xn2,0] <> [])   
   and (linkset[h][a,xn2,4] * linkset[g][0,xn,5] <> [])
     then
      for I in linkset[h][a,xn2,7] -[g] do
       for b in [1] do
         for xn3:= low(linkset[i][b]) to high(linkset[i][b]) do          
             if (linkset[i][b,xn3,1] = linkset[h][a,xn2,2] )            
             and (linkset[i][b,xn3,2] * linkset[g][0,xn,1] = [])
             
           then
            begin
                  
             if  (linkset[g][0,xn,8] * linkset[i][b,xn3,2] <> [] )
             then
              begin                 
              active:=true;      
                 For n in (linkset[g][0,xn,0])  do   
                      begin                
                  covered2[n]:=covered2[n]  + (linkset[g][0,xn,8] * linkset[i][b,xn3,2]);
                 if k = 1 then
                   techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[g][0,xn,8] * linkset[i][b,xn3,2]);
                  end;
                                                
            end;
            
   if (k = 1) and (techwrite[u,1+13]+ (techwrite[u,2+13])+ (techwrite[u,3+13] )
+ (techwrite[u,4+13] ) + (techwrite[u,5+13])+ (techwrite[u,6+13] )
+ (techwrite[u,7+13] ) + (techwrite[u,8+13])+ (techwrite[u,9+13] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[10];
   
   techwrite[u,2]:=linkset[g,0][xn][0];
   techwrite[u,3]:=linkset[g,0][xn][1];
   techwrite[u,4]:=linkset[g,0][xn][2];
   techwrite[u,5]:=linkset[g,0][xn][3];
   
   techwrite[u,6]:=linkset[h,a][xn2][0];
   techwrite[u,7]:=linkset[h,a][xn2][1];
   techwrite[u,8]:=linkset[h,a][xn2][2];
   techwrite[u,9]:=linkset[h,a][xn2][3];
   
   techwrite[u,10]:=linkset[i,b][xn3][0];
   techwrite[u,11]:=linkset[i,b][xn3][1];
   techwrite[u,12]:=linkset[i,b][xn3][2];
   techwrite[u,13]:=linkset[i,b][xn3][3];   

   u:=u+1;
   setlength(techwrite,u+1,23);   
   
   end;         
          
           end;


if k = 1 then chaindisplay(#110,u);

end;{h2wing}

H3-wing: Show
Code: Select all
{hybrid type 2 wing}
procedure H3wing(k:integer);
var
xn,xn2,xn3,a,b,u,n,g,h,i:integer;

begin
links;
if k = 1 then begin u:=0; setlength(techwrite,u+1,23); end;

for g in [1..9] do
for xn:= low(linkset[g][0]) to high(linkset[g][0] ) do
  for h in linkset[g][0,xn,7] do
   for a in [0] do
    for xn2:= low(linkset[h][a]) to high(linkset[h][a]) do
   if (linkset[g,0,xn,0] * linkset[h,a,xn2,3] = [] ) then
    if  (linkset[h][a,xn2,1] * linkset[g][0,xn,2] = [])       
   and (linkset[h][a,xn2,4] * linkset[g][0,xn,5] <> [])   
     then
      for I in linkset[h][a,xn2,7]   do
       for b in [1,3] do
         for xn3:= low(linkset[i][b]) to high(linkset[i][b]) do          
             if (linkset[i,b,xn3,4] * linkset[h,a,xn2,5] <> [] )
            and (linkset[i,b,xn3,5] * linkset[g,0,xn,4] <> [])
            
            and (linkset[i,b,xn3,1] * linkset[g,0,xn,1] = [])
            and (linkset[i,b,xn3,2] * linkset[g,0,xn,1] = [])
            
            and (linkset[i,b,xn3,1] * linkset[h,a,xn2,1] = [])
            and (linkset[i,b,xn3,2] * linkset[h,a,xn2,1] = [])
            
            then
            begin
                  
             if  (linkset[g][0,xn,8] * linkset[i][b,xn3,2] <> [] )
             then
              begin                 
              active:=true;      
                 For n in (linkset[g][0,xn,0])  do   
                        begin                
                  covered2[n]:=covered2[n]  + (linkset[g][0,xn,8] * linkset[i][b,xn3,2]);
                 if k = 1
                   then techwrite[u,n+13]:=techwrite[u,n+13] + (linkset[g][0,xn,8] * linkset[i][b,xn3,2]);
                   end;                            
            end;
            
   if (k = 1) and (techwrite[u,1+13]+ (techwrite[u,2+13])+ (techwrite[u,3+13] )
+ (techwrite[u,4+13] ) + (techwrite[u,5+13])+ (techwrite[u,6+13] )
+ (techwrite[u,7+13] ) + (techwrite[u,8+13])+ (techwrite[u,9+13] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[10];
   
   techwrite[u,2]:=linkset[g,0][xn][0];
   techwrite[u,3]:=linkset[g,0][xn][1];
   techwrite[u,4]:=linkset[g,0][xn][2];
   techwrite[u,5]:=linkset[g,0][xn][3];
   
   techwrite[u,6]:=linkset[h,a][xn2][0];
   techwrite[u,7]:=linkset[h,a][xn2][1];
   techwrite[u,8]:=linkset[h,a][xn2][2];
   techwrite[u,9]:=linkset[h,a][xn2][3];
   
   techwrite[u,10]:=linkset[i,b][xn3][0];
   techwrite[u,11]:=linkset[i,b][xn3][1];
   techwrite[u,12]:=linkset[i,b][xn3][2];
   techwrite[u,13]:=linkset[i,b][xn3][3];   

   u:=u+1;
   setlength(techwrite,u+1,23);   
   
   end;             
          
          
           end;



if k = 1 then chaindisplay(#78,u);

end;{h3-wing}

H45-wing: Show
Code: Select all
{hybrid wing types: 4 & 5}
procedure h45wing(w:integer);
  var
xn,xn2,n,n2,yn,yn2,yn3,g,count,count2,F,s,k:integer;
l:nums;
begin

if w = 0 then begin k:=0; setlength(techwrite,k+1,17); end;
for xn in ocell do
 if (nm[xn] = 2)
  then
   for xn2  in (ocell -[xn] )do
     if (nm[xn2] = 2 )
      and (pm[xn2] * pm[xn] <> [] )   and (pm[xn2] - pm[xn] <> [] )
       then

         for n in pm[xn]*pm[xn2] do
          for n2 in (pm[xn2] - [n]) do

            for yn in ((peerrcb[rsec[rx[xn]]] + peerrcb[Csec[Cy[xn]]]+ peerrcb[Bsec[Bxy[xn]]]) - ([rsec[rx[xn2]]] + [Csec[Cy[xn2]]]+ [Bsec[Bxy[xn2]]])  )  do
             if (Digitrcb[yn,n] * [xn]   = [xn] )
             and (Digitrcb[yn,n] * [xn2] = [])
              then

             for yn2 in ((peerrcb[rsec[rx[xn2]]] + peerrcb[Csec[Cy[xn2]]]+ peerrcb[Bsec[Bxy[xn2]]]) - ([rsec[rx[xn]]] + [Csec[Cy[xn]]]+ [Bsec[Bxy[xn]]])) do
                if (Digitrcb[yn2,n2] * [xn2]   = [xn2]  )
                 and (digitrcb[yn2,n2] *[xn] = [])
                  then

              for yn3 in (peerrcb[yn] * peerrcb[yn2])  do
              begin

               {h 4 wing}
              if ((digitrcb[yn,n] * Digitrcb[yn3,n]) + [xn] = Digitrcb[yn,n])
              and ((digitrcb[yn2,n2] * Digitrcb[yn3,n2]) + [xn2] = Digitrcb[yn2,n2])
              and  (digitrcb[yn3,n2] * digitrcb[yn2,n2] <> [])
               and (digitrcb[yn3,n] * digitrcb[yn,n] <> [])
               and ((digitrcb[yn3,n] * Digitrcb[yn2,n] ) *(digitrcb[yn3,n2] * digitrcb[yn2,n2]  )<> [])

               then
                begin

                  count:=0;
                  count2:=0;
                  l:=[];

                  For g in ((digitrcb[yn,n] * digitrcb[yn3,n]) + (Digitrcb[yn2,n2] * Digitrcb[yn3,n2]) - [xn,xn2]) do
                   begin

                   inc(count);
                   L:= l + pm[g];
                   end;

                   for g in l do
                    inc(count2);

                        if (count = (count2 - 1) )  and (xn in peer[xn2]) {h4 wing}
                         then
                        for g:= slist[count] to flist[count] do
                         if (L - [n2] = comboset[g])
                    and (comboset[g] * pm[xn] -[n]  = [])
                          then
                            begin
                               active:=true;
                               covered2[n]:=covered2[n] + (Digitrcb[yn3,n]  - (Digitrcb[yn,n] + digitrcb[yn2,n2]));

                       if w = 0
                             then
                              begin
                               techwrite[k,0]:=[xn];
                               techwrite[k,10]:=[xn2];
                               techwrite[k,11]:=[n];
                               techwrite[k,12]:=[n2];
                               techwrite[k,13]:=pm[xn] -[n];
                               techwrite[k,14]:=(digitrcb[yn,n] * Digitrcb[yn3,n]);
                               techwrite[k,15]:= (digitrcb[yn2,n2] * Digitrcb[yn3,n2]);
                               techwrite[k,16]:= comboset[g];
                               techwrite[k,n]:= techwrite[k,n]+ (Digitrcb[yn3,n]  - (Digitrcb[yn,n] + digitrcb[yn2,n2]));

                               end;
                              end;

                   if (w=0 ) and (techwrite[k,1] + techwrite[k,2] + techwrite[k,3] + techwrite[k,4] + techwrite[k,5] + techwrite[k,6] + techwrite[k,7] + techwrite[k,8] + techwrite[k,9]  <> [] )
                   then
                      begin
                       k:=k+1;
                       setlength(techwrite,k+1,17);

                      end;

               end; {h4 wing}

           {h5 wing}
            if ((peer[xn] * digitrcb[yn2,n2]) + [xn2] = digitrcb[yn2,n2])
            and (( peer[xn2] * digitrcb[yn,n]) + [xn] = digitrcb[yn,n])
            and ((digitrcb[yn3,n] * digitrcb[yn,n]) + (digitrcb[yn3,n2] * digitrcb[yn2,n2])  = [xn] + (peer[xn] * digitrcb[yn2,n2] )  )
             then
              begin

                 count:=0;
                 count2:=0;

                 L:=[];

                 for g in ((digitrcb[yn3,n] * digitrcb[yn,n] ) + (digitrcb[yn3,n2] * digitrcb[yn2,n2]))   do
                  begin
                   L:= L + pm[g];
                   inc(count);
                  end;

                  for G in l do
                   inc(count2);


                 if (count = (count2 - 1) )
                         then
                        for g:= slist[count] to Flist[count] do
                         if L - [n2] = comboset[g]
                          then
                            begin
                               active:=true;
                               covered2[n]:=covered2[n] + (Digitrcb[yn3,n]  - (Digitrcb[yn,n] + digitrcb[yn2,n2]));

                        if w = 0
                             then
                              begin
                               techwrite[k,0]:=[xn];
                               techwrite[k,10]:=[xn2];
                               techwrite[k,11]:=[n];
                               techwrite[k,12]:=[n2];
                               techwrite[k,13]:=pm[xn] -[n];
                               techwrite[k,14]:=(digitrcb[yn,n] * Digitrcb[yn3,n]);
                               techwrite[k,15]:= (digitrcb[yn2,n2] * Digitrcb[yn3,n2]);
                               techwrite[k,16]:= comboset[g];
                               techwrite[k,n]:= techwrite[k,n]+ (Digitrcb[yn3,n]  - (Digitrcb[yn,n] + digitrcb[yn2,n2]));

                               end;

                            end;

                 if (w=0 ) and (techwrite[k,1] + techwrite[k,2] + techwrite[k,3] + techwrite[k,4] + techwrite[k,5] + techwrite[k,6] + techwrite[k,7] + techwrite[k,8] + techwrite[k,9]  <> [] )
                   then
                      begin
                       k:=k+1;
                       setlength(techwrite,k+1,17);

                      end;

               end; {h5 wing}

          end; {yn3}

if w = 0 then techdisplay(#14,k);

end;{h45 wing}

inverted W wing
iW-wing: Show
Code: Select all
{invertered W-wing} 
procedure iWWing(K:integer);
var
G,a,xn,h,b,xn2,c,xn3,d,xn4,u,n,r:integer;
begin
  if k = 1 then begin u:=0; setlength(techwrite,u+1,30); end;
 
  For g in [1..9] do
   for a in [1,3] do
     for xn:= low(linkset[g][a]) to high(linkset[g][a]) do    
        
       for h in (linkset[g][a][xn,7]) do
        for b in [1,2] do
          for xn2:= low(linkset[h][b]) to high(linkset[h][b]) do
           if (linkset[h][b][xn2,1] = linkset[g,a,xn,2])
           and (linkset[h][b][xn2,4] * linkset[g,a,xn,5] <> [])
           and (linkset[h][b][xn2,2] * linkset[g,a,xn,1] = [])          
          
            then
              for C in [1,3] do
               for xn3:=low(linkset[h][c]) to high(linkset[h][c]) do
                if ((C = b) and (xn3>xn2)) or (c>b)then
                
                  if (linkset[h,c,xn3,4] * linkset[h,b,xn2,5] <> [])
                  and ((linkset[h,c,xn3,1]+linkset[h,c,xn3,2])
                     * (linkset[h,b,xn2,1]+linkset[h,b,xn2,2]) = [])
                    then
               for D in [1,2] do
                   for xn4:= low(linkset[g][d]) to high(linkset[g][d]) do
                     if ((d = a) and (xn4 > xn))then
                           if (linkset[h,c,xn3,2] = linkset[g,d,xn4,1])
                    and (linkset[h,c,xn3,5] * linkset[g,d,xn4,4] <> [])
                    and ((linkset[g,d,xn4,1]+linkset[g,d,xn4,2]) * (linkset[g,a,xn,1]+linkset[g,a,xn,2]) = [])
                    and ((linkset[g,d,xn4,2]) * (linkset[h,c,xn3,1]+linkset[h,c,xn3,2]) = [])
                    and ( (linkset[g,d,xn4,1] + linkset[g,d,xn4,2]) * (linkset[h,b,xn2,1]+linkset[h,b,xn2,2]) = [])
               
           then
           begin
          
           if (linkset[g,a,xn,8] * linkset[g,d,xn4,9]) <> []
            then
                begin
              active:=true;              
          
                for n in (linkset[g,a,xn,0] * linkset[g,d,xn4,3]) do
                begin
                  covered2[n]:=covered2[n] + (linkset[g,a,xn,8] * linkset[g,d,xn4,9]) ;
                if k = 1
                  then
                    techwrite[u,n+19]:=techwrite[u,n+19] + (linkset[g,a,xn,8] * linkset[g,d,xn4,9]) ;
                  end; 
               end;
            
         if (linkset[g,d,xn4,5] * linkset[g,a,xn,4] <> []) then
            begin
             active:=true;                          
                               
            for n in (linkset[h,b,xn2,3] * linkset[h,c,xn3,0]) do
             begin
             covered2[n]:=covered2[n]  + (linkset[h,b,xn2,9] * linkset[h,c,xn3,8]);
             if k = 1
                  then
                    techwrite[u,n+19]:=techwrite[u,n+19] +  (linkset[h,b,xn2,9] * linkset[h,c,xn3,8]);
                  end;
            
             for n in (linkset[h,b,xn2,1] * linkset[g,a,xn,2]) do
              begin
                covered[n]:=covered[n] + (pm[n] - [g,h]);
               if k = 1 then
               for r in (pm[n] - [g,h]) do
                 techwrite[u,r+19]:=techwrite[u,r+19] + [n];
               end;
            
             for n in (linkset[h,c,xn3,2] + linkset[g,d,xn4,1]) do
              begin
               covered[n]:= covered[n] + (pm[n] - [g,h]);
               if k = 1 then
               for r in (pm[n] - [g,h]) do
                 techwrite[u,r+19]:=techwrite[u,r+19] + [n];
               end;
            
             end;
if (k = 1) and (techwrite[u,1+19]+ (techwrite[u,2+19])+ (techwrite[u,3+19] )
+ (techwrite[u,4+19] ) + (techwrite[u,5+19])+ (techwrite[u,6+19] )
+ (techwrite[u,7+19] ) + (techwrite[u,8+19])+ (techwrite[u,9+19] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[16];
   
   techwrite[u,2]:=linkset[g,a][xn][0];
   techwrite[u,3]:=linkset[g,a][xn][1];
   techwrite[u,4]:=linkset[g,a][xn][2];
   techwrite[u,5]:=linkset[g,a][xn][3];
   
   techwrite[u,6]:=linkset[h,b][xn2][0];
   techwrite[u,7]:=linkset[h,b][xn2][1];
   techwrite[u,8]:=linkset[h,b][xn2][2];
   techwrite[u,9]:=linkset[h,b][xn2][3];
   
   techwrite[u,10]:=linkset[h,c][xn3][0];
   techwrite[u,11]:=linkset[h,c][xn3][1];
   techwrite[u,12]:=linkset[h,c][xn3][2];
   techwrite[u,13]:=linkset[h,c][xn3][3];
   
   techwrite[u,14]:=linkset[g,d][xn4][0];
   techwrite[u,15]:=linkset[g,d][xn4][1];
   techwrite[u,16]:=linkset[g,d][xn4][2];
   techwrite[u,17]:=linkset[g,d][xn4][3];
   

   u:=u+1;
   setlength(techwrite,u+1,30);   
   
   end;            
              end;    
   
  if k = 1 then chaindisplay(#137,u);
end; {inverted w-wing}
 

XY-wing, XYZ-wing, Wxyz -wings and larger are covered under B.A.R.N.s
Barns: Show
Code: Select all
procedure Barns(K,M,Q,v:integer);     { k is writting function M is starting size v is ending size,q selectins inital cell size v is end size}
type

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

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

xs:nums;
z1:nums;

p2:numberset;

lx1:numberset;

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

begin

cellcombo;

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

repeat


  begin

  for C:= slist[l] to flist[l] do

   if (combocell[c] <> [])
    then
     begin
      act:=0;

  for p in combocell[c]do
     begin
      inc(act);
      if act >=L then
       break;
       end;


  if act >=L then

   for p in combocell[c] do
    if (peer[p] * combocell[c] <> []  )
     and ( ( (q = 1) and (nm[p] = 2))
     or ((q = 2) and (nm[p] = 3))
     or ((q = 0) and (nm[p] <=L))    )

     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}

       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  not (peer2[p,j] in step[w])
               and ( peer2[p,j] in combocell[c])
               and  ( (peer[p] * (combocell[c] - step[w])  <> [] ) or (w+2 = l) )
                  then
                   begin

                   inc(w);  {increase step count}

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

                   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 in list[w] do
                      if (RCBnum[a]*step[w] <> [] )

                        then
                         begin
                         for B in list[w] do

                           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[a,z] * step[w] ) <> [])
                                 or ( (digitrcb[b,z] * step[w] ) <> [])      )
                                   then
                                     for  lx in ( LIST[W] ) do
                                      if
                                         ( ( (digitRCB[a,z] * digitRCB[lx,z] * step[w]) <> [])
                                         or
                                           ( (digitRCB[b,z] * digitRCB[lx,z] * step[w]) <> []) )

                                      and ( (( DigitRCB[b,z] + DigitRCB[a,z]) * digitrcb[lx,z] * step[w])   =  ( (digitrcb[a,z] + digitrcb[b,z]) * 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[a,x] * step[w] ) <> [])
                                           and  ( (digitrcb[b,x] * step[w] ) <> [])
                                            then
                                             begin
                                             xs:=xs+[x];
                                             p2:= p2 + (( DigitRCB[a,x] + digitrcb[b,x] )*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 (ocell - 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[a,x] + digitrcb[b,x]) * (step[w] ) ) =  ((digitRcb[a,x] + digitrcb[b,x]) * (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
                                           { write(G,'  @: '); }
                                            p2:=(digitrcb[a,g]+digitrcb[b,g])*step[w];

                                            for x in  (ocell - 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(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;
    end;

 if m = 0
  then
  inc(L);

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

end;

Strong Wing
Strong Wing: Show
Code: Select all
Procedure StrongWing(K:integer);{strong wing/rings}
var
xn,xn2,xn3,xn4,c,n,u,g,h,i,j,r:integer;
begin
links;
   if k = 1 then begin u:=0; setlength(techwrite,u+1,27);  end;
   
 for g in [1..9] do
 for xn:= low(linkset[g][1]) to high(linkset[g][1]) do   
   for h in linkset[g,1,xn,7]-[g] do
    for xn2:= low(linkset[h][1]) to high(linkset[h][1]) do   
     if (linkset[g][1,xn,2] = linkset[h][1,xn2,1] )
     and (linkset[g][1,xn,5] * linkset[h][1,xn2,4] <> [])
     and(linkset[g][1,xn,1] * linkset[h][1,xn2,1] = [])
     and (linkset[g][1,xn,1] * linkset[h][1,xn2,2] = [])   
      then
        for I in (linkset[h,1,xn2,7] -[g,h]) do         
        for xn3:=low(linkset[i][1]) to high(linkset[i][1]) do          
      
          if (linkset[i][1,xn3,1] = linkset[h][1,xn2,2])
             and (linkset[i][1,xn3,4] * linkset[h][1,xn2,5] <> [])
                 and (linkset[i][1,xn3,5] * linkset[g][1,xn,4] <> [])
            
             and (linkset[i][1,xn3,2] * linkset[h][1,xn2,2] = [])
            
             and (linkset[i][1,xn3,2] * linkset[g][1,xn,1] = [])
                 and (linkset[i][1,xn3,2] * linkset[g][1,xn,2] = [])
            
             and (linkset[i][1,xn3,1] * linkset[g][1,xn,1] = [])
                 and (linkset[i][1,xn3,1] * linkset[g][1,xn,2] = [])
                                      
                  then
                for j in (linkset[i][1,xn3,7]) do
                for xn4:=low(linkset[j][1]) to high(linkset[j][1]) do
                if (linkset[j,1,xn4,1] = linkset[i,1,xn3,2] )
                and (linkset[j,1,xn4,2] = linkset[g,1,xn,1] )
                  then       
         
               begin               
                         
             if J = g  then
                begin
               
                   active:= true;
                      covered2[j]:= covered2[j] + linkset[g,1,xn,8];
                
                 if k = 1 then
                   techwrite[u,j+17]:=techwrite[u,j+17] + linkset[g,1,xn,8];
                     
                       for n in linkset[g,1,xn,1] do
                     begin
                          covered[n]:=covered[n] + (pm[n] - [j]);
                          if k = 1 then
                       for r in pm[n] - [j] do
                       techwrite[u,j+17]:=techwrite[u,j+17] + [r];
                    end;
                            
                end;
               
               if j <> g then
                   begin                   
                   active:= true;
                  
               for n in linkset[g,1,xn,1] do
                     begin
                          covered[n]:=covered[n] + (pm[n] - [j,g]);
                     if k = 1 then
                       for r in pm[n] - [j,g] do
                       techwrite[u,j+17]:=techwrite[u,j+17] + [r];
                    end;
                   
                   
               for n in linkset[h,1,xn2,1] do
                     begin
                          covered[n]:=covered[n] + (pm[n] - [g,h]);
                     if k = 1 then
                       for r in pm[n] - [g,h] do
                       techwrite[u,j+17]:=techwrite[u,j+17] + [r];
                    end;
                   
                   
               for n in linkset[i,1,xn3,1] do
                   begin
                          covered[n]:=covered[n] + (pm[n] - [i,h]);   
                     if k = 1 then
                       for r in pm[n] - [i,h] do
                       techwrite[u,j+17]:=techwrite[u,j+17] + [r];
                    end;
                   
               for n in linkset[j,1,xn4,1] do
                  begin
                          covered[n]:=covered[n] + (pm[n] - [i,j]);
                     if k = 1 then
                       for r in pm[n] - [i,j] do
                       techwrite[u,j+17]:=techwrite[u,j+17] + [r];
                    end;
                   
                   end;
if (k = 1) and (techwrite[u,1+17]+ (techwrite[u,2+17])+ (techwrite[u,3+17] )
+ (techwrite[u,4+17] ) + (techwrite[u,5+17])+ (techwrite[u,6+17] )
+ (techwrite[u,7+17] ) + (techwrite[u,8+17])+ (techwrite[u,9+17] ) <> [])
 then
 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[14];
   
   techwrite[u,2]:=linkset[g,1][xn][0];
   techwrite[u,3]:=linkset[g,1][xn][1];
   techwrite[u,4]:=linkset[g,1][xn][2];
   techwrite[u,5]:=linkset[g,1][xn][3];
   
   techwrite[u,6]:=linkset[h,1][xn2][0];
   techwrite[u,7]:=linkset[h,1][xn2][1];
   techwrite[u,8]:=linkset[h,1][xn2][2];
   techwrite[u,9]:=linkset[h,1][xn2][3];
   
   techwrite[u,10]:=linkset[i,1][xn3][0];
   techwrite[u,11]:=linkset[i,1][xn3][1];
   techwrite[u,12]:=linkset[i,1][xn3][2];
   techwrite[u,13]:=linkset[i,1][xn3][3];

   techwrite[u,14]:=linkset[j,1][xn4][0];
   techwrite[u,15]:=linkset[j,1][xn4][1];
   techwrite[u,16]:=linkset[j,1][xn4][2];
   techwrite[u,17]:=linkset[j,1][xn4][3];   

   u:=u+1;
   setlength(techwrite,u+1,27);   
   
   end;                  
                  
               end;   
if k = 1 then chaindisplay(#94,u);
  end;{strong wing}
Last edited by StrmCkr on Wed Oct 19, 2022 12:04 am, edited 14 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Almost locked Sets

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

Almost locked set rules
ALS-XZ: Show
Code: Select all
procedure alsxz(k:integer);  {so far this is 100,000% faster}
type
almostlockedset2= array of array of integer;
var
q,xn,xn2,yn,yn2,yn3,yn4,n,z,x,r,u,alsa,alsB,a,b:integer;

A3:numberset;
A4:numberset;

z1:nums;

lx1: rcbpeer;
lx2: rcbpeer;
als2:almostlockedset2;
begin
alsfinder;
  //ahsfinder;
b:=0;
setlength(als2,b,5);

for a:= high(als) downto 0 do    {startin array}
 if (als[a,1]+1 = als[a,2])
  then
   begin
    b:=b+1;
   setlength(als2,b+1,5);   
   als2[b,0]:=als[a,0];
   als2[b,1]:=als[a,1];
   als2[b,2]:=als[a,2];
   als2[b,3]:=als[a,3];
   als2[b,4]:=als[a,4];
end;


if k=0 then begin  u:=0; setlength(techwrite,u+1,18); end;

 for alsA:= low(als2) to (high(als2)-1) do {als A}
   if (als2[alsA,1]+1 = als2[alsA,2]) {cell = digit +1}
     then
       for ALSB:= alsa+1 to high(als2) do {Als B}
          if (als2[alsb,1]+1 = als2[alsb,2] ) {cell = digit +1}
              and (popcnt(dword((comboset2[als2[alsa,4]]*Comboset2[als2[alsb,4]]) ) )   >1 )   {set a & B must share 2 digits}
               and (combosets[als2[alsa,0],als2[alsa,3]]  - combosets[als2[alsb,0],als2[alsb,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als2[alsb,0],als2[alsb,3]] - combosets[als2[alsa,0],als2[alsa,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}
          then
            begin

             xn:=als2[alsa,0];
             xn2:=als2[alsb,0];

            yn:=als2[alsA,3];
            yn3:=als2[alsB,3];
            
            yn2:=als2[alsa,4];
            yn4:= als2[alsb,4];
           z1:=[];

         {restricted common chcek}
            for z in (comboset[yn4] * comboset[yn2]) do
               if ((Digitcell[z] * combosets[xn,yn])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn,yn] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                       then
                      begin
                                                    lx2:=[0..26];

                     for q in (combosets[xn,yn]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both a&b for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];



                         if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z1:=z1 + [z]; {saves the resticted commons}

                     end;

                 if   popcnt(dword(z1)) =1  {single restricted common eliminations}
                        then
                    begin

                                                   for R in ((comboset[yn4]  * comboset[yn2] ) -z1) do   {search for common digit to both, and active in both}
                                                      if ((Digitcell[R]* combosets[xn,yn] )<> [] )
                                                      and(( Digitcell[R] * combosets[xn2,yn3])<> [])
                                                       then
                                                        begin
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]));  {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in ((combosets[xn,yn] + combosets[xn2,yn3]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&B}
                                                           a3:=peer[q] * a3 - (combosets[xn,yn] + combosets[xn2,yn3]);

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+7]:= techwrite[u,r+7] + a3;
                                                            techwrite[u,7]:=techwrite[u,7]+[R];
                                                           end;
                                                        end;



if (k= 0)
 and (techwrite[u,7] <> [])
 then
begin
techwrite[u,0]:=[3];
techwrite[u,1]:=[4];
techwrite[u,2]:=techwrite[u,2]+comboset[yn2];
techwrite[u,3]:=techwrite[u,3]+Combosets[xn,yn];
techwrite[u,4]:=techwrite[u,4]+comboset[yn4];
techwrite[u,5]:=techwrite[u,5]+combosets[xn2,yn3];
techwrite[u,6]:=techwrite[u,6]+ z1;

end;

if u = 32767    {max array size error code safty exit}
 then
 begin
  if k = 0 then
     techdisplay(#97,u);
   
    setlength(techwrite,0,0);
    u:=0; setlength(techwrite,u+1,17)
   
 //exit;
end;


if (k=0) and (techwrite[u,0] <> []) then begin  u:=U+1; setlength(techwrite,u+1,18); end;

                          end;   {normal eliminations}

                if   popcnt(dword(z1)) >1  {doubly linked rules }
                        then
                    begin
                          active:=true;
                  
                                                      active:=true;

                                                     {set A&b is now a locked set removal peers cells visable to all copies of each digit in  both sets}
                                                  for R in comboset[yn2] + comboset[yn4] do
                                        for q in ([0..80] * digitcell[R]) do
                                         begin {R/Q elimiantion search}

                                         if (R in (comboset[yn2] * Comboset[yn4]) ){search for common digit to both, and active in both}
                                         and ((digitcell[R] * combosets[xn,yn])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn2,yn3])  <> [])
                                         and (Peer[q] * ((Combosets[xn,yn]+Combosets[xn2,yn3])*digitcell[R]) = ((Combosets[xn,yn] + Combosets[xn2,yn3])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * (Combosets[xn,yn] + combosets[xn2,yn3]) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];

                                          if k =0 then
                                             begin
                                                             techwrite[u,r+7]:= techwrite[u,r+7] + [q];
                                                             techwrite[u,7]:=techwrite[u,7]+[R];
                                                           end;

                                            end;
                                            {cells in set b for digits exclusivly to b  their peers cannot contain r}
                                          if (R in (Comboset[yn2] - z1))
                                          and  (peer[q] * Digitcell[R] * Combosets[xn,yn] = combosets[xn,yn] * Digitcell[R])
                                          and ([q] * combosets[xn,yn] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+7]:= techwrite[u,r+7] + [q];
                                                             techwrite[u,7]:=techwrite[u,7]+[R];
                                                           end;
                                             end;
                                             {cells in set A for digits exclusivly to A  their peers cannot contain r}
                                          if (R in (Comboset[yn4]  -  z1))
                                          and  (peer[q] * Digitcell[R] * Combosets[xn2,yn3] = combosets[xn2,yn3]* Digitcell[R])
                                          and ([q] * combosets[xn2,yn3] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+7]:= techwrite[u,r+7] + [q];
                                                             techwrite[u,7]:=techwrite[u,7]+[R];
                                                           end;
                                             end;


                                         end; {R/Q elimiantion search}

if (k= 0)
 and (techwrite[u,7] <> [])
 then
begin
techwrite[u,0]:=[3];
techwrite[u,1]:=[4];
techwrite[u,2]:=techwrite[u,2]+comboset[yn2];
techwrite[u,3]:=techwrite[u,3]+Combosets[xn,yn];
techwrite[u,4]:=techwrite[u,4]+comboset[yn4];
techwrite[u,5]:=techwrite[u,5]+combosets[xn2,yn3];
techwrite[u,6]:=techwrite[u,6]+ z1;

end;

if u = 32767    {max array size error code safty exit}
 then
 begin
  if k = 0 then
     techdisplay(#97,u);
   
    setlength(techwrite,0,0);
    u:=0; setlength(techwrite,u+1,18)

 //exit;
end;
if (k=0) and (techwrite[u,0] <> []) then begin  u:=U+1; setlength(techwrite,u+1,18); end;



                     end;  {doubly linked}
         end; {yn4}


if k = 0 then
     chaindisplay(#97,u);

end;{als -xz rule}


AHS-xz: Show
Code: Select all
{almost hidden set xz } // needs a massive overhall for the eliminations process should be cell based not cell+digit
procedure ahsxz(k:integer);  {so far this is 100,000% faster}
var
q,xn,xn2,n,z,x,r,u,alsa,alsB,act3,u2:integer;

a2,a3,b2,b3,z1,x1,lxl,yn,yn2,yn3,yn4:numberset;


begin
//alsfinder;
  ahsfinder;
if k=0 then begin  u:=0; setlength(techwrite,u+1,16); end;

 for alsA:= low(ahs) to (high(ahs)-1) do {als A}
   if (ahs[alsA,1]+1 = ahs[alsA,2]) {digit = cell +1}
   and (ahs[alsa,1] <4)
  // and (sectorrcb[ahs[alsa,0],ahs[alsa,4]] = [24,69,78])
     then
       for ALSB:= alsa+1 to high(ahs) do {Als B}
          if (ahs[alsb,1]+1 = ahs[alsb,2] ) {cell = digit +1}
        and (ahs[alsb,1] <4)
      // and (sectorrcb[ahs[alsb,0],ahs[alsb,4]] = [62,69,71])
           
          then
            begin            

             xn:=ahs[alsa,0]; {sector a}
             xn2:=ahs[alsb,0];

            yn:=comboset[ahs[alsA,3]]; {digits a }
            yn3:=comboset[ahs[alsB,3]]; {digits b}
            
            yn2:=sectorrcb[xn,ahs[alsa,4]]; {cells a }
            yn4:=sectorrcb[xn2,ahs[alsb,4]]; {cells b}
            
            a2:=yn*yn3;// identifies  shared Digits
            z1:=yn2*yn4; // overlapping cells
            
            b2:=[]; //checks for RCC
                b3:=[]; // stores RCC if the
            lxl:=[]; // shared cells with shared digits             
            
            a3:=[]; // digits of a shared cell with no shared digits
            
            if (z1 <> []) and (a2 <> [] )
              then
                for n in a2 do
                 lxl:=lxl + (Digitcell[n]* z1); 
            
            if (lxl=[]) and (z1 <> [])
               then
                  for n in z1 do
                   a3:=a3 + (pm[n] *(yn+yn3));
             
            //identifies shared digits in 1 sector that have 1 option
              for q in a2 do
                begin
                 x1:=[0..26];                 
                 for N in  (DigitCell[q] * (yn2+yn4)) do
                   if (pm[n] -(yn+yn3) * [q]) = [q]                  
                   then
                      begin
                         b2:= b2 + [n];
                      x1:=cellsec[n] * x1;
                        end;
                     
                     {z1:= z1 - b2;}
                     
                  for n in x1 do    
                    if (sectorRCB[n,q] * (yn2 * b2) <> [])
                        and (sectorrcb[n,q] * (yn4 * b2) <> [])                        
                         then
                           b3:=(yn2 * b2)+(yn4 * b2);                        
               end;
               
            
       gotoxy(2,60);
  for n in b3 do
  write(n,' '); 


       gotoxy(2,61);
  for n in z1 do
    write(n,' '); 

   
   
       gotoxy(2,62);
  for n in lxl do
    write(n,' '); 
   
   
   
       gotoxy(2,63);
  for n in a3 do
    write(n,' '); 
   
   
   
   {basic elimination}
   if (B3 + (z1-lxl) <> [])
       then
       begin
       active:=true;
             
           for n in yn - (a2+a3) do
          begin
                  covered2[n]:=covered2[n] + digitcell[n]* (yn4-(b3+(z1-lxl)));   
         if k = 0
               then 
                techwrite[u,n]:=techwrite[u,n]+ digitcell[n]*(yn4-(b3+(z1-lxl)));             
         end;     
             
             
         for n in yn3 - (a2+a3) do
          begin
                  covered2[n]:=covered2[n] + digitcell[n]*(yn2-(b3+(z1-lxl)));
         if k = 0
               then 
                techwrite[u,n]:=techwrite[u,n]+ digitcell[n]*(yn2-(b3+(z1-lxl)));             
         end;
         
      end; 
      
      
 
if (k= 0)
and ((techwrite[u,1]+ techwrite[u,2] + techwrite[u,3] + techwrite[u,3]+techwrite[u,4]+techwrite[u,5]+techwrite[u,6]+techwrite[u,7]+techwrite[u,8]+techwrite[u,9]) <> [])
then
begin
techwrite[u,0]:=yn;
techwrite[u,10]:=yn3;
techwrite[u,11]:=yn2;
techwrite[u,12]:=yn4;
//techwrite[u,13]:=[q];
//techwrite[u,14]:=[R];
//For u2 in pm[r] - (comboset[yn3] + Comboset[yn] ) do
//techwrite[u,u2]:= techwrite[u,u2] + [R];

 inc(u);
 setlength(techwrite,u+1,16);
 
end;


end;
         
     if k=0 then techdisplay(#104,u);   
   
end;{ahs-xz rule }   


ALS-XY: Show
Code: Select all
{all most locked sets XY Rule : including double and trippled linked rules}
procedure alsxy(k:integer);  {so far this is 100,000% faster}
type
almostlockedset2= array of array of integer;
var
q,xn,xn2,xn3,yn,yn2,yn3,yn4,YN5,YN6,n,z,x,act3,r,u,alsA,alsB,alsC,a,b:integer;

A3:numberset;
z1:nums;
Z2:nums;
z3:nums;

lx1: rcbpeer;
lx2: rcbpeer;
lx3: rcbpeer;
als2: almostlockedset2;

begin
alsfinder;
  //ahsfinder;
b:=-1;
setlength(als2,b+1,5);

{reduces the als array to the +1 size}
for a:= high(als) downto 0 do    {startin array}
 if (als[a,1]+1 = als[a,2])
  then
   begin
    b:=b+1;
   setlength(als2,b+1,5);
   als2[b,0]:=als[a,0];
   als2[b,1]:=als[a,1];
   als2[b,2]:=als[a,2];
   als2[b,3]:=als[a,3];
   als2[b,4]:=als[a,4];
end;

if k=0 then begin  u:=0; setlength(techwrite,u+1,20); end;

for alsA:= low(als2) to (high(als2)-2) do {als C}
   if (als2[alsA,1]+1 = als2[alsA,2]) {cell = digit +1}
     then
       for ALSB:= alsa+1 to high(als2)-1 do {Als A}
          if (als2[alsb,1]+1 = als2[alsb,2] ) {cell = digit +1}
        and (popcnt(dword((comboset2[als2[alsa,4]]*Comboset2[als2[alsb,4]]) ) )   >=1 )   {set a & B must share 2 digits}
               and (combosets[als2[alsa,0],als2[alsa,3]]  - combosets[als2[alsb,0],als2[alsb,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als2[alsb,0],als2[alsb,3]] - combosets[als2[alsa,0],als2[alsa,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}
   then
            begin

             xn:=als2[alsa,0];
             xn2:=als2[alsb,0];

            yn:=als2[alsA,3];
            yn3:=als2[alsB,3];
            
            yn2:=als2[alsa,4];
            yn4:= als2[alsb,4];
           z1:=[];
         
   {restricted common chcek A & C}
            for z in (comboset[yn4] * comboset[yn2]) do
               if ((Digitcell[z] * combosets[xn,yn])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn,yn] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                       then
                      begin
                            lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn,yn]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both a&b for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];

                   if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z1:=z1 + [z]; {saves the resticted commons}

                     end;

                 if   popcnt(dword(z1)) >=1  {* single restricted common advance to adding 3rd sector}
                        then                  
            
               
for alsC:= low(als2) to (high(als2)) do {als b}
   if (als2[alsC,1]+1 = als2[alsC,2]) {cell = digit +1}
     and   (popcnt(dword(( comboset2[yn2]*Comboset2[als2[alsC,4]]  ) ) )   >=1 ) {checks that set B and set C share at least 1 digits}
       
     and  (combosets[xn,yn]  - combosets[als2[alsC,0],ALS2[ALSC,3]] <> [] )  { sectors B & C can over lap, however cells cannot overlap in full}
     and  ( combosets[als2[alsC,0],ALS2[ALSC,3]] - combosets[xn,yn] <> [] )
      then
         begin
            z2:=[];
           z3:=[];

           xn3:=als2[alsc,0];
           yn5:=als2[alsc,3];
            yn6:= als2[alsc,4];

   {restricted common chcek B & C}
            for z in (comboset[yn6] * comboset[yn2] ) do
               if ((Digitcell[z] * combosets[xn3,yn5])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn,yn] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn,yn])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn,yn] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn3,yn5] * combosets[xn,yn]) = [])    {resticted commons cannot be found in an overlap cell}
                               //and (digitcell[z] * Combosets[xn2,yn3] - (combosets[xn3,yn5]+combosets[xn,yn]) = []){resticted commons cannot be found in an overlap cell shared by the 2nd set}
                       then
                      begin
                              lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn3,yn5]+combosets[xn,yn]) *digitcell[z] do  {combine common cells in both C&B for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];


                   if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z2:=z2 + [z]; {saves the resticted commons}

                     end;                     
             {restricted common chcek B & A}
            for z in (comboset[yn6] * comboset[yn4] ) do
               if ((Digitcell[z] * combosets[xn3,yn5])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn2,yn3] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn2,yn3] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn3,yn5] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                               //and (digitcell[z] * Combosets[xn2,yn3] - (combosets[xn3,yn5]+combosets[xn,yn]) = []){resticted commons cannot be found in an overlap cell shared by the 2nd set}
                       then
                      begin
                             lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn3,yn5]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both C&B for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];


                   if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z3:=z3 + [z]; {saves the resticted commons}
                     end;      
                  
            if  (( popcnt(dword(z2)) >1 ) and ( popcnt(dword(z1)) >1 )){if the resticted common on a set is more then 1 its an double linked als-xz rule}
              or (( popcnt(dword(z2)) =1 ) and ( popcnt(dword(z1)) =1 )   and (z1 - z2 <> [] ) and (Z2 - z1 <> []))   {checks that both sectors have at least 1 RC and those numbers are diffrent }
                 or (( popcnt(dword(z2)) =1 ) and ( popcnt(dword(z1)) >1 ))
              or (( popcnt(dword(z2)) >1 ) and ( popcnt(dword(z1)) =1 ))
               //  and ((comboset[yn4] * Comboset[yn6] - (z2+z1) ) <> [])
                then
                 begin {Eliminations A & B peer of z}

                 if   (popcnt(dword( (comboset2[yn4]*Comboset2[yn6]) ) )   >=1 )
                                     then
                                            for R in ((comboset[yn6]  * comboset[yn4]  )-(z2+z1{+z3})    ) do   {search for common digit to both A & B, thats not the RC of z1,z2,z3}
                                                      if ((Digitcell[R]* combosets[xn2,yn3] )<> [] )
                                                      and(( Digitcell[R] * combosets[xn3,yn5])<> [])
                                                     // and (Digitcell[R] * combosets[xn2,yn3]   = [])
                                                       then
                                                        begin
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]));  {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in ((combosets[xn3,yn5] + combosets[xn2,yn3] {+ combosets[xn,yn]}) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b}
                                                           a3:=peer[q] * a3 - ({combosets[xn,yn] +} combosets[xn2,yn3] + combosets[xn3,yn5]);

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;

 {if AC share more then 1 digit perform basic als-xz eliminations}
if   (popcnt(dword( (comboset2[yn4]*Comboset2[yn2]) ) )   >1 )
    then
                                           for R in ((comboset[yn2]  * comboset[yn4]  )-(z1)    ) do   {search for common digit to both A & C, thats not the RC of z1,}
                                                      if ((Digitcell[R]* combosets[xn2,yn3] )<> [] )
                                                      and(( Digitcell[R] * combosets[xn,yn])<> [])
                                                     // and (Digitcell[R] * combosets[xn2,yn3]   = [])
                                                       then
                                                        begin
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]));  {valid eliminations must contain R and cannot be in the sets a&C}

                                                          for q in (({combosets[xn3,yn5] +} combosets[xn2,yn3] + combosets[xn,yn]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b}
                                                           a3:=peer[q] * a3 - (combosets[xn,yn] + combosets[xn2,yn3] {+ combosets[xn3,yn5]});

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;

 {if BC share more then 1 digit perform basic als-xz eliminations}
if   (popcnt(dword( (comboset2[yn6]*Comboset2[yn2]) ) )   >1 )
    then
                                           for R in ((comboset[yn2]  * comboset[yn6]  )-(z2)    ) do   {search for common digit to both B & C, thats not the RC of z2,}
                                                      if ((Digitcell[R]* combosets[xn3,yn5] )<> [] )
                                                      and(( Digitcell[R] * combosets[xn,yn])<> [])
                                                     // and (Digitcell[R] * combosets[xn2,yn3]   = [])
                                                       then
                                                        begin
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]));  {valid eliminations must contain R and cannot be in the sets a&C}

                                                          for q in ((combosets[xn3,yn5] {+ combosets[xn2,yn3] }+ combosets[xn,yn]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b}
                                                           a3:=peer[q] * a3 - (combosets[xn,yn] {+ combosets[xn2,yn3]} + combosets[xn3,yn5]);

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;

                                          
                                          
                if  ( popcnt(dword(z1)) >1 ) {doubly linked rules } {A & C}

                        then
                    begin
                                                      active:=true;

                                                     {set A&C is now a locked set removal peers cells visable to all copies of each digit in  both sets}
                                                  for R in comboset[yn2] + comboset[yn4] do
                                        for q in ([0..80] * digitcell[R]) do
                                         begin {R/Q elimiantion search}

                                         if (R in (comboset[yn2] * Comboset[yn4]) ){search for common digit to both, and active in both}
                                         and ((digitcell[R] * combosets[xn,yn])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn2,yn3])  <> [])
                                         and (Peer[q] * ((Combosets[xn,yn]+Combosets[xn2,yn3])*digitcell[R]) = ((Combosets[xn,yn] + Combosets[xn2,yn3])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * (Combosets[xn,yn] + combosets[xn2,yn3]) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];

                                          if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                            end;
                                            {cells in set C for digits exclusivly to C  their peers cannot contain r}
                                          if (R in (Comboset[yn2] - z1))//Comboset[yn4]) )
                                          and  (peer[q] * Digitcell[R] * Combosets[xn,yn] = combosets[xn,yn] * Digitcell[R])
                                          and ([q] * combosets[xn,yn] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;
                                             end;
                                             {cells in set A for digits exclusivly to A  their peers cannot contain r}
                                          if (R in (Comboset[yn4]  -  z1))//Comboset[yn2]) )
                                          and  (peer[q] * Digitcell[R] * Combosets[xn2,yn3] = combosets[xn2,yn3]* Digitcell[R])
                                          and ([q] * combosets[xn2,yn3] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;
                                             end;


                                         end; {R/Q elimiantion search}

                     end;  {doubly linked}

 if  ( popcnt(dword(z2)) >1 )  {doubly linked rules } {B & C}
                          then
                    begin
                                                      active:=true;

                                                     {set B&C is now a locked set removal peers cells visable to all copies of each digit in  both sets}
                                                  for R in comboset[yn2] + comboset[yn6] do
                                        for q in ([0..80] * digitcell[R]) do
                                         begin {R/Q elimiantion search}

                                         if (R in (comboset[yn2] * Comboset[yn6]) ){search for common digit to both, and active in both}
                                         and ((digitcell[R] * combosets[xn,yn])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn3,yn5])  <> [])
                                         and (Peer[q] * ((Combosets[xn,yn]+Combosets[xn3,yn5])*digitcell[R]) = ((Combosets[xn,yn] + Combosets[xn3,yn5])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * (Combosets[xn,yn] + combosets[xn3,yn5]) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];

                                          if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                            end;
                                            {cells in set C for digits exclusivly to C  their peers cannot contain r}
                                          if (R in (Comboset[yn2] - z2))//Comboset[yn6]) )
                                          and  (peer[q] * Digitcell[R] * Combosets[xn,yn] = combosets[xn,yn] * Digitcell[R])
                                          and ([q] * combosets[xn,yn] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;
                                             end;
                                             {cells in set B for digits exclusivly to B  their peers cannot contain r}
                                          if (R in (Comboset[yn6]  - z2))// Comboset[yn2]) )
                                          and  (peer[q] * Digitcell[R] * Combosets[xn3,yn5] = combosets[xn3,yn5]* Digitcell[R])
                                          and ([q] * combosets[xn3,yn5] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;
                                             end;


                                         end; {R/Q elimiantion search}

                     end;  {doubly linked}
                  
{tripply linked rules } {B & A & C  are all locked sets}
 if  (( popcnt(dword(z3)) >=1)  and(( popcnt(dword(z3+z2+z1)) >=3))) // and(z3 - (z2+z1) <> [] ))   {check that the resticted commons between the three sets are all diffrent}
                        then
                    begin

                        active:=true;

                                                     {set B&C is now a locked set removal peers cells visable to all copies of each digit in  all sets}
                                                  for R in comboset[yn4] + comboset[yn6] +comboset[yn2] do
                                        for q in ([0..80] * digitcell[R]) do
                                         begin {R/Q elimiantion search}

                                         if (R in (comboset[yn4] * Comboset[yn6] * Comboset[yn2]) ){search for common digit to all, and active in all}
                                         and ((digitcell[R] * combosets[xn2,yn3])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn3,yn5])  <> [])
                                         and ( (Digitcell[R] * combosets[xn,yn])  <> [])
                                         and (Peer[q] * ((Combosets[xn2,yn3]+Combosets[xn3,yn5]+combosets[xn,yn])*digitcell[R]) = ((Combosets[xn2,yn3] + Combosets[xn3,yn5]+combosets[xn,yn])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * (Combosets[xn2,yn3] + combosets[xn3,yn5]+combosets[xn,yn]) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];

                                          if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                            end;
           if (R in (comboset[yn4] * Comboset[yn6] )  ){search for common digit to ab, and active in ab}
                                         and ((digitcell[R] * combosets[xn2,yn3])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn3,yn5])  <> [])   
                                         and   ( (Digitcell[R] * combosets[xn,yn])  = [])      {and not in c}                                                            
                                         and (Peer[q] * ((Combosets[xn2,yn3]+Combosets[xn3,yn5]{+combosets[xn,yn]})*digitcell[R]) = ((Combosets[xn2,yn3] + Combosets[xn3,yn5]+combosets[xn,yn])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * (Combosets[xn2,yn3] + combosets[xn3,yn5]{+combosets[xn,yn]}) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];

                                          if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                            end;

           if (R in (comboset[yn2] * Comboset[yn6] ) ){search for common digit to cb, and active in c}
                                         and ((digitcell[R] * combosets[xn,yn])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn3,yn5])  <> [])   
                                         and   ( (Digitcell[R] * combosets[xn2,yn3])  = []) {and not in b}   
                                         and (Peer[q] * (({Combosets[xn2,yn3]+}Combosets[xn3,yn5]+combosets[xn,yn])*digitcell[R]) = ((Combosets[xn2,yn3] + Combosets[xn3,yn5]+combosets[xn,yn])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * ({Combosets[xn2,yn3] +} combosets[xn3,yn5]+combosets[xn,yn]) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];

                                          if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                            end;
           if (R in (comboset[yn2] * Comboset[yn4] ) ){search for common digit to ca, and active in ca}
                                         and ((digitcell[R] * combosets[xn,yn])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn2,yn3])  <> [])
                                         and   ( (Digitcell[R] * combosets[xn3,yn5])  = [])   {and not in b}
                                         and (Peer[q] * ((Combosets[xn2,yn3]+{Combosets[xn3,yn5]+}combosets[xn,yn])*digitcell[R]) = ((Combosets[xn2,yn3] + Combosets[xn3,yn5]+combosets[xn,yn])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * (Combosets[xn2,yn3] {+ combosets[xn3,yn5]}+combosets[xn,yn]) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];

                                          if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                            end;                                          
                                          {belive comboset yn6,yn2 can be replaced with z1,z2,z3} //same as i did for the xz-function.
                                            {cells in set A for digits exclusivly to A  their peers cannot contain r}
                                          if (R in (Comboset[yn4] - (Comboset[yn6]+comboset[yn2])) )
                                          and  (peer[q] * Digitcell[R] * Combosets[xn2,yn3] = combosets[xn2,yn3] * Digitcell[R])
                                          and ([q] * combosets[xn2,yn3] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;
                                             end;
                                             {cells in set B for digits exclusivly to B  their peers cannot contain r}
                                          if (R in (Comboset[yn6]  - ( Comboset[yn4]+comboset[yn2]) ))
                                          and  (peer[q] * Digitcell[R] * Combosets[xn3,yn5] = combosets[xn3,yn5]* Digitcell[R])
                                          and ([q] * combosets[xn3,yn5] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;
                                             end;
                                                         {cells in set C for digits exclusivly to C  their peers cannot contain r}
                                          if (R in (Comboset[yn2]  - ( Comboset[yn4]+comboset[yn6]) ))
                                          and  (peer[q] * Digitcell[R] * Combosets[xn,yn] = combosets[xn,yn]* Digitcell[R])
                                          and ([q] * combosets[xn,yn] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
                                             if k =0 then
                                             begin
                                                             techwrite[u,r+9]:= techwrite[u,r+9] + [q];
                                                             techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;
                                             end;

                                         end; {R/Q elimiantion search}

                     end;  {tripply linked}



if (k= 0)
 and (techwrite[u,9] <> [])
 then
begin
techwrite[u,0]:=techwrite[u,0]+[3];
techwrite[u,1]:=techwrite[u,1]+[6];
techwrite[u,2]:=techwrite[u,2]+comboset[yn2];
techwrite[u,3]:=techwrite[u,3]+Combosets[xn,yn];
techwrite[u,4]:=techwrite[u,4]+comboset[yn4];
techwrite[u,5]:=techwrite[u,5]+combosets[xn2,yn3];
techwrite[u,6]:=techwrite[u,6]+comboset[yn6];
techwrite[u,7]:=techwrite[u,7]+combosets[xn3,yn5];
techwrite[u,8]:=techwrite[u,8]+ z1 + z2;

end;


if u = 32767    {max array size error code safty exit}
 then
 begin
  if k = 0 then
     techdisplay(#121,u);

    setlength(techwrite,0,0);
    u:=0; setlength(techwrite,u+1,20)
end;

if (k=0) and (techwrite[u,9] <> []) then begin  u:=U+1; setlength(techwrite,u+1,20); end;
            

                 end; {normal eliminations}

             end;
            end;                  

if k = 0 then
     chaindisplay(#121,u);
end;{als -xy rule}

ALS-w-wing
Als-W-wing: Show
Code: Select all
 
{w -wing technique expanded from bivavle cells into als sets}

procedure alswwing(k:integer);
var
q,xn,xn2,yn,yn2,yn3,yn4,yn5,yn6,n,n2,z,x,r,r2,u,alsa,alsb:integer;

A3:numberset;
z1:nums;

lx1: numberset;
lx2: numberset;
lx3: numberset;

lx4: numberset;
lx5: numberset;

begin
alsfinder;
  //ahsfinder;
if k=0 then begin  u:=0; setlength(techwrite,u+1,21); end;

 for alsA:= low(als) to (high(als)-1) do {als A}
   if (als[alsA,1]+1 = als[alsA,2]) {cell = digit +1}
     then
       for ALSB:= alsa+1 to high(als) do {Als B}
          if (als[alsb,1]+1 = als[alsb,2] ) {cell = digit +1}
              and (popcnt(dword((comboset2[als[alsa,4]]*Comboset2[als[alsb,4]]) ) )   >1 )   {set a & B must share 2 digits}
               and (combosets[als[alsa,0],als[alsa,3]]  - combosets[als[alsb,0],als[alsb,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als[alsb,0],als[alsb,3]] - combosets[als[alsa,0],als[alsa,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}
          then
            begin

             xn:=als[alsa,0];
             xn2:=als[alsb,0];

            yn:=als[alsA,3];
            yn3:=als[alsB,3];
            
            yn2:=als[alsa,4];
            yn4:= als[alsb,4];

         
for N in (comboset[yn4] * comboset[yn2]) do
           if  (digitcell[n] *( combosets[xn,yn] * combosets[xn2,yn3]) = []){sectors cannot have overlapping shared linked digit}
             then
                  begin

lx1:=[0..80];
lx2:=[0..80];

for x in (digitcell[n] * combosets[xn,yn]) do
lx1:=lx1 * peer[x];

for x in (digitcell[n] * combosets[xn2,yn3]) do
lx2:=lx2 * peer[x];

for yn5 in  [0..26]  do
    if (Digitrcb[yn5,n] <> [] )  and (Sec[yn5,n] < 7)
                and ( (digitrcb[yn5,n] * lx1) + (digitrcb[yn5,n] * lx2 )  = digitrcb[yn5,n] )
               // and (lx1 * lx2 <> []) { not as simple as a 1 direction elimination}
                and (digitrcb[yn5,n] * (digitcell[n] * (combosets[xn,yn] + combosets[xn2,yn3])) = [] ) { active N sets cannot overlap the strong link}
            and (lx2 * digitrcb[yn5,n] <> []) {peers cant be blank}
            and ( lx1 * digitrcb[yn5,n] <> []) {peers cant be blank}
         
                 then
                  begin
if k=0 then
begin
techwrite[u,0]:= comboset[yn2];
techwrite[u,10]:= comboset[yn4];
techwrite[u,11]:= (combosets[xn,yn] ) ;
techwrite[u,12]:=(combosets[xn2,yn3] );
techwrite[u,13]:=digitrcb[yn5,n] * lx1;
techwrite[u,14]:=  digitrcb[yn5,n] * lx2;
techwrite[u,15]:= [n];
techwrite[u,16]:=[];
techwrite[u,17]:=[0];
end;

                  for R in ((comboset[yn4] * comboset[yn2]) - [n]) do
                    begin
                     lx3:=[0..80];

                     for x in digitcell[r] * (combosets[xn2,yn3] + combosets[xn,yn]) do
                      lx3:=lx3 * peer[x];

                         if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R] *lx3);

if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                        end;
                   end;

                   {self contained Ring - mimics als-doubly linked}
                   // - restricted common to A & B that is not N and not in the overlap of sets a & B
               for R2 in ((comboset[yn4] * comboset[yn2]) - [n]) do
                if  (digitcell[r2] * combosets[xn,yn] * combosets[xn2,yn3] = [] )  {overlaping cells must not contain r}
                 then
                    begin
                     lx3:=[0..80];

                     for x in digitcell[r2] * (combosets[xn,yn]) do
                      lx3:=lx3 * peer[x];

                        if (lx3 * digitcell[r2]*combosets[xn2,yn3] = digitcell[r2]*combosets[xn2,yn3] )
                        and (lx3 <> [])
                           then
                          begin

if k=0 then
begin
techwrite[u,16]:=techwrite[u,16] +[x];
end;

 for R in comboset[yn2] + comboset[yn4] do
                                        for q in ([0..80] * digitcell[R]) do
                                         begin {R/Q elimiantion search}

                                         if (R in (comboset[yn2] * Comboset[yn4]) ){search for common digit to both, and active in both}
                                         and ((digitcell[R] * combosets[xn,yn])  <> [] )
                                                      and ( (Digitcell[R] * combosets[xn2,yn3])  <> [])
                                         and (Peer[q] * ((Combosets[xn,yn]+Combosets[xn2,yn3])*digitcell[R]) = ((Combosets[xn,yn] + Combosets[xn2,yn3])*digitcell[R])) {makes sure the peer of q can see all the digits}
                                          and ([q] * (Combosets[xn,yn] + combosets[xn2,yn3]) = []) {q cannot elimiante from a set cell}
                                            then
                                           begin
                                             covered2[R]:=Covered2[R] + [q];
 if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *[q]);
end;

                                            end;

                                            {cells in set A for digits exclusivly to A  their peers cannot contain r}
                                          if (R in (Comboset[yn2] - Comboset[yn4]) )
                                          and  (peer[q] * Digitcell[R] * Combosets[xn,yn] = combosets[xn,yn] * Digitcell[R])
                                          and ([q] * combosets[xn,yn] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *[q]);
end;
                                             end;

                                             {cells in set B for digits exclusivly to B  their peers cannot contain r}
                                          if (R in (Comboset[yn4]  -  Comboset[yn2]) )
                                          and  (peer[q] * Digitcell[R] * Combosets[xn2,yn3] = combosets[xn2,yn3]* Digitcell[R])
                                          and ([q] * combosets[xn2,yn3] = [])
                                            then
                                             begin
                                             covered2[R]:=Covered2[R] + [q];
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *[q]);
end;
                                             end;


                                         end; {R/Q elimiantion search}

                                 end;
                           end; {self contained doubly linked als-xz thanks to y5 link}



For n2 in (comboset[yn4]*comboset[yn2])- [n] do
  begin

lx4:=[0..80];
lx5:=[0..80];

for x in (digitcell[n2] * combosets[xn,yn]) do
lx4:=lx4 * peer[x];

for x in (digitcell[n2] * combosets[xn2,yn3]) do
lx5:=lx5 * peer[x];


{rings}
for yn6 in  [0..26]   do
    if (Digitrcb[yn6,n2] <> [] )  and (Sec[yn6,n2] < 7)
                and ( (digitrcb[yn6,n2] * lx4) + (digitrcb[yn6,n2] * lx5 )  = digitrcb[yn6,n2] )
               // and (lx1 * lx2 <> []) { not as simple as a 1 direction elimination}
                and (digitrcb[yn6,n2] * (digitcell[n2] * (combosets[xn,yn] + combosets[xn2,yn3])) = [] ) { active N sets cannot overlap the strong link}
                and (lx4 * digitrcb[yn6,n2] <> []) {peers cant be blank}
            and ( lx5 * digitrcb[yn6,n2] <> []) {peers cant be blank}
      
            
             then
                  begin
                            {regular eliminations}
                  for R in ((comboset[yn4] * comboset[yn2]) - [n2]) do
                    begin
                     lx3:=[0..80];

                     for x in digitcell[r] * (combosets[xn2,yn3] + combosets[xn,yn]) do
                      lx3:=lx3 * peer[x];

                     if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R]*lx3);
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                                              end;{regular eliminations}
                                             end;

                           {regular eliminations}
                  for R in ((comboset[yn4] * comboset[yn2]) - [n]) do
                    begin
                     lx3:=[0..80];

                     for x in digitcell[r] * (combosets[xn2,yn3] + combosets[xn,yn]) do
                      lx3:=lx3 * peer[x];

                     if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R]*lx3);
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;
                                              end;{regular eliminations}
                                             end;

            {all digits common to a & b are locked to a & b remove peers }
             for R in ((comboset[yn4] * comboset[yn2]) ) do
                    begin
                     lx3:=[0..80] - ((digitrcb[yn6,n2]+ digitrcb[yn5,n]) + (combosets[xn2,yn3] + combosets[xn,yn]) );

                     for x in digitcell[r] * (combosets[xn2,yn3] + combosets[xn,yn]) do
                      lx3:=lx3 * peer[x];

                     if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R]*lx3);
 if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                                              end;{peers of set a & B common digits eliminations}
                                             end;

               {B non n,n2 digits are locked to set b }
                         for R in (comboset[yn4] -[n,n2] ) do
                            begin
                     lx3:=[0..80] - (combosets[xn,yn] + combosets[xn2,yn3]);
                     for x in digitcell[r] * (combosets[xn2,yn3]) do
                      lx3:=lx3 * peer[x];

                  if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R]*lx3);
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;


                                              end;
                                             end;

                  {A non n,n2 digits are locked to set A }
                         for R in (comboset[yn2] -[n,n2] ) do
                            begin
                     lx3:=[0..80] - (combosets[xn,yn] + combosets[xn2,yn3]);
                  for x in digitcell[r] * (combosets[xn,yn]) do
                      lx3:=lx3 * peer[x];

                  if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R]*lx3);
 if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                                              end;
                                             end;


                          {eliminates n2 from b + part y6  sector  in cells that are peers }
                    For R in [n2] do
                      begin
                        lx3:= [0..80] - (combosets[xn,yn] + combosets[xn2,yn3] + (digitrcb[yn6,n2]));
                        for x in digitcell[r] * (combosets[xn2,yn3] + (lx5 * digitrcb[yn6,n2])) do
                           lx3:=lx3 * peer[x];
                     if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] +(digitcell[R]*lx3);
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                        end;
                        end;

                   {eliminates n2 from A + part of y6 sector cells that are peers }
                 For R in [n2] do
                      begin
                        lx3:= [0..80] - (combosets[xn,yn] + combosets[xn2,yn3] + (digitrcb[yn6,n2]));
                        for x in digitcell[r] * (combosets[xn,yn] + (lx4 * digitrcb[yn6,n2])) do
                           lx3:=lx3 * peer[x];
                     if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R]*lx3);
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                        end;
                        end;
                                {eliminates n from b + part y5  sector  in cells that are peers }
                    For R in [n] do
                      begin
                        lx3:= [0..80] - (combosets[xn,yn] + combosets[xn2,yn3] + (digitrcb[yn5,n]));
                        for x in digitcell[r] * (combosets[xn2,yn3] + (lx2 * digitrcb[yn5,n])) do
                           lx3:=lx3 * peer[x];
                     if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] + (digitcell[R]*lx3);
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                        end;
                        end;

                   {eliminates n from A + part of y5 sector cells that are peers }
                 For R in [n] do
                      begin
                        lx3:= [0..80] - (combosets[xn,yn] + combosets[xn2,yn3] + (digitrcb[yn5,n]));
                        for x in digitcell[r] * (combosets[xn,yn] + (lx1 * digitrcb[yn5,n])) do
                           lx3:=lx3 * peer[x];
                     if (digitcell[R] * lx3 <> []) and (lx3 <> [0..80])
                       then
                       begin
                        active:=true;
                        covered2[r]:=covered2[r] +(digitcell[R]* lx3);
if k=0 then
begin
techwrite[u,r]:=techwrite[u,r] +(digitcell[R] *lx3);
end;

                        end;
                        end;
if k=0 then
begin
techwrite[u,0]:= comboset[yn2];
techwrite[u,10]:= comboset[yn4];
techwrite[u,11]:= (combosets[xn,yn] ) ;
techwrite[u,12]:=(combosets[xn2,yn3] );
techwrite[u,13]:=digitrcb[yn5,n] * lx1;
techwrite[u,14]:=  digitrcb[yn5,n] * lx2;
techwrite[u,15]:= [n];
techwrite[u,19]:= [n2];
techwrite[u,17]:=[0,1];
techwrite[u,18]:=digitrcb[yn6,n2] * lx4;
techwrite[u,20]:=digitrcb[yn6,n2] * lx5;
end;


if (k = 0)  and  ((techwrite[u,1] <> []) or (techwrite[u,2] <> []) or (techwrite[u,3] <> [])or (techwrite[u,4] <> [])or (techwrite[u,5] <> [])or (techwrite[u,6] <> [])or (techwrite[u,7] <> [])or (techwrite[u,8] <> [])or (techwrite[u,9] <> []))
                 then
                  begin
                  u:=u+1;
                  setlength(techwrite,u+1,21);
                  end;
            
                        end; {yn6}   
            
   
                      end; {n2 restictions check}
               
if (k = 0)  and  ((techwrite[u,1] <> []) or (techwrite[u,2] <> []) or (techwrite[u,3] <> [])or (techwrite[u,4] <> [])or (techwrite[u,5] <> [])or (techwrite[u,6] <> [])or (techwrite[u,7] <> [])or (techwrite[u,8] <> [])or (techwrite[u,9] <> []))
                 then
                  begin
                  u:=u+1;
                  setlength(techwrite,u+1,21);
                  end;

                   end;


              end; {y5 N directional search};

            end; { completed a & b set search}


 if k = 0 then techdisplay(#23,u);

end; {als-w-wing}


AlS-Swing
ALS- S-Wing: Show
Code: Select all
{Swing expaned so the bivavle is an almost locked set}
Procedure alsSwing(K:integer);
var
q,xn,xn5,j,j2,xn2,yn,yn2,yn3,yn4,yn5,yn6,n,n2,z,z2,x,r,r2,g,count,count2,alsa:integer;

A3:numberset;
z1:nums;

lx1: numberset;
lx2: numberset;
lx3: numberset;

lx4: numberset;
lx5: numberset;

begin
alsfinder;
  //ahsfinder;
if k=0 then begin  g:=0; setlength(techwrite,g+1,16); end;

for alsA:= low(als) to (high(als)) do {als A}
   if (als[alsA,1]+1 = als[alsA,2]) {cell = digit +1}
    then
            begin

             xn5:=als[alsa,0];
               yn5:=als[alsA,3];         
            yn4:= als[alsa,4];   

   for n in  (comboset[yn4] ) do
      for n2 in (comboset[yn4] - [n])  do
     begin
     lx1:=[0..80];

for x in (digitcell[n] * combosets[xn5,yn5]) do
lx1:=lx1 * peer[x];
lx2:=[0..80];

for x in (digitcell[n2] * combosets[xn5,yn5]) do
lx2:=lx2 * peer[x];

   for J in [0..26] do
          if (digitrcb[j,n] <> [])
           and ((digitcell[n]*combosets[xn5,yn5]) * digitrcb[j,n]=(digitcell[n]*combosets[xn5,yn5]))
            then

              for yn in peerrcb[j] do
               if  (digitrcb[yn,n] <> [])
                and not ((digitcell[n]*combosets[xn5,yn5])* digitrcb[yn,n]= (digitcell[n]*combosets[xn5,yn5]))
                and (digitrcb[yn,n] * digitrcb[j,n] <> [])
                and ( (Digitrcb[yn,n] * digitrcb[j,n])  = ( lx1 * digitrcb[yn,n] ) )
                 then

                  for z in peerrcb[yn] do
                   if  (digitrcb[z,n] <> [] )
                    and not ((digitcell[n]* combosets[xn5,yn5]) * digitrcb[z,n]= (digitcell[n]*combosets[xn5,yn5]))
                    and (digitrcb[z,n] * digitrcb[yn,n] <> [])
                    and ((digitrcb[z,n] * digitrcb[yn,n]) + (digitrcb[yn,n] * digitrcb[j,n] ) = digitrcb[yn,n])
                    then

         for J2 in ([0..26]) do
          if (digitrcb[j2,n2] <> [])
           and ((digitcell[n2]*combosets[xn5,yn5]) * digitrcb[j2,n2]=(digitcell[n2]*combosets[xn5,yn5]))
            then

              for yn2 in peerrcb[j2] - [yn] do
               if  (digitrcb[yn2,n2] <> [])
                and not ( (digitcell[n2] * combosets[xn5,yn5]) * digitrcb[yn2,n2]=(digitcell[n2] * combosets[xn5,yn5]))
                and (digitrcb[yn2,n2] * digitrcb[j2,n2] <> [])
                and ( (Digitrcb[yn2,n2] * digitrcb[j2,n2])  = ( lx2 * digitrcb[yn2,n2] ) )
                 then

                  for z2 in (peerrcb[z]  * peerrcb[yn2]) do
                   if  (digitrcb[z2,n2] <> [] )
                    and not ((digitcell[n2]*combosets[xn5,yn5]) * digitrcb[z2,n2]=(digitcell[n2]*combosets[xn5,yn5]))
                    and (digitrcb[z2,n2] * digitrcb[yn2,n2] <> [])
                    and ((digitrcb[z2,n2] * digitrcb[yn2,n2]) + (digitrcb[yn2,n2] * digitrcb[j2,n2] ) = digitrcb[yn2,n2])
                    then

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

                     then

         begin
          Count:=0;
          count2:=0;

         
           for q in (digitrcb[yn,n] * digitrcb[z,n]) do
              inc(count);

              for q in (digitrcb[yn2,n2] * digitrcb[z2,n2]) do               
                inc(count2);           

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

          then
           begin

             active:=true;
         
          if k = 0 then begin
          techwrite[g,0]:=combosets[xn5,yn5];
          techwrite[g,10]:= [n];
          techwrite[g,11]:=[n2];
          techwrite[g,12]:= digitrcb[yn,n] * digitrcb[z,n];         
          techwrite[g,13]:= digitrcb[yn,n] - (digitrcb[yn,n] * digitrcb[z,n]);
          techwrite[g,14]:= (digitrcb[yn2,n2] * digitrcb[z2,n2]);
          techwrite[g,15]:= digitrcb[yn2,n2] - (digitrcb[yn2,n2] * digitrcb[z2,n2]);
          end;

if  (count in [1])
and  ((digitrcb[yn,n2] * Digitrcb[z,n2]) * (digitrcb[yn,n] * Digitrcb[z,n]) <> [] )
 then
            for q in ( digitrcb[yn,n] * digitrcb[z,n]) do
             if  (peer[q] * (digitrcb[yn2,n2] * digitrcb[z2,n2])  =  (digitrcb[yn2,n2] * digitrcb[z2,n2]))
               then
             begin
                covered2[n2]:= covered2[n2] +(digitrcb[yn,n] * Digitrcb[z,n]);
            if k = 0
             then techwrite[g,n2]:=(digitrcb[yn,n] * Digitrcb[z,n]);
             end;
             

if (count2 in [1])
 and ((digitrcb[yn2,n] * Digitrcb[z2,n]) * (digitrcb[yn2,n2] * Digitrcb[z2,n2]) <> [])
   then               
           for q in ( digitrcb[yn2,n2] * digitrcb[z2,n2]) do             
               if (peer[q] * (digitrcb[yn,n] * digitrcb[z,n])  =  (digitrcb[yn,n] * digitrcb[z,n]))
               then
             begin
                covered2[n]:= covered2[n] +(digitrcb[yn2,n2] * Digitrcb[z2,n2]);            
            if k = 0
             then techwrite[g,n]:=(digitrcb[yn2,n2] * Digitrcb[z2,n2]);
             end;

if (k = 0) and (techwrite[g,n] + techwrite[g,n2] <> [])
  then
  begin
  g:=g+1;
  setlength(techwrite,g+1,16);
  end;


          end;
         end;

      

       end;
       end;
      

if k= 0 then techdisplay(#4,g);

end;{alsswing}

als-m-wing
ALS-M-Wing: Show
Code: Select all
{All most locket set  version of for the M - wing changing the bivavles to als sets}
procedure alsMwing(k:integer);
var
q,xn,xn5,xn2,yn,yn2,yn3,yn4,yn5,yn6,n,n2,z,x,r,r2,g,alsa:integer;

A3:numberset;
z1:nums;

lx1: numberset;
lx2: numberset;
lx3: numberset;

lx4: numberset;
lx5: numberset;

begin
alsfinder;
  //ahsfinder;
if k=0 then begin  g:=0; setlength(techwrite,g+1,16); end;
   
for alsA:= low(als) to (high(als)) do {als A}
   if (als[alsA,1]+1 = als[alsA,2]) {cell = digit +1}
    then
            begin

             xn5:=als[alsa,0];
               yn5:=als[alsA,3];         
            yn4:= als[alsa,4];   
   
for xn2 in ComboSubset[yn4] do
   
if (popcnt(dword(((comboset[yn4]*pm[xn2])))) >1) and (peer[xn2] * combosets[xn5,yn5] = [])
    then
   
for n  in (comboset[yn4]*pm[xn2]) do
 begin
lx1:=[0..80];

for x in (digitcell[n] * combosets[xn5,yn5]) do
lx1:=lx1 * peer[x];

for yn in [0..26] do
 if (lx1 * digitrcb[yn,n] <> [] )
  and (lx1 * digitrcb[yn,n] <> Digitrcb[yn,n] )
   then

                   {row,box,col}
                   if (digitrcb[yn,n] <> [] ) and (sec[yn,n] <5)
                   and(digitrcb[yn,n] * ( (lx1*digitrcb[yn,n]) + [xn2] )  = digitrcb[yn,n] )
                    then
                      begin

                       for  n2 in ((comboset[yn4]*pm[xn2]) - [n]) do
                              begin

lx2:=[0..80];
for x in (digitcell[n2] * combosets[xn5,yn5]) do
lx2:=lx2 * peer[x];

                              {row}
                               for yn2 in ((peerRCB[Rsec[rx[xn2]]] + peerrcb[Csec[Cy[xn2]]] + peerrcb[bsec[bxy[xn2]]]) ) do
                                begin
                                 if  (digitrcb[yn2,n2] <> [] ) and (sec[yn2,n2] <6)
                                 and ((digitrcb[yn2,n2] * peer[xn2]) + [xn2] = digitrcb[yn2,n2] )

                                  then
                                    begin
                                     active:=true;

                                    for z:= 0 to 80 do
                                     if (peer[z] *  ((digitcell[n2]*combosets[xn5,yn5]) + ( digitrcb[yn2,n2] - [xn2]) )
                            = ((digitcell[n2]*combosets[xn5,yn5]) +( digitrcb[yn2,n2] - [xn2]) ) ) and (z in digitcell[n2])
                                      then
                                         begin
                           
                                       covered2[n2]:=covered2[n2] + [z];

                                          if k = 0 then
                                            techwrite[g,n2]:=techwrite[g,n2] + [z];
                                              end;

                        if ((digitrcb[yn2,n2] * lx2)  =  (digitrcb[yn2,n2] -[xn2]) )   {ring code}
                                             then                  
                                  begin
                                 
                                                for z:= 0 to 80 do   
                                     begin
                                    
                                     if (peer[z] * ([xn2] + (digitrcb[yn,n]  -(digitcell[n]*combosets[xn5,yn5])) )= ([xn2] + (digitrcb[yn,n] - (digitcell[n]*combosets[xn5,yn5])) )) and (z in digitcell[n])
                                                    then
                                                      begin
                                                       covered2[n]:=covered2[n] + [z];
                                                 if k = 0 then
                                                   techwrite[g,n]:=techwrite[g,n] + [z];
                                                  end;
                                       
                                    For R in (comboset[yn4] -[n,n2]) do
                                       if (peer[z] * (Digitcell[R]*Combosets[xn5,yn5]) = digitcell[r]*Combosets[xn5,yn5])
                                          and (R in pm[z])                                       
                                           then
                                           begin
                                           covered2[r]:=covered2[r] + [z];
                                          
                                           if k = 0 then
                                                   techwrite[g,r]:=techwrite[g,r] + [z];
                                           end;    
                                       
                                     end;                                                                                   
                                                                                 
                                                      covered[xn2]:= covered[xn2] + (pm[xn2] - [n,n2] );   {xn2 becomes a locked pair}

                                                        if k= 0
                                                         then
                                                           for z in (pm[xn2] - [n,n2])  do
                                                           techwrite[g,z]:=techwrite[g,z]+[xn2];
                                                                                     
                                                      end; {rings}


  end;
if k =0
 then
begin
techwrite[g,0]:= [n];
techwrite[g,10]:= [n2];
techwrite[g,11]:=combosets[xn5,yn5];
techwrite[g,12]:=[xn2];
techwrite[g,13]:= (digitrcb[yn,n] * lx1);
techwrite[g,14]:= (digitrcb[yn2,n2] * peer[xn2]);
end;                           
    if (k =0) and ( (techwrite[g,n2] <> []) or (techwrite[g,n] <> []) )
  then begin
   g:=g+1;
   setlength(techwrite,g+1,15);
 end;                        
                                end;{end row,box,col}

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

            end;

   end; {set A}       

   if k = 0 then techdisplay(#1,g);
end;{alsMwing}


AALS-2RC-rule: Show
Code: Select all
{Almost Almost locked set 2 RC rule}
procedure Aals2RC(k:integer);  {so far this is 100,000% faster}
var
q,xn,xn2,xn3,yn,yn2,yn3,yn4,YN5,YN6,n,z,x,act3,r,u,alsa,alsb,alsc:integer;

A3:numberset;
z1:nums;
Z2:nums;
z3:nums;

lx1: rcbpeer;
lx2: rcbpeer;
lx3: rcbpeer;

begin
alsfinder;
  //ahsfinder;
if k=0 then begin  u:=0; setlength(techwrite,u+1,20); end;

for alsA:= low(als) to (high(als)) do {als C}
   if (als[alsA,1]+2 = als[alsA,2]) {cell = digit +2}
     then   
       for ALSB:= low(als) to high(als)-1 do {Als A}
          if (als[alsb,1]+1 = als[alsb,2] ) {cell = digit +1}
        and (popcnt(dword((comboset2[als[alsa,4]]*Comboset2[als[alsb,4]]) ) )   >=1 )   {set a & C must share 1 digits}
               and (combosets[als[alsa,0],als[alsa,3]]  - combosets[als[alsb,0],als[alsb,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als[alsb,0],als[alsb,3]] - combosets[als[alsa,0],als[alsa,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}
   then
            begin
            z1:=[];
               xn:=als[alsa,0];
             xn2:=als[alsb,0];

            yn:=als[alsA,3];
            yn3:=als[alsB,3];
            
            yn2:=als[alsa,4];
            yn4:= als[alsb,4];
         {restricted common chcek A & C}
            for z in (comboset[yn4] * comboset[yn2]) do
               if ((Digitcell[z] * combosets[xn,yn])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn,yn] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                       then
                      begin
                             lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn,yn]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both a&b for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];


                   if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z1:=z1 + [z]; {saves the resticted commons}

                     end;

                 if   popcnt(dword(z1)) >=1  {* single restricted common advance to adding 3rd sector}
                        then                      
                  
for alsC:= alsb+1 to (high(als)) do {als b}
   if (als[alsC,1]+1 = als[alsC,2]) {cell = digit +1}
     and   (popcnt(dword(( comboset2[yn2]*Comboset2[als[alsC,4]]  ) ) )   >=1 ) {checks that set B and set C share at least 1 digits}
       
     and  (combosets[xn,yn]  - combosets[als[alsC,0],ALS[ALSC,3]] <> [] )  { sectors B & C can over lap, however cells cannot overlap in full}
     and  ( combosets[als[alsC,0],ALS[ALSC,3]] - combosets[xn,yn] <> [] )
      then
         begin
            z2:=[];
           z3:=[];

           xn3:=als[alsc,0];
           yn5:=als[alsc,3];
            yn6:= als[alsc,4];
         
{restricted common chcek B & C}
            for z in (comboset[yn6] * comboset[yn2] ) do
               if ((Digitcell[z] * combosets[xn3,yn5])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn,yn] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn,yn])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn,yn] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn3,yn5] * combosets[xn,yn]) = [])    {resticted commons cannot be found in an overlap cell}
                               //and (digitcell[z] * Combosets[xn2,yn3] - (combosets[xn3,yn5]+combosets[xn,yn]) = []){resticted commons cannot be found in an overlap cell shared by the 2nd set}
                       then
                      begin
                             lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn3,yn5]+combosets[xn,yn]) *digitcell[z] do  {combine common cells in both C&B for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];


                   if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z2:=z2 + [z]; {saves the resticted commons}

                     end;      
                  
   {restricted common chcek B & A}
            for z in (comboset[yn6] * comboset[yn4] ) do
               if ((Digitcell[z] * combosets[xn3,yn5])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn2,yn3] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - ({(digitcell[z]*COmbosets[xn2,yn3]) + }(combosets[xn2,yn3] * combosets[xn3,yn5])) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn3,yn5] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                               //and (digitcell[z] * Combosets[xn2,yn3] - (combosets[xn3,yn5]+combosets[xn,yn]) = []){resticted commons cannot be found in an overlap cell shared by the 2nd set}
                       then
                      begin
                             lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn3,yn5]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both C&B for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];


                   if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z3:=z3 + [z]; {saves the resticted commons}
                     end;
                  
            if  (( popcnt(dword(z2)) >1 ) and ( popcnt(dword(z1)) >1 )){if the resticted common on a set is more then 1 its an double linked als-xz rule}
              or (( popcnt(dword(z2)) =1 ) and ( popcnt(dword(z1)) =1 )   and (z1 - z2 <> [] ) and (Z2 - z1 <> []))   {checks that both sectors have at least 1 RC and those numbers are diffrent }
                 or (( popcnt(dword(z2)) =1 ) and ( popcnt(dword(z1)) >1 ))
              or (( popcnt(dword(z2)) >1 ) and ( popcnt(dword(z1)) =1 ))
               //  and ((comboset[yn4] * Comboset[yn6] - (z2+z1) ) <> [])
                then
                 begin {Eliminations A & B peer of z}

                 if   (popcnt(dword( (comboset2[yn4]*Comboset2[yn6]*comboset2[yn2]) ) )   >=1 )
                                     then
                                            for R in ((comboset[yn6]  * comboset[yn4] * comboset[yn2]  )   ) do   {search for common digit to both A & B &C, thats not the RC of z1,z2,z3}
                                                      if ((Digitcell[R]* combosets[xn2,yn3] )<> [] )
                                                      and(( Digitcell[R] * combosets[xn3,yn5])<> [])
                                                      and ((Digitcell[R] * combosets[xn,yn]  <> []))
                                         and ((z1-z2) - [r] <> [])
                                         and ((z2-z1) - [r] <> [])
                                                       then
                                                        begin
                                          
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]) ); {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in ((combosets[xn3,yn5] + combosets[xn2,yn3] + combosets[xn,yn]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b&C}
                                                           a3:=peer[q] * a3 - (combosets[xn,yn] + combosets[xn2,yn3] + combosets[xn3,yn5]);

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;
                                          
                       if   (popcnt(dword( (z1+z2) ) )   >=4 ) {double linked restriction of links}
                                     then
                              begin
                                            for R in ((comboset[yn6]  * comboset[yn2]  *z2 )   ) do   {search for common digit to both C & B  thats in Z2}
                                                      if ((Digitcell[R]* combosets[xn,yn] )<> [] )
                                                      and(( Digitcell[R] * combosets[xn3,yn5])<> [])
                                                       then
                                                        begin
                                          
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]) ); {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in ((combosets[xn3,yn5] {+ combosets[xn2,yn3]} + combosets[xn,yn]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b&C}
                                                           a3:=peer[q] * a3- (combosets[xn,yn] {+ combosets[xn2,yn3] }+ combosets[xn3,yn5]);

                                                         if (a3 <> (([0..80] * digitcell[R]))) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;   
                                          
                                   for R in ((comboset[yn2]  * comboset[yn4]  *z1 )   ) do   {search for common digit to both C & A  thats in Z1}
                                                      if ((Digitcell[R]* combosets[xn,yn] )<> [] )
                                                      and(( Digitcell[R] * combosets[xn2,yn3])<> [])
                                                       then
                                                        begin
                                          
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]) ); {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in (({combosets[xn3,yn5] +} combosets[xn2,yn3] + combosets[xn,yn]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b&C}
                                                           a3:=peer[q] * a3 - (combosets[xn,yn] + combosets[xn2,yn3] {+ combosets[xn3,yn5]});

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;   
                                          
                              for R in ((comboset[yn2]   ) -(z1+z2)  ) do   {search for  digit in  A  thats left from Z1+z2}
                                                      if ((Digitcell[R]* combosets[xn,yn] )<> [] )

                                                       then
                                                        begin
                                          
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]) ); {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in (({combosets[xn3,yn5] + combosets[xn2,yn3] +} combosets[xn,yn]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b&C}
                                                           a3:=peer[q] * a3- (combosets[xn,yn] {+ combosets[xn2,yn3] + combosets[xn3,yn5]});

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;
                                          
                              for R in ((comboset[yn4]   ) -(z1+z2)  ) do   {search for  digit in  A  thats left from Z1+z2}
                                                      if ((Digitcell[R]* combosets[xn2,yn3] )<> [] )

                                                       then
                                                        begin
                                          
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]) ); {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in (({combosets[xn3,yn5] + combosets[xn,yn] +} combosets[xn2,yn3]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b&C}
                                                           a3:=peer[q] * a3- (combosets[xn2,yn3] {+ combosets[xn2,yn3] + combosets[xn3,yn5]});

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;
                              for R in ((comboset[yn6]   ) -(z1+z2)  ) do   {search for  digit in  A  thats left from Z1+z2}
                                                      if ((Digitcell[R]* combosets[xn3,yn5] )<> [] )

                                                       then
                                                        begin
                                          
                                                        active:=true;

                                                        a3:=(([0..80] * digitcell[R]) ); {valid eliminations must contain R and cannot be in the sets a&b}

                                                          for q in (({combosets[xn2,yn3] + combosets[xn,yn] +} combosets[xn3,yn5]) * digitcell[R] )  do { a combined peer search for R with in the sets, A&b&C}
                                                           a3:=peer[q] * a3- (combosets[xn3,yn5] {+ combosets[xn2,yn3] + combosets[xn,yn]});

                                                         if (a3 <> (([0..80] * digitcell[R]) )) and (a3 <> [])  {safty checks}
                                                           then
                                                           covered2[R]:=covered2[r] + a3;   {elimination trigger}

                                                         if (k= 0 ) and (a3<> [0..80]) and (a3 <> [])
                                                           then
                                                            begin
                                                            techwrite[u,r+9]:= techwrite[u,r+9] + a3;
                                                            techwrite[u,9]:=techwrite[u,9]+[R];
                                                           end;

                                                        end;
                                          
                     
                               end;
if (k= 0)
 and (techwrite[u,9] <> [])
 then
begin
techwrite[u,0]:=[3];
techwrite[u,1]:=[6];

techwrite[u,2]:=techwrite[u,2]+comboset[yn2];
techwrite[u,3]:=techwrite[u,3]+Combosets[xn,yn];

techwrite[u,4]:=techwrite[u,4]+comboset[yn4];
techwrite[u,5]:=techwrite[u,5]+combosets[xn2,yn3];

techwrite[u,6]:=techwrite[u,6]+comboset[yn6];
techwrite[u,7]:=techwrite[u,7]+combosets[xn3,yn5];

techwrite[u,8]:=techwrite[u,8]+ z1+z2;

end;


if u = 32767    {max array size error code safty exit}
 then
 begin
  if k = 0 then
     techdisplay(#25,u);

    setlength(techwrite,0,0);
    u:=0; setlength(techwrite,u+1,20)

 //exit;

end;

if (k=0) and (techwrite[u,9] <> []) then begin  u:=U+1; setlength(techwrite,u+1,20); end;


                 end;
                             
             end;
            end;
                  

if k = 0 then
     chaindisplay(#25,u);
end;{Aals 2RC rule}   

N^a ls N^rc rule: Show
Code: Select all

{N*almost locked set  N* RC rule } // work in progress

procedure NalsNRC(K:integer);  {mutual exclusion}
type
hold = array of integer;
Nuse = array of integer;
base = array of integer;
rcc = array of  array of nums;

RCDs = array of nums;
TRCC = array of nums;
usednum= array of nums;

used = array of numberset;
used2 = array of numberset;

cellused=array of numberset;

almostlockedset3= array of array of integer;
RCSTORE= array of array of nums;
var

xn,w,p,p2,n,n2,a,m,z,xn2,yn,yn3,yn2,yn4,xn3,yn5,yn6,xn4,q,r,u,b,b2,B3,max,size,f:integer;

h:hold;
nouse: nuse;
step: base;
rc:rcc;
RCD:RCDs;
TRC:TRCC;

als3: almostlockedset3;

store: RCSTORE;

A3:numberset;

z1:nums;
z2:nums;

lx1: rcbpeer;
lx2: rcbpeer;

use:used;
use2:used;

usenum : usednum;
celluse : cellused;

begin
alsfinder;
  //ahsfinder;
setlength(als3,high(als)+1);
setlength(store,high(als)+1);

for a:= high(als) downto 0 do    {startin array}
 begin
 w:=-1;

 for p:= high(als) downto 0 do    {iteration of peers}
   if (als[p,1]+1 = als[p,2] ) then
     if (popcnt(dword((comboset2[als[a,4]]*Comboset2[als[p,4]]) ) )   >=1 )   {set a & B must share >1 digits}
               and (combosets[als[a,0],als[a,3]]  - combosets[als[p,0],als[p,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als[p,0],als[p,3]] - combosets[als[a,0],als[a,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}

       then

         begin

       xn:=als[a,0];
       xn2:=als[p,0];

      yn:=als[a,3];
      yn3:=als[p,3];

      yn2:=als[a,4];
      yn4:= als[p,4];
      z1:=[];

               {restricted common chcek}
            for z in (comboset[yn4] * comboset[yn2]) do
               if ((Digitcell[z] * combosets[xn,yn])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn,yn] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                       then
                      begin
                                                    lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn,yn]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both a&b for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];



                                                         if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z1:=z1 + [z]; {saves the resticted commons}

                     end;
            


   if   ( ( popcnt(dword(z1)) >=1 ) )
        then
      begin
w:=w+1;
setlength(als3[a],w+1);
setlength(store[a],w+1);
als3[a,w]:=p;
store[a,w]:=z1;
end;

end;
end;

if k=1 then begin  u:=0; setlength(techwrite,u+1,0); end;

 for a:= high(als) downto 0 do    {startin array}
 if (high(als3[a]) +1 >= (als[a,2] - als[a,1]))
and (als[a,2] - als[a,1] >=1)
//and (comboset[als[a,4]] = [1,2,4])
 then
 begin
  w:=0;
  setlength(h,w+1);
  h[w]:=high(als3[a]);

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

         TRC[w]:= [];
      
       setlength(usenum,w+1);
       usenum[w]:=comboset[als[a,4]];
       setlength(celluse,w+1);
       celluse[w]:=combosets[als[a,0],als[a,3]];
      
       setlength(rcd,W+1);
       rcd[W]:=Comboset[als[a,4]];

setlength(use,(w+1));  {set the array size to w}
setlength(use2,(w+1));  {set the array size to w}
use[w]:=[0..80] - combosets[als[a,0],als[a,3]];
use2[w]:=[0..80];

 size:= (als[a,2] - als[a,1]);
 
  h[w]:= high(als3[a]);       {keeps track of what array is the next stop used for step W }

   repeat
    for p:= h[w] downto 0 do
     if  ((use[w] * combosets[als[als3[a,p],0],als[als3[a,p],3]]) <> [])    
          and (( store[a,p] - TRC[w] <>[])
         or (w=1) )
        // or (( w< size ) and (popcnt(dword(trc[w]))> size) and (store[a,p]-trc[w] = [])) )
         
         {  and ((comboset[als[als3[a,p],4]] = [2,4])
         
         or  (comboset[als[als3[a,p],4]] = [1,4])) }
         
        then   
        begin
         h[w]:=h[w]-1;
        inc(w);
         setlength(h,w+1);
           h[w]:=p-1;
          setlength(step,w+1);
         step[w]:=p;
       
       setlength(usenum,w+1);
       usenum[w]:=Comboset[als[als3[a,p],4]];
       setlength(celluse,w+1);
       celluse[w]:=combosets[als[als3[a,p],0],als[als3[a,p],3]];
             
       setlength(rcd,W+1);
       rcd[W]:=RCD[w-1] * Comboset[als[als3[a,p],4]];
      
        setlength(TRC,(w+1));   {set the array size to w}

         TRC[w]:= store[a,p]+TRC[w-1];
      
           setlength(use,(w+1));  {set the array size to w}
          setlength(use2,(w+1));  {set the array size to w}
           use[w]:= use[w-1] -  combosets[als[als3[a,p],0],als[als3[a,p],3]];
         use2[w]:= use2[w-1] -  combosets[als[als3[a,p],0],als[als3[a,p],3]];
         
{if (k=1)
 then
  begin
  f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
 
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[f];
   
   techwrite[u,(f+3-1)]:=trc[w];
   techwrite[u,(f+3)]:=z1;
   
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;

    u:=u+1;    
    setlength(techwrite,u+1);   
    writexy(2,60,'size :');
    write(w,' ',size);
  end;    }


//type 1: links = correct number
if ((w) = size)  and (popcnt(dword(TRC[w] )) >= size  ) //and (RCD[w] <> [])
then
begin
   
   
if k = 1
 then
 begin
 
 if u = 32765    {max array size error code safty exit}
 then
 begin
    chaindisplay(#22,u);
    setlength(techwrite,0,0);
    u:=0;
    setlength(techwrite,u+1,0)
        //exit;
end;
 
 f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
end;       
   a3:=[];   
   a3:= [0..80] - use[w];   
   
 
 z1:=[];
for q:= w downto 1 do    
   for b:= w downto 1 do
    begin
    if (popcnt(dword(store[a,step[b]]-z1)) =1)
          then
           Z1:=z1 + (store[a,step[b]]);
      
    if (popcnt(dword(store[a,step[b]]-rcd[w])) = 1 )
      then
       z1:= z1 + (store[a,step[b]] - (rcd[w]));
       
    end;

 
if  popcnt(dword(trc[w] -z1 )) = (size - popcnt(dword(z1)))
    then
        z1:=z1 + trc[w] ;
   

   
// eliminates a common digit thats no listed as a RC when RC = number of links}     
if popcnt(dword(TRC[w])) = size   
 then
   for b in RCD[w] -( trc[w])  do
     for q in digitcell[b] do
       if (peer[q] * (a3 * digitcell[b]) = (a3 * digitcell[b]) ) and (a3 * digitcell[b] <> [])      
        then
        begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;    
       
// eliminates a common "non" RC when there is more digits then links required       
 if popcnt(dword(TRC[w])) >= size   
        then
         for b in RCD[w] - z1  do
          for q in digitcell[b] do
           if( peer[q] * (a3 * digitcell[b]) = (a3 * digitcell[b]) ) and (a3 * digitcell[b] <> [])         
         
             then
           begin
           Active:=true;
               covered2[B]:=covered2[B] + [Q];
       if k = 1
          then
          begin
          techwrite[u,(b+f+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
         
        end;
       
        
// elimination code for locked sets        
if (popcnt(dword(TRC[w])) >= size*2   )
        then    
          begin   
          for r:= w downto 1 do   
               for b in usenum[r] - store[a,step[r]] do
                for q in (( digitcell[b]) - celluse[r] ) do
                 if ((peer[q] * digitcell[b] * celluse[r]) = digitcell[b] * celluse[r])
                        and (digitcell[b] * celluse[r] <> [] )
                             
                                then
                           begin
                                 
           Active:=true;
               covered2[B]:=covered2[B] + [Q];
       if k = 1
          then
          begin
          techwrite[u,(b+f+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
         
         end;
         
      for b in usenum[0] - trc[w] do
                for q in ((digitcell[b] ) - celluse[0] ) do
                 if ((peer[q] * digitcell[b] * celluse[0]) = digitcell[b] * celluse[0])
                        and (digitcell[b] * celluse[0] <> [] )
                             
                                then
                           begin
                                 
           Active:=true;
               covered2[B]:=covered2[B] + [Q];
       if k = 1
          then
          begin
          techwrite[u,(b+f+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;        
         end;
   
   for r:= w downto 1 do   
               for b in usenum[r] * store[a,step[r]] do
                for q in (([0..80] * digitcell[b] ) - (celluse[r]+celluse[0]) ) do
                 if ((peer[q] * digitcell[b] * (celluse[r]+celluse[0])) = (digitcell[b] * (celluse[r]+celluse[0])))
                        and (digitcell[b] * (celluse[r]+celluse[0]) <> [] )
                             
                                then
                           begin
                                 
           Active:=true;
               covered2[B]:=covered2[B] + [Q];
       if k = 1
          then
          begin
          techwrite[u,(b+f+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
         
         end;            
         
        end;
         


if (k=1) and (techwrite[u,(f+3)] <> [])
 then
  begin
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[w];
   
   techwrite[u,(f+3-1)]:=trc[w];
   techwrite[u,(f+3)]:=z1;
   
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;

    u:=u+1;    
    setlength(techwrite,u+1);
  end;

end;
// temp removed type 2 for the time being to focus on missing eliminations in type 1}
//type 2 eliminates  when there is  not enough links then required as it locks the first set to empty if they are all false
if (popcnt(dword(TRC[w] )) > 1+ size  ) and  (w = 1 +size) 
then
begin

if k = 1
 then
 begin
 f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
end;

a3:=[];
a3:= [0..80] - use2[w];
z1:=[];

for q:= w downto 1 do    
   for b:= w downto 1 do
    if popcnt(dword(store[a,step[b]]-z1)) =1
    then
      Z1:=z1 + (store[a,step[b]]);
      
if popcnt(dword(TRC[w])) = 1+size 
 then

   for b in RCD[w] - trc[w]  do    
     for q in [0..80] do
       if (peer[q] * (a3 * digitcell[b]) = (a3 * digitcell[b]) ) and (a3 * digitcell[b] <> [])
      and (q in digitcell[b])
        then
        begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;
      
 if popcnt(dword(TRC[w])) >= 1+ size 
        then
         for b in RCD[w] - z1  do    
          for q in [0..80] do
           if( peer[q] * (a3 * digitcell[b]) = (a3 * digitcell[b]) ) and (a3 * digitcell[b] <> [])
          and (q in digitcell[b])
         
             then
           begin
           Active:=true;
               covered2[B]:=covered2[B] + [Q];
       if k = 1
          then
          begin
          techwrite[u,(b+f+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;

if (k=1) and (techwrite[u,(f+3)] <> [])
 then
  begin
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[w];
   techwrite[u,(f+3-1)]:=trc[w];
   //techwrite[u,(f+3)]:=z1;
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;
 
    u:=u+1;
    setlength(techwrite,u+1);
  end;             
   
end; //type 2         
         


         break;
        end
      else
       h[w]:=h[w] -1;
   
   
   if ((h[w] < 0) and (w >0)) or (w = size+1)
      then
        begin   
dec(w);      //set the array size to w
setlength(h,w+1);
setlength(use,(w+1));
setlength(use2,(w+1));
setlength(TRC,(w+1));
setlength(rcd,W+1);

setlength(usenum,w+1);
setlength(celluse,w+1);

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

 end;
chaindisplay(#22,u);
end; {n*a-ls n-RC }
Last edited by StrmCkr on Wed Oct 19, 2022 12:19 am, edited 5 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Chains

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

x-chains/cycles
X- Chain {x-cycles}: Show
Code: Select all
{x-chain }
procedure xchain(K:integer);
type
xsets = array of array of numberset;
steps = array of array of numberset;
stepper = array of integer;
used2 = array of numberset;
hold = array of integer;
acts = array of array of integer;
acts2 = array of array of integer;
acts3 = array of array of integer;
var
h:hold;
xset: xsets;
step:steps;
phase:stepper;
use2: used2;
act: acts;
act2: acts2;
act3: acts3;
n,a,b,c,d,e,f,g,j,u,m,r,max:integer;
check: boolean;
output: text;
begin

links;

setlength(xset,0,0);
if k = 1 then begin u:=0; setlength(techwrite,u+1,0); end;

 b:=-1;
for n in [1..9] do
 for a in [1..5] do
    for c:=  low(linkset[n][a]) to high(linkset[n][a]) do
        begin
       b:=b+1;
       setlength(xset,b+1,10);
       xset[b]:=linkset[n,a,c];      
      end;
      
//finds the arrays that are the same data points
//finds arrays that use a bivavle as on
 max:= high(xset);
 setlength(act2,0,0);
 setlength(act2,max+1);
 {writexy(2,60,'max: ');
 write(high(linkset[1][5]));}
 
for b:= low(xset) to high(xset) do
begin
 g:=0;
  for e:= low(xset) to high(xset) do
   if e <> b then
   begin   
           {same set} {reverse twin }
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] =xset[e][3]) // first and last are the same
    and (xset[b][1] + xset[b][2] = xset[e][1] + xset[e][2])   // same cells but swapped position
   
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
//same "on cell" position 2 set 1 and set2 postion 2 are the same on values
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][2] * xset[e][2] <> []) // 2nd cell contains same "on cells"
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;

// bi local sets same digit  " on" cannot be "off" some where else
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][2] * xset[e][1] <> []) // on cell for same digit cant be off
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;      
         

//same "off cell" position 1 set 1 and set 2 postion 1 are the same on values
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][1] * xset[e][1] <> []) // 2nd cell contains same "on cells"
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;

{find bivavle cell twins}
if      (xset[b][0]+ xset[b][3] = xset[e][0] + xset[e][3])  //  digit set the same     
    and (xset[b][1] = xset[b][2])//uses 1 cell
   and (xset[e][1] = xset[e][2])//uses 1 cell
   
    and( xset[e][1] = xset[b][1]) // 1 cell in both sets
   and( xset[e][2] = xset[b][2])// 1 cell in both sets
      
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
      

// bivavle digit  is "on" postion linking  same digit sets cant reuse the ending cell.
  if (xset[b][1] = xset[b][2]) // first set uses 1 cell
    and (xset[b][3] = xset[e][0]) // 2nd set starting digit uses exchange digit
    and (xset[e][0] = xset[e][3]) // 2nd is a single digit
    and (xset[b][2] * xset[e][2] <> []) // cannot re use the "on" cell from a & b
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
// first set is a bi-local  2nd set is a bivavle
  if (xset[e][1] = xset[e][2]) // 2nd set uses 1 cell
    and (xset[b][3] = xset[e][0]) // 2nd set starting digit uses exchange digit
    and (xset[b][0] = xset[b][3]) // 1st is a single digit
    and (xset[b][1] * xset[e][1] <> []) // cannot re use the "off" cell from
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
 // first set is a 1 digit-  2nd set is a bivavle
  if (xset[e][1] = xset[e][2]) // 2nd set uses 1 cell
    and (xset[b][3] = xset[e][3]) // 2nd set starting digit uses exchange digit
    and (xset[b][0] = xset[b][3]) // 1st is a single digit
    and (xset[b][1] * xset[e][1] <> []) // cannot re use the "off" cell from
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
end;    
end;

assign(output,'C:\sudoku\twins.txt');
erase(output);
rewrite(output);
close(output);
 // sister tester print info to screen checks to see if the above works
{ gotoxy(2,60);
 write(max,' ');}
 For b:= low(xset) to high(xset) do 
 begin
 append(output);
 writeln(output);
 write(output,'set: ',B,' sister to:');
  for g:= low(act2[b]) to high(act2[b]) do 
    begin   
     write(output,act2[b][g],' ');
    end;
 close(output);   
   end;

// weak-link builder
   
 setlength(act,0,0);
 setlength(act,max+1); //stores the weak-link visible to C
 
for B:= low(xset) to high(xset) do
 begin
 g:=-1;
   For C:= low(xset) to high(xset) do
   if b <> c then
    begin
   
    check:=True;
      for e:= low(act2[b]) to high(act2[b]) do 
       if act2[b][e] = C
        then
          check:= false;         
    if check 
      then       
       begin   
      
       //same digit to same digit
       if    (xset[b][0]+xset[b][3] = xset[c][3]) // digit @ link is identical to first and last
        and (xset[c][3] = xset[c][0]) // 2nd set same digit.
        and (xset[b][5] * xset[c][4] <> []) // shares a sector
        and (xset[b][2] * xset[c][1] = []) // no overlapping cell   
          and (xset[b][9] * xset[c][1] = xset[c][1]) // all of c lands in the peer cells of b       
         then
           begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
           end;
      
         
   
         
         end; // end check
    end;// end c cycle
end; // end B cycle

assign(output,'C:\sudoku\Aic.txt');
erase(output);
rewrite(output);
close(output);
 
For b:= low(xset) to high(xset) do
 begin
 append(output);
 writeln(output);   
 //gotoxy(2,61+b);
 write(output,'set: ',B,' weak-linked to: ');
  for g:= low(act[b]) to high(act[b]) do 
    begin   
     write(output,act[b][g],' ');
    end;
    close(output);
end;

assign(output,'C:\sudoku\Chain.txt');
erase(output);
rewrite(output);
close(output);

//chain walk
 For A:= low(xset) to high(xset) do
  If high(act[A])>-1
    then
    begin
       setlength(act3,0,0);
        b:=0; 
       setlength(act3,b+1,max+1); //sets step storing
      
      //for e:= 0 to max do
       act3[b][0]:=-1; // sets the first "0" as -1 to allow code to see it as off
      
        act3[b][A]:=A;   // saves used nodes
         
         for e:= low(act2[a]) to high(act2[A]) DO
          ACT3[B][act2[a,e]]:=act2[a,e];       
      
      setlength(h,b+1); // sets first step {als links list to choose from}
     if High(act[a])>-1
       then   
       h[b]:=High(act[a]) //sets the link list node count
      else
      h[b]:= -1;
      
      setlength(phase,b+1); // sets the first node
         phase[b]:=A;
      
       // notes
         // act2 = twins
       // act = list of sets
       // act 3 = working list in the chain walk
 
{append(output);
writeln(output);
write(output,'start: ',A);
 write(output,'(',h[b],')');
 for e:= low(act3[b]) to high(act3[b]) DO
           write(output,act3[b][e]);}   
 
       while (h[b] > -1)  do
         begin         
           if (act[phase[b],h[b]] <> act3[b,act[phase[b],h[b]]])                        
                 then 
                   begin                                      
               
                     inc(b);
                setlength(act3,b+1,max+1); //sets step storing
                act3[b]:=act3[b-1]; // copies the previous step
                
                setlength(phase,b+1); // sets the  node
                     phase[b]:=act[phase[b-1],h[b-1]];
               
                act3[b][phase[b]]:=phase[b];   
                   
               {append(output);
               write(output,' - ',phase[b]);}
               
      if k = 1
        then 
           begin        
          F:=((b+1)*4);
         setlength(techwrite[u],0);
         setlength(techwrite[u],f+13);
         end;
               
      for e:= low(act2[phase[b]]) to high(act2[phase[b]]) DO
          ACT3[B][act2[phase[b],e]]:=act2[phase[b],e];    
       
        setlength(h,b+1); // sets first step {als links list to choose from}
 
 if High(act[phase[b]])>-1
         then
            h[b]:=High(act[phase[b]]) //sets the link list node count
        else
             h[b]:=-1;       
       
     // eliminations
   
    //start and end same digit & peers of each other
    if (xset[a][8] * xset[phase[b]][9] <> [])
    and (xset[a][0] = xset[phase[b]][3])
      then
        begin
       for n in (xset[a][0] * xset[phase[b]][3]) do
        if (xset[a,8] * xset[phase[b],9]) <> []
        then
         begin
            covered2[n]:=covered2[n] + (xset[a,8] * xset[phase[b],9]);
             active:= true;
            
            if k = 1
              then    
            techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[a,8] * xset[phase[b],9]);
             { append(output);
             write(output,'[=> eliminates:',n,' @ ');
                  for e in (xset[a,8] * xset[phase[b],9]) do               
                     write(output,e,' ');
                   write(output,']');}
          end;      
        end;    
   
   //  A) start and end diffrent digit   and visible to all copies of canddites used
   
    if (xset[phase[b]][3] * xset[a][6] = xset[phase[b]][3]) // is in the exchange cells
    and (xset[phase[b]][9] * xset[a][1] = xset[a][1])// sees all the digits
    and (xset[a][6] <> [0]) // is not a grouped digit !   
   and (xset[a][0] <> xset[phase[b]][3]) // cannot be linked
   and (xset[a][1] <> xset[phase[b]][2]) // cannot start and end same cells
       then
        begin
          for n in (xset[phase[b]][3]) do
         if (xset[a,1] * xset[phase[b],9]) <> []
         then
          begin
              covered2[n]:=covered2[n] + (xset[a,1] * xset[phase[b],9]);
             active:= true;
            if k = 1
             then               
             techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[a,1] * xset[phase[b],9]);
            {append(output);
            write(output,'[=> eliminates:',n,' @ ');
                  for e in (xset[a,1] * xset[phase[b],9]) do
                     write(output,e,' ');
                     write(output,']');   }
          end;      
        end;
       
   //  B) start and end diffrent digit   and visible to all copies of canddites used
    if (xset[A][0] * xset[phase[b]][7] = xset[a][0]) // is in the exchange cells
    and (xset[A][8] * xset[phase[b]][2] = xset[phase[b]][2])// sees all the digits
    and (xset[phase[b]][7] <> [0]) // is not a grouped digit !   
   and (xset[a][0] <> xset[phase[b]][3]) // cannot be linked
   and (xset[a][1] <> xset[phase[b]][2]) // cannot start and end same cells
   
       then
        begin
          for n in (xset[A][0]) do
          if (xset[phase[B],2] * xset[A,8]) <> []
           then
            begin
                covered2[n]:=covered2[n] + (xset[phase[B],2] * xset[A,8]);
                active:= true;
             
              if k  = 1
                then
                 techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[phase[B],2] * xset[A,8]);
               { append(output);
               write(output,'[=> eliminates:',n,' @ ');
                    for e in (xset[phase[B],2] * xset[A,8]) do
                     write(output,e,' ');
                     write(output,']');}
            end;    
        end;        
          
   //loop end is a bivavle and start has its ending digit 
      if ((xset[a][0] = xset[phase[b]][3])
          and (xset[phase[b]][1] = xset[phase[b]][2]) //is a bivavle
          and (xset[phase[b]][9] * xset[a][1] = xset[a][1])) // all of b  sees  As cells
       
   //loop start is a bivavle and end has its starting digit     
      or
        ((xset[a][0] = xset[phase[b]][3])
          and (xset[a][1] = xset[a][2]) //is a bivavle
          and (xset[a][8] * xset[phase[b]][2] = xset[phase[b]][2]))
       
//   start and end are same digit    
    or    
      ((xset[a][0] = xset[phase[b]][3])
      and (xset[a][8] * xset[phase[b]][2] = xset[phase[b]][2]))
      
          then
           begin               
             For G:= 0 to b do
             for e:= 0 to b do
               begin                  
                 // digits are the same 
                     for n in (xset[phase[G]][3]* xset[phase[e]][0]) do
                 if ((xset[phase[g]][9]*xset[phase[e]][8]) <> [])
                  then
                  begin
                   covered2[n]:= covered2[n] + (xset[phase[g]][9]*xset[phase[e]][8]);                  
                  active:= true;
                   if k  = 1
                       then
                      techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[phase[g]][9]*xset[phase[e]][8]);
                      { append(output);
                       write(output,'[=> eliminates:',n,' @ ');
                             for j in (xset[phase[g]][9] * xset[phase[e]][8]) do
                               write(output,j,' ');
                               write(output,']');}            
                  end;
                  
                  // digits swap in cell cell becomes locked to the exchange digits
                  //2nd and first
                  if   (xset[phase[g]][2] = xset[phase[e]][1])
                   and (xset[phase[g]][7] * xset[phase[e]][0] = xset[phase[e]][0])
                         and (xset[phase[e]][6] * xset[phase[g]][3] = xset[phase[g]][3])               
                  
                             then
                                begin
                                  for J in (xset[phase[g]][2]* xset[phase[e]][1]) do
                            if ((pm[j]-(xset[phase[g]][3] + xset[phase[e]][0])) <> [])
                            then
                             begin
                              covered[j]:=covered[j] + (pm[j]-(xset[phase[g]][3] + xset[phase[e]][0]));
                               active:=true;
                              //append(output);
                                    //write(output,'[=>',j,' eliminates: ');
                               if k = 1
                                then
                                  for n in pm[j] - (xset[phase[g]][3] + xset[phase[e]][0]) do
                                   techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
                                   // write(output,n,' ');
                                       // write(output,']');
                             end;
                           end;
                           
                  // digits swap in cell cell becomes locked to the exchange digits
                  // first and 2
                  if   (xset[phase[g]][1] = xset[phase[e]][2])
                   and (xset[phase[g]][6] * xset[phase[e]][3] = xset[phase[e]][3])
                         and (xset[phase[e]][7] * xset[phase[g]][0] = xset[phase[g]][0])               
                  
                             then
                                begin
                                  for J in (xset[phase[g]][1]* xset[phase[e]][2]) do
                            if ((pm[j]-(xset[phase[g]][0] + xset[phase[e]][3])) <> [])
                            then
                             begin
                              covered[j]:=covered[j] + (pm[j]-(xset[phase[g]][0] + xset[phase[e]][3]));
                               active:=true;
                              //append(output);
                                    //write(output,'[=>',j,' eliminates: ');
                               if k = 1
                                then
                                  for n in pm[j] - (xset[phase[g]][0] + xset[phase[e]][3]) do
                                   techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
                                   // write(output,n,' ');
                                       // write(output,']');
                             end;     
                           end;                                                         
               end;   
                                  
            end; // loop elimination code.
            
// loop end and start land on same cell. <canabalistic>    
   if    
    (xset[a][1] = xset[phase[b]][2]) // first and last cell overlap
    and (xset[a][0] = xset[phase[b]][3]) // first and last digit is the same
    and (xset[phase[b]][7] <> [0]) // exchange is on
    and (xset[a][6] <> [0]) // exchange is on
        then
begin    
   
        for j in xset[a][1] do
          begin
         active:=true;
          covered[j]:=covered[j] + (pm[j] - xset[a][0]);
         
          if k = 1
            then             
            for n in (pm[j] - (xset[a][0])) do
               techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
               
            for n in xset[a][0] do
                begin
                  covered2[n]:=covered2[n] + (xset[a][8]);
              active:= true;
             
           if k = 1
            then       
             techwrite[u][n+f+3]:=techwrite[u][n+f+3] + (xset[a][8]);
            
               end
          end;        
    end;
   
//chain display saving trigger
  if k = 1
            then    
if ((techwrite[u][1+f+3] + techwrite[u][2+f+3] + techwrite[u][3+f+3]
 +  techwrite[u][4+f+3] + techwrite[u][5+f+3] + techwrite[u][6+f+3]
 +  techwrite[u][7+f+3] + techwrite[u][8+f+3] + techwrite[u][9+f+3] )<> [] )
 
  then
    begin
    
    techwrite[u,0]:=[4];
    techwrite[u,1]:=[b];
   
for e:= 0 to b do
 begin
  techwrite[u,(e*4)+2]:=xset[phase[e],0];
  techwrite[u,(e*4)+3]:=xset[phase[e],1];
  techwrite[u,(e*4)+4]:=xset[phase[e],2];
  techwrite[u,(e*4)+5]:=xset[phase[e],3];    
end; 
 
if  u = 32767 
 then
   begin
  // chaindisplay(#26,u);   
   setlength(techwrite,0,0);   
   u:=0;   
 end;
 
 u:=u+1;   
    setlength(techwrite,u+1);
    setlength(techwrite[u],f+15);
   
 end; //saving chain display     
   
            
                 end
             else
              begin
                    dec(h[b]);   
            
             repeat
                   if (h[b] < 0) and (b > 0)
                    then
                     begin    
               
               { append(output);
                writeln(output);
                write(output,'back track 1');
                writeln(output);
                write(output,'start: ');}               
                       dec(b);
                  {for g:= 0 to b do
                     begin
                    write(output,phase[g]);
                    if g <> b then write(output,' - ');
                          end;    }               
                 setlength(act3,b+1,max+1);
                 setlength(h,b+1);
                 setlength(phase,b+1);
                      dec(h[b]);
                 { if (b =0) and (h[b] <= -1) then
                    write(output,' Terminated');}
                     end;   
            until( h[b]>=0) or (b <=0)      
                end;
            
   // back tracking if the while h[b] > -1 condition triggers          
      repeat
                   if (h[b] < 0) and (b > 0)
                    then
                     begin
               
                // eliminations
                  
               { append(output);
                writeln(output);
                write(output,'back track 1');
                writeln(output);
                write(output,'start: ');   }            
                       dec(b);
                 { for g:= 0 to b do
                     begin
                    write(output,phase[g]);
                    if g <> b then write(output,' - ');
                          end; }                  
                 setlength(act3,b+1,max+1);
                 setlength(h,b+1);
                 setlength(phase,b+1);
                      dec(h[b]);
                 { if (b =0) and (h[b] <= -1) then
                    write(output,' Terminated');}
                     end;   
            until( h[b]>=0) or (b <=0)      
       end;
 { close(output);}
   
     end; // chain walk
  if k = 1 then chaindisplay(#24,u);   
end; {x-chain}

XY-Chain: Show
Code: Select all
{XY chain}
procedure XYchain(K:integer);
type
xsets = array of array of numberset;
steps = array of array of numberset;
stepper = array of integer;
used2 = array of numberset;
hold = array of integer;
acts = array of array of integer;
acts2 = array of array of integer;
acts3 = array of array of integer;
var
h:hold;
xset: xsets;
step:steps;
phase:stepper;
use2: used2;
act: acts;
act2: acts2;
act3: acts3;
n,a,b,c,d,e,f,g,j,u,m,r,max:integer;
check: boolean;
output: text;
begin

links;

setlength(xset,0,0);
if k = 1 then begin u:=0; setlength(techwrite,u+1,0); end;

 b:=-1;
for n in [1..9] do
 for a in [0..0] do
    for c:=  low(linkset[n][a]) to high(linkset[n][a]) do
        begin
       b:=b+1;
       setlength(xset,b+1,10);
       xset[b]:=linkset[n,a,c];      
      end;
      
//finds the arrays that are the same data points
//finds arrays that use a bivavle as on
 max:= high(xset);
 setlength(act2,0,0);
 setlength(act2,max+1);
 {writexy(2,60,'max: ');
 write(high(linkset[1][5]));}
 
for b:= low(xset) to high(xset) do
begin
 g:=0;
  for e:= low(xset) to high(xset) do
   if e <> b then
   begin   
           {same set} {reverse twin }
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] =xset[e][3]) // first and last are the same
    and (xset[b][1] + xset[b][2] = xset[e][1] + xset[e][2])   // same cells but swapped position
   
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
//same "on cell" position 2 set 1 and set2 postion 2 are the same on values
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][2] * xset[e][2] <> []) // 2nd cell contains same "on cells"
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;

//same "off cell" position 1 set 1 and set 2 postion 1 are the same on values
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][1] * xset[e][1] <> []) // 2nd cell contains same "on cells"
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;

{find bivavle cell twins}
if      (xset[b][0]+ xset[b][3] = xset[e][0] + xset[e][3])  //  digit set the same     
    and (xset[b][1] = xset[b][2])//uses 1 cell
   and (xset[e][1] = xset[e][2])//uses 1 cell
   
    and( xset[e][1] = xset[b][1]) // 1 cell in both sets
   and( xset[e][2] = xset[b][2])// 1 cell in both sets
      
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
      

// bivavle digit  is "on" postion linking  same digit sets cant reuse the ending cell.
  if (xset[b][1] = xset[b][2]) // first set uses 1 cell
    and (xset[b][3] = xset[e][0]) // 2nd set starting digit uses exchange digit
    and (xset[e][0] = xset[e][3]) // 2nd is a single digit
    and (xset[b][2] * xset[e][2] <> []) // cannot re use the "on" cell from a & b
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
// first set is a bi-local  2nd set is a bivavle
  if (xset[e][1] = xset[e][2]) // 2nd set uses 1 cell
    and (xset[b][3] = xset[e][0]) // 2nd set starting digit uses exchange digit
    and (xset[b][0] = xset[b][3]) // 1st is a single digit
    and (xset[b][1] * xset[e][1] <> []) // cannot re use the "off" cell from
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
 
end;    
end;

assign(output,'C:\sudoku\twins.txt');
erase(output);
rewrite(output);
close(output);
 // sister tester print info to screen checks to see if the above works
{ gotoxy(2,60);
 write(max,' ');}
 For b:= low(xset) to high(xset) do 
 begin
 append(output);
 writeln(output);
 write(output,'set: ',B,' sister to:');
  for g:= low(act2[b]) to high(act2[b]) do 
    begin   
     write(output,act2[b][g],' ');
    end;
 close(output);   
   end;

// weak-link builder
   
 setlength(act,0,0);
 setlength(act,max+1); //stores the weak-link visible to C
 
for B:= low(xset) to high(xset) do
 begin
 g:=-1;
   For C:= low(xset) to high(xset) do
   if b <> c then
    begin
   
    check:=True;
      for e:= low(act2[b]) to high(act2[b]) do 
       if act2[b][e] = C
        then
          check:= false;         
    if check 
      then       
       begin   
      
       //same digit to same digit
       if    (xset[b][0]+xset[b][3] = xset[c][3]) // digit @ link is identical to first and last
        and (xset[c][3] = xset[c][0]) // 2nd set same digit.
        and (xset[b][5] * xset[c][4] <> []) // shares a sector
        and (xset[b][2] * xset[c][1] = []) // no overlapping cell   
          and (xset[b][9] * xset[c][1] = xset[c][1]) // all of c lands in the peer cells of b       
         then
           begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
           end;
         
       //digit exchange @ strong link
       if     (xset[b][3] <> xset[c][0]) // last and next digit are the diffrent
         and  (xset[b][2] = xset[c][1]) // last cell and next cell are the same
         and  (xset[b][7] * xset[c][0] = xset[c][0]) // overlap exchange is true
       and  (xset[c][6] * xset[b][3] = xset[b][3]) // overlap exchange is true
         and  (xset[b][5] * xset[c][4] <> []) // shares a sector
         and  (xset[c][1] * xset[c][2] = []) // cant be a bivavle       
        then
            begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
          end;
         
       //digit exchange @ bivavle
       if     (xset[b][3] = xset[c][0]) // last and next digit are the same
        and  (xset[c][0] <> xset[c][3]) // last and next digit in new link are diffrent     
         and  (xset[b][2] * xset[c][1] = []) // last cell and next cell arent the same           
         and  (xset[b][5] * xset[c][4] <> []) // shares a sector
       and (xset[b][9] * xset[c][1] = xset[c][1]) // all of c lands in the peer cells of b
         and  (xset[c][1] * xset[c][2] = xset[c][2]) // a bivavle       
        then
            begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
          end;
         
             //same digit to same digit
       if    (xset[b][0] <> xset[b][3]) // start is a bivavle
        and (xset[c][0] = xset[c][3]) // 2nd set same digit.
          and (xset[c][0] = xset[b][3]) // sees the same exchange        
        and (xset[b][5] * xset[c][4] <> []) // shares a sector
        and (xset[b][2] * xset[c][1] = []) // no overlapping cell   
          and (xset[b][9] * xset[c][1] = xset[c][1]) // all of c lands in the peer cells of b       
         then
           begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
           end;   
         
         end; // end check
    end;// end c cycle
end; // end B cycle

assign(output,'C:\sudoku\Aic.txt');
erase(output);
rewrite(output);
close(output);
 
For b:= low(xset) to high(xset) do
 begin
 append(output);
 writeln(output);   
 //gotoxy(2,61+b);
 write(output,'set: ',B,' weak-linked to: ');
  for g:= low(act[b]) to high(act[b]) do 
    begin   
     write(output,act[b][g],' ');
    end;
    close(output);
end;

assign(output,'C:\sudoku\Chain.txt');
erase(output);
rewrite(output);
close(output);

//chain walk
 For A:= low(xset) to high(xset) do
  If high(act[A])>-1
    then
    begin
       setlength(act3,0,0);
        b:=0; 
       setlength(act3,b+1,max+1); //sets step storing
      
      //for e:= 0 to max do
       act3[b][0]:=-1; // sets the first "0" as -1 to allow code to see it as off
      
        act3[b][A]:=A;   // saves used nodes
         
         for e:= low(act2[a]) to high(act2[A]) DO
          ACT3[B][act2[a,e]]:=act2[a,e];       
      
      setlength(h,b+1); // sets first step {als links list to choose from}
     if High(act[a])>-1
       then   
       h[b]:=High(act[a]) //sets the link list node count
      else
      h[b]:= -1;
      
      setlength(phase,b+1); // sets the first node
         phase[b]:=A;
      
       // notes
         // act2 = twins
       // act = list of sets
       // act 3 = working list in the chain walk
 
{append(output);
writeln(output);
write(output,'start: ',A);
 write(output,'(',h[b],')');
 for e:= low(act3[b]) to high(act3[b]) DO
           write(output,act3[b][e]);}   
 
       while (h[b] > -1)  do
         begin         
           if (act[phase[b],h[b]] <> act3[b,act[phase[b],h[b]]])                        
                 then 
                   begin                                      
               
                     inc(b);
                setlength(act3,b+1,max+1); //sets step storing
                act3[b]:=act3[b-1]; // copies the previous step
                
                setlength(phase,b+1); // sets the  node
                     phase[b]:=act[phase[b-1],h[b-1]];
               
                act3[b][phase[b]]:=phase[b];   
                   
               {append(output);
               write(output,' - ',phase[b]);}
               
      if k = 1
        then 
           begin        
          F:=((b+1)*4);
         setlength(techwrite[u],0);
         setlength(techwrite[u],f+15);
         end;
               
      for e:= low(act2[phase[b]]) to high(act2[phase[b]]) DO
          ACT3[B][act2[phase[b],e]]:=act2[phase[b],e];    
       
        setlength(h,b+1); // sets first step {als links list to choose from}
 
 if High(act[phase[b]])>-1
         then
            h[b]:=High(act[phase[b]]) //sets the link list node count
        else
             h[b]:=-1;       
       
     // eliminations
   
    //start and end same digit & peers of each other
    if (xset[a][8] * xset[phase[b]][9] <> [])
    and (xset[a][0] = xset[phase[b]][3])
      then
        begin
       for n in (xset[a][0] * xset[phase[b]][3]) do
        if (xset[a,8] * xset[phase[b],9]) <> []
        then
         begin
            covered2[n]:=covered2[n] + (xset[a,8] * xset[phase[b],9]);
             active:= true;
            
            if k = 1
              then    
            techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[a,8] * xset[phase[b],9]);
             { append(output);
             write(output,'[=> eliminates:',n,' @ ');
                  for e in (xset[a,8] * xset[phase[b],9]) do               
                     write(output,e,' ');
                   write(output,']');}
          end;      
        end;    
   
   //  A) start and end diffrent digit   and visible to all copies of canddites used
   
    if (xset[phase[b]][3] * xset[a][6] = xset[phase[b]][3]) // is in the exchange cells
    and (xset[phase[b]][9] * xset[a][1] = xset[a][1])// sees all the digits
    and (xset[a][6] <> [0]) // is not a grouped digit !
   // and (xset[a][0] = xset[a][3])  { single digit}
   // and (xset[phase[b]][3] = xset[phase[b]][0]) {single digit}
   and (xset[a][0] <> xset[phase[b]][3]) // cannot be linked
   and (xset[a][1] <> xset[phase[b]][2]) // cannot start and end same cells
       then
        begin
          for n in (xset[phase[b]][3]) do
         if (xset[a,1] * xset[phase[b],9]) <> []
         then
          begin
              covered2[n]:=covered2[n] + (xset[a,1] * xset[phase[b],9]);
             active:= true;
            if k = 1
             then               
             techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[a,1] * xset[phase[b],9]);
            {append(output);
            write(output,'[=> eliminates:',n,' @ ');
                  for e in (xset[a,1] * xset[phase[b],9]) do
                     write(output,e,' ');
                     write(output,']');   }
          end;      
        end;
       
   //  B) start and end diffrent digit   and visible to all copies of canddites used
    if (xset[A][0] * xset[phase[b]][7] = xset[a][0]) // is in the exchange cells
    and (xset[A][8] * xset[phase[b]][2] = xset[phase[b]][2])// sees all the digits
    and (xset[phase[b]][7] <> [0]) // is not a grouped digit !
   // and (xset[a][0] = xset[a][3])  { single digit}
    //and (xset[phase[b]][3] = xset[phase[b]][0]) {single digit}
   and (xset[a][0] <> xset[phase[b]][3]) // cannot be linked
   and (xset[a][1] <> xset[phase[b]][2]) // cannot start and end same cells
   
       then
        begin
          for n in (xset[A][0]) do
          if (xset[phase[B],2] * xset[A,8]) <> []
           then
            begin
                covered2[n]:=covered2[n] + (xset[phase[B],2] * xset[A,8]);
                active:= true;
             
              if k  = 1
                then
                 techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[phase[B],2] * xset[A,8]);
               { append(output);
               write(output,'[=> eliminates:',n,' @ ');
                    for e in (xset[phase[B],2] * xset[A,8]) do
                     write(output,e,' ');
                     write(output,']');}
            end;    
        end;        
          
   //loop end is a bivavle and start has its ending digit 
      if ((xset[a][0] = xset[phase[b]][3])
          and (xset[phase[b]][1] = xset[phase[b]][2]) //is a bivavle
          and (xset[phase[b]][9] * xset[a][1] = xset[a][1])) // all of b  sees  As cells
       
   //loop start is a bivavle and end has its starting digit     
      or
        ((xset[a][0] = xset[phase[b]][3])
          and (xset[a][1] = xset[a][2]) //is a bivavle
          and (xset[a][8] * xset[phase[b]][2] = xset[phase[b]][2]))
       
//   start and end are same digit    
    or    
      ((xset[a][0] = xset[phase[b]][3])
      and (xset[a][8] * xset[phase[b]][2] = xset[phase[b]][2]))
      
          then
           begin               
             For G:= 0 to b-1 do
             for e:= g+1 to b do
               begin
               //e:= g+1; 
                 // digits are the same 
                     for n in (xset[phase[G]][3]* xset[phase[e]][0]) do
                 if ((xset[phase[g]][9]*xset[phase[e]][8]) <> [])
                  then
                  begin
                   covered2[n]:= covered2[n] + (xset[phase[g]][9]*xset[phase[e]][8]);                  
                  active:= true;
                   if k  = 1
                       then
                      techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[phase[g]][9]*xset[phase[e]][8]);
                      { append(output);
                       write(output,'[=> eliminates:',n,' @ ');
                             for j in (xset[phase[g]][9] * xset[phase[e]][8]) do
                               write(output,j,' ');
                               write(output,']');}            
                  end;
                  
                  // digits swap in cell cell becomes locked to the exchange digits
                  //2nd and first
                  if   (xset[phase[g]][2] = xset[phase[e]][1])
                   and (xset[phase[g]][7] * xset[phase[e]][0] = xset[phase[e]][0])
                         and (xset[phase[e]][6] * xset[phase[g]][3] = xset[phase[g]][3])               
                  
                             then
                                begin
                                  for J in (xset[phase[g]][2]* xset[phase[e]][1]) do
                            if ((pm[j]-(xset[phase[g]][3] + xset[phase[e]][0])) <> [])
                            then
                             begin
                              covered[j]:=covered[j] + (pm[j]-(xset[phase[g]][3] + xset[phase[e]][0]));
                               active:=true;
                              //append(output);
                                    //write(output,'[=>',j,' eliminates: ');
                               if k = 1
                                then
                                  for n in pm[j] - (xset[phase[g]][3] + xset[phase[e]][0]) do
                                   techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
                                   // write(output,n,' ');
                                       // write(output,']');
                             end;
                           end;
                           
                  // digits swap in cell cell becomes locked to the exchange digits
                  // first and 2
                  if   (xset[phase[g]][1] = xset[phase[e]][2])
                   and (xset[phase[g]][6] * xset[phase[e]][3] = xset[phase[e]][3])
                         and (xset[phase[e]][7] * xset[phase[g]][0] = xset[phase[g]][0])               
                  
                             then
                                begin
                                  for J in (xset[phase[g]][1]* xset[phase[e]][2]) do
                            if ((pm[j]-(xset[phase[g]][0] + xset[phase[e]][3])) <> [])
                            then
                             begin
                              covered[j]:=covered[j] + (pm[j]-(xset[phase[g]][0] + xset[phase[e]][3]));
                               active:=true;
                              //append(output);
                                    //write(output,'[=>',j,' eliminates: ');
                               if k = 1
                                then
                                  for n in pm[j] - (xset[phase[g]][0] + xset[phase[e]][3]) do
                                   techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
                                   // write(output,n,' ');
                                       // write(output,']');
                             end;     
                           end;                                                         
               end;   
                                  
            end; // loop elimination code.
            
// loop end and start land on same cell. <canabalistic>    
   if    
    (xset[a][1] = xset[phase[b]][2]) // first and last cell overlap
    and (xset[a][0] = xset[phase[b]][3]) // first and last digit is the same
    and (xset[phase[b]][7] <> [0]) // exchange is on
    and (xset[a][6] <> [0]) // exchange is on
        then
begin    
   
        for j in xset[a][1] do
          begin
         active:=true;
          covered[j]:=covered[j] + (pm[j] - xset[a][0]);
         
          if k = 1
            then             
            for n in (pm[j] - (xset[a][0])) do
               techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
               
            for n in xset[a][0] do
                begin
                  covered2[n]:=covered2[n] + (xset[a][8]);
              active:= true;
             
           if k = 1
            then       
             techwrite[u][n+f+3]:=techwrite[u][n+f+3] + (xset[a][8]);
            
               end
          end;        
    end;
   
//chain display saving trigger     
if ((techwrite[u][1+f+3] + techwrite[u][2+f+3] + techwrite[u][3+f+3]
 +  techwrite[u][4+f+3] + techwrite[u][5+f+3] + techwrite[u][6+f+3]
 +  techwrite[u][7+f+3] + techwrite[u][8+f+3] + techwrite[u][9+f+3] )<> [] )
 
  then
    begin
    
    techwrite[u,0]:=[4];
    techwrite[u,1]:=[b];
   
for e:= 0 to b do
 begin
  techwrite[u,(e*4)+2]:=xset[phase[e],0];
  techwrite[u,(e*4)+3]:=xset[phase[e],1];
  techwrite[u,(e*4)+4]:=xset[phase[e],2];
  techwrite[u,(e*4)+5]:=xset[phase[e],3];    
end; 
 
if  u = 32767 
 then
   begin
   //chaindisplay(#26,u);   
   setlength(techwrite,0,0);   
   u:=0;   
 end;
 
 u:=u+1;   
    setlength(techwrite,u+1);
    setlength(techwrite[u],f+15);
   
 end; //saving chain display     
   
            
                 end
             else
              begin
                    dec(h[b]);   
            
             repeat
                   if (h[b] < 0) and (b > 0)
                    then
                     begin    
               
               { append(output);
                writeln(output);
                write(output,'back track 1');
                writeln(output);
                write(output,'start: ');}               
                       dec(b);
                  {for g:= 0 to b do
                     begin
                    write(output,phase[g]);
                    if g <> b then write(output,' - ');
                          end;    }               
                 setlength(act3,b+1,max+1);
                 setlength(h,b+1);
                 setlength(phase,b+1);
                      dec(h[b]);
                 { if (b =0) and (h[b] <= -1) then
                    write(output,' Terminated');}
                     end;   
            until( h[b]>=0) or (b <=0)      
                end;
            
   // back tracking if the while h[b] > -1 condition triggers          
      repeat
                   if (h[b] < 0) and (b > 0)
                    then
                     begin
               
                // eliminations
                  
               { append(output);
                writeln(output);
                write(output,'back track 1');
                writeln(output);
                write(output,'start: ');   }            
                       dec(b);
                 { for g:= 0 to b do
                     begin
                    write(output,phase[g]);
                    if g <> b then write(output,' - ');
                          end; }                  
                 setlength(act3,b+1,max+1);
                 setlength(h,b+1);
                 setlength(phase,b+1);
                      dec(h[b]);
                 { if (b =0) and (h[b] <= -1) then
                    write(output,' Terminated');}
                     end;   
            until( h[b]>=0) or (b <=0)      
       end;
 { close(output);}
   
     end; // chain walk
   if k = 1 then chaindisplay(#120,u);
end; {xy chain}

Aic
A.I.C: Show
Code: Select all
{A.I.C }
procedure AIC(K:integer);
type
xsets = array of array of numberset;
steps = array of array of numberset;
stepper = array of integer;
used2 = array of numberset;
hold = array of integer;
acts = array of array of integer;
acts2 = array of array of integer;
acts3 = array of array of integer;
acts4 = array of  integer;
var
h:hold;
xset: xsets;
step:steps;
phase:stepper;
use2: used2;
act: acts;
act2: acts2;
act3: acts3;
act4:acts4;

n,a,b,c,d,e,f,g,j,u,m,r,max:integer;
check: boolean;
output: text;
begin
{alsfinder;}
links;

setlength(xset,0,0);
if k = 1 then begin u:=0; setlength(techwrite,0,0); end;

 b:=-1;
for n in [1..9] do
 for a in [0..5] do
    for c:=  low(linkset[n][a]) to high(linkset[n][a]) do
        begin
       b:=b+1;
       setlength(xset,b+1,10);
       xset[b]:=linkset[n,a,c];      
      end;
      
//finds the arrays that are the same data points
//finds arrays that use a bivavle as on
 max:= high(xset);
 setlength(act2,0,0);
 setlength(act2,max+1);
 {writexy(2,60,'max: ');
 write(high(linkset[1][5]));}
 
for b:= low(xset) to high(xset) do
begin
 g:=0;
  for e:= low(xset) to high(xset) do
   if e <> b then
   begin   
           {same set} {reverse twin }
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] =xset[e][3]) // first and last are the same
    and (xset[b][1] + xset[b][2] = xset[e][1] + xset[e][2])   // same cells but swapped position
   
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
//same "on cell" position 2 set 1 and set2 postion 2 are the same on values
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][2] * xset[e][2] <> []) // 2nd cell contains same "on cells"
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;

// bi local sets same digit  " on" cannot be "off" some where else
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][2] * xset[e][1] <> []) // on cell for same digit cant be off
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;      
         

//same "off cell" position 1 set 1 and set 2 postion 1 are the same on values
if      (xset[b][0] = xset[e][0])  //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3]) // first and last are the same digit
   and (xset[e][0] = xset[e][3]) // first and last are the same
    and (xset[b][1] * xset[e][1] <> []) // 2nd cell contains same "on cells"
           then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;

{find bivavle cell twins}
if      (xset[b][0]+ xset[b][3] = xset[e][0] + xset[e][3])  //  digit set the same     
    and (xset[b][1] = xset[b][2])//uses 1 cell
   and (xset[e][1] = xset[e][2])//uses 1 cell
   
    and( xset[e][1] = xset[b][1]) // 1 cell in both sets
   and( xset[e][2] = xset[b][2])// 1 cell in both sets
      
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
      

// bivavle digit  is "on" postion linking  same digit sets cant reuse the ending cell.
  if (xset[b][1] = xset[b][2]) // first set uses 1 cell
    and (xset[b][3] = xset[e][0]) // 2nd set starting digit uses exchange digit
    and (xset[e][0] = xset[e][3]) // 2nd is a single digit
    and (xset[b][2] * xset[e][2] <> []) // cannot re use the "on" cell from a & b
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
// first set is a bi-local  2nd set is a bivavle
  if (xset[e][1] = xset[e][2]) // 2nd set uses 1 cell
    and (xset[b][3] = xset[e][0]) // 2nd set starting digit uses exchange digit
    and (xset[b][0] = xset[b][3]) // 1st is a single digit
    and (xset[b][1] * xset[e][1] <> []) // cannot re use the "off" cell from
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
 // first set is a 1 digit-  2nd set is a bivavle
  if (xset[e][1] = xset[e][2]) // 2nd set uses 1 cell
    and (xset[b][3] = xset[e][3]) // 2nd set starting digit uses exchange digit
    and (xset[b][0] = xset[b][3]) // 1st is a single digit
    and (xset[b][1] * xset[e][1] <> []) // cannot re use the "off" cell from
    then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
end;    
end;

{assign(output,'C:\sudoku\twins.txt');
erase(output);
rewrite(output);
close(output);
 // sister tester print info to screen checks to see if the above works
 gotoxy(2,60);
 write(max,' ');
 For b:= low(xset) to high(xset) do 
 begin
 append(output);
 writeln(output);
 write(output,'set: ',B,' sister to:');
  for g:= low(act2[b]) to high(act2[b]) do 
    begin   
     write(output,act2[b][g],' ');
    end;
 close(output);   
   end;}

// weak-link builder
   
 setlength(act,0,0);
 setlength(act,max+1); //stores the weak-link visible to C
 
for B:= low(xset) to high(xset) do
 begin
 g:=-1;
   For C:= low(xset) to high(xset) do
   if b <> c then
    begin
   
    check:=True;
      for e:= low(act2[b]) to high(act2[b]) do 
       if act2[b][e] = C
        then
          check:= false;         
    if check 
      then       
       begin   
      
       //same digit to same digit
       if    (xset[b][0]+xset[b][3] = xset[c][3]) // digit @ link is identical to first and last
        and (xset[c][3] = xset[c][0]) // 2nd set same digit.
        and (xset[b][5] * xset[c][4] <> []) // shares a sector
        and (xset[b][2] * xset[c][1] = []) // no overlapping cell   
          and (xset[b][9] * xset[c][1] = xset[c][1]) // all of c lands in the peer cells of b       
         then
           begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
           end;
         
       //digit exchange @ strong link
       if     (xset[b][3] <> xset[c][0]) // last and next digit are the diffrent
         and  (xset[b][2] = xset[c][1]) // last cell and next cell are the same
         and  (xset[b][7] * xset[c][0] = xset[c][0]) // overlap exchange is true
       and  (xset[c][6] * xset[b][3] = xset[b][3]) // overlap exchange is true
         and  (xset[b][5] * xset[c][4] <> []) // shares a sector
         and  (xset[c][1] * xset[c][2] = []) // cant be a bivavle       
        then
            begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
          end;
         
       //digit exchange @ bivavle
       if     (xset[b][3] = xset[c][0]) // last and next digit are the same
        and  (xset[c][0] <> xset[c][3]) // last and next digit in new link are diffrent     
         and  (xset[b][2] * xset[c][1] = []) // last cell and next cell arent the same           
         and  (xset[b][5] * xset[c][4] <> []) // shares a sector
       and (xset[b][9] * xset[c][1] = xset[c][1]) // all of c lands in the peer cells of b
         and  (xset[c][1] * xset[c][2] = xset[c][2]) // a bivavle       
        then
            begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
          end;
         
             //same digit to same digit
       if    (xset[b][0] <> xset[b][3]) // start is a bivavle
        and (xset[c][0] = xset[c][3]) // 2nd set same digit.
          and (xset[c][0] = xset[b][3]) // sees the same exchange        
        and (xset[b][5] * xset[c][4] <> []) // shares a sector
        and (xset[b][2] * xset[c][1] = []) // no overlapping cell   
          and (xset[b][9] * xset[c][1] = xset[c][1]) // all of c lands in the peer cells of b       
         then
           begin
            g:=g+1;
            setlength(act[b],g+1);
            act[b][g]:= C;
           end;   
         
         end; // end check
    end;// end c cycle
end; // end B cycle
{
assign(output,'C:\sudoku\Aic.txt');
erase(output);
rewrite(output);
close(output);
 
For b:= low(xset) to high(xset) do
 begin
 append(output);
 writeln(output);   
 //gotoxy(2,61+b);
 write(output,'set: ',B,' weak-linked to: ');
  for g:= low(act[b]) to high(act[b]) do 
    begin   
     write(output,act[b][g],' ');
    end;
    close(output);
end;}
{
assign(output,'C:\sudoku\Chain.txt');
erase(output);
rewrite(output);
close(output);}

//chain walk
{setlength(act4,0);
setlength(act4,max+1);
act4[0]:=-1; }

 For A:= low(xset) to high(xset) do
  If (high(act[A])>-1) {and (act4[a] <> a)}
    then
    begin
       setlength(act3,0,0);
        b:=0; 
       setlength(act3,b+1,max+1); //sets step storing
      
      //for e:= 0 to max do
       act3[b][0]:=-1; // sets the first "0" as -1 to allow code to see it as off
      
        act3[b][A]:=A;   // saves used nodes
         
         for e:= low(act2[a]) to high(act2[A]) DO
          ACT3[B][act2[a,e]]:=act2[a,e];       
      
      setlength(h,b+1); // sets first step {als links list to choose from}
     if High(act[a])>-1
       then   
       h[b]:=High(act[a]) //sets the link list node count
      else
      h[b]:= -1;
      
      setlength(phase,b+1); // sets the first node
         phase[b]:=A;
       
       // notes
         // act2 = twins
       // act = list of sets
       // act 3 = working list in the chain walk
 
{append(output);
writeln(output);
write(output,'start: ',A);
 write(output,'(',h[b],')');
 for e:= low(act3[b]) to high(act3[b]) DO
           write(output,act3[b][e]);}   
 
       while (h[b] > -1)  do
         begin         
           if (act[phase[b],h[b]] <> act3[b,act[phase[b],h[b]]])                        
                 then 
                   begin                                      
               
                     inc(b);
                setlength(act3,b+1,max+1); //sets step storing
                act3[b]:=act3[b-1]; // copies the previous step
                
                setlength(phase,b+1); // sets the  node
                     phase[b]:=act[phase[b-1],h[b-1]];
               
                act3[b][phase[b]]:=phase[b];   
                {act4[phase[b]]:=phase[b]; }
                   
               {append(output);
               write(output,' - ',phase[b]);}
               
      if k = 1
        then 
           begin        
          F:=((b+1)*4);
         setlength(techwrite,u+1);
         setlength(techwrite[u],0);
         setlength(techwrite[u],f+13);
         end;
               
      for e:= low(act2[phase[b]]) to high(act2[phase[b]]) DO
          ACT3[B][act2[phase[b],e]]:=act2[phase[b],e];    
       
        setlength(h,b+1); // sets first step {als links list to choose from}
 
 if High(act[phase[b]])>-1
         then
            h[b]:=High(act[phase[b]]) //sets the link list node count
        else
             h[b]:=-1;       
       
     // eliminations

 
    //start and end same digit & peers of each other
    if (xset[a][8] * xset[phase[b]][9] <> [])
    and (xset[a][0] = xset[phase[b]][3])
      then
        begin
       for n in (xset[a][0] * xset[phase[b]][3]) do
        if (xset[a,8] * xset[phase[b],9]) <> []
        then
         begin
            covered2[n]:=covered2[n] + (xset[a,8] * xset[phase[b],9]);
             active:= true;
            
            if k = 1
              then    
            techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[a,8] * xset[phase[b],9]);
             { append(output);
             write(output,'[=> eliminates:',n,' @ ');
                  for e in (xset[a,8] * xset[phase[b],9]) do               
                     write(output,e,' ');
                   write(output,']');}
          end;      
        end;    
   
   //  A) start and end diffrent digit   and visible to all copies of canddites used
   
    if (xset[phase[b]][3] * xset[a][6] = xset[phase[b]][3]) // is in the exchange cells
    and (xset[phase[b]][9] * xset[a][1] = xset[a][1])// sees all the digits
    and (xset[a][6] <> [0]) // is not a grouped digit !   
   and (xset[a][0] <> xset[phase[b]][3]) // cannot be linked
   and (xset[a][1] <> xset[phase[b]][2]) // cannot start and end same cells
       then
        begin
          for n in (xset[phase[b]][3]) do
         if (xset[a,1] * xset[phase[b],9]) <> []
         then
          begin
              covered2[n]:=covered2[n] + (xset[a,1] * xset[phase[b],9]);
             active:= true;
            if k = 1
             then               
             techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[a,1] * xset[phase[b],9]);
            {append(output);
            write(output,'[=> eliminates:',n,' @ ');
                  for e in (xset[a,1] * xset[phase[b],9]) do
                     write(output,e,' ');
                     write(output,']');   }
          end;      
        end;
       
   //  B) start and end diffrent digit   and visible to all copies of canddites used
    if (xset[A][0] * xset[phase[b]][7] = xset[a][0]) // is in the exchange cells
    and (xset[A][8] * xset[phase[b]][2] = xset[phase[b]][2])// sees all the digits
    and (xset[phase[b]][7] <> [0]) // is not a grouped digit !   
   and (xset[a][0] <> xset[phase[b]][3]) // cannot be linked
   and (xset[a][1] <> xset[phase[b]][2]) // cannot start and end same cells
   
       then
        begin
          for n in (xset[A][0]) do
          if (xset[phase[B],2] * xset[A,8]) <> []
           then
            begin
                covered2[n]:=covered2[n] + (xset[phase[B],2] * xset[A,8]);
                active:= true;
             
              if k  = 1
                then
                 techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[phase[B],3] * xset[A,8]);
               { append(output);
               write(output,'[=> eliminates:',n,' @ ');
                    for e in (xset[phase[B],2] * xset[A,8]) do
                     write(output,e,' ');
                     write(output,']');}
            end;    
        end;        
          
   //loop end is a bivavle and start has its ending digit 
      if ((xset[a][0] = xset[phase[b]][3])
          and (xset[phase[b]][1] = xset[phase[b]][2]) //is a bivavle
          and (xset[phase[b]][9] * xset[a][1] = xset[a][1])) // all of b  sees  As cells
       
   //loop start is a bivavle and end has its starting digit     
      or
        ((xset[a][0] = xset[phase[b]][3])
          and (xset[a][1] = xset[a][2]) //is a bivavle
          and (xset[a][8] * xset[phase[b]][2] = xset[phase[b]][2]))
       
//   start and end are same digit    
    or    
      ((xset[a][0] = xset[phase[b]][3])
      and (xset[a][8] * xset[phase[b]][2] = xset[phase[b]][2]))
      
          then
           begin               
             For G:= 0 to b do
             for e:= 0 to b do
               begin                  
                 // digits are the same 
                     for n in (xset[phase[G]][3]* xset[phase[e]][0]) do
                 if ((xset[phase[g]][9]*xset[phase[e]][8]) <> [])
                  then
                  begin
                   covered2[n]:= covered2[n] + (xset[phase[g]][9]*xset[phase[e]][8]);                  
                  active:= true;
                   if k  = 1
                       then
                      techwrite[u][n+f+3]:=techwrite[u][n+f+3] +(xset[phase[g]][9]*xset[phase[e]][8]);
                      { append(output);
                       write(output,'[=> eliminates:',n,' @ ');
                             for j in (xset[phase[g]][9] * xset[phase[e]][8]) do
                               write(output,j,' ');
                               write(output,']');}            
                  end;
                  
                  // digits swap in cell cell becomes locked to the exchange digits
                  //2nd and first
                  if   (xset[phase[g]][2] = xset[phase[e]][1])
                   and (xset[phase[g]][7] * xset[phase[e]][0] = xset[phase[e]][0])
                         and (xset[phase[e]][6] * xset[phase[g]][3] = xset[phase[g]][3])               
                  
                             then
                                begin
                                  for J in (xset[phase[g]][2]* xset[phase[e]][1]) do
                            if ((pm[j]-(xset[phase[g]][3] + xset[phase[e]][0])) <> [])
                            then
                             begin
                              covered[j]:=covered[j] + (pm[j]-(xset[phase[g]][3] + xset[phase[e]][0]));
                               active:=true;
                              //append(output);
                                    //write(output,'[=>',j,' eliminates: ');
                               if k = 1
                                then
                                  for n in pm[j] - (xset[phase[g]][3] + xset[phase[e]][0]) do
                                   techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
                                   // write(output,n,' ');
                                       // write(output,']');
                             end;
                           end;
                           
                  // digits swap in cell cell becomes locked to the exchange digits
                  // first and 2
                  if   (xset[phase[g]][1] = xset[phase[e]][2])
                   and (xset[phase[g]][6] * xset[phase[e]][3] = xset[phase[e]][3])
                         and (xset[phase[e]][7] * xset[phase[g]][0] = xset[phase[g]][0])               
                  
                             then
                                begin
                                  for J in (xset[phase[g]][1]* xset[phase[e]][2]) do
                            if ((pm[j]-(xset[phase[g]][0] + xset[phase[e]][3])) <> [])
                            then
                             begin
                              covered[j]:=covered[j] + (pm[j]-(xset[phase[g]][0] + xset[phase[e]][3]));
                               active:=true;
                              //append(output);
                                    //write(output,'[=>',j,' eliminates: ');
                               if k = 1
                                then
                                  for n in pm[j] - (xset[phase[g]][0] + xset[phase[e]][3]) do
                                   techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
                                   // write(output,n,' ');
                                       // write(output,']');
                             end;     
                           end;                                                         
               end;   
                                  
            end; // loop elimination code.
            
// loop end and start land on same cell. <canabalistic>    
   if    
    (xset[a][1] = xset[phase[b]][2]) // first and last cell overlap
    and (xset[a][0] = xset[phase[b]][3]) // first and last digit is the same
    and (xset[phase[b]][7] <> [0]) // exchange is on
    and (xset[a][6] <> [0]) // exchange is on
        then
begin    
   
        for j in xset[a][1] do
          begin
         active:=true;
          covered[j]:=covered[j] + (pm[j] - xset[a][0]);
         
          if k = 1
            then             
            for n in (pm[j] - (xset[a][0])) do
               techwrite[u][n+f+3]:=techwrite[u][n+f+3] +[j];
               
            for n in xset[a][0] do
                begin
                  covered2[n]:=covered2[n] + (xset[a][8]);
              active:= true;
             
           if k = 1
            then       
             techwrite[u][n+f+3]:=techwrite[u][n+f+3] + (xset[a][8]);
            
               end
          end;        
    end;
   
//chain display saving trigger 
 if k = 1
            then    
if ((techwrite[u][1+f+3] + techwrite[u][2+f+3] + techwrite[u][3+f+3]
 +  techwrite[u][4+f+3] + techwrite[u][5+f+3] + techwrite[u][6+f+3]
 +  techwrite[u][7+f+3] + techwrite[u][8+f+3] + techwrite[u][9+f+3] ) <> [] )
 
  then
    begin    
    techwrite[u,0]:=[4];
    techwrite[u,1]:=[b];       
    
for e:= 0 to b do
 begin
  techwrite[u,(e*4)+2]:=xset[phase[e],0];
  techwrite[u,(e*4)+3]:=xset[phase[e],1];
  techwrite[u,(e*4)+4]:=xset[phase[e],2];
  techwrite[u,(e*4)+5]:=xset[phase[e],3];    
end;   

 u:=u+1;
   
 end; //saving chain display 
 
if  (u > 32767) 
 then
   begin 
   
   chaindisplay(#26,u-1);
   setlength(techwrite,0,0);   
   u:=0;
 end;    
            
                 end
             else
              begin
                    dec(h[b]);   
            
             repeat
                   if (h[b] < 0) and (b > 0)
                    then
                     begin    
               
               { append(output);
                writeln(output);
                write(output,'back track 1');
                writeln(output);
                write(output,'start: ');}               
                       dec(b);
                  {for g:= 0 to b do
                     begin
                    write(output,phase[g]);
                    if g <> b then write(output,' - ');
                          end;    }               
                 setlength(act3,b+1,max+1);
                 setlength(h,b+1);
                 setlength(phase,b+1);
                      dec(h[b]);
                 { if (b =0) and (h[b] <= -1) then
                    write(output,' Terminated');}
                     end;   
            until( h[b]>=0) or (b <=0)      
                end;
            
   // back tracking if the while h[b] > -1 condition triggers          
      repeat
                   if (h[b] < 0) and (b > 0)
                    then
                     begin
               
                // eliminations
                  
               { append(output);
                writeln(output);
                write(output,'back track 1');
                writeln(output);
                write(output,'start: ');   }            
                       dec(b);
                 { for g:= 0 to b do
                     begin
                    write(output,phase[g]);
                    if g <> b then write(output,' - ');
                          end; }                  
                 setlength(act3,b+1,max+1);
                 setlength(h,b+1);
                 setlength(phase,b+1);
                      dec(h[b]);
                 { if (b =0) and (h[b] <= -1) then
                    write(output,' Terminated');}
                     end;   
            until( h[b]>=0) or (b <=0)      
       end;
 { close(output);}
   
     end; // chain walk
   if k = 1 then chaindisplay(#26,u);
end; {A.I.C}

ALS-Chain: Show
Code: Select all
{A.L.S chain {m.e} }
procedure alsMe(K:integer);  {mutual exclusion}
type
xsets = array of array of numberset;
steps = array of array of numberset;
used2 = array of numberset;
hold = array of integer;
acts = array of array of integer;
acts2 = array of array of integer;
var
h:hold;
xset: xsets;
step:steps;
use2: used2;
act: acts;
act2: acts2;
n,a,b,c,d,e,f,g,j,u,m,r,max:integer;

begin

alsfinder;
links;

setlength(xset,0,0);
if k = 1 then begin u:=0; setlength(techwrite,u+1,0); end;
 b:=-1;
for n in[1..9] do
 for a in [0,7] do
    for c:=  low(linkset[n][a]) to high(linkset[n][a]) do
        begin
       b:=b+1;
       setlength(xset,b+1,12);
       xset[b]:=linkset[n,a,c];      
      end;
      
//finds the arrays that are the same data points

 max:= high(xset);
 setlength(act2,0,0);
 setlength(act2,max+1);

for b:= 0 to max do
begin
 g:=0;
 setlength(act2[b],0);
for e:= 0 to max do
   begin   
               {same set} {reversed }
if      (xset[b][0] = xset[e][0])    //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3])  //first and last are the same digit
   and ((xset[b][1] * xset[e][2]) = (xset[b][1] ) )// first cells match
   and ((xset[b][2] * xset[e][1]) = (xset[b][2] ) )// last cells match
   
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;    
         
         {same set diffrent sector}
{if      (xset[b][0] = xset[e][0])    //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3])  //first and last are the same digit
   and ((xset[b][1] * xset[e][1]) = (xset[b][1] ) )// first cells match
   and ((xset[b][2] * xset[e][2]) = (xset[b][2] ) )// last cells match
   
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;}

         {same starting  digit diffrent starting cells 2nd cells cannot be reused.}
if      (xset[b][0] = xset[e][0])    //  first digit is the same
    and (xset[b][3] = xset[e][3]) //  last digit is the same
   and (xset[b][0] = xset[b][3])  //first and last are the same digit
   //and ((xset[b][1] * xset[e][1]) <> (xset[b][1] ) )// first cells match
   and (((xset[b][1] * xset[e][1]) <> [] )// first cells match   
      or
      ((xset[b][2] * xset[e][2]) <> [] ))// last cells match
   
        then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;    
         
 if  (xset[b][10] = xset[e][10])    //  first set is the same as 2nd set
    and (xset[b][10] <> []) //  sets arent empty
   and (xset[b][11] = xset[e][11])  //   digits are identical
       then
          begin
          setlength(act2[b],g+1);
           act2[b][g]:=e;
          g:=g+1;
         end;
         
    end;
{
gotoxy(2,60);
 write(max,' ');
if b= 3 then begin
write('Cells A: ');
for r in xset[b][1] do
write(' ',r);

writeln;
write('Cells B: ');
for r in xset[b][2] do
write(' ',r);

writeln;
write('Digit A: ');
for r in xset[b][0] do
write(' ',r);

writeln;
write('Digit b: ');
for r in xset[b][3] do
write(' ',r);

writeln;
write(' shared with: ');
for r in act2[b] do
 write(r,' ');
 
 writeln;
delay(150);
   end;}
   
end;

 for a:= max downto 0  do 
     begin
   setlength(act,0,0);
   b:=0; 
   setlength(act,b+1,max+2);
   act[b][a+1]:=a+1;   
 
   for R in act2[a] do
       begin                
       act[b][R+1]:=R+1;         
   end;   
      
   setlength(use2,b+1);   
   use2[b]:= xset[a][2]+ xset[a][1] ; //used cells;
   setlength(h,b+1);
   h[b]:=max;   
   setlength(step,b+1,12);
   step[b]:=xset[a];
   {gotoxy(2,60);
   write(max,' ',a,'  ');}
repeat
   for c:= h[b] downto 0 do         
     if (act[b][c+1] <> C+1 ) //array wasnt used befor    
   and (step[b][5]  * xset[c][4] <> [])  // sectors must shared at the link    
   and (
   (
   // C shares end digit with B, 
   // can be any strong link or a bivavle { this is stricktly non - overlappy} 
   (step[b][3] * xset[c][0] = xset[c][0])  // last digit of b is same as 1  of C   
   and (step[b][9] * xset[c][1]  = xset[c][1]) // first step of C must see last step of B
   and (xset[c][2] * step[b][1] = [] )  // step c cannot over lap B's end point.
   )
      or    (
   // ( 3-1 | [1 -1 or 1-3 ] transfer digit when c is not a bivavle     
    (xset[c][0] = xset[c][3]) // same digit at link
and  (step[b][0] = step[b][3]) // same digit at link
// found an error fixing it
and  (xset[c][0] <> step[b][3]) //  b and c dont share a digit
and (xset[c][6] * step[b][3] = step[b][3])   // checks the cells of B is able to transfer digits to C
and (step[b][7] * xset[c][0] = xset[c][0])   // checks the cells of C is able to transfer digits to B
and (xset[c][1] * step[b][2] = xset[c][1]) // the cells of C & B overlap.   
  )
   or ( 
    // cell b is a bivavle then cell C <> be an overlapping bivavle and c is a  1-1 |1-3 link
    (step[b][1] = step[b][2] )    // one cell
and  (xset[c][2] <> xset[c][1] )   // cannot be a bivavle
and (step[b][3] = xset[c][0] )  // cell must transfer digit to C
and (xset[c][6] * step[b][3] = step[b][3])   // checks the cells of B is able to transfer digits to C
and (step[b][7] * xset[c][0] = xset[c][0])   // checks the cells of C is able to transfer digits to B
and (xset[c][1] * step[b][2] = xset[c][1])   // checks that c[1] cells are exclusivly in step[b]
and (xset[c][2] * step[b][1] = []) // checks that cells of c[2] are not in step b
)   
or ( 
    // cell b is a 1-1|3-1 link then cell C can be a bivavle
    (step[b][1] <> step[b][2] )    // not a bivavle
and  (xset[c][2] = xset[c][1] )   // is a bivavle
and (step[b][3] = xset[c][0] )  // cell must transfer digit to C
and (xset[c][6] * step[b][3] = step[b][3])   // checks the cells of B is able to transfer digits to C
and (step[b][7] * xset[c][0] = xset[c][0])   // checks the cells of C is able to transfer digits to B
and (xset[c][1] * step[b][2] = xset[c][1])   // checks that c[1] cells are exclusivly in step[b]
and (xset[c][2] * step[b][1] = []) // checks that cells of c[2] are not in step b
)   
 )
    then
     begin
      {h[b]:=h[b] - 1;}
      b:=b+1;     
      setlength(act,b+1);
       act[b]:=act[b-1];
       act[b][c+1]:=C+1;      
     
     for R in act2[c] do
       begin         
       act[b][R+1]:=R+1;      
      end;
    
      setlength(h,b+1);
      setlength(use2,b+1);   
       use2[b]:= use2[b-1]+xset[c][1]+xset[c][2] ;       
      h[b]:=max;
         setlength(step,b+1,12);
        step[b]:=xset[c];
       
  {  gotoxy(2,61);
   
   write(B,': ( ');
   if b > 2 then
   for r:= 0 to b do 
   begin
         
    for n in step[r][0] do
       write(n,')');
      
    for n in step[r][1] do
       write(n,' ');
      write(' = ');
      
      for n in step[r][2] do
       write(n,' '); 
      write(' ( ');      
      for n in step[r][3] do
       write(n, ' ) - ');
      
      writeln;
      delay(1500);
      end; }
   

        { break;} 

   if k = 1
        then 
           begin        
          m:=((b+1)*4);
         setlength(techwrite[u],0);
         setlength(techwrite[u],m+14);
         end;
 
{end points visible to each other same digits}    
if (b > 0) and (xset[a][0] = xset[c,3])
 and (xset[c][5] * xset[a][4] = [])and (((xset[a][8]*xset[c][9]) -(use2[b])) <> [])//normal
 then
    begin
    active:=true;
 
    for n in (xset[a][0] + xset[c,3] )  do
      begin
            covered2[n]:=covered2[n] + ((xset[a][8]*xset[c][9]) -(use2[b]));
        if k = 1 then
         techwrite[u,n+m+3]:=techwrite[u,n+m+3] + (digitcell[n] *((xset[a][8]*xset[c][9]) -(use2[b])));
       end; 

{chain loop? }   
         
   end;

{end points visible to each other diffrent digits}
if (b > 0) and (xset[a][0] <> xset[c,3]) {and (xset[c][5] * xset[a][4] <> [])}
 and (xset[c][9] * xset[a][1] = xset[a][1]) 
and ( xset[c][2] * xset[a][1] =[])//and dont use the same cells at start and end
  then
     begin   
    active:=true;

 
      for n in xset[a][0] do
      if N in xset[C][7]  then
       begin
       covered2[n]:=covered2[n] + (xset[c][2]);
      
      if k = 1 then techwrite[u,n+m+3]:=techwrite[u,n+m+3]  + (digitcell[n]*(xset[c][2]));
      
      end;
      
      for n in xset[c][3] do
     if n in xset[a][6] then
      begin
       covered2[n]:=covered2[n] + (xset[a][1]);
      
      if k = 1 then techwrite[u,n+m+3]:=techwrite[u,n+m+3] + (digitcell[n]*(xset[a][1]));
      
       end;    
 
 {chain walk to see if 2 points are the same digits}

    end; 
 
 
 //end points overlap = loop   
if (b > 0) //bi local over lap specifically
and (((xset[a][0] <> xset[c,3]) and (xset[c][5] * xset[a][4] <> [])
and ( xset[c][2] = xset[a][1])  and (xset[c][7] * xset[a][6] <> [0]))
// bivalve intial digit is seen by the end point
or ((xset[a][0] = xset[c][3]) and (xset[c][5] * xset[a][4] <> [])
and (xset[c][2] * xset[a][1] = [])) )

 then
   begin      
   
    for e:= (0) to (b-1) do
       for d:= e+1 to (b) do
        begin
        active:=true;
       
        //overlapping weaklinks are locked                           //below verifies the the step befor can be overlaped by next digit
           if (step[e][2] * step[d][1] = step[e][2]) and (step[e][3] * step[d][6] <> [])
              then    
            for n in step[e][2]*step[d][1] do
             begin
                covered[n]:= covered[n] +( pm[n]-(step[e][3]+step[d][0]));
            
            if k = 1 then
             begin    
              for r in (pm[n]-(step[e][3]+step[d][0])) do
                   techwrite[u,r+m+3]:=techwrite[u,r+m+3]+[n];
               end;   
            end;
            
         if (step[e][1] * step[d][2] = step[e][1]) and (step[e][0] * step[d][7] <> [])
              then    
            for n in step[e][1]*step[d][2] do
                begin             
                covered[n]:= covered[n] +( pm[n]-(step[e][0]+step[d][3]));   
            
            if k = 1 then
             begin    
              for r in (pm[n]-(step[e][0]+step[d][3])) do
                   techwrite[u,r+m+3]:=techwrite[u,r+m+3]+[n];
      
            end;
         
            end;
         
//peers of weaklinks are removed if they share the same digit.          
             if step[d][0] = step[e][3]
               then
             for n in step[d][0] do
            begin
                covered2[n]:=covered2[n] + ((step[d][8] * step[e][9]) - use2[b]);
            
            if k = 1 then techwrite[u,n+m+3]:=techwrite[u,n+m+3] + (digitcell[n]*((step[d][8] * step[e][9]) - use2[b]));
            end;
          end;
 end;
 
 if (k = 1) and (techwrite[u,1+m+3]+ (techwrite[u,2+m+3])+ (techwrite[u,3+m+3] )
+ (techwrite[u,4+m+3] ) + (techwrite[u,5+m+3])+ (techwrite[u,6+m+3] )
+ (techwrite[u,7+m+3] ) + (techwrite[u,8+m+3])+ (techwrite[u,9+m+3] ) <> [])
and (b > 0)
//and (techwrite[u,1+m+3] * [17] = [17])
 then 
   begin
      techwrite[u,0]:=[4];
   techwrite[u,1]:=[b];
   
for e:= 0 to b do
 begin
 
  if step[e,10] = []
   then
     begin 
  techwrite[u,(e*4)+2]:=step[e,0];
  techwrite[u,(e*4)+3]:=step[e,1];
  techwrite[u,(e*4)+4]:=step[e,2];
  techwrite[u,(e*4)+5]:=step[e,3];   
      end;
 
   if step[e,10] <> []
   then
     begin 
  techwrite[u,(e*4)+2]:=step[e,0];
  techwrite[u,(e*4)+3]:=step[e,1];
  techwrite[u,(e*4)+4]:= step[e,10];
  techwrite[u,(e*4)+5]:=(step[e,11]-step[e,0]);   
      end;
 
 
end;

if  u = 32767 
 then
   begin
   chaindisplay(#11,u);
   
   setlength(techwrite,0,0);   
   u:=0;
   end; 
   
   u:=u+1;   
    setlength(techwrite,u+1);
    setlength(techwrite[u],m+14);   
 
   end; 

      {break;}
     end
   
      
     else
      h[b]:= h[b] - 1;   
      
if (h[b] < 0) and (b > 0) 
 then
  begin
  b:=b-1;      
      setlength(use2,b+1);
       setlength(h,b+1);
      setlength(step,b+1,12);
      setlength(act,b+1);
     { h[b]:=h[b]-1;}
  end; 
 
until (h[b] < a) and (b = 0)    
         
   end;
   if k = 1 then chaindisplay(#11,u);
end; {als chain}

ALS+AIC: Show
[code
{A.I.C w A.L.S }
procedure AICWaLS(K:integer);
type
xsets = array of array of numberset;
steps = array of array of numberset;
used2 = array of numberset;
hold = array of integer;
acts = array of array of integer;
acts2 = array of array of integer;
var
h:hold;
xset: xsets;
step:steps;
use2: used2;
act: acts;
act2: acts2;
n,a,b,c,d,e,f,g,j,u,m,r,max:integer;

begin

alsfinder;
links;

setlength(xset,0,0);
if k = 1 then begin u:=0; setlength(techwrite,u+1,0); end;
b:=-1;
for n in[1..9] do
for a in [0..7] do
for c:= low(linkset[n][a]) to high(linkset[n][a]) do
begin
b:=b+1;
setlength(xset,b+1,12);
xset[b]:=linkset[n,a,c];
end;

//finds the arrays that are the same data points

max:= high(xset);
setlength(act2,0,0);
setlength(act2,max+1);

for b:= 0 to max do
begin
g:=0;
setlength(act2[b],0);
for e:= 0 to max do
begin
{same set} {reversed }
if (xset[b][0] = xset[e][0]) // first digit is the same
and (xset[b][3] = xset[e][3]) // last digit is the same
and (xset[b][0] = xset[b][3]) //first and last are the same digit
and ((xset[b][1] * xset[e][2]) = (xset[b][1] ) )// first cells match
and ((xset[b][2] * xset[e][1]) = (xset[b][2] ) )// last cells match

then
begin
setlength(act2[b],g+1);
act2[b][g]:=e;
g:=g+1;
end;

{same set diffrent sector}
{if (xset[b][0] = xset[e][0]) // first digit is the same
and (xset[b][3] = xset[e][3]) // last digit is the same
and (xset[b][0] = xset[b][3]) //first and last are the same digit
and ((xset[b][1] * xset[e][1]) = (xset[b][1] ) )// first cells match
and ((xset[b][2] * xset[e][2]) = (xset[b][2] ) )// last cells match

then
begin
setlength(act2[b],g+1);
act2[b][g]:=e;
g:=g+1;
end;}

{same starting digit diffrent starting cells 2nd cells cannot be reused.}
if (xset[b][0] = xset[e][0]) // first digit is the same
and (xset[b][3] = xset[e][3]) // last digit is the same
and (xset[b][0] = xset[b][3]) //first and last are the same digit
//and ((xset[b][1] * xset[e][1]) <> (xset[b][1] ) )// first cells match
and (((xset[b][1] * xset[e][1]) <> [] )// first cells match
or
((xset[b][2] * xset[e][2]) <> [] ))// last cells match

then
begin
setlength(act2[b],g+1);
act2[b][g]:=e;
g:=g+1;
end;

if (xset[b][10] = xset[e][10]) // first set is the same as 2nd set
and (xset[b][10] <> []) // sets arent empty
and (xset[b][11] = xset[e][11]) // digits are identical
then
begin
setlength(act2[b],g+1);
act2[b][g]:=e;
g:=g+1;
end;

end;
{
gotoxy(2,60);
write(max,' ');
if b= 3 then begin
write('Cells A: ');
for r in xset[b][1] do
write(' ',r);

writeln;
write('Cells B: ');
for r in xset[b][2] do
write(' ',r);

writeln;
write('Digit A: ');
for r in xset[b][0] do
write(' ',r);

writeln;
write('Digit b: ');
for r in xset[b][3] do
write(' ',r);

writeln;
write(' shared with: ');
for r in act2[b] do
write(r,' ');

writeln;
delay(150);
end;}

end;

for a:= max downto 0 do
begin
setlength(act,0,0);
b:=0;
setlength(act,b+1,max+2);
act[b][a+1]:=a+1;

for R in act2[a] do
begin
act[b][R+1]:=R+1;
end;

setlength(use2,b+1);
use2[b]:= xset[a][2]+ xset[a][1] ; //used cells;
setlength(h,b+1);
h[b]:=max;
setlength(step,b+1,12);
step[b]:=xset[a];
{gotoxy(2,60);
write(max,' ',a,' ');}
repeat
for c:= h[b] downto 0 do
if (act[b][c+1] <> C+1 ) //array wasnt used befor
and (step[b][5] * xset[c][4] <> []) // sectors must shared at the link
and (
(
// C shares end digit with B,
// can be any strong link or a bivavle { this is stricktly non - overlappy}
(step[b][3] * xset[c][0] = xset[c][0]) // last digit of b is same as 1 of C
and (step[b][9] * xset[c][1] = xset[c][1]) // first step of C must see last step of B
and (xset[c][2] * step[b][1] = [] ) // step c cannot over lap B's end point.
)


or (
// ( 3-1 | [1 -1 or 1-3 ] transfer digit when c is not a bivavle
(xset[c][0] = xset[c][3]) // same digit at link
and (step[b][0] = step[b][3]) // same digit at link
// found an error fixing it
and (xset[c][0] <> step[b][3]) // b and c dont share a digit
and (xset[c][6] * step[b][3] = step[b][3]) // checks the cells of B is able to transfer digits to C
and (step[b][7] * xset[c][0] = xset[c][0]) // checks the cells of C is able to transfer digits to B
and (xset[c][1] * step[b][2] = xset[c][1]) // the cells of C & B overlap.
)
or (
// cell b is a bivavle then cell C <> be an overlapping bivavle and c is a 1-1 |1-3 link
(step[b][1] = step[b][2] ) // one cell
and (xset[c][2] <> xset[c][1] ) // cannot be a bivavle
and (step[b][3] = xset[c][0] ) // cell must transfer digit to C
and (xset[c][6] * step[b][3] = step[b][3]) // checks the cells of B is able to transfer digits to C
and (step[b][7] * xset[c][0] = xset[c][0]) // checks the cells of C is able to transfer digits to B
and (xset[c][1] * step[b][2] = xset[c][1]) // checks that c[1] cells are exclusivly in step[b]
and (xset[c][2] * step[b][1] = []) // checks that cells of c[2] are not in step b
)
or (
// cell b is a 1-1|3-1 link then cell C can be a bivavle
(step[b][1] <> step[b][2] ) // not a bivavle
and (xset[c][2] = xset[c][1] ) // is a bivavle
and (step[b][3] = xset[c][0] ) // cell must transfer digit to C
and (xset[c][6] * step[b][3] = step[b][3]) // checks the cells of B is able to transfer digits to C
and (step[b][7] * xset[c][0] = xset[c][0]) // checks the cells of C is able to transfer digits to B
and (xset[c][1] * step[b][2] = xset[c][1]) // checks that c[1] cells are exclusivly in step[b]
and (xset[c][2] * step[b][1] = []) // checks that cells of c[2] are not in step b
)
)
then
begin
{h[b]:=h[b] - 1;}
b:=b+1;
setlength(act,b+1);
act[b]:=act[b-1];
act[b][c+1]:=C+1;

for R in act2[c] do
begin
act[b][R+1]:=R+1;
end;

setlength(h,b+1);
setlength(use2,b+1);
use2[b]:= use2[b-1]+xset[c][1]+xset[c][2] ;
h[b]:=max;
setlength(step,b+1,12);
step[b]:=xset[c];

{ gotoxy(2,61);

write(B,': ( ');
if b > 2 then
for r:= 0 to b do
begin

for n in step[r][0] do
write(n,')');

for n in step[r][1] do
write(n,' ');
write(' = ');

for n in step[r][2] do
write(n,' ');
write(' ( ');
for n in step[r][3] do
write(n, ' ) - ');

writeln;
delay(1500);
end; }


{break;}

if k = 1
then
begin
m:=((b+1)*4);
setlength(techwrite[u],0);
setlength(techwrite[u],m+14);
end;

{end points visible to each other same digits}
if (b > 0) and (xset[a][0] = xset[c,3])
and (xset[c][5] * xset[a][4] = [])and (((xset[a][8]*xset[c][9]) -(use2[b])) <> [])//normal
then
begin
active:=true;

for n in (xset[a][0] + xset[c,3] ) do
begin
covered2[n]:=covered2[n] + ((xset[a][8]*xset[c][9]) -(use2[b]));
if k = 1 then
techwrite[u,n+m+3]:=techwrite[u,n+m+3] + (digitcell[n] *((xset[a][8]*xset[c][9]) -(use2[b])));
end;

{chain loop? }

end;

{end points visible to each other diffrent digits}
if (b > 0) and (xset[a][0] <> xset[c,3]) {and (xset[c][5] * xset[a][4] <> [])}
and (xset[c][9] * xset[a][1] = xset[a][1])
and ( xset[c][2] * xset[a][1] =[])//and dont use the same cells at start and end
then
begin
active:=true;


for n in xset[a][0] do
if N in xset[C][7] then
begin
covered2[n]:=covered2[n] + (xset[c][2]);

if k = 1 then techwrite[u,n+m+3]:=techwrite[u,n+m+3] + (digitcell[n]*(xset[c][2]));

end;

for n in xset[c][3] do
if n in xset[a][6] then
begin
covered2[n]:=covered2[n] + (xset[a][1]);

if k = 1 then techwrite[u,n+m+3]:=techwrite[u,n+m+3] + (digitcell[n]*(xset[a][1]));

end;

{chain walk to see if 2 points are the same digits}

end;


//end points overlap = loop
if (b > 0) //bi local over lap specifically
and (((xset[a][0] <> xset[c,3]) and (xset[c][5] * xset[a][4] <> [])
and ( xset[c][2] = xset[a][1]) and (xset[c][7] * xset[a][6] <> [0]))
// bivalve intial digit is seen by the end point
or ((xset[a][0] = xset[c][3]) and (xset[c][5] * xset[a][4] <> [])
and (xset[c][2] * xset[a][1] = [])) )

then
begin

for e:= (0) to (b-1) do
for d:= e+1 to (b) do
begin
active:=true;

//overlapping weaklinks are locked //below verifies the the step befor can be overlaped by next digit
if (step[e][2] * step[d][1] = step[e][2]) and (step[e][3] * step[d][6] <> [])
then
for n in step[e][2]*step[d][1] do
begin
covered[n]:= covered[n] +( pm[n]-(step[e][3]+step[d][0]));

if k = 1 then
begin
for r in (pm[n]-(step[e][3]+step[d][0])) do
techwrite[u,r+m+3]:=techwrite[u,r+m+3]+[n];
end;
end;

if (step[e][1] * step[d][2] = step[e][1]) and (step[e][0] * step[d][7] <> [])
then
for n in step[e][1]*step[d][2] do
begin
covered[n]:= covered[n] +( pm[n]-(step[e][0]+step[d][3]));

if k = 1 then
begin
for r in (pm[n]-(step[e][0]+step[d][3])) do
techwrite[u,r+m+3]:=techwrite[u,r+m+3]+[n];

end;

end;

//peers of weaklinks are removed if they share the same digit.
if step[d][0] = step[e][3]
then
for n in step[d][0] do
begin
covered2[n]:=covered2[n] + ((step[d][8] * step[e][9]) - use2[b]);

if k = 1 then techwrite[u,n+m+3]:=techwrite[u,n+m+3] + (digitcell[n]*((step[d][8] * step[e][9]) - use2[b]));
end;
end;
end;

if (k = 1) and (techwrite[u,1+m+3]+ (techwrite[u,2+m+3])+ (techwrite[u,3+m+3] )
+ (techwrite[u,4+m+3] ) + (techwrite[u,5+m+3])+ (techwrite[u,6+m+3] )
+ (techwrite[u,7+m+3] ) + (techwrite[u,8+m+3])+ (techwrite[u,9+m+3] ) <> [])
and (b > 0)

then
begin
techwrite[u,0]:=[4];
techwrite[u,1]:=[b];

for e:= 0 to b do
begin

if step[e,10] = []
then
begin
techwrite[u,(e*4)+2]:=step[e,0];
techwrite[u,(e*4)+3]:=step[e,1];
techwrite[u,(e*4)+4]:=step[e,2];
techwrite[u,(e*4)+5]:=step[e,3];
end;

if step[e,10] <> []
then
begin
techwrite[u,(e*4)+2]:=step[e,0];
techwrite[u,(e*4)+3]:=step[e,1];
techwrite[u,(e*4)+4]:= step[e,10];
techwrite[u,(e*4)+5]:=(step[e,11]-step[e,0]);
end;


end;

if u = 32767
then
begin
chaindisplay(#13,u);

setlength(techwrite,0,0);
u:=0;
end;

u:=u+1;
setlength(techwrite,u+1);
setlength(techwrite[u],m+14);

end;

{ break;}
end


else
h[b]:= h[b] - 1;

if (h[b] < 0) and (b > 0)
then
begin
b:=b-1;
setlength(use2,b+1);
setlength(h,b+1);
setlength(step,b+1,12);
setlength(act,b+1);
{ h[b]:=h[b]-1;}
end;

until (h[b] < a) and (b = 0)

end;
if k = 1 then chaindisplay(#13,u);
end; {A.I.C w als}[/code]
Last edited by StrmCkr on Wed Oct 19, 2022 1:19 am, edited 6 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Distributed Disjoint Subsets

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

Distributed Disjoint Subsets
SueDeCoq: Show
Code: Select all
procedure Suedecoq(K,l,v:integer); { http://forum.enjoysudoku.com/two-sector-disjoint-subsets-t2033.html}
type
hold = array of integer;
Nuse = array of integer;
base = array of integer;
rcc = array of  array of nums;

RCDs = array of nums;
TRCC = array of nums;
usednum= array of nums;
usednum2= array of nums;

used = array of numberset;
used2 = array of numberset;

cellused=array of numberset;

almostlockedset3= array of array of integer;
RCSTORE= array of array of nums;
var

xn,w,p,p2,n,n2,a,m,z,xn2,yn,yn3,yn2,yn4,xn3,yn5,yn6,xn4,q,r,u,b,b2,B3,max,size,f,count,g:integer;

h:hold;
nouse: nuse;
step: base;
rc:rcc;
RCD:RCDs;
TRC:TRCC;

als3: almostlockedset3;

store: RCSTORE;

A3:numberset;

z1:nums;
z2:nums;

lx1: rcbpeer;
lx2: rcbpeer;

use:used;
use2:used;

usenum : usednum;
 usenum2 : usednum2;
celluse : cellused;

begin
alsfinder;
  //ahsfinder;
setlength(als3,high(als)+1);
setlength(store,high(als)+1);

for a:= high(als) downto 0 do    {startin array}
 begin
 w:=-1;
 for p:= high(als) downto 0 do    {iteration of peers}
   if (als[p,1]+1 = als[p,2] ) then
     if (popcnt(dword((comboset2[als[a,4]]*Comboset2[als[p,4]]) ) )   >=1 )   {set a & B must share >=1 digits}
               and (combosets[als[a,0],als[a,3]]  - combosets[als[p,0],als[p,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als[p,0],als[p,3]] - combosets[als[a,0],als[a,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}

       then

         begin

       xn:=als[a,0];
       xn2:=als[p,0];

      yn:=als[a,3];
      yn3:=als[p,3];

      yn2:=als[a,4];
      yn4:= als[p,4];
      z1:=[];

               {restricted common chcek}
            for z in (comboset[yn4] * comboset[yn2]) do
               if ((Digitcell[z] * combosets[xn,yn])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn,yn] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                       then
                      begin
                                                    lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn,yn]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both a&b for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];
                                                         if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z1:=z1 + [z]; {saves the resticted commons}

                     end;            


   if   ( ( popcnt(dword(z1)) >=1 ) )
        then
      begin
w:=w+1;
setlength(als3[a],w+1);
setlength(store[a],w+1);
als3[a,w]:=p;
store[a,w]:=z1;
end;

end;
end;

if k=1 then begin  u:=0; setlength(techwrite,u+1,0); end;

 for a:= high(als) downto 0 do    {startin array}
 if (high(als3[a]) +1 >= (als[a,2] - als[a,1]))
and (als[a,2] - als[a,1] >L) and (als[a,2] - als[a,1] <=v)

 then
 begin
  w:=0;
  setlength(h,w+1);
  h[w]:=high(als3[a]);

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

         TRC[w]:= []; {{stores the RC between A and all steps}}
      
       setlength(RCD,(w+1));   {set the array size to w}

         RCD[w]:= []; {{stores the RC between A and current steps}}
      
       setlength(usenum,w+1);      
       usenum[w]:=comboset[als[a,4]];  {digits used in the  step}
      
       setlength(celluse,w+1);
       celluse[w]:=combosets[als[a,0],als[a,3]];       {cells used in step}     

setlength(use,(w+1));  {set the array size to w}
use[w]:=[0..80] - combosets[als[a,0],als[a,3]]; {cells unused to choose from}

 size:= (als[a,2] - als[a,1]); {stes the number of added sets to search for is equal to the missing space size of A }
 
  h[w]:= high(als3[a]);       {keeps track of what array is the next stop used for step W }
 
 setlength(use2,(w+1));  {set the array size to w}
 use2[w]:=combosets[als[a,0],als[a,3]]; {all cells used}
     
 
  setlength(usenum2,w+1);   
       usenum2[w]:=comboset[als[a,4]];  {all digits used}

   repeat
    for p:= h[w] downto 0 do
     if  ((use[w] * combosets[als[als3[a,p],0],als[als3[a,p],3]]) <> [])   {checks the new set selected adds cells} 
          and (( store[a,p] - TRC[w] <>[]) {checks that a new RC is added}
         or (w=1) )      
         
        then   
        begin
         h[w]:=h[w]-1;
        inc(w);
       
         setlength(h,w+1);
           h[w]:=p-1;
         
          setlength(step,w+1);
         step[w]:=p;
       
       setlength(usenum,w+1); {stores digits used at step}
      
        usenum[w]:=Comboset[als[als3[a,p],4]];
      
       setlength(celluse,w+1); {stores the cells used at step}
       celluse[w]:=combosets[als[als3[a,p],0],als[als3[a,p],3]];
             
       setlength(TRC,(w+1));   
         TRC[w]:= store[a,p]+TRC[w-1]; {stores the RC between A and all steps}
      
       setlength(RCD,(w+1));   
         RCD[w]:= store[a,p]; {stores the RC between A and current steps}
      
           setlength(use,(w+1));  {removes the cells from the unused list}       
           use[w]:= use[w-1] -  combosets[als[als3[a,p],0],als[als3[a,p],3]];
         
         setlength(use2,(w+1));  {all cells used}          
           use2[w]:=use2[w-1] + combosets[als[als3[a,p],0],als[als3[a,p],3]];
 
  setlength(usenum2,w+1);   {all digits used} 
       usenum2[w]:=usenum2[w-1]+Comboset[als[als3[a,p],4]]; 
      
count:=0;
 for g in use2[w] do
     inc(count);
   
{removes the common RC if its used in muti sets}    
{z1:=[];
   for R:= 1 to w-1 do
    for q:= (R+1) to w do
     z1:=Z1 + (RCD[r] * RCD[Q]); }   

z2:=usenum2[w];    
if (size = w) and (count = popcnt(dword(usenum2[w] ))) then
   {begin // removed  version faster rendition is below
 for R in usenum2[w] do  //numbers
  for q in [ 0..26] do  //sector
    if (combosetS[q,510]) * (use2[w] * Digitcell[R] ) = (use2[w] * Digitcell[R] )
     then
       z2:=z2 - [r];  //identifies digits not in 1 sector
end;  }
 
for R in usenum2[w] do
 begin
  for q in (use2[w] * Digitcell[r]) do
    for g in CellSec[q] do
      if  combosets[g,510] * (use2[w]*digitcell[r] )  =  (use2[w]*digitcell[r] )
         then
             begin
               z2:=z2 - [r];
              break;
             end;          
 
 end;   

//type 1: N cells with N digits where each of the N digits is locked to 1 sector exactly ie N sectors.

if (size = w) and (count = popcnt(dword(usenum2[w]-z2 )))    
then
begin         
   
if k = 1
 then
 begin
 
 if u = 32765    {max array size error code safty exit}
 then
 begin
    chaindisplay(#22,u);
    setlength(techwrite,0,0);
    u:=0;
    setlength(techwrite,u+1,0)
        //exit;
end;
 
 f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
end;    
       
// elimnations for als parts back to the first one.    
 {   for R:= w downto 1 do
     For B in RCD[R] -z1 do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * ((celluse[r] + celluse[0])*digitcell[b])))
         =    ((celluse[r] + celluse[0])*digitcell[b])   )
and ( ((celluse[r] + celluse[0])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end; }   
       
// elliminations for RC's as z1 digits common to all als
   {  For B in z1 do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * ((use2[w])*digitcell[b])))
         =    ((use2[w])*digitcell[b])   )
          and ( ((use2[w])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end; }
       
// elliminations for all digits  since each digit is only in 1 sector we can use all cells and all digits.
 
     For B in usenum2[w] {- (RCD[W] + Z1)}  do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * (use2[w])))
         =    ((use2[w])*digitcell[b])   )
          and ( ((use2[w])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;                

if (k=1) and (techwrite[u,(f+3)] <> [])
 then
  begin
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[f];
   
   techwrite[u,(f+3-1)]:=trc[w];
   //techwrite[u,(f+3)]:=z1;
   
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;

    u:=u+1;    
    setlength(techwrite,u+1);
  end;
               

end ;{ case 1}
               
         break;
        end
      else
       h[w]:=h[w] -1;
   
   
   if ((h[w] < 0) and (w >0)) or (w = size)
      then
        begin   
dec(w);      //set the array size to w
setlength(h,w+1);
setlength(use,(w+1));
setlength(TRC,(w+1));
setlength(RCD,(w+1));
setlength(usenum,w+1);
setlength(celluse,w+1);

setlength(usenum2,w+1);
setlength(use2,(w+1));
        end;      
      
   until (w = 0) and (h[w] < 0)

 end;
chaindisplay(#100,u);
end; {sue de coq}

DeathBlossom: Show
Code: Select all
procedure DeathBlossom(K,l,v:integer); {4 sector disjoint set}
type
hold = array of integer;
Nuse = array of integer;
base = array of integer;
rcc = array of  array of nums;

RCDs = array of nums;
TRCC = array of nums;
usednum= array of nums;
usednum2= array of nums;

used = array of numberset;
used2 = array of numberset;

cellused=array of numberset;

almostlockedset3= array of array of integer;
RCSTORE= array of array of nums;
var

xn,w,p,p2,n,n2,a,m,z,xn2,yn,yn3,yn2,yn4,xn3,yn5,yn6,xn4,q,r,u,b,b2,B3,max,size,f,count,g:integer;

h:hold;
nouse: nuse;
step: base;
rc:rcc;
RCD:RCDs;
TRC:TRCC;

als3: almostlockedset3;

store: RCSTORE;

A3:numberset;

z1:nums;
z2:nums;

lx1: rcbpeer;
lx2: rcbpeer;

use:used;
use2:used;

usenum : usednum;
 usenum2 : usednum2;
celluse : cellused;

begin
alsfinder;
  //ahsfinder;
setlength(als3,high(als)+1);
setlength(store,high(als)+1);

for a:= high(als) downto 0 do    {startin array}
 begin
 w:=-1;
 for p:= high(als) downto 0 do    {iteration of peers}
   if (als[p,1]+1 = als[p,2] ) then
     if (popcnt(dword((comboset2[als[a,4]]*Comboset2[als[p,4]]) ) )   >=1 )   {set a & B must share >=1 digits}
               and (combosets[als[a,0],als[a,3]]  - combosets[als[p,0],als[p,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als[p,0],als[p,3]] - combosets[als[a,0],als[a,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}

       then

         begin

       xn:=als[a,0];
       xn2:=als[p,0];

      yn:=als[a,3];
      yn3:=als[p,3];

      yn2:=als[a,4];
      yn4:= als[p,4];
      z1:=[];

               {restricted common chcek}
            for z in (comboset[yn4] * comboset[yn2]) do
               if ((Digitcell[z] * combosets[xn,yn])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn,yn] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                       then
                      begin
                                                    lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn,yn]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both a&b for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];
                                                         if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z1:=z1 + [z]; {saves the resticted commons}

                     end;            


   if   ( ( popcnt(dword(z1)) >=1 ) )
        then
      begin
w:=w+1;
setlength(als3[a],w+1);
setlength(store[a],w+1);
als3[a,w]:=p;
store[a,w]:=z1;
end;

end;
end;

if k=1 then begin  u:=0; setlength(techwrite,u+1,0); end;

 for a:= high(als) downto 0 do    {startin array}
 if (high(als3[a]) +1 >= (als[a,2] - als[a,1]))
and (als[a,2] - als[a,1] >L) and (als[a,2] - als[a,1] <=v)

 then
 begin
  w:=0;
  setlength(h,w+1);
  h[w]:=high(als3[a]);

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

         TRC[w]:= []; {{stores the RC between A and all steps}}
      
       setlength(RCD,(w+1));   {set the array size to w}

         RCD[w]:= []; {{stores the RC between A and current steps}}
      
       setlength(usenum,w+1);      
       usenum[w]:=comboset[als[a,4]];  {digits used in the  step}
      
       setlength(celluse,w+1);
       celluse[w]:=combosets[als[a,0],als[a,3]];       {cells used in step}     

setlength(use,(w+1));  {set the array size to w}
use[w]:=[0..80] - combosets[als[a,0],als[a,3]]; {cells unused to choose from}

 size:= (als[a,2] - als[a,1]); {stes the number of added sets to search for is equal to the missing space size of A }
 
  h[w]:= high(als3[a]);       {keeps track of what array is the next stop used for step W }
 
 setlength(use2,(w+1));  {set the array size to w}
 use2[w]:=combosets[als[a,0],als[a,3]]; {all cells used}
     
 
  setlength(usenum2,w+1);   
       usenum2[w]:=comboset[als[a,4]];  {all digits used}

   repeat
    for p:= h[w] downto 0 do
     if  ((use[w] * combosets[als[als3[a,p],0],als[als3[a,p],3]]) <> [])   {checks the new set selected adds cells} 
          and (( store[a,p] - TRC[w] <>[]) {checks that a new RC is added}
         or (w=1) )      
         
        then   
        begin
         h[w]:=h[w]-1;
        inc(w);
       
         setlength(h,w+1);
           h[w]:=p-1;
         
          setlength(step,w+1);
         step[w]:=p;
       
       setlength(usenum,w+1); {stores digits used at step}
      
        usenum[w]:=Comboset[als[als3[a,p],4]];
      
       setlength(celluse,w+1); {stores the cells used at step}
       celluse[w]:=combosets[als[als3[a,p],0],als[als3[a,p],3]];
             
       setlength(TRC,(w+1));   
         TRC[w]:= store[a,p]+TRC[w-1]; {stores the RC between A and all steps}
      
       setlength(RCD,(w+1));   
         RCD[w]:= store[a,p]; {stores the RC between A and current steps}
      
           setlength(use,(w+1));  {removes the cells from the unused list}       
           use[w]:= use[w-1] -  combosets[als[als3[a,p],0],als[als3[a,p],3]];
         
         setlength(use2,(w+1));  {all cells used}          
           use2[w]:=use2[w-1] + combosets[als[als3[a,p],0],als[als3[a,p],3]];
 
  setlength(usenum2,w+1);   {all digits used} 
       usenum2[w]:=usenum2[w-1]+Comboset[als[als3[a,p],4]]; 
      
count:=0;
 for g in use2[w] do
     inc(count);
   
{removes the common RC if its used in muti sets}    
{z1:=[];
   for R:= 1 to w-1 do
    for q:= (R+1) to w do
     z1:=Z1 + (RCD[r] * RCD[Q]); }   

z2:=usenum2[w];    
if (size = w) and (count = popcnt(dword(usenum2[w] ))) then
   {begin // removed  version faster rendition is below
 for R in usenum2[w] do  //numbers
  for q in [ 0..26] do  //sector
    if (combosetS[q,510]) * (use2[w] * Digitcell[R] ) = (use2[w] * Digitcell[R] )
     then
       z2:=z2 - [r];  //identifies digits not in 1 sector
end;  }
 
for R in usenum2[w] do
 begin
  for q in (use2[w] * Digitcell[r]) do
    for g in CellSec[q] do
      if  combosets[g,510] * (use2[w]*digitcell[r] )  =  (use2[w]*digitcell[r] )
         then
             begin
               z2:=z2 - [r];
              break;
             end;          
 
 end;   

//type 1: N cells with N digits where each of the N digits is locked to 1 sector exactly ie N sectors.

if (size = w) and (count = popcnt(dword(usenum2[w]-z2 )))    
then
begin         
   
if k = 1
 then
 begin
 
 if u = 32765    {max array size error code safty exit}
 then
 begin
    chaindisplay(#22,u);
    setlength(techwrite,0,0);
    u:=0;
    setlength(techwrite,u+1,0)
        //exit;
end;
 
 f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
end;    
       
// elimnations for als parts back to the first one.    
 {   for R:= w downto 1 do
     For B in RCD[R] -z1 do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * ((celluse[r] + celluse[0])*digitcell[b])))
         =    ((celluse[r] + celluse[0])*digitcell[b])   )
and ( ((celluse[r] + celluse[0])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end; }   
       
// elliminations for RC's as z1 digits common to all als
   {  For B in z1 do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * ((use2[w])*digitcell[b])))
         =    ((use2[w])*digitcell[b])   )
          and ( ((use2[w])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end; }
       
// elliminations for all digits  since each digit is only in 1 sector we can use all cells and all digits.
 
     For B in usenum2[w] {- (RCD[W] + Z1)}  do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * (use2[w])))
         =    ((use2[w])*digitcell[b])   )
          and ( ((use2[w])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;                

if (k=1) and (techwrite[u,(f+3)] <> [])
 then
  begin
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[f];
   
   techwrite[u,(f+3-1)]:=trc[w];
   //techwrite[u,(f+3)]:=z1;
   
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;

    u:=u+1;    
    setlength(techwrite,u+1);
  end;
               

end ;{ case 1}
               
         break;
        end
      else
       h[w]:=h[w] -1;
   
   
   if ((h[w] < 0) and (w >0)) or (w = size)
      then
        begin   
dec(w);      //set the array size to w
setlength(h,w+1);
setlength(use,(w+1));
setlength(TRC,(w+1));
setlength(RCD,(w+1));
setlength(usenum,w+1);
setlength(celluse,w+1);

setlength(usenum2,w+1);
setlength(use2,(w+1));
        end;      
      
   until (w = 0) and (h[w] < 0)

 end;
chaindisplay(#69,u);
end; {Death blossom}

DDS: Show
Code: Select all
procedure DDS(K,l,v:integer); { http://forum.enjoysudoku.com/distributed-disjoint-subsets-t5423.html}
type
hold = array of integer;
Nuse = array of integer;
base = array of integer;
rcc = array of  array of nums;

RCDs = array of nums;
TRCC = array of nums;
usednum= array of nums;
usednum2= array of nums;

used = array of numberset;
used2 = array of numberset;

cellused=array of numberset;

almostlockedset3= array of array of integer;
RCSTORE= array of array of nums;
var

xn,w,p,p2,n,n2,a,m,z,xn2,yn,yn3,yn2,yn4,xn3,yn5,yn6,xn4,q,r,u,b,b2,B3,max,size,f,count,g:integer;

h:hold;
nouse: nuse;
step: base;
rc:rcc;
RCD:RCDs;
TRC:TRCC;

als3: almostlockedset3;

store: RCSTORE;

A3:numberset;

z1,z2,z3:nums;
//z2:nums;
//z3:nums;

lx1,lx2: rcbpeer;
//lx2: rcbpeer;

use:used;
use2:used;

usenum : usednum;
usenum2 : usednum2;
celluse : cellused;

begin
alsfinder;
  //ahsfinder;
setlength(als3,high(als)+1);
setlength(store,high(als)+1);

for a:= high(als) downto 0 do    {startin array}
 begin
 w:=-1;
 for p:= high(als) downto 0 do    {iteration of peers}
   if (als[p,1]+1 = als[p,2] ) then
     if (popcnt(dword((comboset2[als[a,4]]*Comboset2[als[p,4]]) ) )   >=1 )   {set a & B must share >=1 digits}
               and (combosets[als[a,0],als[a,3]]  - combosets[als[p,0],als[p,3]] <> [] )  { sectors can over lap, however cells cannot overlap in full}
            and (combosets[als[p,0],als[p,3]] - combosets[als[a,0],als[a,3]] <> [] ) { sectors can over lap, however cells cannot overlap in full}

       then

         begin

       xn:=als[a,0];
       xn2:=als[p,0];

      yn:=als[a,3];
      yn3:=als[p,3];

      yn2:=als[a,4];
      yn4:= als[p,4];
      z1:=[];

               {restricted common chcek}
            for z in (comboset[yn4] * comboset[yn2]) do
               if ((Digitcell[z] * combosets[xn,yn])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z digit has cells out side the overlap}
                and ((Digitcell[z] * combosets[xn2,yn3])  - (combosets[xn2,yn3] * combosets[xn,yn]) <> [] ) {checks that the sector for z dgit has cells out side the overlap}
                               and (digitcell[z] *( combosets[xn,yn] * combosets[xn2,yn3]) = [])    {resticted commons cannot be found in an overlap cell}
                       then
                      begin
                                                    lx2:=[0..26];   { a RC should only exist in the common intersections of the selected sets}

                     for q in (combosets[xn,yn]+combosets[xn2,yn3]) *digitcell[z] do  {combine common cells in both a&b for common sectors amongts those cells}
                      lx2:= lx2 * cellsec[q];
                                                         if (popcnt(dword(lx2)) >0) and (popcnt(dword(lx2)) < 3)  {check that those cells only existing in 1 or 2 sectors to be restircted}
                       then
                       z1:=z1 + [z]; {saves the resticted commons}

                     end;            


   if   ( ( popcnt(dword(z1)) >=1 ) )
        then
      begin
w:=w+1;
setlength(als3[a],w+1);
setlength(store[a],w+1);
als3[a,w]:=p;
store[a,w]:=z1;
end;

end;
end;

if k=1 then begin  u:=0; setlength(techwrite,u+1,0); end;

 for a:= high(als) downto 0 do    {startin array}
 if (high(als3[a]) +1 >= (als[a,2] - als[a,1]))
and (als[a,2] - als[a,1] >L) and (als[a,2] - als[a,1] <=v)

 then
 begin
  w:=0;
  setlength(h,w+1);
  h[w]:=high(als3[a]);

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

         TRC[w]:= []; {{stores the RC between A and all steps}}
      
       setlength(RCD,(w+1));   {set the array size to w}

         RCD[w]:= []; {{stores the RC between A and current steps}}
      
       setlength(usenum,w+1);      
       usenum[w]:=comboset[als[a,4]];  {digits used in the  step}
      
       setlength(celluse,w+1);
       celluse[w]:=combosets[als[a,0],als[a,3]];       {cells used in step}     

setlength(use,(w+1));  {set the array size to w}
use[w]:=[0..80] - combosets[als[a,0],als[a,3]]; {cells unused to choose from}

 size:= (als[a,2] - als[a,1]); {stes the number of added sets to search for is equal to the missing space size of A }
 
  h[w]:= high(als3[a]);       {keeps track of what array is the next stop used for step W }
 
 setlength(use2,(w+1));  {set the array size to w}
 use2[w]:=combosets[als[a,0],als[a,3]]; {all cells used}
     
 
  setlength(usenum2,w+1);   
       usenum2[w]:=comboset[als[a,4]];  {all digits used}

   repeat
    for p:= h[w] downto 0 do
     if  ((use[w] * combosets[als[als3[a,p],0],als[als3[a,p],3]]) <> [])   {checks the new set selected adds cells} 
          and (( store[a,p] - TRC[w] <>[]) {checks that a new RC is added}
         or (w=1) )      
         
        then   
        begin
         h[w]:=h[w]-1;
        inc(w);
       
         setlength(h,w+1);
           h[w]:=p-1;
         
          setlength(step,w+1);
         step[w]:=p;
       
       setlength(usenum,w+1); {stores digits used at step}
      
        usenum[w]:=Comboset[als[als3[a,p],4]];
      
       setlength(celluse,w+1); {stores the cells used at step}
       celluse[w]:=combosets[als[als3[a,p],0],als[als3[a,p],3]];
             
       setlength(TRC,(w+1));   
         TRC[w]:= store[a,p]+TRC[w-1]; {stores the RC between A and all steps}
      
       setlength(RCD,(w+1));   
         RCD[w]:= store[a,p]; {stores the RC between A and current steps}
      
           setlength(use,(w+1));  {removes the cells from the unused list}       
           use[w]:= use[w-1] -  combosets[als[als3[a,p],0],als[als3[a,p],3]];
         
         setlength(use2,(w+1));  {all cells used}          
           use2[w]:=use2[w-1] + combosets[als[als3[a,p],0],als[als3[a,p],3]];
 
  setlength(usenum2,w+1);   {all digits used} 
       usenum2[w]:=usenum2[w-1]+Comboset[als[als3[a,p],4]]; 
      
count:=0;
 for g in use2[w] do
     inc(count);
   
{removes the common RC if its used in muti sets}    
{z1:=[];
   for R:= 1 to w-1 do
    for q:= (R+1) to w do
     z1:=Z1 + (RCD[r] * RCD[Q]); }

// checks for common z to all
z3:=[1..9];
 for r:= w downto 0 do
   z3:= usenum[r] * z3;
   
z2:=usenum2[w];    
if (size = w) and (count = popcnt(dword(usenum2[w] ))) then
  for R in usenum2[w] do
 begin
  for q in (use2[w] * Digitcell[r]) do
    for g in CellSec[q] do
      if  combosets[g,510] * (use2[w]*digitcell[r] )  =  (use2[w]*digitcell[r] )
         then
             begin
               z2:=z2 - [r];
              break;
             end;          
 
 end;   

//type 1: N cells with N digits where each of the N digits is locked to 1 sector exactly ie N sectors.

if (size = w) and (count = popcnt(dword(usenum2[w]-z2 )))    
then
begin         
   
if k = 1
 then
 begin
 
 if u = 32765    {max array size error code safty exit}
 then
 begin
    chaindisplay(#22,u);
    setlength(techwrite,0,0);
    u:=0;
    setlength(techwrite,u+1,0)
        //exit;
end;
 
 f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
end;    
    
// elliminations for all digits  since each digit is only in 1 sector we can use all cells and all digits.
 
     For B in usenum2[w]   do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * (use2[w])))
         =    ((use2[w])*digitcell[b])   )
          and ( ((use2[w])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;                

if (k=1) and (techwrite[u,(f+3)] <> [])
 then
  begin
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[f];
   
   techwrite[u,(f+3-1)]:=trc[w];
   //techwrite[u,(f+3)]:=z1;
   
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;

    u:=u+1;    
    setlength(techwrite,u+1);
  end;
               

end ;{ case 1}


// type 2: N als N RC  - common z's of all als 
if (size = w) and (popcnt(dword(trc[w])) >=size) and (z3 <> [])    
then
begin         
   
if k = 1
 then
 begin
 
 if u = 32765    {max array size error code safty exit}
 then
 begin
    chaindisplay(#22,u);
    setlength(techwrite,0,0);
    u:=0;
    setlength(techwrite,u+1,0)
        //exit;
end;
 
 f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
end;          
       
// elliminations z3 digits common to all als if RC's counts are still above link size 
     For B in z3 do
      begin
        z1:= TRC[w] - [b];
      if  (popcnt(dword(z1)) >=size)
        then
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * ((use2[w])*digitcell[b])))
         =    ((use2[w])*digitcell[b])   )
          and ( ((use2[w])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;                
       end;
 
if (k=1) and (techwrite[u,(f+3)] <> [])
 then
  begin
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[f];
   
   techwrite[u,(f+3-1)]:=trc[w];
   //techwrite[u,(f+3)]:=z1;
   
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;

    u:=u+1;    
    setlength(techwrite,u+1);
  end;          

end ;{ case 2}


// type 3:  N- asl with RC count >= x2 link size
if (size = w) and (popcnt(dword(trc[w])) >=size*2)
then
begin         
   
if k = 1
 then
 begin
 
 if u = 32765    {max array size error code safty exit}
 then
 begin
    chaindisplay(#22,u);
    setlength(techwrite,0,0);
    u:=0;
    setlength(techwrite,u+1,0)
        //exit;
end;
 
 f:=((w+1)*2);
setlength(techwrite[u],0);
setlength(techwrite[u],((f+13)+1));
end;    
       
// elimnations for parts back to the first.    
    for R:= w downto 1 do
     For B in  RCD[R] do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * ((celluse[r] + celluse[0])*digitcell[b])))
         =    ((celluse[r] + celluse[0])*digitcell[b])   )
and ( ((celluse[r] + celluse[0])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;    

// set a is locked  for z digit when  set - RC  leaves at least 1.     
      For B in usenum2[0] do
     begin
       z1:= TRC[w] - [b];
      if  (popcnt(dword(z1)) >=size*2)
         then       
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (digitcell[b] * (use2[w])))
         =    ((use2[w])*digitcell[b])   )
          and ( ((use2[w])*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end; 
   end;
   
// if the first set is locked to all sets then all sets are locked sets
if TRC[w] * usenum[0] = usenum[0]
   then
    for R:= w downto 1 do
     For B in  usenum2[r] - RCD[r] do
       for Q in (digitcell[b] - (use2[w]*digitcell[b])) do
           if ((peer[q] * (celluse[r] *digitcell[b]))
         =    ((celluse[r] )*digitcell[b])   )
and ( ((celluse[r] )*digitcell[b])   <> [])      
         then
         begin
        Active:=true;
        covered2[B]:=covered2[B] + [Q];
       
        if k = 1
          then
         begin
          techwrite[u,(b+F+3)]:=techwrite[u,(b+f+3)] + [q];
          techwrite[u,(f+3)]:=techwrite[u,(f+3)] + [b];
          end;
        end;   
   
 
if (k=1) and (techwrite[u,(f+3)] <> [])
 then
  begin
   techwrite[u,0]:=[3];
   techwrite[u,1]:=[f];
   
   techwrite[u,(f+3-1)]:=trc[w];
   //techwrite[u,(f+3)]:=z1;
   
   techwrite[u,2]:=comboset[als[a,4]];
   techwrite[u,3]:=combosets[als[a,0],als[a,3]];
   
   for b:= 1 to w do
    begin
     techwrite[u,(b*2)+2]:=techwrite[u,(b*2)+2] + comboset[als[als3[a,step[b]],4]];
    techwrite[u,(b*2)+3]:=techwrite[u,(b*2)+3]+ combosets[als[als3[a,step[b]],0],als[als3[a,step[b]],3]];
    end;

    u:=u+1;    
    setlength(techwrite,u+1);
  end;          

end ;{ case 3}
            
         break;
        end
      else
       h[w]:=h[w] -1;
   
   
   if ((h[w] < 0) and (w >0)) or (w = size)
      then
        begin   
dec(w);      //set the array size to w
setlength(h,w+1);
setlength(use,(w+1));
setlength(TRC,(w+1));
setlength(RCD,(w+1));
setlength(usenum,w+1);
setlength(celluse,w+1);

setlength(usenum2,w+1);
setlength(use2,(w+1));
        end;      
      
   until (w = 0) and (h[w] < 0)

 end;
chaindisplay(#106,u);
end; {DDS}

Almost Disjointed distributed subset{A.d.d.S}
ADDS: Show
Code: Select all
 procedure Adds(K,M,Q:integer);    { k is writting function M is starting size q is ending size}
type

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

base3 =  array of array of numberset;
base4 =  array of  nums;

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

z1:nums;
z2:base4;

p2,lx1:numberset;

p3: base3;

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

begin

cellcombo;

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

repeat

  begin

  for C:= slist[l] to flist[l] do
   if (combocell[c]  <> []) then
    begin
     act:=0;

     for p in combocell[c]do begin
      inc(act);
      if act >=L then
       break;
       end;

   if act >= L then

for  p in combocell[c]  do
 if  (peer[p] * combocell[c]<> [])
    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(p3,10,(w+1)); { digits cells}

        setlength(loc,(w+1));  {starting cell}
        setlength(z2,(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;
        z2[w]:=[];

        for n:= 1 to 9 do
          begin

            if n in pm[p]
             then
              p3[n,w]:= [p]
             else
              p3[n,w]:=[];

           if n in pm[p]
            then
             z2[w]:=z2[w]+[n];

          end;


           repeat

            for J:= h[w] downto 0 do
             begin
               if  not (peer2[loc[w],j] in step[w])
               and ( peer2[loc[w],j] in (combocell[c]))
               and (( peer[peer2[loc[w],j]] * (combocell[c]-step[w]) <> [])  or (w+2 = 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[loc[w-1],j]]] + [Cy[peer2[loc[w-1],j]]+9] + [BXY[peer2[loc[w-1],j]]+18];

                   H[w]:=19;

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

        setlength(p3,10,(w+1)); { digits cells}
         setlength(z2,(w+1)); { digits cells}

         for n:= 1 to 9 do
          begin

            if n in pm[peer2[loc[w-1],j]]
             then
              p3[n,w]:= [peer2[loc[w-1],j]] + p3[n,w-1]
             else
              p3[n,w]:=p3[n,w-1]+p3[n,w];

              if n in pm[peer2[loc[w-1],j]]
               then
                z2[w]:=z2[w-1]+[n] + z2[w]
               else
                z2[w]:=z2[w-1] + z2[w];


          end;

                   end

                  else
                   dec(H[w]);

               if (W = (l-1))  and (comboset[c] = z2[w] )
                then
                 begin

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

                     For N in comboset[c] do
                      for z in list[w] do
                       if  (DigitRCB[z,n] * p3[n,w] = p3[n,w] )
                        then
                          begin
                          lx1:=lx1 + [z];
                          z1:=z1+[n];
                          end;

              if ( L - popcnt(dword(z1)) = 1 )     and (z2[w] + z1 = comboset[c])
                  then
                       begin

                    for n in (comboset[c] -z1)  do
                      for z in ([0..80] - p3[n,w] ) do
                      if (peer[z] * p3[n,w] = p3[n,w] )
                        and ( n in pm[z] )
                        then
                         begin
                          active:=true;
                          covered2[n]:= covered2[n] + [z];


                          end;


                   end;

                 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}
                   setlength(p3,10,(w+1));
                   setlength(z2,w+1);

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

              end;

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

 if m = 0
  then
  inc(L);

 until (L = m) or (L > q);    { change the 6 to a range of 2-9 to stop the cycles}

  end; {aDDS}
Last edited by StrmCkr on Wed Oct 19, 2022 12:51 am, edited 2 times in total.
Some do, some teach, the rest look it up.
stormdoku
User avatar
StrmCkr
 
Posts: 1415
Joined: 05 September 2006

Next

Return to Software

cron