fittable solver

soduko · Posted: Sat Jul 11, 2009 7:12 am Post subject:

Here the full code of my present program.

it is not anymore the quick program i had but is much stronger.

far from optimized yet but here is it all

the placements are numbered 1-729 (see function celsymtoplace)
and the constraint (test () in the program 1-324)

i use QB45 as basic/ basis and you need to use the /ah option when starting.
probably you can get it working on other basics as well

The program uses quite a lot of memory if it doesn't run reduce the value of the constant maxfitsize.

but for the easter monster you need a size of 244.

if even setting the value to 0 doesn't work that sorry it will not run.

setting the value to 0 as a matter of fact stops the fittablesolver (solver5 and all subs starting with fit working all together.)

maybe removing many of the comments and unnescesary tests (all tests that only leads to a stop) is better.

The pit (positive implication solver- solver4) only uses the pitarray (also a rather big array) 729 by 81 so will then still work

there are lots of stops in the program but they are just a help when i am programming.

post questions if you like.

included is also a small (and inefficient) bruteforce solver (brute solver and brutesolverfit) that uses brute force.
(but again this only works if maxfitsize is big enough.)
it reuses the fittable because i did not have enough memory to let it have its own array.

[code]

DEFINT A-Z
REM $DYNAMIC

OPTION BASE 1

'SODUKO solver
' pit tables DONE solver4
' fit tables bit done solver5
' fullpittables very beginning solver6

CONST maxfitsize = 244: 'maximum size for fittable
' can be a bit bigger
'unknown what the maximal needed size is
'guess 250
'(number of candidates after hidden and naked singles are removed)
'easter monster has 240
'if it can be unlimited set it to sz6 (size ^6)
'see just before the declaration of shared arrays

'start
DECLARE SUB memprint (a$)
DECLARE SUB fillcelarrays ()
DECLARE SUB fillmainarrays ()
DECLARE SUB fillplacearrays ()
DECLARE SUB keyboard ()

DECLARE SUB main ()
DECLARE SUB clearpuzzle ()
DECLARE SUB clearsolverdata ()
DECLARE SUB statustest ()
DECLARE SUB testsolution (a$)
DECLARE SUB solverdata ()

'show
DECLARE SUB printgrid ()
DECLARE SUB locatecel (cel)
DECLARE SUB showsolution ()
DECLARE SUB showcel (cel)
DECLARE SUB showplacementsstat ()
DECLARE SUB showplaceingrid (place)

'given
DECLARE SUB addgiven (place)
DECLARE SUB removegiven (cel)
DECLARE SUB showgivens (show)
DECLARE SUB showtestresults ()
DECLARE SUB message (a$)
DECLARE SUB message2 (a$)

'solution
DECLARE SUB addtosolution (place)
DECLARE SUB addtosolutiondry (place)
DECLARE SUB addtoblocked (place)

DECLARE SUB solver ()
DECLARE SUB solver1 ()
DECLARE SUB solver2 ()
DECLARE SUB solver3 (depth)
DECLARE SUB solver4 ()
DECLARE SUB pitarraytest ()
DECLARE SUB solver5 ()
DECLARE SUB solver5fittest ()
DECLARE SUB solver5reftest ()
DECLARE SUB solver5solfittest ()
DECLARE SUB solver6 ()

DECLARE SUB brutesolver ()
DECLARE SUB brutesolverfit ()

DECLARE SUB solversall ()
DECLARE SUB solversread ()
DECLARE SUB solverstest ()

'scrapbook
DECLARE SUB clearplacelist ()
DECLARE SUB cleartestoptions ()

DECLARE SUB readsoduko (a$)
DECLARE SUB testoption2 (test, p1, p2)

'fittable sub's
'fittable start
DECLARE SUB fittoplacefill ()
DECLARE SUB fittablefill1 ()

DECLARE SUB fitnewdiscards ()
DECLARE SUB fittablefrompit ()

'placegrows
DECLARE SUB fittablefill2 ()
DECLARE SUB fitplacegrow ()
DECLARE SUB fitimpliesgrow ()
DECLARE SUB fitblockgrow ()

'testgrows
DECLARE SUB fittestgrow ()
DECLARE SUB fittestgrow1 ()
DECLARE SUB fittestgrow2 ()
DECLARE SUB fittestgrow2a ()
DECLARE SUB fittestgrow3 ()

DECLARE SUB fitmixed ()
DECLARE SUB fitmixedgrow ()
DECLARE SUB fitmixedgrow1 ()
DECLARE SUB fitmixedgrow2 ()
DECLARE SUB fitfilltestlist (test1)

'fittable end
DECLARE SUB fittabletopit ()
DECLARE SUB pittablestats ()
DECLARE SUB fittabletests ()

DECLARE FUNCTION celsymtoplace (cel, sym)
DECLARE FUNCTION rowcoltocel (row, col)
DECLARE FUNCTION opencount ()
DECLARE FUNCTION fillblocklist (p1)
DECLARE SUB testtest ()

'signature functions
DECLARE FUNCTION celsig$ (cel)
DECLARE FUNCTION placesig$ (place)
DECLARE FUNCTION testsig$ (test)
DECLARE FUNCTION symsig$ (sym)

'arrays
CONST sz = 3
CONST sz2 = sz * sz
CONST sz4 = sz2 * sz2
CONST sz44 = sz4 * 4
CONST sz6 = sz4 * sz2
CONST implies = sz6 + 10
CONST blocked = sz6 + 11

CLS
PRINT
memprint " memory before making arrays"
'main arrays

'placearrays
DIM SHARED testtoplace(sz44, sz2)
DIM SHARED placetotest(sz6, 4)
DIM SHARED placetocel(sz6)
DIM SHARED placetosym(sz6)
'celarrays
DIM SHARED celtorow(sz4)
DIM SHARED celtocol(sz4)
DIM SHARED celtobox(sz4)
DIM SHARED celtopib(sz4)

memprint " after main arrays"

'solution

DIM SHARED given(sz4)
DIM SHARED placeref(sz6)
DIM SHARED solution(sz4)
DIM SHARED sstatus
DIM SHARED givennr

'supporting arrays
DIM SHARED solverloop

DIM SHARED placelist(sz6): 'scrabbook for place
DIM SHARED testoptions(sz44) 'for solver2 and 3
DIM SHARED blocklist(sz2 * 4)
memprint " before pitarray"

'pittables
DIM SHARED pitarray(sz6, sz4)
memprint " after pitarray"

'fit tables
DIM SHARED fittable(maxfitsize, maxfitsize)
memprint " only fittable size " + STR$(maxfitsize)
DIM SHARED fitlist(maxfitsize):
DIM SHARED fittoplace(maxfitsize)
memprint " after al maxfitsize arrays"

DIM SHARED placetofit(sz6)
memprint " 1 more sz6 arrays"

DIM SHARED discardf(sz6)
DIM SHARED foundf(sz6)
memprint " 2 more sz6 arrays"

DIM SHARED testlist(sz2): 'used in testgrow
DIM SHARED testlist2(sz2): 'used in testgrow2

memprint " just before 4 more shared variables"

DIM SHARED maxfit
DIM SHARED newdiscard
DIM SHARED newimplies
DIM SHARED fitloop

memprint " after all shared arrays"
keyboard

CLS
' fills arrays
fillcelarrays
fillplacearrays

loadstart = 1
IF loadstart = 1 THEN
a$ = ""
a$ = a$ + "1.......2"
a$ = a$ + ".3.4...5."
a$ = a$ + "..6...7.."
a$ = a$ + ".5...8..."
a$ = a$ + "...36...."
a$ = a$ + "...9.1.4."
a$ = a$ + "2.....6.."
a$ = a$ + ".4...3.9."
a$ = a$ + "..7.....1"
readsoduko a$
solver
'solversread
main
STOP
END IF

top50000 = 1
IF top50000 = 1 THEN
'try solve top50000
OPEN "c:\qbasic\soduko\top50000.sdm" FOR INPUT AS #1
' OPEN "c:\qbasic\soduko\top50000.out" FOR OUTPUT AS #2
DO
j = j + 1
IF j = 1000 THEN
i = i + 1
j = 0
END IF
INPUT #1, a$

message2 "top 50000"
PRINT "top 50000"; " nr "; i; j; SPACE$(30)
readsoduko a$

solversread
showsolution
testsolution a$
message2 " "
' keyboard
message2 "top 50000"
IF sstatus = 2 THEN
STOP
ELSEIF sstatus = 1 THEN
message2 "top 50000 nr " + STR$(i) + STR$(j) + " solved"
'keyboard
ELSE
IF sstatus <> 0 THEN STOP
' PRINT #2, a$
message2 "top 50000 nr " + STR$(i) + STR$(j) + " unsolved"
keyboard
main
END IF
LOOP UNTIL EOF(1)
PRINT "end of top 50000"
keyboard
END IF

CLS
printgrid
main

END

REM $STATIC
SUB addgiven (place)

cel = placetocel(place)

'testnew place
IF placeref(place) = implies THEN
'place cannot go there
cel = placetocel(place)
IF solution(cel) = place THEN
message "symbol was allready known"
given(cel) = place
EXIT SUB
END IF
ELSEIF placeref(place) = blocked THEN
IF given(cel) > 0 THEN
sym = placetosym(place)

placeold = given(cel)
osym = placetosym(placeold)
b$ = "replace " + symsig$(osym) + " with " + symsig(sym)
removegiven cel
IF placeref(place) = blocked THEN
message "cannot " + b$
EXIT SUB
ELSE
message b$
END IF
ELSE
message "symbol cannot go there"
EXIT SUB
END IF
END IF

'add given

given(cel) = place
givennr = givennr + 1
addtosolution (place)
IF sstatus > 0 THEN EXIT SUB
showsolution
solver

END SUB

SUB addtoblocked (place)

'block place
IF place > sz6 THEN STOP
IF place < 1 THEN STOP

'test of already blocked
ref = placeref(place)

IF ref = blocked THEN EXIT SUB
IF ref = implies THEN
'problem...
STOP
END IF

placeref(place) = blocked

END SUB

SUB addtosolution (place)

addtosolutiondry (place)

'block other placements in testtoplace

FOR i = 1 TO 4
test = placetotest(place, i)
FOR j = 1 TO sz2
placebl = testtoplace(test, j)
IF placebl <> place THEN
addtoblocked (placebl)
END IF
NEXT
testoptions(test) = 1
NEXT
statustest

END SUB

SUB addtosolutiondry (place)

'place is good point
a$ = placesig$(place)

'tests
ref = placeref(place)
IF ref = implies THEN
EXIT SUB
'allready implies
showsolution
EXIT SUB
END IF
IF ref = blocked THEN
'problem
STOP
END IF

' place it in grid
showplaceingrid place
message2 "newpoint " + a$
solution(cel) = place
placeref(place) = implies

END SUB

SUB brutesolver

'kind of brute force (not to much of course)

solver4

'pittablestats

openp = opencount
message2 " "
message " number of open placements " + STR$(openp)

'count opentests
testnr = 0
FOR t1 = 1 TO sz44
IF testoptions(t1) > 2 THEN
testnr = testnr + 1
END IF
NEXT
message2 " "
message " number of open tests " + STR$(testnr)
keyboard

'DIM fullpit(openp, testnr)
'unfortunedly we are out of memory...

ftest = 1
IF openp > maxfit THEN ftest = 0
IF testnr > maxfit THEN ftest = 0

IF ftest = 1 THEN
brutesolverfit
END IF

END SUB

SUB brutesolverfit

'brutesolver (mis) using fittables
'only knowledge this far is that it fits...

DIM placetofpit(sz6)
DIM testtofpit(sz44)

DIM celsol(sz4)
DIM fullsol(maxfitsize)
DIM bsol(sz4)
DIM bsolution(2, sz4)

'fill placetofpit
fpnr = 0
eqcount = 0
FOR p1 = 1 TO sz6
p1loop = 1
IF placeref(p1) = 0 THEN
fpnr = fpnr + 1
placetofpit(p1) = fpnr
ELSE
placetofpit(p1) = blocked
END IF
NEXT p1

message " placements to concider " + STR$(fpnr)
IF fpnr > maxfitsize THEN STOP
keyboard

'fill testtofpit
testnr = 0
FOR t1 = 1 TO sz44
IF testoptions(t1) > 1 THEN
testnr = testnr + 1
testtofpit(t1) = testnr
ELSE
testtofpit(t1) = blocked
END IF
NEXT
maxtest = testnr
message "number of constraints to test " + STR$(maxtest)
IF maxtest > maxfitsize THEN STOP
keyboard

'clear pittable
FOR i = 1 TO maxfitsize
FOR j = 1 TO maxfitsize
fittable(i, j) = 0
NEXT
NEXT

'fill pittable with links
FOR p1 = 1 TO sz6
IF placeref(p1) = 0 THEN
f1 = placetofpit(p1)
addctest = 0
FOR c2 = 1 TO sz4
p2 = pitarray(p1, c2)
IF p2 > 0 THEN
addctest = addctest + 1
FOR i3 = 1 TO 4
t3 = placetotest(p2, i3)
IF testoptions(t3) = 1 THEN STOP
tf3 = testtofpit(t3)
r = fittable(f1, tf3)
IF r = 0 THEN
fittable(f1, tf3) = p2
ELSEIF r <> p2 THEN
STOP
END IF
NEXT i3
END IF
NEXT c2
IF addctest = 1 THEN
'place without implies
p1$ = placesig$(p1)
'STOP
END IF
END IF
NEXT p1

'search begins here...............................

'fill celsol with solution
FOR c1 = 1 TO sz4
celsol(c1) = solution(c1)
NEXT

bsolnr = 0
ecel = 1
minplace = 0
bsolverfound = 0

DO
IF celsol(ecel) > 0 THEN
DO
ecel = ecel + 1
IF ecel > sz4 THEN
bsolverfound = bsolverfound + 1
message " found a solution"
FOR i1 = 1 TO bsolnr
ps = bsol(i1)
bsolution(bsolverfound, i1) = ps
p$ = placesig(ps)
showplaceingrid ps
'message2 "sol part" + STR$(i2) + p$
'keyboard
NEXT
message " found a solution"
keyboard
'STOP
minplace = ps - 1
ecel = 0
EXIT DO
END IF
LOOP UNTIL celsol(ecel) = 0
END IF
minplace = minplace + 1

mcel = placetocel(minplace)
IF mcel < ecel THEN
'minplace to small goto first place that fits
minplace = celsymtoplace(ecel, 1)
mcel = ecel
END IF
minplace$ = placesig$(minplace)

IF mcel = ecel THEN
'test if minplace fits in bsol
ftest = 0
IF placeref(minplace) = 0 THEN
f1 = placetofpit(minplace)
ftest = 1
'testif place fits in fullsol
FOR i2 = 1 TO maxtest
ft1 = fittable(f1, i2)
ft2 = fullsol(i2)
IF ft1 > 0 AND ft2 > 0 THEN
IF ft1 <> ft2 THEN
ftest = 0
EXIT FOR
END IF
END IF
NEXT
IF ftest = 1 THEN
'place fits
bsolnr = bsolnr + 1
bsol(bsolnr) = minplace
'add places to celsol
addctest = 0
FOR c2 = 1 TO sz4
p2 = pitarray(minplace, c2)
IF p2 > 0 THEN
pt = celsol(c2)
IF pt > 0 AND pt <> p2 THEN STOP
celsol(c2) = p2
showplaceingrid p2
addctest = addctest + 1
END IF
NEXT
IF addctest = 0 THEN STOP
addftest = 0
f1 = placetofpit(minplace)

'add places to fullsol
FOR ft2 = 1 TO maxtest
p2 = fittable(f1, ft2)
IF p2 > 0 THEN
pt = fullsol(ft2)
IF pt > 0 AND pt <> p2 THEN STOP
fullsol(ft2) = p2
addftest = addftest + 1
END IF
NEXT
IF addftest <> addctest * 4 THEN STOP
END IF
END IF
END IF

IF mcel > ecel THEN
'no solution possible with present startingpoints

'remove last place in stplace
p1 = bsol(bsolnr)
IF p1 = 0 THEN STOP
IF placeref(p1) <> 0 THEN STOP
bsol(bsolnr) = 0
bsolnr = bsolnr - 1
IF bsolnr = 0 THEN EXIT DO
minplace = p1
ecel = placetocel(minplace)

printgrid
'clear celsol and fpitsol
FOR c1 = 1 TO sz4
p1 = solution(c1)
celsol(c1) = p1
IF p1 > 0 THEN
showplaceingrid p1
END IF
NEXT
FOR i1 = 1 TO maxtest
fullsol(i1) = 0
NEXT i1

'rebuild celsol and fpitsol
FOR i4 = 1 TO bsolnr
p4 = bsol(i4)
FOR c5 = 1 TO sz4
p5 = pitarray(p4, c5)
IF p5 > 0 THEN
pt = celsol(c5)
IF pt > 0 AND pt <> p5 THEN STOP
celsol(c5) = p5
showplaceingrid p5
END IF
NEXT
f4 = placetofpit(p4)
FOR ft5 = 1 TO maxtest
p5 = fittable(f4, ft5)
IF p5 > 0 THEN
pt = fullsol(ft5)
IF pt > 0 AND pt <> p5 THEN STOP
fullsol(ft5) = p5
END IF
NEXT
NEXT i4
END IF
LOOP UNTIL bsolverfound > 1

SELECT CASE bsolverfound
CASE 0
message "soduko has no solution"
CASE 1
message "soduko has one solution"
CASE 2
message "soduko has more than one solution"
END SELECT
keyboard

FOR i1 = 1 TO bsolverfound
message " found a solution" + STR$(i1)
FOR b2 = 1 TO sz4
ps = bsolution(i1, b2)
IF ps > 0 THEN
p$ = placesig(ps)
message2 "sol part" + STR$(b2) + p$
keyboard
END IF
NEXT
NEXT

STOP

END SUB

FUNCTION celsig$ (cel)

'signature of cel at the moment same as testsig)
row = celtorow(cel)
col = celtocol(cel)

r$ = CHR$(row + 48)
c$ = CHR$(col + 48)

sig$ = "R" + r$ + "C" + c$

celsig$ = sig$

END FUNCTION

FUNCTION celsymtoplace (cel, sym)

IF cel < 1 OR cel > sz4 THEN STOP
IF sym < 1 OR sym > sz2 THEN STOP

place = cel * sz2 + sym - sz2
IF place < 1 OR place > sz6 THEN STOP

celsymtoplace = place

END FUNCTION

SUB clearplacelist
FOR i = 1 TO sz6
placelist(i) = 0
NEXT

END SUB

SUB clearpuzzle

sstatus = 0
FOR i = 1 TO sz4
given(i) = 0
NEXT

clearsolverdata

CLS
printgrid
givennr = 0

END SUB

SUB clearsolverdata

sstatus = 0
FOR i = 1 TO sz4
solution(i) = 0
NEXT

'clear placeref
FOR i = 1 TO sz6
placeref(i) = 0
NEXT

'clear pitarray
FOR i = 1 TO sz6
FOR j = 1 TO sz4
pitarray(i, j) = 0
NEXT
NEXT

FOR i = 1 TO maxfitsize
foundf(i) = 0
discardf(i) = 0
NEXT

'fitarray doesn't need cleaning

solver: ' just to cleanup messages

END SUB

SUB cleartestoptions

FOR t = 1 TO sz44
testoptions(t) = sz2
NEXT

END SUB

FUNCTION fillblocklist (p1)

IF placeref(p1) = blocked THEN STOP

'fills blocklist
FOR i1 = 1 TO 4
t1 = placetotest(p1, i1)
FOR j2 = 1 TO sz2
p2 = testtoplace(t1, j2)
ptest = 1
IF p2 = p1 THEN ptest = 0
IF placeref(p2) = blocked THEN ptest = 0
IF ptest = 1 THEN
nr = nr + 1
blocklist(nr) = p2
END IF
NEXT
NEXT

fillblocklist = nr

END FUNCTION

SUB fillcelarrays

FOR h1 = 1 TO 3
FOR h2 = 1 TO 3
row = 3 * h1 + h2 - 3
FOR v1 = 1 TO 3
box = 3 * h1 + v1 - 3
FOR v2 = 1 TO 3
col = 3 * v1 + v2 - 3
pig = 3 * h2 + v2 - 3
cel = rowcoltocel(row, col)
celtorow(cel) = row
celtocol(cel) = col
celtobox(cel) = box
celtopib(cel) = pig
NEXT
NEXT
NEXT
NEXT

show = 0
'show = 1
IF show = 1 THEN

CLS
PRINT "cel"
PRINT SPACE$(14); "+"; STRING$(43, "-"); "+";
FOR r1 = 1 TO 3
FOR r2 = 1 TO 3
row = r1 * 3 + r2 - 3
PRINT
PRINT USING " ## Ý"; row;
FOR c1 = 1 TO 3
FOR c2 = 1 TO 3
col = c1 * 3 + c2 - 3
cel = rowcoltocel(row, col)
PRINT USING " ## "; cel;
NEXT
PRINT " Ý ";
NEXT
NEXT
PRINT
PRINT SPACE$(14); "+"; STRING$(43, "-"); "+";
NEXT

PRINT
keyboard

CLS
printgrid
FOR cel = 1 TO sz4
locatecel (cel)
i = celtocol(cel)
PRINT symsig$(i);
NEXT
message "col"
keyboard

CLS
printgrid
FOR cel = 1 TO sz4
locatecel (cel)
i = celtorow(cel)
PRINT symsig$(i);
NEXT
message "row"
keyboard

CLS
printgrid
FOR cel = 1 TO sz4
locatecel (cel)
i = celtobox(cel)
PRINT symsig$(i);
NEXT
message "box"
keyboard

CLS
printgrid
FOR cel = 1 TO sz4
locatecel (cel)
i = celtopib(cel)
PRINT symsig$(i);
NEXT
message "pib"
keyboard
END IF

END SUB

SUB fillplacearrays

FOR cel = 1 TO sz4
row = celtorow(cel)
col = celtocol(cel)
box = celtobox(cel)
pib = celtopib(cel)
FOR sym = 1 TO sz2
place = celsymtoplace(cel, sym)
placetocel(place) = cel
placetosym(place) = sym
test1 = 0 * sz4 + cel
test2 = 1 * sz4 + row * sz2 + sym - sz2
test3 = 2 * sz4 + col * sz2 + sym - sz2
test4 = 3 * sz4 + box * sz2 + sym - sz2

placetotest(place, 1) = test1
placetotest(place, 2) = test2
placetotest(place, 3) = test3
placetotest(place, 4) = test4
IF testtoplace(test1, sym) <> 0 THEN STOP
IF testtoplace(test2, col) <> 0 THEN STOP
IF testtoplace(test3, row) <> 0 THEN STOP
IF testtoplace(test4, pib) <> 0 THEN STOP

testtoplace(test1, sym) = place
testtoplace(test2, col) = place
testtoplace(test3, row) = place
testtoplace(test4, pib) = place
NEXT
NEXT

'show=1
IF show = 1 THEN
FOR i = 1 TO 4 * sz2
FOR j = 1 TO sz2
test = i * sz2 + j - sz2
PRINT
PRINT test; testsig$(test); " : ";
FOR i3 = 1 TO sz2
place = testtoplace(test, i3)
PRINT placesig$(place); " ";
NEXT
NEXT
PRINT
'keyboard
NEXT
END IF

'test testtoplace
FOR i1 = 1 TO sz4
FOR j = 1 TO sz2
place1 = testtoplace(i1, j)
cel = placetocel(place1)
sym = placetosym(place1)
IF cel <> i1 THEN STOP
IF sym <> j THEN STOP
NEXT
NEXT

FOR i1 = 1 TO sz2
FOR i2 = 1 TO sz2
test2 = 1 * sz4 + i1 * sz2 + i2 - sz2
IF show = 1 THEN
PRINT
PRINT test2; testsig$(test2); " : ";
END IF
FOR i3 = 1 TO sz2
place2 = testtoplace(test2, i3)
IF show = 1 THEN PRINT placesig$(place2); " ";
cel = placetocel(place2)
col = celtocol(cel)
row = celtorow(cel)
sym = placetosym(place2)
IF sym <> i2 THEN STOP
IF col <> i3 THEN STOP
IF row <> i1 THEN STOP
NEXT
test3 = test2 + sz4
IF show = 1 THEN
PRINT
PRINT test3; testsig$(test3); " : ";
END IF
FOR i3 = 1 TO sz2
place3 = testtoplace(test3, i3)
IF show = 1 THEN PRINT placesig$(place3); " ";
cel = placetocel(place3)
col = celtocol(cel)
row = celtorow(cel)
sym = placetosym(place3)
IF sym <> i2 THEN STOP
IF col <> i1 THEN STOP
IF row <> i3 THEN STOP
NEXT
test4 = test3 + sz4
IF show = 1 THEN
PRINT
PRINT test4; testsig$(test4); " : ";
END IF
FOR i3 = 1 TO sz2

place4 = testtoplace(test4, i3)
IF show = 1 THEN PRINT placesig(place4); " ";
cel = placetocel(place4)
box = celtobox(cel)
pib = celtopib(cel)
sym = placetosym(place4)
IF sym <> i2 THEN STOP
IF pib <> i3 THEN STOP
IF box <> i1 THEN STOP
NEXT
NEXT
NEXT
END SUB

SUB fitblockgrow

'BLOCK GROW f1 -> -f2 => f2 -> -f1
FOR f1 = 1 TO maxfit
IF discardf(f1) = 0 THEN
FOR f2 = 1 TO maxfit
IF fittable(f1, f2) = blocked THEN
'f1 -> -f2
IF fittable(f2, f1) = 0 THEN
fittable(f2, f1) = blocked
ELSEIF fittable(f2, f1) = implies THEN
'f2-> f1, f1-> -f2 => -f2
discardf(f2) = 1
newdiscard = 1
END IF
END IF
NEXT f2
END IF
NEXT f1

END SUB

SUB fitfilltestlist (test1)

nropt1 = 0
FOR i2 = 1 TO sz2
p2 = testtoplace(test1, i2)
f2 = placetofit(p2)
placeblock = 0
IF placeref(p2) = implies THEN STOP
IF placeref(p2) = 0 THEN
IF f2 = blocked THEN STOP
nropt1 = nropt1 + 1
testlist(nropt1) = f2
END IF
NEXT i2
IF nropt1 <> testoptions(test1) THEN STOP

END SUB

SUB fitimpliesgrow

'fittable test
'f1 -> f2 , -f2 => -f1

DO
testdone = 1
FOR f1 = 1 TO maxfit
IF discardf(f1) = 0 THEN
FOR f2 = 1 TO maxfit
IF fittable(f1, f2) = implies THEN
IF discardf(f2) = 1 THEN
IF foundf(f1) = 1 THEN STOP
discardf(f1) = 1
newdiscard = 1
testdone = 0
END IF
END IF
NEXT f2
END IF
NEXT
LOOP UNTIL testdone = 1

'expand implications
'p2 -> p1, p1-> +/-p3 => p2-> +/- p3

FOR f1 = 1 TO maxfit
IF discardf(f1) = 0 AND foundf(f1) = 0 THEN
FOR f2 = 1 TO maxfit
f2loop = 1
IF fittable(f2, f1) <> implies THEN f2loop = 0
IF discardf(f2) = 1 THEN f2loop = 0
IF f2 = f1 THEN f2loop = 0
IF f2loop = 1 THEN
'f2 -> f1
FOR f3 = 1 TO maxfit
test13 = fittable(f1, f3)
IF f3 = f1 THEN test13 = 0
IF f3 = f2 THEN test13 = 0
IF test13 > 0 THEN
' f1 -> +/- f3 => f2 -> +/-f3
test23 = fittable(f2, f3)
IF test23 = 0 THEN
fittable(f2, f3) = test13
newimplies = newimplies + 1
ELSE
IF test13 <> test23 THEN
'f2 -> f3, f2 -> -f3 => -f2
discardf(f2) = 1
newdiscard = 1
EXIT FOR
END IF
END IF
END IF
NEXT f3
END IF
NEXT f2
END IF
NEXT f1

END SUB

SUB fitmixedgrow

'does the more complex implications
'fitmixedgrow 1
'f7 v f8 v f9, f2 -> -f7, f2 -> -f8 => f2 -> f9
'f7 v f8 v f9, f2 -> -f7, f2 -> -f8, f2 ->-f9 => -f2

'and
'fitmixedgrow 2
'f7 v f8 v f9, f2 -> -f7, f8 -> *f5 f9 -> *f5 => f2 -> *f5
' ft1 , f2 , f5

'think this is as far as you can go with fittables

solver5reftest

IF newimplies <> 0 THEN STOP
IF fitloop <> 0 THEN STOP

DO
newloop = 0
loopcnt = loopcnt + 1
message "fitmixedgrow loop" + STR$(loopcnt)
newimplies = 0
'fittestgrow1 to update testoptions
fittestgrow1

fitmixedgrow2

IF newimplies = 1 THEN
fitloop = 1
END IF
IF newdiscard = 1 THEN
fitnewdiscards
'solver5reftest
newloop = 1
fitloop = 1
END IF
LOOP UNTIL newloop = 0

IF newdiscard = 1 THEN STOP

solver5reftest
END SUB

SUB fitmixedgrow2

'does complex testplace grow
'fitmixedgrow 1
'f7 v f8 v f9, f2 -> -f7, f2 -> -f8 => f2 -> f9
'also
'f7 v f8 v f9, f2 -> -f7, f2 -> -f8, f2 -> -f9 => -f2

'TESTGROW 2
'maybe the last option to strenghten solver 5
'f7 v f8 v f9, f2 -> -f7, f8 -> *f5 f9 -> *f5 => f2 -> *f5
' ft1 , f2 , f5
'exit out of test1 loop after one newdiscard implication
'to make it more simple for the moment

solver5reftest

testgrow = 0
FOR test1 = 1 TO sz44
'solver5reftest
topt1 = testoptions(test1)
IF topt1 > 2 THEN
fitfilltestlist (test1)

'test against placements
FOR f2 = 1 TO maxfit
f2loop = 1
IF discardf(f2) = 1 THEN f2loop = 0
IF f2loop = 1 THEN
' test if f2 is in testlist
' or implies one in test
' no test
FOR i3 = 1 TO topt1
f3 = testlist(i3)
IF f2 = f3 THEN f2loop = 0
IF fittable(f2, f3) = implies THEN f2loop = 0
IF f2loop = 0 THEN
EXIT FOR
END IF
NEXT i3
END IF

'another testif f2 is in test
IF f2loop = 1 THEN
ptest = fittoplace(f2)
FOR i3 = 1 TO 4
IF test1 = placetotest(ptest, i3) THEN
STOP
'should already be found
f2loop = 0
END IF
NEXT
END IF

IF f2loop = 1 THEN
'testloop2

'make list from testlist without options blocked by f2
f2opt = 0
FOR i3 = 1 TO topt1
f3 = testlist(i3)
IF fittable(f2, f3) = implies THEN STOP
IF f2 = f3 THEN STOP

IF fittable(f2, f3) = 0 THEN
f2opt = f2opt + 1
testlist2(f2opt) = f3
END IF
NEXT i3

IF f2opt < topt1 THEN
IF f2opt < 2 THEN
'fitmixedgrow 1
IF f2opt = 0 THEN
'f2 has no follower in test1 -> f2 is blocked
discardf(f2) = 1
newdiscard = 1
EXIT FOR
ELSEIF f2opt = 1 THEN
f9 = testlist2(1)
ftest = fittable(f2, f9)
IF ftest = 0 THEN
fittable(f2, f9) = implies
newimplies = 1
ELSEIF ftest = blocked THEN
'f2 -> f9, f2 -> -f9 => -f2
discardf(f2) = 1
newdiscard = 1
EXIT FOR
END IF
END IF
IF newimplies = 0 THEN STOP
ELSE
'fixmixedgrow 2
'for all options in testlist2
first = 1
FOR i3 = 1 TO f2opt
f7 = testlist2(i3)
IF f7 = 0 THEN STOP
IF first = 1 THEN
first = 0
FOR f5 = 1 TO maxfit
fitlist(f5) = fittable(f7, f5)
NEXT
ELSE
FOR f5 = 1 TO maxfit
IF fitlist(f5) > 0 THEN
IF fitlist(f5) <> fittable(f7, f5) THEN
fitlist(f5) = 0
END IF
END IF
NEXT
END IF
NEXT i3

'f2 implies all what remains in fitlist
FOR f5 = 1 TO maxfit
rlist = fitlist(f5)
IF rlist > 0 THEN
rtable = fittable(f2, f5)
IF rtable = 0 THEN
fittable(f2, f5) = rlist
newimplies = 1
ELSEIF rlist <> rtable THEN
discardf(f2) = 1
newdiscard = 1
END IF
END IF
NEXT f5
IF newdiscard = 1 THEN
EXIT SUB
END IF
END IF
END IF
END IF
NEXT f2
END IF
NEXT test1

END SUB

SUB fitnewdiscards

'add to solution all with foundf=1
'or are implied by then

'add to blocked all with blockf=1
'or have that potential

solver5fittest

'add new found to solution
DO
newfound = 0
FOR f1 = 1 TO maxfit
IF foundf(f1) = 1 THEN
solverloop = 1
p1 = fittoplace(f1)
IF placeref(p1) = blocked THEN STOP
IF placeref(p1) <> implies THEN
IF placeref(p1) <> 0 THEN STOP
addtosolutiondry p1
fitloop = 1
FOR f2 = 1 TO maxfit
IF fittable(f1, f2) = implies THEN
' f1 , f1 -> f2 => f2
foundf(f2) = 1
newfound = 1
END IF
' f1 , f1 -> -f2 => -f2
' f1 , f2 -> -f1 => -f2 'not really nessecary ??
f2test = 0
IF fittable(f1, f2) = blocked THEN f2test = 1
IF fittable(f2, f1) = blocked THEN f2test = 1
IF f2test = 1 THEN
IF foundf(f2) = 1 THEN
p1 = fittoplace(f1)
p1$ = placesig$(p1)
p2 = fittoplace(f2)
p2$ = placesig$(p2)

STOP
END IF
discardf(f2) = 1
END IF
'clear fittable
fittable(f1, f2) = 0
fittable(f2, f1) = 0
NEXT
END IF
END IF
NEXT
LOOP WHILE newfound = 1

solver5solfittest

'test
FOR f1 = 1 TO maxfit
IF foundf(f1) = 1 THEN
FOR f2 = 1 TO maxfit
IF fittable(f1, f2) <> 0 THEN STOP
IF fittable(f2, f1) <> 0 THEN STOP
NEXT
END IF
NEXT

solver5fittest

'block all discarded from solution
DO
newdiscard = 0
FOR f1 = 1 TO maxfit
IF discardf(f1) = 1 THEN
solverloop = 1
p1 = fittoplace(f1)
IF placeref(p1) = implies THEN STOP
IF placeref(p1) <> blocked THEN
IF placeref(p1) <> 0 THEN STOP
fitloop = 1
addtoblocked p1
newdiscard = 1
FOR f2 = 1 TO maxfit
IF fittable(f2, f1) = implies THEN
' - p1, p2 -> p1 => -p2
discardf(f2) = 1
newdiscard = 1
fitloop = 1
END IF
fittable(f1, f2) = 0
fittable(f2, f1) = 0
NEXT
END IF
END IF
NEXT
LOOP WHILE newdiscard = 1

'test
FOR f1 = 1 TO maxfit
IF discardf(f1) = 1 OR foundf(f1) = 1 THEN
FOR f2 = 1 TO maxfit
'fittable(f1, f2) = 0
'fittable(f2, f1) = 0
IF f1 <> f2 THEN
IF fittable(f1, f2) <> 0 THEN STOP
IF fittable(f2, f1) <> 0 THEN STOP
END IF
NEXT
END IF
NEXT
fitloop = 1

showplacementsstat

solver5reftest

END SUB

SUB fitplacegrow

'does all place only grows for fittable
'loop is on newimplies not on newblocked or newdiscards

DO
newimplies = 0
fitblockgrow
fitimpliesgrow
LOOP UNTIL newimplies = 0
fitblockgrow

END SUB

SUB fittablefill1

'fill fittable with first values
' p1 blocks all p in tests that include p1
' p1 forces p1

'clear fitttable
'only bit used? -> only till maxfit
FOR f1 = 1 TO maxfitsize
FOR f2 = 1 TO maxfitsize
fittable(f1, f2) = 0
NEXT
NEXT

FOR f1 = 1 TO maxfit
p1 = fittoplace(f1)
IF p1 = 0 THEN STOP

nrb = fillblocklist(p1)
FOR i1 = 1 TO nrb
p2 = blocklist(i1)
f2 = placetofit(p2)
ptest = 1

IF f2 = blocked THEN ptest = 0
IF ptest = 1 THEN
fittable(f1, f2) = blocked
fittable(f2, f1) = blocked
END IF
NEXT
fittable(f1, f1) = implies
NEXT

END SUB

SUB fittablefill2

' fill fittable with second values.
' all tests with 2 values
' p7 v p8, p1 -> -p7 => p1 -> p8
' p7 v p8, p1 -> -p8 => p1 -> p7
' is done at solver5loop

'solver5reftest
IF newdiscard = 1 THEN STOP

FOR test = 1 TO sz44
IF testoptions(test) = 2 THEN
'for al tests with 2 options
testoption2 test, p3, p4
IF p3 = 0 THEN STOP
IF p4 = 0 THEN STOP

f3 = placetofit(p3)
f4 = placetofit(p4)
IF f3 > maxfit THEN STOP
IF f4 > maxfit THEN STOP
IF foundf(f3) = 1 THEN STOP
IF foundf(f4) = 1 THEN STOP
IF discardf(f3) = 1 THEN STOP
IF discardf(f4) = 1 THEN STOP

FOR f1 = 1 TO maxfit
testf1 = 1
IF foundf(f1) = 1 THEN testf1 = 0
IF discardf(f1) = 1 THEN testf1 = 0
IF f1 = f3 THEN testf1 = 0
IF f1 = f4 THEN testf1 = 0
IF testf1 = 1 THEN
FOR i = 1 TO 2
IF i = 1 THEN
f7 = f3: f8 = f4
ELSEIF i = 2 THEN
f7 = f4: f8 = f3
END IF
IF fittable(f1, f7) = blocked THEN
ftest = fittable(f1, f8)
IF ftest = blocked THEN
IF foundf(f1) = 1 THEN STOP
IF discardf(f1) = 0 THEN
discardf(f1) = 1
newdiscard = 1
END IF
ELSEIF ftest = 0 THEN
fittable(f1, f8) = implies
newimplies = 1
END IF
END IF
NEXT
END IF
NEXT
END IF
NEXT

END SUB

SUB fittablefrompit

pitarraytest

'fill fittable from pitarray

FOR p1 = 1 TO sz6
IF placeref(p1) = 0 THEN
f1 = placetofit(p1)
FOR c2 = 1 TO sz4
p2 = pitarray(p1, c2)
IF p2 > 0 THEN
IF placeref(p2) = blocked THEN
STOP: 'not really possible
'p1 should be blocked as well here...
END IF
IF placeref(p2) = 0 THEN
f2 = placetofit(p2)
IF fittable(f1, f2) = blocked THEN STOP
fittable(f1, f2) = implies
END IF
END IF
NEXT
END IF
NEXT

END SUB

SUB fittabletests

'looks like there is something wrong with fittables therefore a test
solver5reftest
solver5solfittest

solverdata

FOR f1 = 1 TO maxfit
p1 = fittoplace(f1)
IF placeref(p1) = 0 THEN
FOR f2 = 1 TO maxfit
fitlist(f2) = fittable(f1, f2)
NEXT
p$ = placesig$(p1)
FOR t2 = 1 TO sz44
t$ = testsig(t2)
t2opt = testoptions(t2)
IF t2opt > 1 THEN
blockcnt = 0
impcnt = 0
cnt0 = 0
topt = 0
FOR i3 = 1 TO sz2
p3 = testtoplace(t2, i3)
IF placeref(p3) = 0 THEN
p3$ = placesig$(p3)
topt = topt + 1
f3 = placetofit(p3)
r3 = fittable(f1, f3)
SELECT CASE r3
CASE blocked: blockcnt = blockcnt + 1
CASE implies: impcnt = impcnt + 1
CASE 0: cnt0 = cnt0 + 1
CASE ELSE: STOP
END SELECT
END IF
NEXT
IF t2opt <> topt THEN STOP
IF impcnt > 1 THEN STOP
IF impcnt = 1 THEN
IF cnt0 > 0 THEN STOP
IF blockcnt <> topt - 1 THEN STOP
END IF
IF cnt0 = 1 THEN STOP
IF blockcnt > topt - 2 AND cnt0 > 0 THEN STOP
END IF
NEXT t2
END IF
NEXT f1

'test tests

'testif alloption=2 are recognised
FOR t1 = 1 TO sz44
IF testoptions(t1) = 2 THEN
testoption2 t1, p7, p8
f7 = placetofit(p7)
f8 = placetofit(p8)
FOR f2 = 1 TO maxfit
p2 = fittoplace(f2)
IF placeref(p2) = 0 THEN
r7 = fittable(f2, f8)
r8 = fittable(f2, f7)
IF r8 > 0 OR r7 > 0 THEN
IF r8 = r7 THEN STOP
IF r8 = 0 THEN STOP
IF r7 = 0 THEN STOP
END IF
END IF
NEXT
END IF
NEXT

'test implications

FOR f1 = 1 TO maxfit
FOR f2 = 1 TO maxfit
IF fittable(f1, f2) = blocked THEN
IF fittable(f1, f2) <> blocked THEN STOP
END IF

IF fittable(f1, f2) = implies THEN
'f1 -> f2
FOR f3 = 1 TO maxfit
IF fittable(f2, f3) > 0 THEN
IF fittable(f2, f3) <> fittable(f1, f3) THEN STOP
END IF
IF fittable(f3, f2) = blocked THEN
IF fittable(f3, f1) <> blocked THEN STOP
END IF
NEXT
END IF
NEXT
NEXT

'test equivalents
eqcount = 0
show = 0
FOR f1 = 1 TO maxfit
FOR f2 = 1 TO maxfit
IF fittable(f1, f2) = implies THEN
IF fittable(f2, f1) = implies THEN
IF f2 > f1 THEN
'f1 <-> f2
IF show = 1 THEN
p1 = fittoplace(f1)
p2 = fittoplace(f2)
eqcount = eqcount + 1
eq$ = ": " + placesig$(p1) + " <-> " + placesig$(p2)
message2 "eq" + STR$(eqcount) + eq$
keyboard
END IF
FOR f3 = 1 TO maxfit
IF fittable(f1, f3) <> fittable(f2, f3) THEN STOP
IF fittable(f3, f1) <> fittable(f3, f2) THEN STOP
NEXT
END IF
END IF
END IF
NEXT
NEXT

END SUB

SUB fittabletopit

'copy pittable results to pit array

solver5reftest

linkcnt = 0
FOR f1 = 1 TO maxfit
p1 = fittoplace(f1)
IF placeref(p1) = 0 THEN
c1 = placetocel(p1)
FOR f2 = 1 TO maxfit
p2 = fittoplace(f2)
IF placeref(p2) = 0 THEN
IF fittable(f2, f1) = implies THEN
linkcnt = linkcnt + 1
'p2-> p1
pitp = pitarray(p2, c1)
IF pitp = 0 THEN
pitarray(p2, c1) = p1
ELSEIF pitp <> p1 THEN
'pittable and fittable disagree!
STOP
END IF
END IF
END IF
NEXT f2
END IF
NEXT f1

message2 "links found " + STR$(linkcnt)

END SUB

SUB fittestgrow

'all fittable routines directly from test
'works because every test needs to be satisfied (at least once)

DO
newloop = 0

'solver5reftest
fittestgrow1
' looks for tests with only one option
' also updates testoptions
' adds to solution as well
'after this all testoption(t)=1 are solved

IF newdiscard = 1 THEN
newloop = 1
END IF

IF newloop = 0 THEN
'solver5reftest
fittestgrow2
IF newdiscard = 1 THEN
newloop = 1
END IF
END IF

IF newloop = 0 THEN
'fills fittable with links from testoptions=2 tests
'also tests tests with two options that needs to be blocked ???
'solver5reftest
newimplies = 0
fittestgrow2a
IF newimplies = 1 THEN
endfitloop = 1
fitloop = 0
newloop = 1
END IF
IF newdiscard = 1 THEN
newloop = 1
END IF
END IF

'fitestgrow3 is like solver3 only on fittable
IF newloop = 0 THEN
'solver5reftest
fittestgrow3
END IF

IF newdiscard = 1 THEN
endfitloop = 1
solver5fittest
fitnewdiscards
newloop = 1
'solver5reftest
END IF
LOOP UNTIL newloop = 0

IF endfitloop = 1 THEN
fitloop = 1
END IF

END SUB

SUB fittestgrow1

' looks for tests with only one option
' adds them all to solution
' also updates testoptions

DO
'solver5reftest
test1loop = 0
FOR t1 = 1 TO sz44
op = testoptions(t1)
IF op = 0 THEN STOP
IF op > 1 THEN
blocknr = 0
oldfound = 0
foundp = 0
nropt = 0
FOR i2 = 1 TO sz2
p2 = testtoplace(t1, i2)
ref = placeref(p2)
IF ref = implies THEN
nropt = nropt + 1
foundp = p2
oldfound = oldfound + 1
ELSEIF ref = 0 THEN
nropt = nropt + 1
foundp = p2
ELSEIF ref = blocked THEN
blocknr = blocknr + 1
ELSE
STOP
END IF
NEXT
IF oldfound > 1 THEN
'two founds in one test no good
STOP
END IF

IF nropt > op THEN STOP
IF nropt + blocknr <> sz2 THEN STOP

IF nropt = 0 THEN
'no options in test remaining
'error in soduko or program (much more likely)
STOP
END IF
testoptions(t1) = nropt

IF nropt = 1 THEN
IF oldfound = 0 THEN
'new only point found
f2 = placetofit(foundp)
IF f2 = blocked THEN STOP
IF discardf(f2) = 1 THEN STOP
foundf(f2) = 1
newdiscard = 1
EXIT FOR: 'for the moment
END IF
END IF
END IF
NEXT
solver5solfittest

IF newdiscard = 1 THEN
'solver5fittest
fitnewdiscards
test1loop = 1
fitloop = 1
END IF
LOOP UNTIL test1loop = 0

'solver5reftest

END SUB

SUB fittestgrow2
'like solver2 only on fittable

'solver5reftest

'f7 v f8 , f7-> +/-f2, f8 -> +/-f2 => +/-f2

FOR test = 1 TO sz44
'solver5reftest
IF testoptions(test) = 2 THEN
IF newdiscard = 0 THEN
'solver5reftest
END IF
'for al tests with 2 options
testoption2 test, p7, p8
IF p7 = 0 THEN STOP
IF p8 = 0 THEN STOP

f7 = placetofit(p7)
f8 = placetofit(p8)

FOR f2 = 1 TO maxfit
testf2 = 1
IF foundf(f2) = 1 THEN testf2 = 0
IF discardf(f2) = 1 THEN testf2 = 0
IF f2 = f7 THEN testf2 = 0
IF f2 = f8 THEN testf2 = 0
IF testf2 = 1 THEN
rn = fittable(f7, f2)
IF rn > 0 THEN
IF rn = fittable(f8, f2) THEN
newdiscard = 1
IF rn = blocked THEN
discardf(f2) = 1
ELSEIF rn = implies THEN
foundf(f2) = 1
ELSE
STOP
END IF
END IF
END IF
END IF
NEXT f2
END IF
NEXT test

END SUB

SUB fittestgrow2a

'p7 v p8, p2-> -p7 => p2 -> p8
FOR test = 1 TO sz44
'solver5reftest
IF testoptions(test) = 2 THEN
IF newdiscard = 0 THEN
'solver5reftest
END IF
'for al tests with 2 options
testoption2 test, p3, p4
IF p3 = 0 THEN STOP
IF p4 = 0 THEN STOP

f3 = placetofit(p3)
f4 = placetofit(p4)

FOR f2 = 1 TO maxfit
testf2 = 1
IF foundf(f2) = 1 THEN testf2 = 0
IF discardf(f2) = 1 THEN testf2 = 0
IF f2 = f3 THEN testf2 = 0
IF f2 = f4 THEN testf2 = 0
IF fittable(f2, f3) = implies THEN testf2 = 0
IF fittable(f2, f4) = implies THEN testf2 = 0
IF testf2 = 1 THEN
FOR i3 = 1 TO 2
IF i3 = 1 THEN
f7 = f3: f8 = f4
ELSEIF i3 = 2 THEN
f7 = f4: f8 = f3
ELSE
STOP
END IF
r7 = fittable(f2, f7)
IF r7 = blocked THEN
r8 = fittable(f2, f8)
IF r8 = 0 THEN
fittable(f2, f8) = implies
newimplies = 1
ELSEIF r8 = blocked THEN
newdiscard = 1
discardf(f2) = 1
EXIT FOR
ELSE
STOP
END IF
END IF
NEXT i3
END IF
NEXT f2
END IF
NEXT test

END SUB

SUB fittestgrow3

'fitestgrow3 is like solver3 only on fittable

'solver 3 is heavy testsolver

'solver5reftest
FOR opennr = 3 TO sz2
'message2 "fittestgrow1round " + STR$(opennr)
FOR test1 = 1 TO sz44
options = testoptions(test1)
IF options = opennr THEN

'dotest
first = 1
blockednr = 0
nropt = 0
FOR i2 = 1 TO sz2
p2 = testtoplace(test1, i2)
ref = placeref(p2)
IF ref = implies THEN
testoptions(test) = 1
STOP
END IF
IF ref = blocked THEN
blockednr = blockednr + 1
ELSE
f2 = placetofit(p2)
nropt = nropt + 1

IF first = 1 THEN
first = 0
FOR f3 = 1 TO maxfit
fitlist(f3) = fittable(f2, f3)
NEXT
ELSE
FOR f3 = 1 TO maxfit
IF fitlist(f3) <> 0 THEN
IF fittable(f2, f3) <> fitlist(f3) THEN
fitlist(f3) = 0
END IF
END IF
NEXT
END IF
END IF
NEXT i2

IF opennr + blockednr <> sz2 THEN STOP
IF opennr <> nropt THEN STOP

'do with points still in fitlist
FOR f3 = 1 TO maxfit
rn = fitlist(f3)
IF rn > 0 THEN
newdiscard = 1
IF rn = blocked THEN
discardf(f3) = 1
ELSEIF rn = implies THEN
foundf(f3) = 1
ELSE
STOP
END IF
END IF
NEXT f3
IF newdiscard = 1 THEN EXIT FOR
END IF
NEXT test1
IF newdiscard = 1 THEN EXIT FOR
NEXT opennr

END SUB

SUB fittoplacefill

'fill fittoplace and placetofit
fitnr = 0
FOR p = 1 TO sz6
ref = placeref(p)
IF ref = 0 THEN
fitnr = fitnr + 1
fittoplace(fitnr) = p
placetofit(p) = fitnr
IF fitnr > maxfit THEN STOP
ELSEIF ref = blocked THEN
placetofit(p) = blocked
ELSEIF ref = implies THEN
placetofit(p) = blocked
ELSE
STOP
END IF
NEXT
IF fitnr <> maxfit THEN STOP

FOR f = 1 TO maxfit
foundf(f) = 0
discardf(f) = 0
NEXT

solver5reftest
END SUB

SUB info

'testarrays

'array 1 - sz2 places in the same cel
'array 1*sz2+1 - 2*sz2 places in the same row sym
'array 2*sz2+1 - 3*sz2 places in the same col sym
'array 3*sz2+1 - 4*sz2 places in the same box sym

'not very efficient but will have to do for now.
' much better have all sorted by sym

'array 1 - ???? places wiyh sym=1 row
'array 1 - ???? places wiyh sym=1 col
'array 1 - ???? places wiyh sym=1 grid
'array 1 - ???? places wiyh sym=2
'array 1 - ???? places wiyh sym=3
' ect
'array 3*sz2+1 - 4*sz2 places in the same cel

'variables that only exsist in info

newdiscards = 5
o = 4

END SUB

SUB keyboard

INPUT a$

END SUB

SUB locatecel (cel)

col = celtocol(cel)
row = celtorow(cel)

colextra = INT((col - 1) / sz)
rowextra = INT((row - 1) / sz)
hor = 1 + row + rowextra
ver = 2 + col * 3 + colextra

LOCATE hor, ver, 1

END SUB

SUB main

cel = 41
DO
statustest
IF sstatus = 2 THEN s$ = "no solution"
IF sstatus = 1 THEN s$ = " Soduko solved "
IF sstatus = 0 THEN s$ = " "
message2 s$

showgivens showg

showcel (cel)
locatecel (cel)
DO
a$ = INKEY$
LOOP UNTIL a$ <> ""
message SPACE$(50)

b$ = LEFT$(a$, 1)
b = ASC(b$)
SELECT CASE b
CASE 0
'cursor movement
col = celtocol(cel)
row = celtorow(cel)
dir = ASC(RIGHT$(a$, 1))
SELECT CASE dir
CASE 75: col = col - 1: 'left
CASE 77: col = col + 1: 'right
CASE 72: row = row - 1: 'up
CASE 80: row = row + 1: 'down
CASE 83: removegiven (cel): 'del
CASE ELSE
message "unknown enter"
PRINT dir;
'STOP
END SELECT
IF col < 1 THEN col = 1
IF row < 1 THEN row = 1
IF col > sz2 THEN col = sz2
IF row > sz2 THEN row = sz2
cel = rowcoltocel(row, col)
locatecel cel
CASE 13
'enter pressed
STOP
CASE 48
'remove cel from givenlist
removegiven cel
solver
CASE 49 TO 59
'add given to list
sym = b - 48
place = celsymtoplace(cel, sym)
addgiven place
CASE ASC("s")
solver
CASE ASC("b")
brutesolver
CASE ASC("g")
showg = 1 - showg
CASE ASC("c")
message "clear board? y/.."
INPUT a$
message SPACE$(50)
message2 SPACE$(50)
IF a$ = "y" THEN
clearpuzzle
cel = 41
END IF
CASE ASC("x")
message "end program? y/.."
INPUT a$
message SPACE$(50)
message2 SPACE$(50)
IF a$ = "y" THEN
EXIT SUB
END IF
CASE ASC("t")
solverstest
CASE ASC("f")
solversall

CASE ELSE
message " "
LOCATE 20, 1
b$ = LEFT$(a$, 1)
c$ = RIGHT$(a$, 1)
PRINT " >"; a$; "< = "; ASC(b$), ASC(c$)
'STOP
END SELECT
LOOP

END SUB

SUB memprint (a$)

PRINT USING " \ \ "; a$;
PRINT USING "###### ####### #####"; FRE(0); FRE(-1); FRE(-2)

END SUB

SUB message (a$)
LOCATE 20, 1
PRINT SPACE$(50)

LOCATE 20, 1
PRINT a$

END SUB

SUB message2 (a$)
LOCATE 21, 1
PRINT SPACE$(50)
'PRINT SPACE$(50)

LOCATE 21, 1
PRINT a$

END SUB

FUNCTION opencount

foundnr = 0
blockednr = 0
opennr = 0
FOR i = 1 TO sz6
ref = placeref(i)
IF ref = blocked THEN
blockednr = blockednr + 1
ELSEIF ref = implies THEN
foundnr = foundnr + 1
ELSE
opennr = opennr + 1
END IF
NEXT

IF foundnr > sz4 THEN STOP

IF foundnr = sz4 THEN
IF sstatus <> 2 THEN
'soduko solved
sstatus = 1
IF opennr <> 0 THEN STOP
END IF
END IF

'test the other way around
IF opennr = 0 THEN
IF foundnr <> sz4 THEN STOP
IF foundnr = sz4 THEN
IF sstatus <> 2 THEN
'soduko solved
sstatus = 1
IF opennr <> 0 THEN STOP
END IF
END IF
END IF

opencount = opennr

END FUNCTION

SUB pitarraytest

FOR p1 = 1 TO sz6
IF placeref(p1) = implies THEN
FOR c2 = 1 TO sz4
p2 = pitarray(p1, c2)
IF p2 > 0 THEN
IF placeref(p2) <> implies THEN STOP
END IF
NEXT
END IF
NEXT

FOR p1 = 1 TO sz6
IF placeref(p1) = 0 THEN
FOR c2 = 1 TO sz4
p2 = pitarray(p1, c2)
IF p2 > 0 THEN
IF placeref(p2) = blocked THEN STOP
END IF
NEXT
END IF
NEXT

END SUB

SUB pittablestats

maxtrl = 0
linkcnt = 0

FOR p1 = 1 TO sz6
p1loop = 1
c1 = placetocel(p1)
IF placeref(p1) > sz6 THEN
p1loop = 0
ELSE
opennr = opennr + 1
END IF
IF p1loop = 1 THEN
trl = 0
FOR c2 = 1 TO sz4
p2 = pitarray(p1, c2)
IF p2 > 0 THEN
IF placeref(p2) = 0 THEN
'p1 -> p2
trl = trl + 1
linkcnt = linkcnt + 1
IF pitarray(p2, c1) = p1 THEN
eqcount = eqcount + 1
ELSEIF pitarray(p2, c1) <> 0 THEN
STOP
'major error in solver4 !!!!!!!!!!!
END IF
END IF
END IF
NEXT
IF trl > maxtrl THEN maxtrl = trl
END IF
NEXT p1

opc = opencount
IF opennr <> opc THEN STOP

message2 " "
message "number of implications (cnt all)" + STR$(linkcnt)
keyboard
message "longest tread" + STR$(maxtrl)
keyboard

'look for equalivalents p1->p2 and p2->p1

DIM placetofpit(sz6)
fpnr = 0
opennr = 0
eqcount = 0
linkcnt = 0
maxtrl = 0

FOR p1 = 1 TO sz6
p1loop = 1
IF placeref(p1) > sz6 THEN
placetofpit(p1) = blocked
p1loop = 0
ELSE
opennr = opennr + 1
END IF
IF placetofpit(p1) > 0 THEN p1loop = 0
IF p1loop = 1 THEN
c1 = placetocel(p1)
IF placetofpit(p1) <> 0 THEN STOP
fpnr = fpnr + 1
placetofpit(p1) = fpnr
FOR p2 = 1 TO sz6
p2loop = 1
c2 = placetocel(p2)
IF placeref(p2) > sz6 THEN p2loop = 0: ' not really nessesary ?
IF pitarray(p1, c2) <> p2 THEN p2loop = 0
IF p1 = p2 THEN p2loop = 0
IF p2loop = 1 THEN
trl = trl + 1
'p1 -> p2
IF pitarray(p2, c1) = p1 THEN
'p1 -> p2 , p2 ->p1 => p1 <-> p2
placetofpit(p2) = fpnr
eqcount = eqcount + 1
ELSEIF pitarray(p2, c1) <> 0 THEN
STOP
'major error in solver4 !!!!!!!!!!!
END IF
END IF
NEXT
END IF
IF trl > maxtrl THEN maxtrl = trl
NEXT p1

opc = opencount

IF opennr <> opc THEN STOP
message2 " "
message " number of treads " + STR$(fpnr)
keyboard
'message "number of implications " + STR$(linkcnt)
'keyboard

message "number of p1 <--> p2 = " + STR$(eqcount)
keyboard

'count opentests
testnr = 0
FOR t1 = 1 TO sz44
IF testoptions(t1) > 2 THEN
testnr = testnr + 1
IF testoptions(t1) > 7 THEN
s$ = testsig$(t1)
'STOP
END IF
END IF
NEXT
message2 " "
message " number of open tests " + STR$(testnr)
keyboard

END SUB

FUNCTION placesig$ (place)

SELECT CASE place
CASE 0
result$ = "--0--"
CASE blocked
result$ = "block"
CASE IS > sz6
STOP
CASE IS < 0
STOP

CASE ELSE
cel = placetocel(place)
sym = placetosym(place)
col = celtocol(cel)
row = celtorow(cel)
c$ = CHR$(col + 48)
r$ = CHR$(row + 48)
s$ = CHR$(sym + 48)
result$ = "R" + r$ + "C" + c$ + "=" + s$
END SELECT

placesig$ = result$

END FUNCTION

SUB printgrid

t1$ = " ÉÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍ» "
r1$ = " º + + + º + + + º + + + º "
r2$ = " ÌÍÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍÎÍÍÍÍÍÍÍÍÍ¹ "
b1$ = " ÈÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍ¼ "

LOCATE 1, 1
PRINT t1$
PRINT r1$
PRINT r1$
PRINT r1$
PRINT r2$
PRINT r1$
PRINT r1$
PRINT r1$
PRINT r2$
PRINT r1$
PRINT r1$
PRINT r1$
PRINT b1$

END SUB

SUB readsoduko (a$)

IF LEN(a$) > sz4 THEN STOP

clearpuzzle
FOR c = 1 TO LEN(a$)
b$ = MID$(a$, c, 1)
b = ASC(b$)
IF b > 48 AND b < 59 THEN
sym = b - 48
IF sym > sz2 THEN STOP
IF sym < 1 THEN STOP
place = celsymtoplace(c, sym)
given(c) = place
givennr = givennr + 1
addtosolution place
IF sstatus > 0 THEN EXIT SUB
END IF
NEXT

END SUB

SUB removegiven (cel)

'remove given from given list

place = solution(cel)
IF place = 0 THEN
message "nothing given on this place"
EXIT SUB
END IF

place = given(cel)
IF place = 0 THEN
message "not a given"
ELSE
given(cel) = 0

clearsolverdata

'add all given to solution
givennr = 0
FOR i = 1 TO sz4
place = given(i)
IF place > 0 THEN
addtosolution (place)
IF sstatus > 0 THEN EXIT SUB
givennr = givennr + 1
END IF
NEXT
END IF

END SUB

FUNCTION rowcoltocel (row, col)

cel = row * sz2 + col - sz2

IF cel < 1 THEN STOP
IF cel > sz4 THEN STOP
rowcoltocel = cel

END FUNCTION

SUB showcel (cel)

cel$ = celsig$(cel)

'mini cel overview
LOCATE 1, 40
PRINT "cel"; cel; cel$
LOCATE 2, 40
PRINT "Cel options"
FOR c1 = 1 TO 3
FOR c2 = 1 TO 3
s = c1 * 3 + c2 - 3
p = celsymtoplace(cel, s)
ref = placeref(p)
IF ref = blocked THEN
s$ = "-"
ELSE
s$ = symsig$(s)
END IF
LOCATE 2 + c1, 40 + 2 * c2
PRINT s$;
NEXT
NEXT

'giventest
LOCATE 6, 42
p = solution(cel)
IF p > 0 THEN
IF given(cel) > 0 THEN
IF given(cel) <> p THEN STOP
i$ = "Given"
ELSE
i$ = "Found"
END IF
ELSE
i$ = " "
END IF
PRINT i$;

END SUB

SUB showgivens (show)

FOR c = 1 TO sz4
locatecel (c)
p = solution(c)
pg = given(c)

IF p > 0 THEN
test = 1
IF placetocel(p) <> c THEN test = 0
IF pg > 0 AND pg <> p THEN test = 0
IF test = 0 THEN
'c$=celsig$(c)
'p2$=placesig$(p)
'p1$ = placesig$(test2(c))
STOP
END IF
sym = placetosym(p)
s$ = symsig$(sym)
IF pg > 0 AND show = 1 THEN
PRINT s$ + "*";
ELSE
PRINT s$ + " ";
END IF
ELSE
IF pg > 0 THEN STOP
PRINT "+ ";
END IF
NEXT

END SUB

SUB showplaceingrid (place)

cel = placetocel(place)
sym = placetosym(place)
locatecel (cel)
PRINT symsig$(sym)

END SUB

SUB showplacementsstat

foundnr = 0
blockednr = 0
opennr = 0
FOR i = 1 TO sz6
ref = placeref(i)
IF ref = blocked THEN
blockednr = blockednr + 1
ELSEIF ref = implies THEN
foundnr = foundnr + 1
ELSE
opennr = opennr + 1
END IF
NEXT
LOCATE 18, 1
PRINT "Placements ";
PRINT " open"; opennr; "blocked"; blockednr; "in solution"; foundnr

END SUB

SUB showsolution
'
'test solution
'if points in place ref implies are also in solution

DIM test1(sz4): 'list from placeref

teststatus = 1
FOR p = 1 TO sz6
IF placeref(p) = implies THEN
cel = placetocel(p)
IF test1(cel) > 0 THEN
STOP
END IF
test1(cel) = p
END IF
NEXT

FOR c = 1 TO sz4
p = solution(c)
IF test1(c) <> p THEN
'c$=celsig$(c)
'p2$=placesig$(p)
'p1$ = placesig$(test2(c))
STOP
END IF

locatecel (c)
IF p > 0 THEN
sym = placetosym(p)
PRINT symsig$(sym); " ";
ELSE
PRINT "+ ";
teststatus = 0
END IF
NEXT

IF teststatus = 1 AND sstatus = 0 THEN STOP

END SUB

SUB showtestresults

DIM teststest(sz2)

LOCATE 15, 1
FOR i = 1 TO 5
PRINT SPACE$(50)
NEXT

FOR t = 1 TO sz44
op = testoptions(t)
IF op = 0 THEN STOP
teststest(op) = teststest(op) + 1
NEXT

'test solution
gc = 0
fc = 0
oc = 0
FOR c = 1 TO sz4
p = solution(c)
g = given(c)
IF g > 0 THEN
gc = gc + 1
IF p <> g THEN STOP
END IF
IF p > 0 THEN
fc = fc + 1
ELSE
oc = oc + 1
END IF
NEXT

'IF fc <> foundnr THEN STOP
IF gc <> givennr THEN STOP
IF fc + oc <> sz4 THEN STOP
IF fc * 4 <> teststest(1) THEN STOP

LOCATE 15, 1
PRINT "Tests analyses"
FOR i = 1 TO sz2
PRINT USING " ### "; teststest(i);
NEXT
PRINT

PRINT "Cel analysis";
PRINT " given "; gc; "found"; fc - gc; "open"; oc

showplacementsstat

END SUB

SUB solver

'main solverloop

'only solver 1 and fitsolver at the moment

IF sstatus = 2 THEN EXIT SUB

cleartestoptions

loopnr = 0
DO
solverloop = 0
loopnr = loopnr + 1
message "solverloop" + STR$(loopnr)
'keyboard
IF loopnr MOD 100 = 0 THEN
keyboard
END IF
solver1
IF sstatus > 0 THEN
EXIT SUB
END IF

showtestresults

IF solverloop = 0 THEN
' solver2
END IF
IF sstatus <> 0 THEN EXIT SUB

IF solverloop = 0 THEN
'heavy testsolver
' solver3 (4)
END IF
IF sstatus <> 0 THEN EXIT SUB

IF solverloop = 0 THEN
'PIT solver
' solver4
END IF
IF sstatus <> 0 THEN EXIT SUB

IF solverloop = 0 THEN
'heavy testsolver
'solver3 (sz2)
END IF
IF sstatus <> 0 THEN EXIT SUB

openpl1 = opencount
IF solverloop = 0 THEN
'FIT solver
solver5
IF solverloop = 0 THEN
openpl2 = opencount
IF openpl2 < openpl1 THEN
STOP
END IF
END IF
END IF
IF sstatus <> 0 THEN EXIT SUB

LOOP UNTIL solverloop = 0

message2 SPACE$(50)

END SUB

SUB solver1

'test for only option in test
'and update testoptions

message2 "solver1"

DO
newfound = 0
FOR t = 1 TO sz44
' testsig$(t)
IF testoptions(t) = 0 THEN STOP
IF testoptions(t) > 1 THEN
posnr = 0
posp = 0
allreadyfound = 0
blockedoptions = 0
FOR i = 1 TO sz2
p = testtoplace(t, i)
ref = placeref(p)
SELECT CASE ref
CASE blocked
blockedoptions = blockedoptions + 1
CASE implies
allreadyfound = allreadyfound + 1
testoptions(t) = 1
CASE ELSE
posnr = posnr + 1
posp = p
END SELECT
NEXT
IF allreadyfound > 1 THEN
'big problem
STOP
END IF
IF allreadyfound = 1 AND posnr > 0 THEN
'something wrong
'not all imposibilities are blocked
STOP
FOR i = 1 TO sz2
p = testtoplace(t, i)
ref = placeref(p)
SELECT CASE ref
CASE blocked, implies
'do nothing
CASE ELSE
addtoblocked (p)
END SELECT
NEXT
END IF
IF allreadyfound = 0 THEN
IF posnr = 0 THEN
'no solution
sstatus = 2
EXIT SUB
END IF
IF posnr = 1 THEN
'found symbol
addtosolution (posp)
IF sstatus > 0 THEN EXIT SUB
solverloop = 1
testoptions(t) = 1
newfound = 1
ELSE
testoptions(t) = posnr
IF blockedoptions + posnr <> sz2 THEN
STOP
END IF
END IF
END IF
END IF
NEXT
LOOP UNTIL newfound = 0

statustest

END SUB

SUB solver2

'solver2
'if a test has only two options and both block the same place
'then block that place

message2 "solver2"

[/code]

soduko · Posted: Sat Jul 11, 2009 7:15 am Post subject:

oops it stoped after solver 2

here from sub solver 2 onwards

PIsaacson · Posted: Mon Jul 13, 2009 12:22 pm Post subject:

Suduko,

I compiled your code using qb64, but it required changing all the STOP statements to END and commenting out the FRE memory usage displays. Apparently, qb64 is "work in progress", but it translates the QBasic code to C++ which it then compiles using g++, so it requires cygwin or Mingw.

So, my problem is that a blind port probably isn't the best way to discover what's going on, but after compiling and attempting to execute, I keep getting an error in line 383 in the subroutine addtosolutiondry on the line:

soduko · Posted: Wed Jul 15, 2009 4:57 pm Post subject:

the first problem

yes a line cel= placetocel(place) is missing.

at the moment i am on holyday so cannot check my program.

(it should give an error and it did not )

funny that the program still worked. (there is a lot of double work in the program, one of the reasons it is that slow)

the routine for doing the top 50000 is in the main routine.

( just look at it and remove all that is unnessesary.)

the program is very slow at the moment, next version will be much quicker.

but realy quick will take longer.

how did you guess the missing line?

PIsaacson · Posted: Thu Jul 16, 2009 5:28 pm Post subject:

energztm · Posted: Tue Jul 21, 2009 2:55 pm Post subject:

I think posting it here is a great idea.