文字列の八方向検索 in Haskell DouKaku?

与えられた矩形状の文字列中に存在する文字列"ウオリ"の位置を全て出力するプログラムを
書いてください。
文字列の検索方向は八方全てで、また連続している（左右や上下の境界をまたがない）ものを
対象とします。出力は起点"ウ"の座標と方向のリストにしてください。

サンプル入力：

リオウウリウ
ウオリウオリ
オリリオリウ
リリオオウオ

サンプル出力：

(2, 0), 左
(0, 1), 右
(0, 1), 下
(3, 1), 右
(4, 3), 左上

--
より一般には、任意の検索文字列への対応も考えてみてください。

8方向のそれぞれで、さがす文字列と同じ長さの断片を切り出して、
それが検索文字列と一致しているかどうかを見るだけの素朴な実装。

実行結果は以下のとおり。

*Main> showResult $ search8 str mat
右: (0,1) (3,1)
左: (2,0)
下: (0,1)
上: 
右下: 
左上: 
左下: 
右上: (4,3)

import Control.Applicative
import Data.List
import qualified System.IO.UTF8 as U

attachIndex :: [[a]] -> [[((Int,Int),a)]]
attachIndex = map (uncurry (flip zipWith [0..] . ((,) .) . flip (,))) . zip [0..]

splices :: Int -> [a] -> [[a]]
splices n = (!! n) . transpose . map inits . tails
  where []     !! _ = []
        (x:xs) !! 0 = x
        (x:xs) !! m = xs !! (m-1)

steps :: [[a]] -> [[a]]
steps []           = []
steps ([]:yss)     = steps yss
steps ((x:xs):yss) = [x] : zipCons xs (steps yss)

zipCons []     yys    = yys
zipCons xxs    []     = map (:[]) xxs
zipCons (x:xs) (y:ys) = (x:y) : zipCons xs ys

hors :: Int -> [[a]] -> [[a]]
hors= concatMap . splices

vers :: Int -> [[a]] -> [[a]]
vers = (. transpose) . hors

slas :: Int -> [[a]] -> [[a]]
slas = (. steps) . hors

bsls :: Int -> [[a]] -> [[a]]
bsls = (. map reverse) . slas

search8 :: Eq a => [a] -> [[a]] -> [[(Int,Int)]]
search8 s m = map (map (fst . head)) 
            $ map (filter (g s)) [hs,hs',vs,vs',ss,ss',bs,bs']
  where m'  = attachIndex m 
        hs  = hors len m'
        hs' = map reverse hs
        vs  = vers len m'
        vs' = map reverse vs
        ss  = slas len m'
        ss' = map reverse ss
        bs  = bsls len m'
        bs' = map reverse bs
        len = length s
        g x = (x ==) . map snd

showResult :: [[(Int,Int)]] -> IO ()
showResult = U.putStr 
           . unlines 
           . zipWith (\ x y -> x++": "++showPoss y) ["右","左","下","上","右下","左上","左下","右上"]

showPoss :: [(Int,Int)] -> String
showPoss = concat . intersperse " " . map show
                                   
mat = ["リオウウリウ"
      ,"ウオリウオリ"
      ,"オリリオリウ"
      ,"リリオオウオ"
      ]

str = "ウオリ"

Suffix Array 的なもの(?)を書いてみたかったつもりなのですが、出来あがってみるとちょっと微妙。

Main> find "UOL" (mkIndex input)
[(右,(3,1)),(左,(2,0)),(下,(0,1)),(左上,(4,3)),(右,(0,1))]

import List
import Data.Map (Map,(!))
import qualified Data.Map as Map

heads :: [[a]] -> [a]
heads = head . transpose

take2 :: Int -> [[a]] -> [a]
take2 n xss = take n (heads xss)

rests :: [[a]] -> [[a]]
rests = map tail

drop2 :: Int -> [[a]] -> [[a]]
drop2 n xss = (rests (take n xss)) ++ drop n xss

slants' :: Int -> [[a]] -> [[a]]
slants' _ [] = []
slants' _ [[]] = []
slants' (n+1) ([]:xss) = take2 n xss : slants' (succ n) (drop2 n xss)
slants'  n        xss  = take2 n xss : slants' (succ n) (drop2 n xss)

slants :: [[a]] -> [[a]]
slants = slants' 1

data Dir = N | NE | E | SE | S | SW | W | NW
instance Show Dir where
  show N  = "上"
  show NE = "右上"
  show E  = "右"
  show SE = "右下"
  show S  = "下"
  show SW = "左下"
  show W  = "左"
  show NW = "左上"

type Loc = (Int, Int)

locations :: [[Loc]]
locations = [[(x, y) | x <- [0..]] | y <- [0..]]

zipWithLoc :: [[a]] -> [[(a, Loc)]]
zipWithLoc xss = map (\(xs,locs) -> zip xs locs) (zip xss locations)

suffixes :: [a] -> [[a]]
suffixes xs = init [s | s <- tails xs]

type StringWithLoc = [(Char, Loc)]

implode :: StringWithLoc -> (String, Loc)
implode xs = ((map fst xs), (snd $ head xs))

suffixesWithLoc :: [StringWithLoc] -> [(String, Loc)]
suffixesWithLoc ss = map implode $ concat $ map suffixes ss

suffixesWithDirAndLoc :: Dir -> [StringWithLoc] -> [(String, (Dir, Loc))]
suffixesWithDirAndLoc d ss = map (\(s,l) -> (s,(d,l))) (suffixesWithLoc ss)

mkAllSuffixes :: [String] -> [(String, (Dir, Loc))]
mkAllSuffixes ss = sortBy (\a b -> fst a `compare` fst b)  $ concat [
  suffixesWithDirAndLoc E  ss',
  suffixesWithDirAndLoc W  (map reverse ss'),
  suffixesWithDirAndLoc S  (transpose ss'),
  suffixesWithDirAndLoc N  (transpose $ reverse ss'),
  suffixesWithDirAndLoc SW (slants ss'),
  suffixesWithDirAndLoc NW (slants $ reverse ss'),
  suffixesWithDirAndLoc NE (slants $ transpose ss'),
  suffixesWithDirAndLoc SE (slants $ transpose $ reverse ss')]
  where ss' = zipWithLoc ss

type Index = Map String [(String, (Dir, Loc))]

mkIndex' :: [(String, (Dir, Loc))] -> Index -> Index
mkIndex' [] idx = idx
mkIndex' ((s,dl):ss) idx =
  if Map.member s idx
  then mkIndex' ss idx
  else mkIndex' ss (Map.insert s ((s,dl):ss) idx)

mkIndex :: [String] -> Index
mkIndex ss = mkIndex' (mkAllSuffixes ss) Map.empty

find' :: String -> [(String, (Dir, Loc))] -> [(Dir, Loc)]
find' _ [] = []
find' s ((a,dl):xs) | s `isPrefixOf` a = dl : find' s xs
                    | otherwise        = []

find :: String -> Index -> [(Dir, Loc)]
find s idx = find' s (idx ! s)

input = [ "LOUULU", "UOLUOL", "OLLOLU", "LLOOUO" ]

素朴な実装で。

import Data.Maybe
import qualified System.IO.UTF8 as U

type M = [((Int,Int),Char)]

toMap :: [String] -> M
toMap [] = []
toMap xss@(x:xs) = zip f $ concat xss
    where hs = [0..length x - 1]
          vs = [0..length xss - 1]
          f = concatMap (\v -> map (\h -> (h,v)) hs) vs

val :: (Int -> Int) -> (Int -> Int) -> (Int,Int) -> Int -> M -> String
val f g (x,y) len m = catMaybes $ recur (x,y) 0
    where recur p@(x,y) n | n == len = []
                          | otherwise = lookup p m:recur (f x, g y) (n + 1)

ds = [(val pred id,   "左"),
      (val pred pred, "左上"),
      (val pred succ, "左下"),
      (val succ id,   "右"),
      (val succ pred, "右上"),
      (val succ succ, "右下"),
      (val id pred,   "上"),
      (val id succ,   "下")]

exec :: String -> [String] -> [((Int,Int),String)]
exec str xs = concatMap (\p -> catMaybes $ map (\(f,d) -> g p d (f p n m)) ds) ps
    where m = toMap xs
          n = length str
          g p d s | s == str = Just (p,d)
                  | otherwise = Nothing
          ps = map fst $ filter ((==) (head str) . snd) m 

main = mapM_ (U.putStrLn . format) $ exec "ウオリ" sample
    where format (p,d) = show p ++ ", " ++ d
          sample = ["リオウウリウ","ウオリウオリ","オリリオリウ","リリオオウオ"]

全探索ならリストモナド、インデックス参照なら配列ということで作りました。この問題の場合は、配列は更新されないので通常のArrayを使います。

import Data.Array
import Data.List
import Control.Monad

search8 search table =
  let 
    range = (,) (0,0) (length (head table) - 1, length table - 1)
    array = listArray range (concat.transpose $ table)
  in do
    (dx, dy, dir) <- 
      [(dx, dy, yname++xname) |
       (dx, xname) <- [(-1,  "Left"), (0, ""), (1, "Right")],
       (dy, yname) <- [(-1, "Upper"), (0, ""), (1, "Lower")],
       dx /= 0 || dy /= 0
       ]
    p0 <- indices array

    let str = unfoldr (\p@(x,y) -> if inRange range p 
                          then Just (array!p, (x + dx, y + dy)) 
                          else Nothing) p0

    guard(isPrefixOf search str)
    return (p0, dir)

main = print $ search8 "UOL" ["LOUULU", "UOLUOL", "OLLOLU", "LLOOUO"]

{-
> :main
[((4,3),"UpperLeft"),((2,0),"Left"),((0,1),"Lower"),((0,1),"Right"),((3,1),"Right")]
-}

DouKaku?

文字列の八方向検索

Posted feedbacks - Haskell

Index

Feed

Other

Link

Pathtraq