必ず解ける迷路 in Haskell DouKaku?

必ず解ける迷路

以下のルールを満たすn×mの迷路を出力するプログラムを作ってください。

1. 格子状の迷路であること。
2. 経路の幅は均等であること。
3. 迷路のある地点からの全ての地点に到達する経路が1つだけ存在すること。
   ループも認めません。
4. 出力の度にランダムな迷路であること。
   ランダムシードが同じ時に同じ迷路になってしまうのはよいです。

たとえば、n=4, m=5の迷路の出力は以下のようになります。

　｜１｜２｜３｜４｜
―■■■■■■■■■
１■　　　■　　　■
―■■■　■■■　■
２■　　　■　　　■
―■　■■■　■　■
３■　　　　　■　■
―■　■■■　■　■
４■　■　　　■　■
―■　■　■■■　■
５■　■　　　■　■
―■■■■■■■■■

こう言うのは、×の部分が3のルールに違反するのでダメです。
　｜１｜２｜３｜４｜
―■■■■■■■■■
１■　　　■×■　■
―■■■　■■■　■
２■　　　■　　　■
―■　■■■　■　■
３■　　　　　■　■
―■　■■■■■　■
４■　■×××■　■
―■　■×■■■　■
５■　■×××■　■
―■■■■■■■■■

このようなループも2のルールに違反するのでダメです。
　｜１｜２｜３｜４｜
―■■■■■■■■■
１■　　　　　■　■
―■■■　■　■　■
２■　　　■　　　■
―■　■■■　■　■
３■　　　　　■　■
―■　■■■　■　■
４■　■　　　■　■
―■　■　■■■　■
５■　　　　　■　■
―■■■■■■■■■

できたプログラムを使って n=1024, m=1024 の迷路を作るのにかかった時間を教えてください。


難易度高めです。限られたメモリを使って縦方向に無限に広い迷路を
どうやって作るのかを考えると答えが見えてくると思います。
ソースコードはJavaで150行程度になりました。

post comment

Posted feedbacks - Haskell

Haskellでやってみました。学習中です。とても楽しい問題ですね！

地道にスタート地点からほり続けるアルゴリズムです。

最初はData.Array.Arrayを使いました。ヒープ爆発で没。その後、UArrayを使い、多少改善、
最終的にはIOUArrayに落ち着きました。

その他のメモリ消費・速度対策としては
１．何度も計算する必要のないものを定数化する。
２．深さ優先の再帰から広さ優先の再帰にする。かつ、TailRecursionにした。
３．元の実装は迷路中の位置をすべてタプル（ｘ、ｙ）で表現していたので、配列アクセスのときにインデックスへの
変換が多発していた。ので、インデックスベースの計算の高度も少し書きました。
４．迷路のサイズのグローバル変数化

GHCのプロファイラをはじめて使いました。

結果として、
-- Vista Ultimate on Toshiba Portege M200 (Centrino Duo)
--try 1 Elapsed Time :  00:00:05.760
--try 2 Elapsed Time :  00:00:05.787
--try 3 Elapsed Time :  00:00:05.790
といった結果が出ています。

出題の方のコメントのうち、「。限られたメモリを使って縦方向に無限に広い迷路を…」の部分のヒントは
利用していません…使えば、まだまだ早くなると思うのですが、アルゴリズム的なショートカットではないかたちで、
ほかにどんなテクニックで高速化ができるかに興味があります。
考えたけどやってないもののひとつとしては、迷路の１マスを１Bitでやってみるとか…

ほかの方のHaskellの投稿もぜひ見せてもらいたいです。何かフィードバックありましたらよろしくお願いします。

module Main
    where

import Data.Array.IO 
import Control.Monad.State
import System.Random
import Data.List    -- for intercalate

type Point = (Int, Int)
type TwoDArray = IOUArray Int Char
type Maze = TwoDArray

ptToIdx :: Point -> Int
ptToIdx (x, y) = (y * rszx) + x

rasterize :: Int -> Int
rasterize i = i * 2 + 1

rasterizePt :: Point -> Point
rasterizePt (x, y) = (rasterize x, rasterize y)

lstMappedPoint :: Point -> [Point] -> [Point]
lstMappedPoint pt pts = map (addPt pt) pts 
    where
        addPt (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)

lstMappedIdx :: Int -> [Int] -> [Int]
lstMappedIdx idx idxs = map (idx +) idxs 


inBoundForMove :: Point -> Bool
inBoundForMove (x, y)
    | x <= 0 || x + 1 >= rszx || y <= 0 || y + 1 >= rszy = False
    | otherwise = True

surroundingsIdx :: Point -> [Int]
surroundingsIdx (x, y)
    | x == 0        && y == 0        =                               nbIdxsTopLeft
    | x == rszx - 1 && y == 0        =                               nbIdxsTopRightMapped
    | x == 0        && y == rszy - 1 =                               nbIdxsBottomLeftMapped 
    | x == rszx - 1 && y == rszy - 1 =                               nbIdxsBottomRightMapped 
    | x == 0                         = lstMappedIdx (ptToIdx (x, y)) nbIdxsLeft
    | x == rszx - 1                  = lstMappedIdx (ptToIdx (x, y)) nbIdxsRight
    |                  y == 0        = lstMappedIdx (ptToIdx (x, y)) nbIdxsTop
    |                  y == rszy - 1 = lstMappedIdx (ptToIdx (x, y)) nbIdxsBottom
    | otherwise                      = lstMappedIdx (ptToIdx (x, y)) nbIdxs

onTheSameLineIdx :: [Int] -> Bool
onTheSameLineIdx [] = True
onTheSameLineIdx [i] = True
onTheSameLineIdx (idx:idxs) = (all (sameX idx) idxs) || (all (sameY idx) idxs)
    where
        sameX idx1 idx2 = (abs $ idx1 - idx2) <= 2
        sameY idx1 idx2 = (abs $ idx1 - idx2) == rszy || (abs $ idx1 - idx2) == rszy * 2

left  =[0..1]    :: [Int]
right =[-1..0]    :: [Int]
top   =[0..1]    :: [Int]

bottom=[-1..0]    :: [Int]
rest  =[-1..1]    :: [Int]

nbptsTopLeft     = [(x, y) | x <- left,  y <- top,    x /= 0 || y /= 0]    :: [Point]
nbptsTop         = [(x, y) | x <- rest,  y <- top,    x /= 0 || y /= 0]    :: [Point]
nbptsTopRight    = [(x, y) | x <- right, y <- top,    x /= 0 || y /= 0]    :: [Point]
nbptsLeft        = [(x, y) | x <- left,  y <- rest,   x /= 0 || y /= 0]    :: [Point]
nbpoints         = [(x, y) | x <- rest,  y <- rest,   x /= 0 || y /= 0]    :: [Point]
nbptsRight       = [(x, y) | x <- right, y <- rest,   x /= 0 || y /= 0]    :: [Point]
nbptsBottomLeft  = [(x, y) | x <- left,  y <- bottom, x /= 0 || y /= 0]    :: [Point]
nbptsBottom      = [(x, y) | x <- rest,  y <- bottom, x /= 0 || y /= 0]    :: [Point]
nbptsBottomRight = [(x, y) | x <- right, y <- bottom, x /= 0 || y /= 0]    :: [Point]

nbIdxsTopLeft     = map ptToIdx nbptsTopLeft
nbIdxsTop         = map ptToIdx nbptsTop
nbIdxsTopRight    = map ptToIdx nbptsTopRight
nbIdxsLeft        = map ptToIdx nbptsLeft
nbIdxs            = map ptToIdx nbpoints
nbIdxsRight       = map ptToIdx nbptsRight
nbIdxsBottomLeft  = map ptToIdx nbptsBottomLeft
nbIdxsBottom      = map ptToIdx nbptsBottom
nbIdxsBottomRight = map ptToIdx nbptsBottomRight

nbIdxsTopRightMapped    = lstMappedIdx (ptToIdx(rszx - 1, 0)) nbIdxsTopRight
nbIdxsBottomLeftMapped  = lstMappedIdx (ptToIdx(0, rszy- 1)) nbIdxsTopRight
nbIdxsBottomRightMapped = lstMappedIdx (ptToIdx(rszx - 1, rszy- 1)) nbIdxsTopRight

movable :: Point -> Bool
movable (x, y)  = (abs x) + (abs y) == 1

nbmovables :: [Point]
nbmovables = filter (movable) nbpoints

nbmovablesIdx :: [Int]
nbmovablesIdx = map ptToIdx nbmovables

potentialMoves :: Point -> [Point]
potentialMoves pt = lstMappedPoint pt nbmovables

initialMaze :: IO TwoDArray
initialMaze = newArray (0, rcmz) 'x'

dig :: TwoDArray -> Point -> IO()
dig rg pt = do
    writeArray rg (ptToIdx pt) ' '

fetchIdx :: TwoDArray -> Int -> IO Char
fetchIdx rg idx = readArray rg idx

fetch :: TwoDArray -> Point -> IO Char
fetch rg pt = readArray rg (ptToIdx pt)

idxHas :: Maze -> Int -> IO Bool
idxHas mz idx = do
    chT <- fetchIdx mz idx
    return $ chT == ' '

lookaround :: Maze -> Point -> IO Bool
lookaround mz pt = do
    filteredPoints <- filterM (idxHas mz) $ surroundingsIdx pt
    return $ onTheSameLineIdx filteredPoints

legalMove :: Maze -> Point -> IO Bool
legalMove mz pt = do
        ch <- fetch mz pt
        if ch == 'x' then
            lookaround mz pt
            else
                return False

moves :: Point -> [Point]
moves pt = filter (inBoundForMove) $ potentialMoves pt

diggableNbr :: Point -> Point -> Bool
diggableNbr (x1, y1) (x2, y2) = ((abs $ x1 - x2) + (abs $ y1 - y2)) == 1

genMaze :: Maze -> [Point] -> IO()
genMaze mz pts = doRecurse pts
    where
        doRecurse :: [Point] -> IO()
        doRecurse [] = return ()
        doRecurse pts = do
            ptsDug <- mapDig pts
            doRecurse $ concatMap (moves) ptsDug

        mapDig :: [Point] -> IO [Point]
        mapDig [] = return []
        mapDig (x:xs) = do
            fDug <- digIfValid x
            if (fDug) then do
                xsRet <- mapDig xs -- $ filter (diggableNbr x) xs
                return (x:xsRet)
                else
                    mapDig xs

        digIfValid :: Point -> IO Bool
        digIfValid pt = do
            fPtValid <- legalMove mz pt
            if (fPtValid) then do
                dig mz pt
                return True
                else
                    return False

dumpRow :: TwoDArray -> Int -> IO()
dumpRow rg iy = do
    str <- mapM (readArray rg) $ [(iy * rszx)..(iy * rszx + rszx - 1)]
    putStrLn str

dumpMaze :: TwoDArray -> IO ()
dumpMaze rg = do
    mapM (dumpRow rg) [0..(rszy - 1)]
    return ()

szx = 1024 :: Int
szy = 1024 :: Int
rszx = rasterize szx
rszy = rasterize szy

cmz = szx * szy - 1
rcmz = rszx * rszy - 1

main :: IO()
main = do
    mz <- initialMaze
    x <- getStdRandom $ randomR (0, szx - 1)
    y <- getStdRandom $ randomR (0, szy - 1)
    putStrLn $ show (x, y)
    genMaze mz [rasterizePt (x, y)]
    dumpMaze mz

DouKaku?

必ず解ける迷路

Posted feedbacks - Haskell

Index

Feed

Other

Link

Pathtraq