Build.hs

module Topkata.World.Build where

import Topkata.World.Base
import Data.Array
import Data.Ix
import System.Random
import Data.Maybe
import Data.List
import Control.Monad
import Debug.Trace

neighborSide SideFront  = SideBack
neighborSide SideBack   = SideFront
neighborSide SideLeft   = SideRight
neighborSide SideRight  = SideLeft
neighborSide SideTop    = SideBottom
neighborSide SideBottom = SideTop

neighborPos pos@(x,y,z) _          SideBack   | z > 1  = Just (x, y, z-1)
neighborPos pos@(x,y,z) (_, _, mz) SideFront  | z < mz = Just (x, y, z+1)
neighborPos pos@(x,y,z) _          SideLeft   | x > 1  = Just (x-1, y, z)
neighborPos pos@(x,y,z) (mx, _, _) SideRight  | x < mx = Just (x+1, y, z)
neighborPos pos@(x,y,z) _          SideBottom | y > 1  = Just (x, y-1, z)
neighborPos pos@(x,y,z) (_, my, _) SideTop    | y < my = Just (x, y+1, z)
neighborPos _           _          _                   = Nothing

neighborUpdate world p side ws =
    case np of
         Nothing -> Just world
         Just np ->
             let nb  = world ! np 
                 nb' = nb // [(side, ws)]
             in
               if (nb ! ns) == NotSet 
                 then Just (world // [(np, nb')])
                 else if (nb ! ns) == ws 
                      then Just world
                      else Nothing
  where np = neighborPos p (snd $ bounds world) ns
        ns = neighborSide side
        

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

makeWorld :: (Int, Int, Int) -> World

inWorld world  (x, y, z) =
    minx <= x && x <= maxx &&
    miny <= y && y <= maxy &&
    minz <= z && z <= maxz
  where ((minx, miny, minz), (maxx, maxy, maxz)) = bounds world

isExtendPos world pos = 
    inWorld world pos && null (world ! pos)

mapIndexed :: (a -> b) -> [a] -> [(a, b)]
mapIndexed f l = zip l (map f l)

makeWorld size = 
    aux g world init []
  where aux g world [] []  = trace "empty" world
        aux g world [] acc = 
            trace ("shuffle " ++ show acc) aux g1 world (shuffle g2 $ nub acc) []
           where (g1, g2) = split g
        aux g world (pos:t) acc =
            if null extPos 
               then trace ("delete: " ++ show pos) $ aux g world t acc
               else trace ("extend: " ++ show pos ++ " " ++ show extPos) $ aux g2 world' t acc''
          where extPos           = filter (isExtendPos world . snd) $ mapIndexed (nextPos  pos) allSides
                (side, pos')     = head $ shuffle g1 extPos
                nside            = neighborSide side
                (g1, g2)         = split g
                world'           = world // [(pos, side:(world ! pos)), (pos', [nside])]
                acc'             = pos' : acc
                acc''            = if length extPos > 1 then pos: acc' else acc
        init   = [origin]
        g      =  mkStdGen (0::Int)
        world  = trace "happy new world" $ emptyWorld size

nextPos :: Pos -> BlockSide -> Pos
nextPos (x, y, z) SideBack   = (x, y, z+1)
nextPos (x, y, z) SideFront  = (x, y, z-1)
nextPos (x, y, z) SideRight  = (x+1, y, z)
nextPos (x, y, z) SideLeft   = (x-1, y, z)
nextPos (x, y, z) SideBottom = (x, y-1, z)
nextPos (x, y, z) SideTop    = (x, y+1, z)