Rubik cube excercise

[lsap]

Hey Team! I would like to have an exercise for solving Rubik's cube (2x2x2 to 5x5x5 but it' can be unlimited) please (see attached)! I waited days but the program is busy calculating (even for 2x2x2)... There is a room to improve. Thank you in advance (for enhancement), have a nice one!

[lsap]

`{-# OPTIONS_HADDOCK prune, ignore-exports #-}

{------------------------------------------------------------------------------}
{- Author: Dushkin Roman -}
{------------------------------------------------------------------------------}

module Rubik where

import qualified Data.Set as Set
import Data.Set (Set, (\))
import qualified Data.Map as Map
import Data.Map (Map, (!))
import qualified PSQueue as PSQ
import PSQueue (PSQ, Binding(..), minView)
import Data.List (foldl')
import Control.Monad (foldM)
import AStar
import Data.List ((!!))
import Data.Set (Set)

data Color = Blue
| Green
| Orange
| Red
| White
| Yellow
deriving (Eq, Ord)

data RDirection = ClockWise
| CounterClockWise
deriving (Eq, Ord, Show)

data Plain = Horizontal
| Vertical
| Frontal
deriving (Eq, Ord, Show)

data RubikCube = RC
{
rcTop :: Matrix Color,
rcBottom :: Matrix Color,
rcFront :: Matrix Color,
rcRear :: Matrix Color,
rcRight :: Matrix Color,
rcLeft :: Matrix Color
}
deriving (Eq, Ord)

type Vector a = [a]

type Matrix a = [Vector a]

getWidth :: Matrix a -> Int
getWidth m = length $ getRow m 0

getHeight :: Matrix a -> Int
getHeight m = length $ getColumn m 0

getSize :: Matrix a -> (Int, Int)
getSize m = (getWidth m, getHeight m)

getVectorElement :: Vector a -> Int -> a
getVectorElement = (!!)

setVectorElement :: Vector a -> Int -> a -> Vector a
setVectorElement v i x = take i v ++ [x] ++ drop (i + 1) v

getElement :: Matrix a -> Int -> Int -> a
getElement m r c = getRow m r !! c

setElement :: Matrix a -> Int -> Int -> a -> Matrix a
setElement m r c x = setRow m r $ setVectorElement row c x
where
row = getRow m r

getRow :: Matrix a -> Int -> Vector a
getRow = (!!)

setRow :: Matrix a -> Int -> Vector a -> Matrix a
setRow m r v = take r m ++ [v] ++ drop (r + 1) m

getColumn :: Matrix a -> Int -> Vector a
getColumn m c = map (!! c) m

setColumn :: Matrix a -> Int -> Vector a -> Matrix a
setColumn m c v = map ((row, x) -> setVectorElement row c x) $ zip m v

rotateMatrix :: Matrix a -> RDirection -> Matrix a
rotateMatrix m ClockWise = map (reverse . getColumn m) [0..getWidth m - 1]
rotateMatrix m CounterClockWise = map (getColumn m) [getWidth m - 1,
getWidth m - 2..0]

rotateRubik :: RubikCube -> RDirection -> Plain -> Int -> RubikCube
rotateRubik rc rd Horizontal i =
rc
{
rcTop = if i == 0
then rotateMatrix (rcTop rc) rd
else rcTop rc,
rcBottom = if i == getHeight (rcFront rc)
then rotateMatrix (rcBottom rc) $ against rd
else rcBottom rc,
rcFront = setRow (rcFront rc) i $ getRow ((if rd == ClockWise
then rcRight
else rcLeft) rc) i,
rcRear = setRow (rcRear rc) i $ getRow ((if rd == ClockWise
then rcLeft
else rcRight) rc) i,
rcRight = setRow (rcRight rc) i $ getRow ((if rd == ClockWise
then rcRear
else rcFront) rc) i,
rcLeft = setRow (rcLeft rc) i $ getRow ((if rd == ClockWise
then rcFront
else rcRear) rc) i
}
rotateRubik rc ClockWise Vertical i =
rc
{
rcTop = setColumn (rcTop rc) i $
getColumn (rcFront rc) i,
rcBottom = setColumn (rcBottom rc) i $
getColumn (rcRear rc) i,
rcFront = setColumn (rcFront rc) i $
getColumn (rcBottom rc) i,
rcRear = setColumn (rcRear rc) i $
getColumn (rcTop rc) i,
rcRight = if i == getWidth (rcFront rc)
then rotateMatrix (rcRight rc) ClockWise
else rcRight rc,
rcLeft = if i == 0
then rotateMatrix (rcLeft rc) CounterClockWise
else rcLeft rc
}
rotateRubik rc CounterClockWise Vertical i =
rc
{
rcTop = setColumn (rcTop rc) i $
getColumn (rcRear rc) i,
rcBottom = setColumn (rcBottom rc) i $
getColumn (rcFront rc) i,
rcFront = setColumn (rcFront rc) i $
getColumn (rcTop rc) i,
rcRear = setColumn (rcRear rc) i $
getColumn (rcBottom rc) i,
rcRight = if i == getWidth (rcFront rc)
then rotateMatrix (rcRight rc) CounterClockWise
else rcRight rc,
rcLeft = if i == 0
then rotateMatrix (rcLeft rc) ClockWise
else rcLeft rc
}
rotateRubik rc ClockWise Frontal i =
rc
{
rcTop = setRow (rcTop rc) (getHeight (rcTop rc) - i - 1) $
getColumn (rcLeft rc) (getWidth (rcLeft rc) - i - 1),
rcBottom = setRow (rcBottom rc) i $
getColumn (rcRight rc) i,
rcFront = if i == 0
then rotateMatrix (rcFront rc) ClockWise
else rcFront rc,
rcRear = if i == getWidth (rcRight rc)
then rotateMatrix (rcRear rc) CounterClockWise
else rcRear rc,
rcRight = setColumn (rcRight rc) i $
getRow (rcTop rc) (getHeight (rcTop rc) - i - 1),
rcLeft = setColumn (rcLeft rc) (getWidth (rcLeft rc) - i - 1) $
getRow (rcBottom rc) i
}
rotateRubik rc CounterClockWise Frontal i =
rc
{
rcTop = setRow (rcTop rc) (getHeight (rcTop rc) - i - 1) $
getColumn (rcRight rc) i,
rcBottom = setRow (rcBottom rc) i $
getColumn (rcLeft rc) (getWidth (rcLeft rc) - i - 1),
rcFront = if i == 0
then rotateMatrix (rcFront rc) CounterClockWise
else rcFront rc,
rcRear = if i == getWidth (rcRight rc)
then rotateMatrix (rcRear rc) ClockWise
else rcRear rc,
rcRight = setColumn (rcRight rc) i $
getRow (rcBottom rc) i,
rcLeft = setColumn (rcLeft rc) (getWidth (rcLeft rc) - i - 1) $
getRow (rcTop rc) (getHeight (rcTop rc) - i - 1)
}

against :: RDirection -> RDirection
against ClockWise = CounterClockWise
against CounterClockWise = ClockWise

neighbours :: ((RDirection, Plain, Int), RubikCube)
-> Set ((RDirection, Plain, Int), RubikCube)
neighbours (_, rc) = Set.fromList $
map (\s@(rd, p, i) -> (s, rotateRubik rc rd p i))
[(rd, p, i) | rd <- [ClockWise, CounterClockWise],
p <- [Horizontal, Vertical, Frontal],
i <- [0..getWidth (rcTop rc) - 1]]

goal :: ((RDirection, Plain, Int), RubikCube) -> Bool
goal (_, rc) = all ((x:xs) -> all (== x) xs) $
map (concat . ($ rc)) [rcTop, rcBottom, rcFront,
rcRear, rcRight, rcLeft]

cube :: Int -> ((RDirection, Plain, Int), RubikCube)
cube 2 = ((ClockWise, Horizontal, 0),
RC {
rcTop = [[Green, Red],
[Blue, Green]],
rcBottom = [[Yellow, White],
[Blue, Orange]],
rcFront = [[Yellow, Red],
[Orange, Yellow]],
rcRear = [[Yellow, Blue],
[Green, Orange]],
rcRight = [[White, Blue],
[Red, White]],
rcLeft = [[Red, Orange],
[Green, White]]
})
cube 3 = ((ClockWise, Horizontal, 0),
RC {
rcTop = [[White, Yellow, White],
[Green, White, White],
[Red, Blue, Red]],
rcBottom = [[Orange, Yellow, Green],
[Green, Yellow, Blue],
[Blue, Blue, Red]],
rcFront = [[White, Red, Green],
[Green, Blue, Orange],
[Yellow, Red, White]],
rcRear = [[Orange, Blue, Orange],
[Red, Green, Orange],
[Yellow, Orange, Orange]],
rcRight = [[Yellow, Red, Blue],
[Yellow, Orange, Green],
[Red, White, Blue]],
rcLeft = [[Green, Yellow, Blue],
[White, Red, White],
[Yellow, Orange, Green]]
})
cube 4 = ((ClockWise, Horizontal, 0),
RC {
rcTop = [[White, Red, Orange, Yellow],
[Blue, Blue, Yellow, White],
[Orange, Red, Yellow, Orange],
[Orange, Yellow, Orange, Red]],
rcBottom = [[Green, Red, Blue, Red],
[Yellow, Green, Yellow, Yellow],
[Green, Orange, Orange, White],
[Red, Yellow, Green, Orange]],
rcFront = [[Blue, Green, Green, Blue],
[Green, White, Red, Blue],
[White, Orange, Blue, Yellow],
[White, Green, Yellow, Yellow]],
rcRear = [[Orange, Yellow, White, Green],
[White, Green, White, White],
[Blue, Yellow, Red, Blue],
[Blue, Orange, Red, Blue]],
rcRight = [[White, White, Green, Green],
[Orange, White, Blue, Green],
[Orange, Blue, Green, Red],
[Green, Red, Blue, Yellow]],
rcLeft = [[Red, Orange, White, White],
[Red, Red, Green, Yellow],
[Red, Orange, White, Blue],
[Yellow, Red, Blue, Orange]]
})
cube 5 = ((ClockWise, Horizontal, 0),
RC {
rcTop = [[Orange, Blue, Green, Red, Yellow],
[Orange, Green, Blue, White, Yellow],
[Red, White, Yellow, White, Orange],
[Green, Yellow, Blue, Blue, Yellow],
[Red, White, Green, Blue, Blue]],
rcBottom = [[Red, Blue, White, Yellow, Blue],
[Yellow, Yellow, Red, Red, White],
[Orange, Red, White, White, Orange],
[Orange, Yellow, Yellow, White, Red],
[Blue, White, Red, Green, White]],
rcFront = [[Green, Orange, Red, Red, Yellow],
[Green, White, White, Green, Green],
[Yellow, Orange, Red, Yellow, White],
[Orange, Blue, Blue, Blue, Green],
[Green, Orange, Green, Blue, Red]],
rcRear = [[Orange, Yellow, Yellow, White, Green],
[Orange, Green, Green, Red, Yellow],
[Green, Orange, Orange, Red, White],
[White, Yellow, Green, Green, Blue],
[Blue, Yellow, Blue, Red, Yellow]],
rcRight = [[White, Green, Yellow, White, White],
[Blue, Orange, Orange, White, Red],
[Blue, Yellow, Blue, Yellow, Blue],
[Red, Orange, Orange, Red, Green],
[Red, Blue, Yellow, Orange, Yellow]],
rcLeft = [[Orange, Red, White, Orange, Green],
[Red, Orange, Red, Blue, White],
[Red, Green, Green, Green, Orange],
[Yellow, Orange, Blue, Red, Green],
[White, Blue, Blue, White, Orange]]
})

main :: Int -> IO ()
main n = mapM_ putStrLn $
case aStar neighbours (_ _ -> 1) (_ -> 0) goal $ cube n of
Nothing -> []
Just path -> map (show . fst) path

{-[ Module ends ]-------------------------------------------------------------}`