topkata-0.2: Labygen.hs

module Labygen where

import Data.Ix
import Data.List
import Data.Array
import System.Random
import Debug.Trace

data Block = Block | Free deriving (Show, Eq, Ord)

class Ix a => WorldIdx a where
    adjacent :: (a, a) -> a -> [a]
    borders  :: (a, a) -> a -> [a]

type World p = Array p Block

newtype Pos2 = Pos2 (Int, Int) deriving (Ix, Ord, Eq, Show, Read)
newtype Pos3 = Pos3 (Int, Int, Int) deriving (Ix, Ord, Eq, Show, Read)

instance WorldIdx Pos2 where
    adjacent bnds (Pos2 (x,y)) =
        [ e | e <- map Pos2 [(x-1,y), (x+1,y), (x,y-1), (x,y+1)], inRange bnds e]
    borders bnds p@(Pos2 (x,y)) =
        adjacent bnds p ++
          [ e | e <- map Pos2 [(x-1,y-1), (x+1,y-1), (x-1,y+1), (x+1,y+1)], inRange bnds e]


instance WorldIdx Pos3 where
    adjacent bnds (Pos3 (x,y,z)) =
        [ e | e <- map Pos3 [(x-1,y,z), (x+1,y,z), (x,y-1,z), (x,y+1,z), (x,y,z-1), (x,y,z+1)], inRange bnds e]
    borders bnds p@(Pos3 (x,y,z)) =
        adjacent bnds p ++
          [ e | e <- map Pos3 [(x-1,y-1,z-1), (x-1,y-1,z+1), (x-1,y+1,z-1), (x-1,y-1,z+1),
                               (x-1,y,z-1), (x-1,y,z+1), (x+1,y,z-1), (x+1,y,z+1),
                               (x+1,y-1,z-1), (x+1,y-1,z+1), (x+1,y+1,z-1), (x+1,y-1,z+1)], inRange bnds e]

instance Random Pos3 where
    random g = (Pos3 (x, y, z), g'')
       where (g', g'') = split g
             x:y:z:_   = randoms g'

    randomR bnds g = (range bnds !! idx, g')
      where size      = rangeSize bnds
            (idx, g') = randomR (0, size-1) g

      

shuffle g list = map snd $ sort $ zip (randomRs (maxBound::Int, minBound) g) list

-- labygen :: WorldIdx p => a -> b -> c -> p -> Either (World p) (World p)
labygen g bounds origin target =
    aux g [(origin,[origin])] laby False
  where laby = array bounds [ (ix, Block) | ix <- range bounds ]
        aux g [] laby True = Right laby
        aux g [] laby False = Left laby
        aux g ((p,slist):t) laby ok | canNotExtend laby slist p = aux g t laby ok
                            | otherwise = aux g2 paths laby' ok'
            where ok'      = ok || p == target
                  laby'    = laby // [ (p, Free) ]
                  adj      = adjacent bounds p
                  paths   | target `elem` adj  = (target, (p:adj)) : t
                          | otherwise          = shuffle g1 (zip adj (repeat (p:adj)) ++ t)
                  (g1, g2) = split g
        canNotExtend laby slist p = length [ a | a <- borders bounds p, laby ! a == Free, not (a `elem` slist)] > 0
        tr p s a = trace ("p=" ++ show p ++ ", a=" ++show a ++ ", slist=" ++ show s ) a



labygenIO bounds origin target =
    rep  $ \g ->labygen g bounds origin target
 where
  rep f = do
    g <- newStdGen
    case f g of
      Right a -> return a
      Left _ -> rep f

inWall laby x y z =
    {- trace (show p) $ -} not (inRange bnds p) ||
        laby ! p == Block
  where bnds = bounds laby
        p    = Pos3 ((truncate x), (truncate y), (truncate z))



randomFreePos laby g =
      if laby ! pos == Block 
        then randomFreePos laby g'
        else result
   where result@(pos, g') = randomR (bounds laby) g

randomFreePosIO laby = do
    g <- newStdGen
    return $ fst $ randomFreePos laby g