COMMENT:-----------------------

ghc -O Queens.lhs
ghc -O -fvia-C -O2-for-C Queens.lhs
-------------------------------

> import CPS
> import LibSystem
> import Benchmark

> main                  =  getArgs                              >>= \ args ->
>                          let n = read (args!!0)               in
>                          time (
>                          --  print (length (allSolutions (queens1 n) ()))
>                              print (allSolutions (queens2 n) ()!!0)
>                          --  printAllSolutions (queens1 n) ()
>                          --  printFirstSolution (queens2 n) ()
>                          )

> type Prolog val res   =  BT () val res

> queens1               :: Int -> Prolog [Int] res
> queens1 n             =  place 1 [] [] [1 .. n]
>     where
>     place c d1 d2 rs
>         | c > n       =  unit []
>         | otherwise   =  remove rs                            &= \ (q,rs') ->
>                          guard ((q - c) `notElem` d1)         &
>                          guard ((q + c) `notElem` d2)         &
>                          place (c + 1) ((q - c) : d1)
>                                        ((q + c) : d2) rs'     &= \ qs ->
>                          unit (q:qs)

> remove                :: [a] -> Prolog (a,[a]) res
> remove []             =  zero
> remove (a:x)          =  unit (a,x)
>                       ?? remove x                             &= \ (b,x') ->
>                          unit (b,a:x')

> type Row              =  Int
> type Col              =  Int
> type Board            =  [(Col, Row)]

> queens2               :: Int -> Prolog Board res
> --queens2             :: Int -> Prolog Board (IO ())
> queens2 n             =  place (domains n)
>     where
>     place []          =  unit []
>     place ((c,d):ds)  =  --io (print c)                       &
>                          choose d                             &= \ r ->
>                          place (forward (c,r) ds)             &= \ ps ->
>                          unit ((c,r):ps)

> domains n             =  [ (c, [1 .. n]) | c<-[1 .. n] ]

> choose                :: [a] -> Prolog a res
> choose []             =  zero
> choose (a:x)          =  unit a
>                       ?? choose x

> forward (c,r) []      =  []
> forward (c,r) ((c',d):ds)
>                       =  firstFail (c',d \\ [r+c-c',r,r+c'-c])
>                                    (forward (c,r) ds)
>
> firstFail v []                =  [v]
> firstFail v@(_,d) (w@(_,d'):ds)
>     | length d<length d'      =  v : w : ds
>     | otherwise               =  w : v : ds

> domains' n            =  [ (i, interleave [m,m-1..1] [m+1..n]) | i<-[1..a] ]
>                       ++ [ (i, interleave [1..m-1] [n,n-1..m]) | i<-[a+1..b] ]
>                       ++ [ (i, interleave [m,m-1..1] [m+1..n]) | i<-[b+1..n] ]
>     where m           =  n `div` 2
>           a           =  n `div` 3
>           b           =  n - a

> interleave [] x               =  x
> interleave (a:x) []           =  a : x
> interleave (a:x) (b:y)        =  a : interleave (b:y) x

> io                    :: IO a -> BT st a (IO res)
> io cmd                =  \c f s -> cmd >>= \v -> c v f s

> collectSolutions      :: BT st val (IO [val]) -> st -> IO [val]
> collectSolutions p    =  p (\v f _ -> f >>= \vs -> return (v:vs)) (return [])

> printFirstSolution    :: Text val => BT st val (IO ()) -> st -> IO ()
> printFirstSolution p  =  p (\v f _ -> print v) (putStr "no\n")

> printAllSolutions     :: Text val => BT st val (IO ()) -> st -> IO ()
> printAllSolutions p   =  p (\v f _ -> print v >> f) (putStr "no\n")

> {-# inline domains #-}
> {-# inline firstFail #-}