//Program.fs
open FData.ExactCover
open System
//In the standard 9×9 Sudoku variant, there are four kinds of constraints
type Constraint =
| Row of int * int //Row-Number: Each row must contain each number exactly once.
| Col of int * int //Column-Number: Each column must contain each number exactly once.
| Box of int * int //Box-Number: Each box must contain each number exactly once.
| Pos of int * int //Row-Column: Each intersection of a row and column, i.e, each cell, must contain exactly one number.
| Given of int
type Move
= { mRow : int; mCol : int; mVal : int }
let inline box r c = ((r-1) / 3) * 3 + ((c-1) / 3) + 1
//Since there are 9 rows, 9 columns, 9 boxes and 9 numbers, there are 9×9=81 row-column constraint sets,
//9×9=81 row-number constraint sets, 9×9=81 column-number constraint sets,
// and 9×9=81 box-number constraint sets: 81+81+81+81=324 constraint sets in all.
let inline constraintsFor rest m =
(m, Pos(m.mRow, m.mCol)) :: (m, Row(m.mRow, m.mVal)) ::
(m, Col(m.mCol, m.mVal)) :: (m, Box(box m.mRow m.mCol, m.mVal)) :: rest
let inline constraints givenMarks =
//In the standard 9×9 Sudoku variant, in which each of 9×9 cells is assigned one of 9 numbers,
// there are 9×9×9=729 possibilities.
let l =
seq {for r in 1..9 do
for c in 1..9 do
for v in 1..9 do
yield { mRow = r; mCol = c; mVal = v }}
let input =
Seq.append
(Seq.mapi (fun i (r,c,v) ->
{ mRow = r; mCol = c; mVal = v }, Given (i + 1)) givenMarks)
(Seq.fold constraintsFor [] l)
addCover input
let inline zipCoords s =
let coords =
seq {for r in 1..9 do
for c in 1..9 do
yield (r,c)}
Seq.zip coords s
let inline board input =
seq{for (r,c),v in zipCoords input do if v>0 then yield (r,c,v)}
let inline problem s=
List.concat s
|>board
|>constraints
let test f=
printfn "Test Start."
let sw = new System.Diagnostics.Stopwatch()
sw.Start()
let res=f ()
sw.Stop()
printfn "Time Duration : %A" sw.ElapsedMilliseconds
//printfn "Result : %A" res
//simple Sudoku
let s2 =
[[0; 0; 8; 3; 0; 0; 6; 0; 0]
[0; 0; 4; 0; 0; 0; 0; 1; 0]
[6; 7; 0; 0; 8; 0; 0; 0; 0]
[0; 1; 6; 4; 3; 0; 0; 0; 0]
[0; 0; 0; 7; 9; 0; 0; 2; 0]
[0; 9; 0; 0; 0; 0; 4; 0; 1]
[0; 0; 0; 9; 1; 0; 0; 0; 5]
[0; 0; 3; 0; 5; 0; 0; 0; 2]
[0; 5; 0; 0; 0; 0; 0; 7; 4]]
//middle
let s3 =
[[1;0;0;0;0;7;0;9;0];
[0;3;0;0;2;0;0;0;8];
[0;0;9;6;0;0;5;0;0];
[0;0;5;3;0;0;9;0;0];
[0;1;0;0;8;0;0;0;2];
[6;0;0;0;0;4;0;0;0];
[3;0;0;0;0;0;0;1;0];
[0;4;0;0;0;0;0;0;7];
[0;0;7;0;0;0;3;0;0]]
//hard
let s4 =
[[0;0;0; 0;0;0; 0;0;8];
[0;0;3; 0;0;0; 4;0;0];
[0;9;0; 0;2;0; 0;6;0];
[0;0;0; 0;7;9; 0;0;0];
[0;0;0; 0;6;1; 2;0;0];
[0;6;0; 5;0;2; 0;7;0];
[0;0;8; 0;0;0; 5;0;0];
[0;1;0; 0;0;0; 0;2;0];
[4;0;5; 0;0;0; 0;0;3]]
test (fun()-> problem s2|>solveExactCover)
test (fun()-> problem s3|>solveExactCover)
test (fun()-> problem s4|>solveExactCover)//ExactCover.fs
namespace FData
open System
[<RequireQualifiedAccess>]
module PrioSeq =
type PSQ<'k, 'p> =
| Void
| Winner of 'k * 'p * LTree<'k, 'p> * 'k
and LTree<'k, 'p> =
| Start
| LLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
| RLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
let inline play t1 t2 =
match t1, t2 with
| Void, t -> t
| t, Void -> t
| Winner (k, p, t, m), Winner (k', p', t', m') ->
match p <= p' with
| true -> Winner(k, p, RLoser(k', p', t, m, t'), m')
| false -> Winner(k', p', LLoser(k, p, t, m, t'), m')
type TourView<'k, 'p> =
| Null
| Single of 'k * 'p
| Play of PSQ<'k, 'p> * PSQ<'k, 'p>
let inline tourView psq =
match psq with
| Void -> Null
| Winner(k, p, Start, _) -> Single(k, p)
| Winner(k, p, RLoser(k', p', tl, m, tr), m') -> Play(Winner(k, p, tl, m), Winner(k', p', tr, m'))
| Winner(k, p, LLoser(k', p', tl, m, tr), m') -> Play(Winner(k', p', tl, m), Winner(k, p, tr, m'))
let empty = Void
let inline single (k, p) = Winner(k, p, Start, k)
let inline key (k,_) = k
let inline prio (_, p) = p
let inline maxKey (Winner (_, _, _, m)) = m
let rec insert b q =
match tourView q with
| Null -> single b
| Single(k,p) when key b < k -> play (single b) (single(k, p))
| Single(k,p) when key b = k -> single b
| Single(k,p) -> play (single(k, p)) (single b)
| Play(tl, tr) when key b <= maxKey tl -> play (insert b tl) tr
| Play(tl, tr) -> play tl (insert b tr)
let inline foldm f e x =
let rec inner n xs =
match n, xs with
| 1, y::ys -> (y, ys)
| n, ys ->
let m = n / 2
let (y1, ys1) = inner (n-m) ys
let (y2, ys2) = inner m ys1
f y1 y2, ys2
match x with
| [] -> e
| _ -> fst (inner (List.length x) x)
let inline fromOrdList l =
foldm play empty l
let rec toOrdLists q=
match tourView q with
| Null -> List.empty
| Single(k, p) -> [single (k, p)]
| Play(tl, tr) -> (toOrdLists tl) @ (toOrdLists tr)
let inline rebalance<'k,'p when 'p : comparison> : (PSQ<'k, 'p> ->PSQ<'k, 'p>)= fromOrdList<<toordlists
let lookup k p =
match tourView q with
| Null -> None
| Single(k', p) when k = k' -> Some p
| Single(k', p) -> None
| Play(tl, tr) when k <= maxKey tl -> lookup k tl
| Play(tl, tr) -> lookup k tr
let rec delete k q =
match tourView q with
| Null -> empty
| Single(k', p) when k = k' -> empty
| Single(k', p) -> single (k', p)
| Play(tl, tr) when k <= maxKey tl -> play (delete k tl) tr
| Play(tl, tr) -> play tl (delete k tr)
type MinView<'k, 'p> =
| Empty
| Min of ('k * 'p)
let inline minView q =
match q with
| Void -> Empty
| Winner(k, p, t, m) -> Min (k, p)
let rec adjust f key q =
match q with
| Void -> Void
| Winner(k, p, Start, _) when key = k -> single (k, (f p))
| Winner(k, p, Start, _) -> single (k, p)
| Winner(k, p, RLoser(k', p', tl, m, tr), m') when key <= m ->
play (adjust f key (Winner(k, p, tl, m))) (Winner(k', p', tr, m'))
| Winner(k, p, RLoser(k', p', tl, m, tr), m') ->
play (Winner(k, p, tl, m)) (adjust f key (Winner(k', p', tr, m')))
| Winner(k, p, LLoser(k', p', tl, m, tr), m') when key <= m ->
play (adjust f key (Winner( k', p', tl, m))) (Winner(k, p, tr, m'))
| Winner(k, p, LLoser(k', p', tl, m, tr), m') ->
let w2 = Winner(k, p, tr, m')
play (Winner(k', p', tl, m)) (adjust f key w2)
module ExactCover =
open System.Collections.Generic
open Microsoft.FSharp.Collections
type ECValue<'r when 'r : comparison> = { ecvSize : int; ecvRows : Set<'r> }
type ExactCover<'r, 'c when 'r : comparison and 'c : comparison> =
{ ecCol : PrioSeq.PSQ<'c, ECValue<'r>>; ecRow : Map<'r, Set<'c>> }
let inline emptyCover<'c, 'r when 'c : comparison and 'r : comparison> =
{ecCol = PrioSeq.empty; ecRow = Map.empty}
let inline addCover rcs =
let createMap f g =
rcs
|>Seq.groupBy f
|>Seq.map (fun (x, ys) -> x, Seq.map g ys|>Set.ofSeq)
let col =
createMap snd fst
|>Seq.fold (fun acc (c, m) ->
PrioSeq.insert (c, {ecvSize = Set.count m ; ecvRows = m}) acc
) PrioSeq.empty
let row =
createMap fst snd
|>Map.ofSeq
{ ecCol = PrioSeq.rebalance col; ecRow = row }
let inline flip f a b = f b a
let rec solve soFar ec =
match PrioSeq.minView ec.ecCol with
| PrioSeq.Empty -> soFar
| PrioSeq.Min(_, rs) ->
let setDifference ys ecv =
let zs = ecv.ecvRows - ys
{ ecvSize = Set.count zs; ecvRows = zs }
Seq.map (fun move ->
//Get all constraints of current move
let constraints = Map.find move ec.ecRow
//Get all moves of selected constraints
let moves = Set.unionMany (Seq.map (fun k ->
match PrioSeq.lookup k ec.ecCol with
| Some ecv -> ecv.ecvRows
| None -> failwith ("Nothing" + k.ToString())) constraints)
//all posible constraints for selected moves
let posibleConstraints = Seq.concat (Seq.map (flip Map.find ec.ecRow) moves)
let newCol =
//delete all constraints of current move
let acc = Seq.fold (flip PrioSeq.delete) ec.ecCol constraints
//update posible constraints for selected moves
Seq.fold (flip (PrioSeq.adjust (setDifference moves))) acc posibleConstraints
let newRow = Seq.fold (flip Map.remove) ec.ecRow moves
solve (Set.add move soFar) {ecCol = newCol; ecRow = newRow}) rs.ecvRows
|>Set.unionMany
let inline solveExactCover ec = solve Set.empty ec|>Set.toListTest Start.
Time Duration : 342L
Test Start.
Time Duration : 545L
Test Start.
Time Duration : 3713L
0 Kommentare:
Kommentar veröffentlichen