.

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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
{-# OPTIONS_GHC -O2 -fexcess-precision -funbox-strict-fields -fvia-c -optc-O3 #-}
module Main where

import Data.Array.Unboxed
import System.Environment
import Control.Arrow
import Data.List (unfoldr,intersect,nub)
import Control.Monad

data B = K | H | P | G | S | W
  deriving (Eq,Show,Read)

type Field =  Int
type Pos = (Int,Int)
type Board = UArray Pos Field

instance Enum B where
  toEnum 1 = P
  toEnum 2 = G
  toEnum 3 = S
  toEnum 4 = W
  toEnum 5 = H
  toEnum 6 = K
  fromEnum P = 1
  fromEnum G = 2
  fromEnum S = 3
  fromEnum W = 4
  fromEnum H = 5
  fromEnum K = 6

main = do
  [f] <- getArgs
  board <- getBoard `fmap` readFile f
  --print board
  p $ solve board

{-# INLINE p #-}
p :: Bool   IO ()
p True = putStrLn "Nie"
p _ = putStrLn "Tak"

{-# INLINE getBoard #-}
getBoard :: String -> Board
getBoard str = listArray ((1,1),(m,n)) $ concatMap (map r) lst
  where lst =  lines str
        n = length$  head lst
        m = length lst
        r '.' = 0
        r b = fromEnum (read [b] :: B)

printTable _ [] = putStrLn "\n"
printTable n lst = (>> (putStrLn "" >> printTable n b) ) $  mapM_ (putStr . aux  ) a
  where (a,b) = splitAt n lst
        aux 0 = "."
        aux n = show $ (toEnum n :: B)

solve :: Board -> Bool
solve board =  and $ do
  (i,e) <- assocs board
  guard $ e /= 0
  return $ isSafe board (toEnum e) i


{-# INLINE sasP #-}
sasP :: Pos -> [Pos]
sasP (i,j) = [(i+1,j-1),(i+1,j+1)]

{-# INLINE sasW #-}
sasW :: (Pos,Pos) -> Pos ->   [Pos]
sasW r p= nub $ concatMap (sasLine p (inRange r)) [(id,succ),(id,pred),
                                                   (pred,id),(succ,id)]
{-# INLINE sasLine #-}
sasLine :: Pos -> (Pos -> Bool) -> (Int -> Int,Int -> Int) -> [Pos]
sasLine pos del (f,g) = flip unfoldr pos $
    \p -> if not$ del p  then Nothing  else Just (p,f *** g $ p)

{-# INLINE sasG #-}
sasG :: (Pos,Pos) -> Pos -> [Pos]
sasG r p= nub $ concatMap (sasLine p (inRange r)) [(succ,succ),(pred,pred),
                                                   (succ,pred),(pred,succ)]
{-# INLINE sasH #-}
sasH :: (Pos,Pos) -> Pos -> [Pos]
sasH r p= nub $ sasG r p ++ sasW r p

{-# INLINE sasS #-}
sasS :: Pos -> [Pos]
sasS (i,j) =  nub $ a ++ b ++ c ++ d
  where
     a = concatMap (\p -> [first succ p,first pred p]) [(i,j+2),(i,j-2)]
     b = concatMap (\p -> [second succ p,second pred p]) [(i+2,j),(i-2,j)]
     c = concatMap (\p -> [first (+2) p,first (subtract 2) p]) [(i,j+1),(i,j-1)]
     d = concatMap (\p -> [second (+2) p,second (subtract 2) p]) [(i+1,j),(i-1,j)]


{-# INLINE get #-}
get board i
  | inRange (bounds board ) i = board ! i
  | otherwise = 0

{-# INLINE isSafe #-}
isSafe :: Board -> B -> Pos -> Bool
isSafe board b = (6 `notElem`) . map (get board ). sas b
  where r = bounds board
        {-# INLINE sas #-}
        sas K  = const []
        sas P  = sasP
        sas W  = sasW r
        sas G  = sasG r
        sas H  = sasH r
        sas S  = sasS