mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
bc923bb6b1
What is Frege? ------------- Frege is a non-strict, pure functional programming language in the spirit of Haskell for the JVM. It enjoys a strong static type system with type inference. Higher rank types are supported, though type annotations are required for that. Frege programs are compiled to Java and run in a JVM. Existing Java Classes and Methods can be used seamlessly from Frege. The Frege programming language is named after and in honor of Gottlob Frege. Project State: ------------- The compiler, an Eclipse plugin and a provisional version of the documentation can be downloaded from here https://github.com/Frege/frege/releases. The REPL can be downloaded from here https://github.com/Frege/frege-repl/releases. An online REPL is running here http://try.frege-lang.org/. Examples: -------- 1) Command Line Clock: https://github.com/Frege/frege/blob/master/examples/CommandLineClock.fr 2) Brainfuck: https://github.com/Frege/frege/blob/master/examples/Brainfuck.fr 3) Concurrency: https://github.com/Frege/frege/blob/master/examples/Concurrent.fr 4) Sudoku: https://github.com/Frege/frege/blob/master/examples/Sudoku.fr 5) Java Swing examples: https://github.com/Frege/frege/blob/master/examples/SwingExamples.fr
562 lines
23 KiB
Plaintext
562 lines
23 KiB
Plaintext
package examples.Sudoku where
|
|
|
|
import Data.TreeMap (Tree, keys)
|
|
import Data.List as DL hiding (find, union)
|
|
|
|
|
|
type Element = Int -- 1,2,3,4,5,6,7,8,9
|
|
type Zelle = [Element] -- set of candidates
|
|
type Position = Int -- 0..80
|
|
type Feld = (Position, Zelle)
|
|
type Brett = [Feld]
|
|
|
|
--- data type for assumptions and conclusions
|
|
data Assumption =
|
|
!ISNOT Position Element
|
|
| !IS Position Element
|
|
|
|
|
|
derive Eq Assumption
|
|
derive Ord Assumption
|
|
instance Show Assumption where
|
|
show (IS p e) = pname p ++ "=" ++ e.show
|
|
show (ISNOT p e) = pname p ++ "/" ++ e.show
|
|
|
|
showcs cs = joined " " (map Assumption.show cs)
|
|
|
|
elements :: [Element] -- all possible elements
|
|
elements = [1 .. 9]
|
|
|
|
{-
|
|
a b c d e f g h i
|
|
0 1 2 | 3 4 5 | 6 7 8 1
|
|
9 10 11 |12 13 14 |15 16 17 2
|
|
18 19 20 |21 22 23 |24 25 26 3
|
|
---------|---------|--------
|
|
27 28 29 |30 31 32 |33 34 35 4
|
|
36 37 38 |39 40 41 |42 43 44 5
|
|
45 46 47 |48 49 50 |51 52 53 6
|
|
---------|---------|--------
|
|
54 55 56 |57 58 59 |60 61 62 7
|
|
63 64 65 |66 67 68 |69 70 71 8
|
|
72 73 74 |75 76 77 |78 79 80 9
|
|
-}
|
|
|
|
positions :: [Position] -- all possible positions
|
|
positions = [0..80]
|
|
rowstarts :: [Position] -- all positions where a row is starting
|
|
rowstarts = [0,9,18,27,36,45,54,63,72]
|
|
colstarts :: [Position] -- all positions where a column is starting
|
|
colstarts = [0,1,2,3,4,5,6,7,8]
|
|
boxstarts :: [Position] -- all positions where a box is starting
|
|
boxstarts = [0,3,6,27,30,33,54,57,60]
|
|
boxmuster :: [Position] -- pattern for a box, by adding upper left position results in real box
|
|
boxmuster = [0,1,2,9,10,11,18,19,20]
|
|
|
|
|
|
--- extract field for position
|
|
getf :: Brett -> Position -> Feld
|
|
getf (f:fs) p
|
|
| fst f == p = f
|
|
| otherwise = getf fs p
|
|
getf [] p = (p,[])
|
|
|
|
|
|
--- extract cell for position
|
|
getc :: Brett -> Position -> Zelle
|
|
getc b p = snd (getf b p)
|
|
|
|
--- compute the list of all positions that belong to the same row as a given position
|
|
row :: Position -> [Position]
|
|
row p = [z..(z+8)] where z = (p `quot` 9) * 9
|
|
|
|
--- compute the list of all positions that belong to the same col as a given position
|
|
col :: Position -> [Position]
|
|
col p = map (c+) rowstarts where c = p `mod` 9
|
|
|
|
--- compute the list of all positions that belong to the same box as a given position
|
|
box :: Position -> [Position]
|
|
box p = map (z+) boxmuster where
|
|
ri = p `div` 27 * 27 -- 0, 27 or 54, depending on row
|
|
ci = p `mod` 9 -- column index 0..8, 0,1,2 is left, 3,4,5 is middle, 6,7,8 is right
|
|
cs = ci `div` 3 * 3 -- 0, 3 or 6
|
|
z = ri + cs
|
|
|
|
--- check if candidate set has exactly one member, i.e. field has been solved
|
|
single :: Zelle -> Bool
|
|
single [_] = true
|
|
single _ = false
|
|
|
|
unsolved :: Zelle -> Bool
|
|
unsolved [_] = false
|
|
unsolved _ = true
|
|
|
|
-- list of rows, cols, boxes
|
|
allrows = map row rowstarts
|
|
allcols = map col colstarts
|
|
allboxs = map box boxstarts
|
|
allrcb = zip (repeat "row") allrows
|
|
++ zip (repeat "col") allcols
|
|
++ zip (repeat "box") allboxs
|
|
|
|
|
|
containers :: [(Position -> [Position], String)]
|
|
containers = [(row, "row"), (col, "col"), (box, "box")]
|
|
|
|
-- ----------------- PRINTING ------------------------------------
|
|
-- printable coordinate of field, upper left is a1, lower right is i9
|
|
pname p = packed [chr (ord 'a' + p `mod` 9), chr (ord '1' + p `div` 9)]
|
|
|
|
-- print board
|
|
printb b = mapM_ p1line allrows >> println ""
|
|
where
|
|
p1line row = do
|
|
print (joined "" (map pfld line))
|
|
where line = map (getc b) row
|
|
|
|
-- print field (brief)
|
|
-- ? = no candidate
|
|
-- 5 = field is 5
|
|
-- . = some candidates
|
|
pfld [] = "?"
|
|
pfld [x] = show x
|
|
pfld zs = "0"
|
|
|
|
-- print initial/final board
|
|
result msg b = do
|
|
println ("Result: " ++ msg)
|
|
print ("Board: ")
|
|
printb b
|
|
return b
|
|
|
|
res012 b = case concatMap (getc b) [0,1,2] of
|
|
[a,b,c] -> a*100+b*10+c
|
|
_ -> 9999999
|
|
|
|
-- -------------------------- BOARD ALTERATION ACTIONS ---------------------------------
|
|
-- print a message about what is done to the board and return the new board
|
|
turnoff1 :: Position -> Zelle -> Brett -> IO Brett
|
|
turnoff1 i off b
|
|
| single nc = do
|
|
-- print (pname i)
|
|
-- print ": set to "
|
|
-- print (head nc)
|
|
-- println " (naked single)"
|
|
return newb
|
|
| otherwise = return newb
|
|
where
|
|
cell = getc b i
|
|
nc = filter (`notElem` off) cell
|
|
newb = (i, nc) : [ f | f <- b, fst f != i ]
|
|
|
|
turnoff :: Int -> Zelle -> String -> Brett -> IO Brett
|
|
turnoff i off msg b = do
|
|
-- print (pname i)
|
|
-- print ": set to "
|
|
-- print nc
|
|
-- print " by clearing "
|
|
-- print off
|
|
-- print " "
|
|
-- println msg
|
|
return newb
|
|
where
|
|
cell = getc b i
|
|
nc = filter (`notElem` off) cell
|
|
newb = (i, nc) : [ f | f <- b, fst f != i ]
|
|
|
|
turnoffh ps off msg b = foldM toh b ps
|
|
where
|
|
toh b p = turnoff p off msg b
|
|
|
|
setto :: Position -> Element -> String -> Brett -> IO Brett
|
|
setto i n cname b = do
|
|
-- print (pname i)
|
|
-- print ": set to "
|
|
-- print n
|
|
-- print " (hidden single in "
|
|
-- print cname
|
|
-- println ")"
|
|
return newb
|
|
where
|
|
nf = [n]
|
|
newb = (i, nf) : [ f | f <- b, fst f != i ]
|
|
|
|
|
|
-- ----------------------------- SOLVING STRATEGIES ---------------------------------------------
|
|
-- reduce candidate sets that contains numbers already in same row, col or box
|
|
-- This finds (and logs) NAKED SINGLEs in passing.
|
|
reduce b = [ turnoff1 p sss | (p,cell) <- b, -- for each field
|
|
unsolved cell, -- with more than 1 candidate
|
|
-- single fields in containers that are candidates of that field
|
|
sss = [ s | (rcb, _) <- containers, [s] <- map (getc b) (rcb p), s `elem` cell],
|
|
sss != [] ] -- collect field index, elements to remove from candidate set
|
|
|
|
-- look for a number that appears in exactly 1 candidate set of a container
|
|
-- this number can go in no other place (HIDDEN SINGLE)
|
|
hiddenSingle b = [ setto i n cname | -- select index, number, containername
|
|
(cname, rcb) <- allrcb, -- FOR rcb IN allrcb
|
|
n <- elements, -- FOR n IN elements
|
|
fs = filter (unsolved • snd) (map (getf b) rcb),
|
|
occurs = filter ((n `elem`) • snd) fs,
|
|
length occurs == 1,
|
|
(i, _) <- occurs ]
|
|
|
|
-- look for NAKED PAIRS, TRIPLES, QUADS
|
|
nakedPair n b = [ turnoff p t ("(naked tuple in " ++ nm ++ ")") | -- SELECT pos, tuple, name
|
|
-- n <- [2,3,4], // FOR n IN [2,3,4]
|
|
(nm, rcb) <- allrcb, -- FOR rcb IN containers
|
|
fs = map (getf b) rcb, -- let fs = fields for rcb positions
|
|
u = (fold union [] . filter unsolved . map snd) fs, -- let u = union of non single candidates
|
|
t <- n `outof` u, -- FOR t IN n-tuples
|
|
hit = (filter ((`subset` t) . snd) . filter (unsolved . snd)) fs,
|
|
length hit == n,
|
|
(p, cell) <- fs,
|
|
p `notElem` map fst hit,
|
|
any (`elem` cell) t
|
|
]
|
|
|
|
-- look for HIDDEN PAIRS, TRIPLES or QUADS
|
|
hiddenPair n b = [ turnoff p off ("(hidden " ++ show t ++ " in " ++ nm ++ ")") | -- SELECT pos, tuple, name
|
|
-- n <- [2,3,4], // FOR n IN [2,3,4]
|
|
(nm, rcb) <- allrcb, -- FOR rcb IN containers
|
|
fs = map (getf b) rcb, -- let fs = fields for rcb positions
|
|
u = (fold union [] . filter ((>1) . length) . map snd) fs, -- let u = union of non single candidates
|
|
t <- n `outof` u, -- FOR t IN n-tuples
|
|
hit = (filter (any ( `elem` t) . snd) . filter (unsolved . snd)) fs,
|
|
length hit == n,
|
|
off = (fold union [] . map snd) hit `minus` t,
|
|
off != [],
|
|
(p, cell) <- hit,
|
|
! (cell `subset` t)
|
|
]
|
|
|
|
a `subset` b = all (`elem` b) a
|
|
a `union` b = uniq (sort (a ++ b))
|
|
a `minus` b = filter (`notElem` b) a
|
|
a `common` b = filter (`elem` b) a
|
|
n `outof` as
|
|
| length as < n = []
|
|
| [] <- as = []
|
|
| 1 >= n = map (:[]) as
|
|
| (a:bs) <- as = map (a:) ((n-1) `outof` bs) ++ (n `outof` bs)
|
|
| otherwise = undefined -- cannot happen because either as is empty or not
|
|
|
|
same f a b = b `elem` f a
|
|
|
|
intersectionlist = [(allboxs, row, "box/row intersection"), (allboxs, col, "box/col intersection"),
|
|
(allrows ++ allcols, box, "line/box intersection")]
|
|
intersections b = [
|
|
turnoff pos [c] reason | -- SELECT position, candidate, reson
|
|
(from, container, reason) <- intersectionlist,
|
|
rcb <- from,
|
|
fs = (filter (unsolved . snd) . map (getf b)) rcb, -- fs = fields in from with more than 1 candidate
|
|
c <- (fold union [] • map snd) fs, -- FOR c IN union of candidates
|
|
cpos = (map fst • filter ((c `elem`) • snd)) fs, -- cpos = positions where c occurs
|
|
cpos != [], -- WHERE cpos is not empty
|
|
all (same container (head cpos)) (tail cpos), -- WHERE all positions are in the intersection
|
|
-- we can remove all occurences of c that are in container, but not in from
|
|
(pos, cell) <- map (getf b) (container (head cpos)),
|
|
c `elem` cell,
|
|
pos `notElem` rcb ]
|
|
|
|
|
|
-- look for an XY Wing
|
|
-- - there exists a cell A with candidates X and Y
|
|
-- - there exists a cell B with candidates X and Z that shares a container with A
|
|
-- - there exists a cell C with candidates Y and Z that shares a container with A
|
|
-- reasoning
|
|
-- - if A is X, B will be Z
|
|
-- - if A is Y, C will be Z
|
|
-- - since A will indeed be X or Y -> B or C will be Z
|
|
-- - thus, no cell that can see B and C can be Z
|
|
xyWing board = [ turnoff p [z] ("xy wing " ++ pname b ++ " " ++ pname c ++ " because of " ++ pname a) |
|
|
(a, [x,y]) <- board, -- there exists a cell a with candidates x and y
|
|
rcba = map (getf board) (row a ++ col a ++ box a), -- rcba = all fields that share a container with a
|
|
(b, [b1, b2]) <- rcba,
|
|
b != a,
|
|
b1 == x && b2 != y || b2 == x && b1 != y, -- there exists a cell B with candidates x and z
|
|
z = if b1 == x then b2 else b1,
|
|
(c, [c1, c2]) <- rcba,
|
|
c != a, c!= b,
|
|
c1 == y && c2 == z || c1 == z && c2 == y, -- there exists a cell C with candidates y and z
|
|
ps = (uniq . sort) ((row b ++ col b ++ box b) `common` (row c ++ col c ++ box c)),
|
|
-- remove z in ps
|
|
(p, cs) <- map (getf board) ps,
|
|
p != b, p != c,
|
|
z `elem` cs ]
|
|
|
|
-- look for a N-Fish (2: X-Wing, 3: Swordfish, 4: Jellyfish)
|
|
-- When all candidates for a particular digit in N rows are located
|
|
-- in only N columns, we can eliminate all candidates from those N columns
|
|
-- which are not located on those N rows
|
|
fish n board = fish "row" allrows row col ++ fish "col" allcols col row where
|
|
fishname 2 = "X-Wing"
|
|
fishname 3 = "Swordfish"
|
|
fishname 4 = "Jellyfish"
|
|
fishname _ = "unknown fish"
|
|
fish nm allrows row col = [ turnoff p [x] (fishname n ++ " in " ++ nm ++ " " ++ show (map (pname . head) rset)) |
|
|
rset <- n `outof` allrows, -- take n rows (or cols)
|
|
x <- elements, -- look for certain number
|
|
rflds = map (filter ((>1) . length . snd) . map (getf board)) rset, -- unsolved fields in the rowset
|
|
colss = (map (map (head . col . fst) . filter ((x `elem`) . snd)) rflds), -- where x occurs in candidates
|
|
all ((>1) . length) colss, -- x must appear in at least 2 cols
|
|
cols = fold union [] colss,
|
|
length cols == n,
|
|
cstart <- cols,
|
|
(p, cell) <- map (getf board) (col cstart),
|
|
x `elem` cell,
|
|
all (p `notElem`) rset]
|
|
|
|
|
|
-- compute immediate consequences of an assumption of the form (p `IS` e) or (p `ISNOT` e)
|
|
conseq board (IS p e) = uniq (sort ([ p `ISNOT` x | x <- getc board p, x != e ] ++
|
|
[ a `ISNOT` e |
|
|
(a,cs) <- map (getf board) (row p ++ col p ++ box p),
|
|
a != p,
|
|
e `elem` cs
|
|
]))
|
|
conseq board (ISNOT p e) = uniq (sort ([ p `IS` x | cs = getc board p, length cs == 2, x <- cs, x != e ] ++
|
|
[ a `IS` e |
|
|
cp <- [row p, box p, col p],
|
|
as = (filter ((e `elem`) . getc board) . filter (p!=)) cp,
|
|
length as == 1,
|
|
a = head as
|
|
]))
|
|
|
|
-- check if two assumptions contradict each other
|
|
contradicts (IS a x) (IS b y) = a==b && x!=y
|
|
contradicts (IS a x) (ISNOT b y) = a==b && x==y
|
|
contradicts (ISNOT a x) (IS b y) = a==b && x==y
|
|
contradicts (ISNOT _ _) (ISNOT _ _) = false
|
|
|
|
-- get the Position of an Assumption
|
|
aPos (IS p _) = p
|
|
aPos (ISNOT p _) = p
|
|
|
|
-- get List of elements that must be turned off when assumption is true/false
|
|
toClear board true (IS p x) = filter (x!=) (getc board p)
|
|
toClear board false (IS p x) = [x]
|
|
toClear board true (ISNOT p x) = [x]
|
|
toClear board false (ISNOT p x) = filter (x!=) (getc board p)
|
|
|
|
|
|
-- look for assumptions whose implications contradict themself
|
|
chain board paths = [ solution a (head cs) (reverse cs) |
|
|
(a, css) <- paths,
|
|
cs <- take 1 [ cs | cs <- css, contradicts a (head cs) ]
|
|
]
|
|
where
|
|
solution a c cs = turnoff (aPos a) (toClear board false a) reason where
|
|
reason = "Assumption " ++ show a ++ " implies " ++ show c ++ "\n\t"
|
|
++ showcs cs ++ "\n\t"
|
|
++ "Therefore, " ++ show a ++ " must be false."
|
|
|
|
-- look for an assumption that yields to contradictory implications
|
|
-- this assumption must be false
|
|
chainContra board paths = [ solution a (reverse pro) (reverse contra) |
|
|
(a, css) <- paths, -- FOR ALL assumptions "a" with list of conlusions "css"
|
|
(pro, contra) <- take 1 [ (pro, contra) |
|
|
pro <- (uniqBy (using head) . sortBy (comparing head)) css, -- FOR ALL conslusion chains "pro"
|
|
c = head pro, -- LET "c" BE the final conclusion
|
|
contra <- take 1 (filter ((contradicts c) . head) css) -- THE FIRST conclusion that contradicts c
|
|
]
|
|
]
|
|
where
|
|
solution a pro con = turnoff (aPos a) (toClear board false a) reason where
|
|
reason = ("assumption " ++ show a ++ " leads to contradictory conclusions\n\t"
|
|
++ showcs pro ++ "\n\t" ++ showcs con)
|
|
|
|
|
|
|
|
-- look for a common implication c of some assumptions ai, where at least 1 ai is true
|
|
-- so that (a0 OR a1 OR a2 OR ...) IMPLIES c
|
|
-- For all cells pi in same container that have x as candidate, we can construct (p0==x OR p1==x OR ... OR pi==x)
|
|
-- For a cell p with candidates ci, we can construct (p==c0 OR p==c1)
|
|
cellRegionChain board paths = [ solution b as (map head os) |
|
|
as <- cellas ++ regionas, -- one of as must be true
|
|
iss = filter ((`elem` as) . fst) paths, -- the implications for as
|
|
(a, ass) <- take 1 iss, -- implications for first assumption
|
|
fs <- (uniqBy (using head) . sortBy (comparing head)) ass,
|
|
b = head fs, -- final conclusions of first assumption
|
|
os = [fs] : map (take 1 . filter ((b==) . head) . snd) (tail iss), -- look for implications with same conclusion
|
|
all ([]!=) os]
|
|
where
|
|
cellas = [ map (p `IS`) candidates | (p, candidates@(_:_:_)) <- board ]
|
|
regionas = [ map (`IS` e) ps |
|
|
region <- map (map (getf board)) (allrows ++ allcols ++ allboxs),
|
|
e <- elements,
|
|
ps = map fst (filter ((e `elem`) . snd) region),
|
|
length ps > 1 ]
|
|
solution b as oss = turnoff (aPos b) (toClear board true b) reason where
|
|
reason = "all of the assumptions " ++ joined ", " (map show as) ++ " imply " ++ show b ++ "\n\t"
|
|
++ joined "\n\t" (map (showcs . reverse) oss) ++ "\n\t"
|
|
++ "One of them must be true, so " ++ show b ++ " must be true."
|
|
|
|
|
|
{-
|
|
Wir brauchen für einige Funktionen eine Datenstruktur wie
|
|
[ (Assumption, [[Assumption]]) ]
|
|
d.i. eine Liste von möglichen Annahmen samt aller Schlußketten.
|
|
Idealerweise sollte die Schlußkette in umgekehrter Reihenfolge vorliegen,
|
|
dann kann man einfach finden:
|
|
- Annahmen, die zum Selbstwiderspruch führen.
|
|
- alles, was aus einer bestimmten Annahme folgt (map (map head) [[a]])
|
|
-...
|
|
-}
|
|
--- Liste aller Annahmen für ein bestimmtes Brett
|
|
assumptions :: Brett -> [Assumption]
|
|
assumptions board = [ a |
|
|
(p, cs) <- board,
|
|
!(single cs),
|
|
a <- map (ISNOT p) cs ++ map (IS p) cs ]
|
|
|
|
consequences :: Brett -> [Assumption] -> [[Assumption]]
|
|
consequences board as = map (conseq board) as
|
|
|
|
acstree :: Brett -> Tree Assumption [Assumption]
|
|
acstree board = Tree.fromList (zip as cs)
|
|
where
|
|
as = assumptions board
|
|
cs = consequences board as
|
|
|
|
-- bypass maybe on tree lookup
|
|
find :: Tree Assumption [Assumption] -> Assumption -> [Assumption]
|
|
find t a
|
|
| Just cs <- t.lookup a = cs
|
|
| otherwise = error ("no consequences for " ++ show a)
|
|
|
|
-- for performance resons, we confine ourselves to implication chains of length 20 per assumption
|
|
mkPaths :: Tree Assumption [Assumption] -> [ (Assumption, [[Assumption]]) ]
|
|
mkPaths acst = map impl (keys acst) -- {[a1], [a2], [a3] ]
|
|
where
|
|
-- [Assumption] -> [(a, [chains, ordered by length]
|
|
impl a = (a, impls [[a]])
|
|
impls ns = (take 1000 • concat • takeUntil null • iterate expandchain) ns
|
|
-- expandchain :: [[Assumption]] -> [[Assumption]]
|
|
expandchain css = [ (n:a:as) |
|
|
(a : as) <- css, -- list of assumptions
|
|
n <- find acst a, -- consequences of a
|
|
n `notElem` as -- avoid loops
|
|
]
|
|
-- uni (a:as) = a : uni (filter ((head a !=) • head) as)
|
|
-- uni [] = empty
|
|
-- empty = []
|
|
|
|
|
|
-- ------------------ SOLVE A SUDOKU --------------------------
|
|
-- Apply all available strategies until nothing changes anymore
|
|
-- Strategy functions are supposed to return a list of
|
|
-- functions, which, when applied to a board, give a changed board.
|
|
-- When a strategy does not find anything to alter,
|
|
-- it returns [], and the next strategy can be tried.
|
|
solve b
|
|
| all (single . snd) b = result "Solved" b
|
|
| any (([]==) . snd) b = result "not solvable" b
|
|
| res@(_:_) <- reduce b = apply b res >>=solve -- compute smallest candidate sets
|
|
-- comment "candidate sets are up to date" = ()
|
|
| res@(_:_) <- hiddenSingle b = apply b res >>= solve -- find HIDDEN SINGLES
|
|
-- comment "no more hidden singles" = ()
|
|
| res@(_:_) <- intersections b = apply b res >>= solve -- find locked candidates
|
|
-- comment "no more intersections" = ()
|
|
| res@(_:_) <- nakedPair 2 b = apply b res >>= solve -- find NAKED PAIRS, TRIPLES or QUADRUPELS
|
|
-- comment "no more naked pairs" = ()
|
|
| res@(_:_) <- hiddenPair 2 b = apply b res >>= solve -- find HIDDEN PAIRS, TRIPLES or QUADRUPELS
|
|
-- comment "no more hidden pairs" = ()
|
|
-- res@(_:_) <- nakedPair 3 b = apply b res >>= solve // find NAKED PAIRS, TRIPLES or QUADRUPELS
|
|
-- | comment "no more naked triples" = ()
|
|
-- res@(_:_) <- hiddenPair 3 b = apply b res >>= solve // find HIDDEN PAIRS, TRIPLES or QUADRUPELS
|
|
-- | comment "no more hidden triples" = ()
|
|
-- res@(_:_) <- nakedPair 4 b = apply b res >>=solve // find NAKED PAIRS, TRIPLES or QUADRUPELS
|
|
-- | comment "no more naked quadruples" = ()
|
|
-- res@(_:_) <- hiddenPair 4 b = apply b res >>=solve // find HIDDEN PAIRS, TRIPLES or QUADRUPELS
|
|
-- | comment "no more hidden quadruples" = ()
|
|
| res@(_:_) <- xyWing b = apply b res >>=solve -- find XY WINGS
|
|
-- comment "no more xy wings" = ()
|
|
| res@(_:_) <- fish 2 b = apply b res >>=solve -- find 2-FISH
|
|
-- comment "no more x-wings" = ()
|
|
-- res@(_:_) <- fish 3 b = apply b res >>=solve // find 3-FISH
|
|
-- | comment "no more swordfish" = ()
|
|
-- res@(_:_) <- fish 4 b = apply b res >>=solve // find 4-FISH
|
|
-- | comment "no more jellyfish" = ()
|
|
-- | comment pcomment = ()
|
|
| res@(_:_) <- chain b paths = apply b (take 9 res) >>= solve -- find forcing chains
|
|
| res@(_:_) <- cellRegionChain b paths = apply b (take 9 res) >>= solve -- find common conclusion for true assumption
|
|
| res@(_:_) <- chainContra b paths = apply b (take 9 res) >>= solve -- find assumptions that allow to infer both a and !a
|
|
-- comment "consistent conclusions only" = ()
|
|
|
|
| otherwise = result "ambiguous" b
|
|
where
|
|
apply brd fs = foldM (\b\f -> f b) brd fs
|
|
paths = mkPaths (acstree b)
|
|
-- pcomment = show (length paths) ++ " assumptions with " ++ show (fold (+) 0 (map (length <~ snd) paths))
|
|
-- ++ " implication chains"
|
|
|
|
-- comment com = do stderr << com << "\n" for false
|
|
-- log com = do stderr << com << "\n" for true
|
|
|
|
--- turn a string into a row
|
|
mkrow :: String -> [Zelle]
|
|
mkrow s = mkrow1 xs
|
|
where
|
|
xs = s ++ "---------" -- make sure at least 9 elements
|
|
mkrow1 xs = (take 9 • filter ([]!=) • map f • unpacked) xs
|
|
f x | x >= '1' && x <= '9' = [ord x - ord '0']
|
|
| x == ' ' = [] -- ignored
|
|
| otherwise = elements
|
|
|
|
main ["-h"] = main []
|
|
main ["-help"] = main []
|
|
main [] = do
|
|
mapM_ stderr.println [
|
|
"usage: java Sudoku file ...",
|
|
" java Sudoku position",
|
|
"where position is a 81 char string consisting of digits",
|
|
"One can get such a string by going to",
|
|
"http://www.sudokuoftheday.com/pages/s-o-t-d.php",
|
|
"Right click on the puzzle and open it in new tab",
|
|
"Copy the 81 digits from the URL in the address field of your browser.",
|
|
"",
|
|
"There is also a file with hard sudokus in examples/top95.txt\n"]
|
|
return ()
|
|
|
|
|
|
main [s@#^[0-9\W]{81}$#] = solve board >> return ()
|
|
where
|
|
board = zip positions felder
|
|
felder = decode s
|
|
|
|
main files = forM_ files sudoku
|
|
where
|
|
sudoku file = do
|
|
br <- openReader file
|
|
lines <- BufferedReader.getLines br
|
|
bs <- process lines
|
|
ss <- mapM (\b -> print "Puzzle: " >> printb b >> solve b) bs
|
|
println ("Euler: " ++ show (sum (map res012 ss)))
|
|
return ()
|
|
|
|
-- "--3-" => [1..9, 1..9, [3], 1..9]
|
|
decode s = map candi (unpacked s) where
|
|
candi c | c >= '1' && c <= '9' = [(ord c - ord '0')]
|
|
| otherwise = elements
|
|
process [] = return []
|
|
process (s:ss)
|
|
| length s == 81 = consider b1
|
|
| length s == 9,
|
|
length acht == 8,
|
|
all ((9==) • length) acht = consider b2
|
|
| otherwise = do
|
|
stderr.println ("skipped line: " ++ s)
|
|
process ss
|
|
where
|
|
acht = take 8 ss
|
|
neun = fold (++) "" (s:acht)
|
|
b1 = zip positions (decode s)
|
|
b2 = zip positions (decode neun)
|
|
consider b = do
|
|
-- print "Puzzle: "
|
|
-- printb b
|
|
bs <- process ss
|
|
return (b:bs)
|
|
|