module HCube.Lib (Rubik(..),
Cube(..),
posToId,
getPos,
consCubeInfo,
solvedSurf,
cubeIdsOfFace,
cubeTypes,
initCube,
getFaceColor,
getCubeFromPos,
doCubeOps,
loadCube,
saveCube) where
import Data.Monoid
import Control.Monad (foldM)
import Data.List (find, sort, foldl)
import Data.Maybe (fromJust, mapMaybe)
import Data.Char (ord, chr)
import System.Directory (doesFileExist)
import HCube.Data
import HCube.Utility
import HCube.OrientGroup
data Rubik = Rubik {
n :: Size,
crn :: [Cube],
edg :: [Cube],
cnt :: [Cube],
hid :: [Cube],
loop :: Bool,
view :: View,
his :: [Rotation]
} deriving (Show, Read, Eq)
data Cube = Cube {
pos :: Vec,
ori :: Orient,
cid :: Numb
} deriving (Show, Read, Eq)
loadCube :: Size -> FilePath -> IO Rubik
loadCube sz fp = doesFileExist fp >>= f where
f True = fromFile fp
f False = return g <* saveCube fp g
g = initCube sz
saveCube :: FilePath -> Rubik -> IO ()
saveCube fn rb = writeFile fn (show $ rb {loop = True})
doCubeOps :: [Rotation] -> Rubik -> Rubik
doCubeOps ops rk = foldl f rk ops where
f rk2 (RotateCube sb dr) = doCubeOps g rk2 where
g = map (Rotation sb dr) [1 .. i]
f rk3 rt = rk3 { crn = h crn,
edg = h edg,
cnt = h cnt,
hid = h hid
} where
h fn = twist i rt (fn rk3)
i = n rk
twist :: Size -> Rotation -> [Cube] -> [Cube]
twist sz rt@(Rotation sb dir nm) = map f where
f cb = g $ nm == getAxis sb (pos cb) where
g False = cb
g True = moveCube sz rt cb
getCube :: [Cube] -> Vec -> Maybe Cube
getCube cbs ps = f where
f = find g cbs
g cb = ps == pos cb
getFaceColor :: Rubik -> (Numb,Side) -> String
getFaceColor rk (pos, sd) = f (getCubeFromPos rk pos) sd where
f cb = show . sideToColor . getFaceOrientation cb
getCubeFromPos :: Rubik -> Numb -> Cube
getCubeFromPos rk pos = fromJust $ getCube cs (getPos sz pos) where
sz = n rk
cs = concat [crn rk, edg rk, cnt rk, hid rk]
rotate :: Size -> Rotation -> (Point -> Point)
rotate sz rt (x,y) = f rt where
f (Rotation dr _ _)
= g $ humanDir sz rt where
g Clockwise = (y, sz x + 1)
g Counter = (sz y + 1, x)
g Twice = (sz x + 1, sz y + 1)
humanDir :: Size -> Rotation -> Direction
humanDir sz = f where
f (Rotation _ dr _) = dr
getTwistOrient :: Rotation -> Orient
getTwistOrient = cons . f where
f (Rotation Layer Clockwise _) = 'f'
f (Rotation Layer Counter _) = 'l'
f (Rotation Layer Twice _) = 't'
f (Rotation HSlice Clockwise _) = 'r'
f (Rotation HSlice Counter _) = 'g'
f (Rotation HSlice Twice _) = 'k'
f (Rotation VSlice Clockwise _) = 'o'
f (Rotation VSlice Counter _) = 'd'
f (Rotation VSlice Twice _) = 'e'
orient :: Rotation -> Orient -> Orient
orient rt or = f rt where
f (Rotation sb dr _)
= Orient $ map (g |*|) (getVec $ mempty) where
g = h |**| to or
h = to $ getTwistOrient rt
initCube :: Size -> Rubik
initCube sz = f $ cubeTypes sz where
f (cr,ed,ce,hi) = Rubik { n = sz,
crn = map g cr,
edg = map g ed,
cnt = map g ce,
hid = map g hi,
loop = True,
view = LeftV,
his = []}
g id = Cube (getPos sz id) mempty id
moveCube :: Size -> Rotation -> Cube -> Cube
moveCube sz rt cb = f rt where
f (Rotation sb dr _)
= cb { pos = apply (rotate sz rt) sb (pos cb),
ori = orient rt (ori cb) }
apply :: (Point -> Point) -> Slab -> Vec -> Vec
apply fn sb (a,b,c) = f sb where
f VSlice = (a, g (b,c), h (b,c))
f HSlice = (g (a,c), b, h (a,c))
f Layer = (g (a,b), h (a,b), c)
g = fst . fn
h = snd . fn
getFaceOrientation :: Cube -> Side -> Side
getFaceOrientation cb = transform (ori cb)
transform :: Orient -> Side -> Side
transform or sd = vecToSide $ (inverse $ to or) |*| (sideToVec sd)
getAxis :: Slab -> Vec -> Numb
getAxis Layer (_,_,ps) = ps
getAxis HSlice (_,ps,_) = ps
getAxis VSlice (ps,_,_) = ps
cubeTypes :: Size -> ([Int],[Int],[Int],[Int])
cubeTypes n = foldr f ([],[],[],[]) $ consCubeInfo n (solvedSurf n) where
f (id, _, chs) (cr,ed,ce,hi) = g $ length chs where
g 0 = (cr,ed,ce,id:hi)
g 1 = (cr,ed,id:ce,hi)
g 2 = (cr,id:ed,ce,hi)
g 3 = (id:cr,ed,ce,hi)
nullActCube :: Int -> [(Int,ActualCube,ColorTag)]
nullActCube n = zip3 [1..] f g where
f = replicate h (ActualCube NoColor NoColor NoColor NoColor NoColor NoColor)
g = replicate h []
h = n*n*n
solvedSurf :: Int -> CubeSurf
solvedSurf n = map f [UpS,FrontS,DownS,BackS,LeftS,RightS] where
f sd = (sd, replicate (n*n) (sideToColor sd))
consCubeInfo :: Int -> CubeSurf -> [(Int, ActualCube, ColorTag)]
consCubeInfo n = foldl f (nullActCube n) where
f acs (sd, cls) = foldl g acs $ zip (cubeIdsOfFace n sd) cls where
g acs (pi,cl) = map h acs where
h tu@(ci,ac,ct)
| ci == pi = (ci, i sd ac cl, sort $ (head $ show cl) : ct)
| otherwise = tu
i UpS ac cl = ac {up = cl}
i FrontS ac cl = ac {front = cl}
i DownS ac cl = ac {down = cl}
i BackS ac cl = ac {back = cl}
i LeftS ac cl = ac {left = cl}
i RightS ac cl = ac {right = cl}
cubeIdsOfFace :: Int -> Side -> [Int]
cubeIdsOfFace n = f where
f UpS = [1 .. l]
f FrontS = concat [[g x .. g x + n 1] | x <-[1..n]]
f DownS = h (\s -> (n1)*l + (s1)*n + 1)
f BackS = h j
f RightS = i (\s -> reverse [ (s1)*n + j y | y <- [1..n]])
f LeftS = i (\s -> [(s1)*n + k y | y <- [1..n]] )
g ix = ix*l n + 1
h fu = reverse $ concat [ reverse [fu x .. fu x + n 1] | x <- [1..n] ]
i fu = concat [fu x | x <- [1..n]]
j ix = (ix1)*l + 1
k ix = (ix1)*l + n
l = n*n
posToId :: Size -> Vec -> Numb
posToId n (a,b,c) = a + n*(b1) + n*n*(c1)
getPos :: Size -> Numb -> Vec
getPos n id = head [(a,b,c) | c <- [1..n],
b <- [1..n],
a <- [1..n],
posToId n (a,b,c) == id]
fromFile :: FilePath -> IO Rubik
fromFile fn = readFile fn >>= return . read