lsap
commented
3 years ago `{-# 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 ]-------------------------------------------------------------}`
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!