diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2014 Li-yao Xia + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,150 @@ +Twentyseven +=========== + +Rubik's cube solver in Haskell. + +Inspired by [Herbert Kociemba's *Cube Explorer*](http://kociemba.org/cube.htm). + +The main idea is to precompute, for every configuration, the number of moves +required to put certain subsets of the 27 cubies composing the 3x3 Rubik's cube +in their right place and/or in the right orientation. This gives lower bounds +used for an A⋆-like search in the graph of scrambled cubes. + +--- + +By default, a suboptimal "two-phase" solver is used, as it runs rather quickly. +It currently solves 1000 random cubes (uniformly distributed) in about one +minute. The optimal solver is quite slow however, taking between five minutes +and two hours to solve a random cube (18 moves in average). + +The solver must precompute a certain number of lookup tables, which can be +stored in files. These tables take fifteen seconds to compute and weigh 13MB +for the two-phase solver, compare that to about 8 hours and 2GB for the optimal +one! + +You may check the produced files with the checksums in `ts-tables.sha256`. +A compressed archive `ts-tables.zip` (723MB) of all precomputed tables is +available in the branch `fetch-tables` via `git-lfs`. Unzip it in `$HOME/.27/`, +or wherever (see usage below). + +Usage summary +------------- + + twentyseven [-p] [--strict] [-d DIR] [--optimal] + +- For the first invocation, use `-p` to precompute nonexistent lookup tables, + otherwise an error is thrown when `twentyseven` tries to load them; +- `--strict` loads tables immediately, otherwise they are loaded "by need" (so + you can also send it a cube to solve); +- `-d DIR` specifies the directory where the tables should be read and written + (default: `$HOME/.27/`). + +The input is read line by line. + +Input format +------------ + +A line can be one of: + +- A string of 54 characters (ignoring spaces) from a set of (almost any) 6 + characters. Each character then corresponds to the color of one facelet, in + the order illustrated below. + + Output: a sequence of moves to unscramble it. + + Facelets are numbered in base 9. Faces `0,1,2,3,4,5` correspond to `U,L,F,R,B,D`. + + 00 01 02 + 03 04 05 + 06 07 08 + + 10 11 12 20 21 22 30 31 32 40 41 42 + 13 14 15 23 24 25 33 34 35 43 44 45 + 16 17 18 26 27 28 36 37 38 46 47 48 + + 50 51 52 + 53 54 55 + 56 57 58 + +- A dot `.` followed by a sequence of moves to scramble the cube. + + The basic moves are given by a letter in `[ULFRBD]`, or their lowercase + counterparts. Each letter corresponds to a clockwise quarter turn of the + given face (up, left, front, right, back, down). The orientation is + determined when looking directly at the turning face. + + For every basic move, an optional suffix `[23']` allows to specify a half + turn (e.g., `U2`), equivalent to a sequence of two quarter turns (`UU`), or a + counterclockwise quarter turn (e.g., `U3` or `U'`) equivalent to a sequence + of three clockwise (`UUU`). + + Output: a description of the resulting cube if the moves are applied starting + from the solved cube (in the format above, with letters `ULFRBD` as + colors). + +- The keyword `random`. + + Output: a random *solvable* cube with uniform distribution. + +- The keyword `quit` (or an end-of-file) terminates the interactive session. + +Example +------- + +### Initialization + + $ echo quit|twentyseven -p --strict + +### Example + +`examples.txt`: + + qwqwqwqwq erererere tytytytyt rerererer ytytytyty wqwqwqwqw + qwqwqwqwq erqrerere tytytytyt rerererer ytytytyty wqwqwqwqw + BBBBUBBBB UUUULUUUU RRRRFRRRR DDDDRDDDD LLLLBLLLL FFFFDFFFF + DDDFUDLRB FUFDLLLRR UBLBFDFUD ULBFRULLB RRRLBBRUB UBFFDFDRU + 111121111 333313333 222232222 444454444 666646666 555565555 + 111111214 223222222 131333333 344444444 555555555 666666666 + .udddlrrrbfffuddd + random + +The output then looks like this: + + $ twentyseven < examples.txt + U2 D2 L2 R2 F2 B2 + Facelets [6,18,11] ("qtq") do not match any regular cubie. + U D F B L R U2 R2 F2 R2 U2 L2 B2 U' D' B2 + U L B' L R2 D R U2 F U2 L2 B2 U B2 D' B2 U' R2 U L2 R2 U + U D L R F B U2 B2 L2 F2 D2 B2 R2 U' D' L2 + L U' F2 U F2 U L U' L2 D F2 D' F2 + BBBBUBBBB UUUULUUUU RRRRFRRRR DDDDRDDDD LLLLBLLLL FFFFDFFFF + BDLLUFBUD LBUBLURFL RLBFFBFRU RLFURULRR UBDRBRDDU DFBDDDFLF + +--- + +Detail of current heuristics +---------------------------- + +The distance estimations are based on cosets corresponding to the following +elements. + +### Two-phase + +#### Phase 1 + +- Corner Orientation × UD Slice +- Edge Orientation × UD Slice + +It is possible to store the actual distances to the goal set in phase 1 but +the current speed seems good enough for now. + +#### Phase 2 + +- Corner Permutation × UD Slice Permutation (Phase 2) +- UD Edge Permutation (Phase 2) × UD SlicePermutation (Phase 2) + +### Optimal + +- Corner Orientation × Edge Orientation + × XY Slice Permutation, for XY in {UD, LR, FB} +- Corner Orientation × Corner Permutation diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exec-src/twentyseven.hs b/exec-src/twentyseven.hs new file mode 100644 --- /dev/null +++ b/exec-src/twentyseven.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} + +import Rubik.Cube +import Rubik.Misc +import qualified Rubik.Solver.Optimal as Optimal +import qualified Rubik.Solver.TwoPhase as TwoPhase +import qualified Rubik.Tables.Internal as Option + +import Control.Exception +import Control.Monad + +import Data.Time.Clock + +import Data.Char +import Data.Monoid + +import Numeric ( showFFloat ) + +import Options.Applicative hiding ( value ) +import qualified Options.Applicative as Opt + +import System.Exit +import System.IO.Error + +type Solver = Cube -> Move + +data Parameters = Parameters { + verbose :: Bool, + solve :: Solver, + tsPath :: Maybe FilePath, + precompute :: Bool, + overwrite :: Bool, + noFiles :: Bool, + strict :: Bool, + debug :: Bool + } + +optparse :: Parser Parameters +optparse = Parameters + <$> switch ( long "verbose" <> short 'v' + <> help "Print time taken to solve every cube" ) + <*> flag TwoPhase.solve Optimal.solve ( long "optimal" + <> help "Use optimal solver (experimental)" ) + <*> (optional . strOption) ( long "ts-dir" <> short 'd' + <> metavar "DIR" + <> help "Location of precomputed tables" ) + <*> switch ( long "precompute" <> short 'p' + <> help "Precompute and store tables \ + \(do enable this at the first invocation)" ) + <*> switch ( long "overwrite" + <> help "Recompute and overwrite tables even when they exist already" ) + <*> switch ( long "no-files" + <> help "Do not read or write any files \ + \(recompute tables for this session)" ) + <*> switch ( long "strict" + <> help "Force loading tables before doing anything else" ) + <*> switch ( long "debug" ) + +main :: IO () +main = do + p <- execParser $ info (helper <*> optparse) briefDesc + setOptions p + catchIOError + (forever $ + flip answer p =<< filter (not . isSpace) <$> getLine) + (\e -> if isEOFError e then return () else ioError e) + +setOptions :: Parameters -> IO () +setOptions Parameters{..} = do + mapM_ Option.setTsPath tsPath + Option.setPrecompute precompute + Option.setOverwrite overwrite + Option.setNoFiles noFiles + Option.setDebug debug + when strict . void $ evaluate + (solve . either undefined moveToCube . stringToMove $ "ulfrbd") + +answer :: String -> Parameters -> IO () +answer s p = case s of + '.' : s' -> moveSequence s' + "random" -> putStrLn =<< stringOfCubeColors <$> randomCube + "quit" -> exitSuccess + "" -> return () + _ -> faceletList s p + +-- A sequence of moves, e.g., "URF". +moveSequence s = putStrLn $ + case stringToMove s of + Left c -> "Unexpected '" ++ [c] ++ "'." + Right ms -> stringOfCubeColors . moveToCube . reduceMove $ ms + +faceletList = either (const . putStrLn) justSolve . readCube + +readCube s + = case colorFacelets'' s of + Nothing -> Left "Expected string of length 54 of a set of (any) 6 \ + \characters. Centers must be distinct." + Just colors -> + case colorFaceletsToCube colors of + Left fs -> + Left $ "Facelets " ++ show fs + ++ " (" ++ show (map (s !!) fs) ++ ") \ + \do not match any regular cubie." + Right Nothing -> + Left "Not a permutation of cubies \ + \(a cubie is absent, and a cubie occurs twice)." + Right (Just c) | solvable c -> Right c + _ -> Left "Unsolvable cube." + +justSolve :: Cube -> Parameters -> IO () +justSolve c p = do + let solved = solve p c + solStr = moveToString solved + flip vPutStrLn p . toString =<< clock (evaluate solved) + if c <> moveToCube solved == iden + then putStrLn solStr + else fail $ "Incorrect solver: " ++ solStr + where + toString d = showFFloat (Just 2) d "s" + +unlessQuiet' :: IO () -> Parameters -> IO () +unlessQuiet' a = unlessQuiet (const a) () + +-- Strict in its second argument +unlessQuiet :: (a -> IO ()) -> a -> Parameters -> IO () +unlessQuiet f a p = evaluate a >> when (verbose p) (f a) + +clock :: IO a -> IO Double +clock a = do + t <- getCurrentTime + a + t' <- getCurrentTime + return (diffTimeToSeconds (diffUTCTime t' t)) + where + diffTimeToSeconds = fromRational . toRational + +listSeq' :: [a] -> [a] +listSeq' s = s `listSeq` s + +vPutStrLn :: String -> Parameters -> IO () +vPutStrLn s = unlessQuiet putStrLn (listSeq' s) + +vPutStr :: String -> Parameters -> IO () +vPutStr s = unlessQuiet putStrLn (listSeq' s) diff --git a/src/Data/Binary/Storable.hs b/src/Data/Binary/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Storable.hs @@ -0,0 +1,43 @@ +-- | A binary-(the library)-like module which communicates directly through +-- handles rather than using bytestring. + +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Binary.Storable where + +import Control.Monad +import qualified Data.Vector as V +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import System.IO + +type Put a = Handle -> a -> IO () +type Get a = Handle -> IO a + +class Binary a where + put :: Put a + get :: Get a + +storablePut :: Storable a => Put a +storablePut h a = with a (\ptr -> hPutBuf h ptr (sizeOf a)) + +storableGet :: forall a. Storable a => Get a +storableGet h = alloca (\ptr -> hGetBuf h ptr (sizeOf (undefined :: a)) >> peek ptr) + +instance Binary Int where + put = storablePut + get = storableGet + +instance Binary a => Binary [a] where + put h as = put h (length as) >> forM_ as (put h) + get h = get h >>= \n -> replicateM n (get h) + +instance Binary a => Binary (V.Vector a) where + put h = put h . V.toList + get h = V.fromList <$> get h + +encodeFile :: Binary a => FilePath -> a -> IO () +encodeFile file a = withBinaryFile file WriteMode $ \h -> put h a + +decodeFile :: Binary a => FilePath -> IO a +decodeFile file = withBinaryFile file ReadMode $ \h -> get h diff --git a/src/Data/MBitVector.hs b/src/Data/MBitVector.hs new file mode 100644 --- /dev/null +++ b/src/Data/MBitVector.hs @@ -0,0 +1,37 @@ +module Data.MBitVector where + +import Control.Monad.Primitive +import Data.Bool +import Data.Bits +import qualified Data.Vector.Storable.Allocated as S + +newtype MBitVector s = MBitVector (S.MVector s Word) + +replicate :: PrimMonad m => Int -> Bool -> m (MBitVector (PrimState m)) +replicate n b = MBitVector <$> + S.replicate (1 + (n-1) `div` wordSize) (bool 0 (Data.Bits.complement zeroBits) b) + +modify :: PrimMonad m + => (Word -> Int -> Word) -> MBitVector (PrimState m) -> Int -> m () +modify (?) (MBitVector v) i = S.modify v (? ofs) j + where + (j, ofs) = i `divMod` wordSize + +set, clear, complement + :: PrimMonad m => MBitVector (PrimState m) -> Int -> m () +set = modify clearBit +clear = modify setBit +complement = modify complementBit + +-- Assume the word is 0 or 1 +put :: PrimMonad m => MBitVector (PrimState m) -> Int -> Word -> m () +put (MBitVector v) i b = S.modify v ((.|. b `shiftL` ofs) . (`clearBit` ofs)) j + where + (j, ofs) = i `divMod` wordSize + +test :: PrimMonad m => MBitVector (PrimState m) -> Int -> m Bool +test (MBitVector v) i = (`testBit` ofs) <$> S.read v j + where + (j, ofs) = i `divMod` wordSize + +wordSize = finiteBitSize (0 :: Word) diff --git a/src/Data/Tuple/Extra.hs b/src/Data/Tuple/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple/Extra.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies, TypeOperators, TemplateHaskell #-} +module Data.Tuple.Extra where + +import Control.Monad ( forM ) +import Data.Tuple.Template ( decTupleCons ) + +class TupleCons b where + type (:|) a b :: * + (|:|) :: a -> b -> a :| b + split :: a :| b -> (a, b) + +forM [3 .. 10] decTupleCons + +newtype Tuple1 a = Tuple1 a + deriving (Eq, Ord, Show) + +instance TupleCons (Tuple1 a) where + type (:|) b (Tuple1 a) = (b, a) + {-# INLINE (|:|) #-} + a |:| Tuple1 b = (a, b) + {-# INLINE split #-} + split (a, b) = (a, Tuple1 b) diff --git a/src/Data/Tuple/Template.hs b/src/Data/Tuple/Template.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple/Template.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TemplateHaskell, ViewPatterns #-} +module Data.Tuple.Template where + +import Control.Monad +import Language.Haskell.TH hiding ( tupleT ) + +-- | $(tupleName n) = Tuple[n] +tupleName :: Int -> Name +tupleName n = mkName $ "(" ++ replicate (n-1) ',' ++ ")" + +tupleT :: [TypeQ] -> TypeQ +tupleT args = appsT (conT (tupleName n)) args + where + appsT = foldl appT + n = length args + +tupleE :: [ExpQ] -> ExpQ +tupleE args = appsE $ conE (tupleName n) : args + where n = length args + +tupleP :: [PatQ] -> PatQ +tupleP ps = conP (tupleName n) ps + where n = length ps + +decTupleCons :: Int -> Q Dec +decTupleCons n = do + aas@(a : as) <- replicateM n (varT <$> newName "a") + instanceD (cxt []) + (foldl appT (conT (mkName "TupleCons")) + [tupleT as]) + [typeD aas, consInlD, consD, splitInlD, splitD] + where + typeD aas@(a : as) = + TySynInstD (mkName ":|") <$> tySynEqn [a, tupleT as] (tupleT aas) + consInlD = pragInlD (mkName "|:|") Inline FunLike AllPhases + splitInlD = pragInlD (mkName "split") Inline FunLike AllPhases + consD = do + xxs@(x : xs) <- replicateM n (newName "x") + funD (mkName "|:|") + [ clause + [ varP x, tupleP (varP <$> xs) ] + (normalB [| $(tupleE' xxs) |]) + [] ] + splitD = do + xxs@(x : xs) <- replicateM n (newName "x") + funD (mkName "split") + [ clause + [ tupleP (varP <$> xxs) ] + (normalB [| ($(varE x), $(tupleE' xs)) |]) + [] ] + tupleE' = tupleE . fmap varE diff --git a/src/Data/Vector/Generic/Mutable/Loops.hs b/src/Data/Vector/Generic/Mutable/Loops.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Generic/Mutable/Loops.hs @@ -0,0 +1,20 @@ +-- | Traversing mutable vectors. +module Data.Vector.Generic.Mutable.Loops where + +import Control.Monad.Primitive +import Data.Vector.Generic.Mutable as MG + +type Loop m v a = v (PrimState m) a -> (a -> m ()) -> m () +type ILoop m v a = v (PrimState m) a -> (Int -> a -> m ()) -> m () + +{-# INLINE iForM_ #-} +iForM_ :: (MG.MVector v a, PrimMonad m) => ILoop m v a +iForM_ v f = for' 0 (MG.length v) $ \i -> MG.unsafeRead v i >>= f i + +{-# INLINE forM_ #-} +forM_ :: (MG.MVector v a, PrimMonad m) => Loop m v a +forM_ v = iForM_ v . const + +-- @forM_ [0 .. n-1]@ somehow runs out of memory +for' i n f | i == n = return () +for' i n f = f i >> for' (i+1) n f diff --git a/src/Data/Vector/HalfByte.hs b/src/Data/Vector/HalfByte.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/HalfByte.hs @@ -0,0 +1,153 @@ +-- | Vectors with integer values in '[0 .. 15]', which hold in half a byte. +-- This module is generic in the underlying vector, and specialized to 'Pinned' +-- in 'Data.Vector.HalfByte.Pinned'. + +{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, + MagicHash, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, + TypeFamilies #-} +module Data.Vector.HalfByte where + +import Control.DeepSeq +import Control.Monad +import Data.Binary.Storable +import Data.Bits +import Data.Coerce +import Data.Foldable +import Data.Primitive (sizeOf) +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as MG +import qualified Data.Vector.Storable.Allocated as S + +newtype Word4 = Word4 { unWord4 :: Word } + deriving (Eq, Ord, Real, Integral) + +instance Enum Word4 where + succ (Word4 x) + | x == 15 = error "succ: Word4 maxBound" + | otherwise = Word4 (succ x) + pred (Word4 x) = Word4 (pred x) + toEnum = Word4 . toEnum + fromEnum = fromEnum . unWord4 + +instance Num Word4 where + Word4 x + Word4 y = Word4 ((x + y) .&. 15) + Word4 x * Word4 y = Word4 ((x * y) .&. 15) + Word4 x - Word4 y = Word4 ((x - y) .&. 15) + abs = id + signum 0 = 0 + signum _ = 1 + fromInteger = word4 . fromInteger + +instance Show Word4 where + showsPrec = coerce (showsPrec :: Int -> Word -> ShowS) + +instance Read Word4 where + readsPrec = coerce (readsPrec :: Int -> ReadS Word) + +type Vector' = Vector S.Vector Word4 +type MVector' s = MVector S.MVector s Word4 + +data Vector v a = Vector !Int !Int !(v Word) + -- ^ Offset (0,'sizeOf (_::Word)'), length, underlying vector. + +data MVector v s a = MVector !Int !Int !(v s Word) + +instance NFData (v Word) => NFData (Vector v Word4) where + rnf (Vector _ _ v) = rnf v + +instance G.Vector v Word => Show (Vector v Word4) where + showsPrec = G.showsPrec + +word4 :: Word -> Word4 +word4 = Word4 . (.&. word4Ones) + +{-# INLINE wordSize #-} +{-# INLINE wordSize2 #-} +{-# INLINE word4Bits #-} +wordSize, wordSize2, word4Bits :: Int +wordSize = sizeOf (undefined :: Word) +-- | Number of 'Word4' in a 'Word' +wordSize2 = 2 * wordSize +word4Bits = 4 +{-# INLINE word4Ones #-} +word4Ones :: Word +word4Ones = 15 + +{-# INLINE replWord #-} +replWord :: Word4 -> Word +replWord (Word4 x) + = foldl' (\z b -> z .|. (x `shiftL` (word4Bits * b))) 0 [0 .. wordSize2 - 1] + +instance MG.MVector v Word => MG.MVector (MVector v) Word4 where + {-# INLINE basicLength #-} + basicLength (MVector _ n _) = n + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m (MVector ofs _ v) + = MVector ofs' m (MG.basicUnsafeSlice vOfs (1 + (ofs'+m-1) `div` wordSize2) v) + where + (vOfs, ofs') = (ofs + j) `divMod` wordSize2 + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector _ _ v) (MVector _ _ w) = MG.basicOverlaps v w + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n = MVector 0 n <$> MG.basicUnsafeNew (1 + (n-1) `div` wordSize2) + {-# INLINE basicInitialize #-} + basicInitialize (MVector _ _ v) = MG.basicInitialize v + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeReplicate n x = MVector 0 n <$> + MG.basicUnsafeReplicate (1 + (n-1) `div` wordSize2) (replWord x) + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (MVector ofs _ v) i + = word4 . (`shiftR` (word4Bits * b)) <$> MG.basicUnsafeRead v j + where + (j, b) = (ofs + i) `divMod` wordSize2 + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (MVector ofs _ v) i (Word4 x) + = MG.basicUnsafeRead v j >>= \y -> do + let y' = (y .&. mask) .|. (x `shiftL` (word4Bits * b)) + MG.basicUnsafeWrite v j y' + where + (j, b) = (ofs + i) `divMod` wordSize2 + mask = complement (word4Ones `shiftL` (word4Bits * b)) + {-# INLINE basicSet #-} + basicSet v0@(MVector ofs n v) x0@(Word4 x) + = do + let (m', b') = (ofs + n) `divMod` wordSize2 + MG.basicUnsafeRead v 0 >>= \y -> do + let y' = foldl' set y [ofs .. min (ofs+n) wordSize2 - 1] + MG.basicUnsafeWrite v 0 y' + when (m' > 1) $ do + let v' = MG.basicUnsafeSlice 1 (m'-1) v + z = replWord x0 + MG.basicSet v' z + when (ofs+n > wordSize2) $ do + MG.basicUnsafeRead v m' >>= \y -> do + let y' = foldl' set y [0 .. b'-1] + MG.basicUnsafeWrite v m' y' + where + set y b = + let mask = complement (word4Ones `shiftL` (word4Bits * b)) + in (y .&. mask) .|. (x `shiftL` (word4Bits * b)) + +type instance G.Mutable (Vector v) = MVector (G.Mutable v) + +instance G.Vector v Word => G.Vector (Vector v) Word4 where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (MVector ofs n mv) = Vector ofs n <$> G.basicUnsafeFreeze mv + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (Vector ofs n v) = MVector ofs n <$> G.basicUnsafeThaw v + {-# INLINE basicLength #-} + basicLength (Vector _ n _) = n + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m (Vector ofs _ v) + = Vector ofs' m (G.basicUnsafeSlice vOfs (1 + (ofs'+m-1) `div` wordSize2) v) + where + (vOfs, ofs') = (ofs + j) `divMod` wordSize2 + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM (Vector ofs _ v) i + = word4 . (`shiftR` (word4Bits * b)) <$> G.basicUnsafeIndexM v j + where + (j, b) = (ofs + i) `divMod` wordSize2 + +instance Binary (v Word) => Binary (Vector v Word4) where + put h (Vector ofs n v) = put h ofs >> put h n >> put h v + get h = get h >>= \ofs -> get h >>= \n -> Vector ofs n <$> get h diff --git a/src/Data/Vector/Storable/Allocated.hs b/src/Data/Vector/Storable/Allocated.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/Storable/Allocated.hs @@ -0,0 +1,152 @@ +-- | An alternative to 'Data.Vector.Storable' where the underlying byte arrays +-- are pinned. + +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MagicHash, + MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +module Data.Vector.Storable.Allocated where + +import Control.DeepSeq +import Control.Monad +import Control.Monad.Primitive +import Control.Monad.ST +import Data.Binary.Storable +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as MG +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Storable.Mutable as MS +import Foreign +import System.IO + +newtype Vector a = Vector { unV :: S.Vector a } + deriving (Eq, Ord, Read, Show, NFData) + +newtype MVector s a = MVector { unMV :: MS.MVector s a } + deriving (NFData) + +instance Storable a => MG.MVector MVector a where + {-# INLINE basicLength #-} + basicLength = MG.basicLength . unMV + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m = MVector . MG.basicUnsafeSlice j m . unMV + {-# INLINE basicOverlaps #-} + basicOverlaps (MVector v) (MVector w) = MG.basicOverlaps v w + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew = fmap MVector . callocVector + {-# INLINE basicInitialize #-} + basicInitialize = MG.basicInitialize . unMV + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead = MG.basicUnsafeRead . unMV + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite = MG.basicUnsafeWrite . unMV + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector v) (MVector w) = MG.basicUnsafeCopy v w + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove (MVector v) (MVector w) = MG.basicUnsafeMove v w + {-# INLINE basicSet #-} + basicSet = MG.basicSet . unMV + +type instance G.Mutable Vector = MVector + +instance Storable a => G.Vector Vector a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze = fmap Vector . G.basicUnsafeFreeze . unMV + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw = fmap MVector . G.basicUnsafeThaw . unV + {-# INLINE basicLength #-} + basicLength = G.basicLength . unV + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j n = Vector . G.basicUnsafeSlice j n . unV + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM = G.basicUnsafeIndexM . unV + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy (MVector mv) (Vector v) = G.basicUnsafeCopy mv v + {-# INLINE elemseq #-} + elemseq = G.elemseq . unV + +{-# INLINE callocVector #-} +callocVector :: forall a m. (PrimMonad m, Storable a) + => Int -> m (S.MVector (PrimState m) a) +callocVector n = unsafePrimToPrim $ + S.MVector n <$> (newForeignPtr finalizerFree =<< callocArray n) + +-- * Mutable interface + +{-# INLINE replicate #-} +replicate :: (PrimMonad m, Storable a) => Int -> a -> m (MVector (PrimState m) a) +replicate = MG.replicate + +{-# INLINE read #-} +read :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> m a +read = MG.read + +{-# INLINE write #-} +write :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> a -> m () +write = MG.write + +{-# INLINE modify #-} +modify :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +modify = MG.modify + +{-# INLINE unsafeRead #-} +unsafeRead :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> m a +unsafeRead = MG.unsafeRead + +{-# INLINE unsafeWrite #-} +unsafeWrite + :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> a -> m () +unsafeWrite = MG.unsafeWrite + +{-# INLINE unsafeModify #-} +unsafeModify + :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () +unsafeModify = MG.unsafeModify + +-- * Immutable interface + +{-# INLINE (!) #-} +(!) :: Storable a => Vector a -> Int -> a +(!) = (G.!) + +{-# INLINE length #-} +length :: Storable a => Vector a -> Int +length = G.length + +{-# INLINE generate #-} +generate :: Storable a => Int -> (Int -> a) -> Vector a +generate = G.generate + +{-# INLINE create #-} +create :: Storable a => (forall s. ST s (MVector s a)) -> Vector a +create = G.create + +{-# INLINE map #-} +map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b +map = G.map + +{-# INLINE ifilter #-} +ifilter :: Storable a => (Int -> a -> Bool) -> Vector a -> Vector a +ifilter = G.ifilter + +{-# INLINE fromList #-} +fromList :: Storable a => [a] -> Vector a +fromList = G.fromList + +-- * IO + +getMVector :: forall a. Storable a => Handle -> MVector RealWorld a -> IO () +getMVector h (MVector (S.MVector n ptr)) + = withForeignPtr ptr $ \ptr -> hGetBuf h ptr n' >>= \m -> + when (m /= n') $ fail "Not enough bytes." + where + n' = n * sizeOf (undefined :: a) + +instance Storable a => Binary (Vector a) where + put h (Vector v) + = S.unsafeWith v $ \ptr -> put h n >> hPutBuf h ptr (n * size) + where + n = S.length v + size = sizeOf (undefined :: a) + + get h = get h >>= \n -> MG.new n >>= getMVector h >>. G.unsafeFreeze + where + (>>.) = liftM2 (>>) diff --git a/src/Rubik/Cube.hs b/src/Rubik/Cube.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube.hs @@ -0,0 +1,13 @@ +{- | Representations of Rubik's cube. +-} +module Rubik.Cube ( + module Rubik.Cube.Facelet, + module Rubik.Cube.Coord, + module Rubik.Cube.Cubie, + module Rubik.Cube.Moves, + ) where + +import Rubik.Cube.Facelet +import Rubik.Cube.Coord +import Rubik.Cube.Cubie +import Rubik.Cube.Moves diff --git a/src/Rubik/Cube/Coord.hs b/src/Rubik/Cube/Coord.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube/Coord.hs @@ -0,0 +1,318 @@ +{- | + Encoding cube projections as @Int@ coordinates. + + Explicit dictionary passing style: + using a class would require explicit type annotations /anyway/. +-} + +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, ScopedTypeVariables, ViewPatterns #-} +module Rubik.Cube.Coord where + +import Rubik.Cube.Cubie.Internal +import Rubik.Misc + +import Control.DeepSeq +import Control.Monad.Random +import Control.Newtype + +import Data.Binary.Storable +import Data.List +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU +import qualified Data.Vector.Storable.Allocated as S + +-- * Raw coordinates + +-- Unwrapped coordinate +type RawCoord' = Int + +-- MaxInt 2^29 = 479001600 (at least, according to the standard) +-- | Encoding to an efficient datatype +-- for which it is possible to build tables +-- instead of computing functions. +newtype RawCoord a = RawCoord { unRawCoord :: RawCoord' } + deriving (Eq, Ord, Show, NFData, Binary) + +newtype RawVector a b = RawVector { unRawVector :: U.Vector b } + +newtype RawMove a = RawMove { unRawMove :: S.Vector RawCoord' } + deriving (Eq, Ord, Show, NFData, Binary) + +instance Newtype (RawCoord a) Int where + pack = RawCoord + unpack = unRawCoord + +instance Newtype (RawMove a) (S.Vector Int) where + pack = RawMove + unpack = unRawMove + +{-# INLINE (!$) #-} +(!$) :: RawMove a -> RawCoord a -> RawCoord a +RawMove v !$ RawCoord i = RawCoord (v S.! i) + +(!.) :: MU.Unbox b => RawVector a b -> RawCoord a -> b +RawVector v !. RawCoord i = v U.! i + +-- * Dictionaries + +-- | Encoding dictionary. +-- +-- Probably synonymous with instances for both +-- @('Enum' a, 'Bounded' a)@. +-- +-- > inRange (range d) $ encode x +-- > encode . decode == id +-- > decode . encode == id +-- +-- A special constructor for dictionaries of product types +-- is particularly useful to create tables of functions +-- if their actions on every projection are independent. +-- +class RawEncodable a where + -- | Number of elements that can be converted. + -- Their values are to lie in @[0 .. range c - 1]@. + range :: proxy a -> Int + encode :: a -> RawCoord a + decode :: RawCoord a -> a + +-- ** Instances +-- | The number of elements of every set is given. + +-- | @8! = 40320@ +instance RawEncodable CornerPermu where + range _ = 40320 + encode = RawCoord . encodeFact numCorners . U.toList . fromCornerPermu + decode = unsafeCornerPermu' . decodeFact numCorners numCorners . unRawCoord + +-- | @12! = 479001600@ +-- +-- A bit too much to hold in memory. +-- +-- Holds just right in a Haskell @Int@ (@maxInt >= 2^29 - 1@). +instance RawEncodable EdgePermu where + range _ = 479001600 + encode = RawCoord . encodeFact numEdges . U.toList . fromEdgePermu + decode = unsafeEdgePermu' . decodeFact numEdges numEdges . unRawCoord + +-- | @3^7 = 2187@ +instance RawEncodable CornerOrien where + range _ = 2187 + encode = RawCoord . encodeBaseV 3 . U.tail . fromCornerOrien + -- The first orientation can be deduced from the others in a solvable cube + decode (RawCoord x) = unsafeCornerOrien' (h : t) + where h = (3 - sum t) `mod` 3 + t = decodeBase 3 (numCorners - 1) x + +-- | @2^11 = 2048@ +instance RawEncodable EdgeOrien where + range _ = 2048 + encode = RawCoord . encodeEdgeOrien' . fromEdgeOrien + decode (RawCoord x) = unsafeEdgeOrien' (h : t) + where h = sum t `mod` 2 + t = decodeBase 2 (numEdges - 1) x + +encodeEdgeOrien' = encodeBaseV 2 . U.tail + +numUDS = numUDSliceEdges +numUDE = numEdges - numUDS + +-- | 12! / 8! = 11880 +instance RawEncodable UDSlicePermu where + range _ = 11880 + encode = RawCoord . encodeFact numEdges . U.toList . fromUDSlicePermu + decode = unsafeUDSlicePermu' . decodeFact numEdges numUDS . unRawCoord + +-- | @12C4 = 495@ +instance RawEncodable UDSlice where + range _ = 495 + encode = RawCoord . encodeCV . fromUDSlice + decode = unsafeUDSlice . decodeCV numUDS . unRawCoord + +-- | @4! = 24@ +instance RawEncodable UDSlicePermu2 where + range _ = 24 + encode = RawCoord . encodeFact numUDS . U.toList . fromUDSlicePermu2 + decode = unsafeUDSlicePermu2' . decodeFact numUDS numUDS . unRawCoord + +-- | @8! = 40320@ +instance RawEncodable UDEdgePermu2 where + range _ = 40320 + encode = RawCoord . encodeFact numUDE . U.toList . fromUDEdgePermu2 + decode = unsafeUDEdgePermu2' . decodeFact numUDE numUDE . unRawCoord + +instance (RawEncodable a, RawEncodable b) => RawEncodable (a, b) where + range _ = range ([] :: [a]) * range ([] :: [b]) + encode (a, b) = flatCoord (encode a) (encode b) + decode (splitCoord -> (a, b)) = (decode a, decode b) + +{-# INLINE flatCoord #-} +flatCoord + :: (RawEncodable a, RawEncodable b) + => RawCoord a -> RawCoord b -> RawCoord (a, b) +flatCoord (RawCoord a) b'@(RawCoord b) = RawCoord (flatIndex (range b') a b) + +{-# INLINE splitCoord #-} +splitCoord + :: (RawEncodable a, RawEncodable b) + => RawCoord (a, b) -> (RawCoord a, RawCoord b) +splitCoord (RawCoord ab_) = (a, b) + where + (RawCoord -> a, RawCoord -> b) = ab_ `divMod` range b + +-- * Table building + +-- | Endofunctions +type Endo a = a -> a + +-- | Lift an endofunction to its coordinate representation, +-- the dictionary provides a @RawCoord@ encoding. +-- +-- That is, we construct a vector @v@ such that, basically, +-- +-- > decode (v ! encode x) == f x +-- +-- So function application becomes simply vector indexing. +endoVector :: RawEncodable a => Endo a -> RawMove a +endoVector f + = RawMove . S.generate (range f) $ + under RawCoord (encode . f . decode) + +-- | The 'cubeAction' method is partially applied to a 'Cube' +-- and turned into an 'Endo' function. +-- +-- The 'CA a' type argument controls the refinement of the endofunction. +cubeActionToEndo :: CubeAction a => Cube -> Endo a +cubeActionToEndo c = (`cubeAction` c) + +-- | Composition of 'endoVector' and 'cubeAction'. +moveTable :: (CubeAction a, RawEncodable a) => Cube -> RawMove a +moveTable = endoVector . cubeActionToEndo + +symToEndo :: (Cube -> a -> a) -> Cube -> Endo a +symToEndo = id + +symTable :: RawEncodable a => (Cube -> a -> a) -> Cube -> RawMove a +symTable conj = endoVector . symToEndo conj + +-- * Miscellaneous + +-- | Checks over the range @range@ that: +-- +-- > encode . decode == id +-- +checkCoord :: RawEncodable a => proxy a -> Bool +checkCoord proxy + = all (\(RawCoord -> k) -> encode (decode k `asProxyTypeOf` proxy) == k) + [0 .. range proxy - 1] + +randomRawCoord :: forall a m. (MonadRandom m, RawEncodable a) => m (RawCoord a) +randomRawCoord = RawCoord <$> getRandomR (0, range ([] :: [a]) - 1) + +-- * Helper +-- | Helper functions to define the dictionaries + +-- ** Fixed base + +-- | If +-- @all (`elem` [0 .. b-1]) v@ +-- then @v@ is the base @b@ representation of +-- @encode b v@ +-- such that its least significant digit is @head v@. +-- +-- For any @n@, @encodeBase b@ is a bijection from lists of length @n@ +-- with elements in @[0 .. b-1]@ to @[0 .. b^n - 1]@ +encodeBase :: Int -> [Int] -> Int +encodeBase b = foldr1 (\x y -> x + b * y) + +-- | Vector version of 'encodeBase'. +encodeBaseV :: Int -> Vector Int -> Int +encodeBaseV b = U.foldr1' (\x y -> x + b * y) + +-- | @len@ is the length of the resulting vector +-- +-- > encodeBase b . decodeBase b len == id +-- > decodeBase b len . encodeBase b == id +-- +decodeBase :: Int -> Int -> Int -> [Int] +decodeBase b len = take len . unfoldr (\x -> Just (x `modDiv` b)) + where modDiv = ((.).(.)) (\(x,y) -> (y,x)) divMod + +-- ** Factorial radix + +-- | Input list must be a @k@-permutation of @[0 .. n-1]@. +-- +-- @encodeFact@ is a bijection between k-permutations of @[0 .. n-1]@ +-- and @[0 .. (fact n / fact (n-k)) - 1]@. +encodeFact :: Int -> [Int] -> Int +encodeFact n [] = 0 +encodeFact n (y : ys) = y + n * encodeFact (n - 1) ys' + where + ys' = case elemIndex (n - 1) ys of + Nothing -> ys -- y == n - 1 + Just k -> subs k y ys -- recovers a subpermutation of @[0 .. n-2]@ + +-- | Inverse of 'encodeFact'. +-- +-- > encodeFact n . decodeFact n k == id -- k <= n +-- > decodeFact n k . encodeFact n == id -- on k-permutations +-- +decodeFact :: Int -> Int -> Int -> [Int] +decodeFact n 0 _ = [] +decodeFact n k x = y : ys + where + (q, y) = x `divMod` n + ys' = decodeFact (n - 1) (k - 1) q + ys = case elemIndex y ys' of + Nothing -> ys' -- y == n - 1 + Just k -> subs k (n - 1) ys' + +-- ** Binomial enumeration + +-- Bijection between @[0 .. choose n (k-1)]@ +-- and @k@-combinations of @[0 .. n-1]@. + +-- | > cSum k z == sum [y `choose` k | y <- [k .. z-1]] +-- +-- requires @k < cSum_mMaz@ and @z < cSum_nMaz@. +cSum :: Int -> Int -> Int +cSum = \k z -> v U.! (k * n + z) + where + cSum' k z = sum [y `choose` k | y <- [k .. z-1]] + v = U.generate (n * m) (uncurry cSum' . (`divMod` n)) + m = cSum_mMax + n = cSum_nMax + +-- | Bound on arguments accepted by @cSum@ +cSum_mMax, cSum_nMax :: Int +cSum_mMax = 4 +cSum_nMax = 16 + +-- | > encodeCV == encodeCV + cSum k (y k) +-- +-- where @c@ is a @k@-combination, +-- that is a sorted list of @k@ nonnegative elements. +-- +-- @encodeCV@ is in fact a bijection between increasing lists +-- (of non-negative integers) and integers. +-- +-- Restriction: @k < cSum_mMax@, @y k < cSum_nMax@. +encodeCV :: Vector Int -> Int +encodeCV = U.sum . U.imap cSum + +-- | Inverse of 'encodeCV'. +-- +-- The length of the resulting list must be supplied as a hint +-- (although it could technically be guessed). +decodeCV :: Int -> Int -> Vector Int +decodeCV k x = U.create (do + v <- MU.new k + let + decode' (-1) _ _ = return () + decode' k z x + | s <= x = MU.write v k z >> decode' (k-1) (z-1) (x-s) + | otherwise = decode' k (z-1) x + where + s = cSum k z + decode' (k-1) (cSum_nMax-1) x + return v) diff --git a/src/Rubik/Cube/Cubie.hs b/src/Rubik/Cube/Cubie.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube/Cubie.hs @@ -0,0 +1,73 @@ +{- | + Cubie representation. + + A Rubik's cube is the cartesian product of a permutation of cubies + and an action on their orientations. +-} + +module Rubik.Cube.Cubie ( + -- * Complete cube + CubeAction (..), + FromCube (..), + Cube (..), + + -- ** Solvability test + solvable, + + -- * Corners + numCorners, + CornerPermu, + CornerOrien, + Corner (..), + + -- ** (De)construction + cornerPermu, + cornerOrien, + fromCornerPermu, + fromCornerOrien, + + -- * Edges + numEdges, + EdgePermu, + EdgeOrien, + Edge (..), + + -- ** (De)construction + edgePermu, + edgeOrien, + fromEdgePermu, + fromEdgeOrien, + + -- * Conversions + stringOfCubeColors, + toFacelet, + colorFaceletsToCube, + + -- * UDSlice + numUDSliceEdges, + UDSlicePermu, + UDSlice, + UDSlicePermu2, + UDEdgePermu2, + FlipUDSlice, + FlipUDSlicePermu, + + -- ** (De)construction + uDSlicePermu, + uDSlice, + uDSlicePermu2, + uDEdgePermu2, + edgePermu2, + fromUDSlicePermu, + fromUDSlice, + fromUDSlicePermu2, + fromUDEdgePermu2, + + -- ** Symmetry + conjugateUDSlicePermu, + conjugateFlipUDSlice, + conjugateFlipUDSlicePermu, + conjugateCornerOrien + ) where + +import Rubik.Cube.Cubie.Internal diff --git a/src/Rubik/Cube/Cubie/Internal.hs b/src/Rubik/Cube/Cubie/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube/Cubie/Internal.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +module Rubik.Cube.Cubie.Internal where + +import Rubik.Cube.Facelet.Internal as F +import Rubik.Misc + +import Control.Applicative +import Control.Exception +import Control.Monad + +import Data.Function ( on ) +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU + +-- | Cubie permutation is in replaced-by representation. +newtype CornerPermu = CornerPermu { fromCornerPermu :: Vector Int } + deriving (Eq, Show) + +newtype CornerOrien = CornerOrien { fromCornerOrien :: Vector Int } + deriving (Eq, Show) + +data Corner = Corner + { cPermu :: CornerPermu + , cOrien :: CornerOrien } + deriving (Eq, Show) + +-- | Check that the argument is a permutation of size 8 and wrap it. +-- +-- In a 'solvable' Rubik's cube, +-- its parity must be equal to that of the associated 'EdgePermu'. +cornerPermu :: Vector Int -> Maybe CornerPermu +cornerPermu v = CornerPermu <$> mfilter check (Just v) + where check v = U.length v == numCorners + && isPermutationVector v + +unsafeCornerPermu = CornerPermu +unsafeCornerPermu' = CornerPermu . U.fromList + +-- | Check that the argument is a vector of senary (6) values of size 8 and +-- wrap it. +-- +-- In a 'solvable' Rubik's cube, +-- only ternary values are possible; +-- i.e., all elements must be between 0 and 2. +-- Their sum must also be a multiple of 3. +-- +-- == Orientation encoding +-- +-- Corner orientations are permutations of 3 facelets. +-- +-- They are mapped to integers in @[0 .. 5]@ +-- such that @[0, 1, 2]@ are rotations (even permutations) +-- and @[3, 4, 5]@ are transpositions (although impossible in a Rubik's cube). +-- +-- - 0. identity +-- - 1. counter-clockwise +-- - 2. clockwise +-- - 3. left facelet fixed +-- - 4. right facelet fixed +-- - 5. top (reference) facelet fixed +-- +cornerOrien :: Vector Int -> Maybe CornerOrien +cornerOrien v = do + guard $ U.length v == numCorners + && U.all (\o -> 0 <= o && o < 6) v + return (CornerOrien v) + +unsafeCornerOrien = CornerOrien +unsafeCornerOrien' = CornerOrien . U.fromList + +-- + +-- | Cubie permutation is in replaced-by representation. +newtype EdgePermu = EdgePermu { fromEdgePermu :: Vector Int } + deriving (Eq, Show) + +newtype EdgeOrien = EdgeOrien { fromEdgeOrien :: Vector Int } + deriving (Eq, Show) + +data Edge = Edge + { ePermu :: EdgePermu + , eOrien :: EdgeOrien } + deriving (Eq, Show) + +-- | Check that the argument is a permutation of size 12 and wrap it. +-- +-- In a 'solvable' Rubik's cube, +-- its parity must be equal to that of the associated 'CornerPermu'. +edgePermu :: Vector Int -> Maybe EdgePermu +edgePermu v = do + guard $ U.length v == numEdges + && isPermutationVector v + return (EdgePermu v) + +unsafeEdgePermu = EdgePermu +unsafeEdgePermu' = EdgePermu . U.fromList + +-- | Check that the argument is a vector of binary values of size 12 and wrap it. +-- +-- In a 'solvable' Rubik's cube, their sum must be even. +edgeOrien :: Vector Int -> Maybe EdgeOrien +edgeOrien v = do + guard $ U.length v == numEdges + && U.all (`elem` [0, 1]) v + return (EdgeOrien v) + +unsafeEdgeOrien = EdgeOrien +unsafeEdgeOrien' = EdgeOrien . U.fromList + +-- Complete cube + +-- | A cube is given by the positions of its corners and edges. +-- +-- Cubes are identified with the permutations that produce them starting +-- from the solved cube. +-- +-- The cube permutation composition (@class 'Group' 'Cube'@) is defined +-- \"in left to right order\", so that the sequence of movements +-- \"@x@ then @y@ then @z@\" is represented by @x <> y <> z@. +data Cube = Cube + { corner :: Corner + , edge :: Edge } + deriving (Eq, Show) + +class FromCube a where + fromCube :: Cube -> a + +instance (FromCube a, FromCube b) => FromCube (a, b) where + fromCube c = (fromCube c, fromCube c) + +-- | Group action of 'Cube' on type @a@ +-- +-- > x `cubeAction` iden == x +-- > (x `cubeAction` a) `cubeAction` b == x `cubeAction (a <> b) +-- +-- It seems that with proper additional laws +-- between 'FromCube' and 'Group' instances, +-- it may be possible to automatically deduce a default 'CubeAction' instance. +-- +-- > cubeAction a = (a <>) . fromCube +-- +-- This module defines representations of right cosets (@Hg where g :: Cube@) +-- of certain subgroups H of the Rubik group @Cube@, which acts on the right of +-- the set of cosets. +class CubeAction a where + cubeAction :: a -> Cube -> a + +instance (CubeAction a, CubeAction b) => CubeAction (a, b) where + cubeAction (a, b) c = (cubeAction a c, cubeAction b c) + +cube :: Vector Int -> Vector Int -> Vector Int -> Vector Int -> Maybe Cube +cube cp co ep eo = Cube <$> c <*> e + where c = Corner <$> cornerPermu cp <*> cornerOrien co + e = Edge <$> edgePermu ep <*> edgeOrien eo + +cube' :: [Int] -> [Int] -> [Int] -> [Int] -> Maybe Cube +cube' cp co ep eo = cube (f cp) (f co) (f ep) (f eo) + where f = U.fromList + +unsafeCube :: Vector Int -> Vector Int -> Vector Int -> Vector Int -> Cube +unsafeCube cp co ep eo = Cube c e + where c = Corner (CornerPermu cp) (CornerOrien co) -- Unsafe raw constructors + e = Edge (EdgePermu ep) (EdgeOrien eo) + +unsafeCube' :: [Int] -> [Int] -> [Int] -> [Int] -> Cube +unsafeCube' cp co ep eo = unsafeCube (f cp) (f co) (f ep) (f eo) + where f = U.fromList + +-- + +instance FromCube Corner where + fromCube = corner + +instance FromCube CornerPermu where + fromCube = cPermu . corner + +instance FromCube CornerOrien where + fromCube = cOrien . corner + +instance FromCube Edge where + fromCube = edge + +instance FromCube EdgePermu where + fromCube = ePermu . edge + +instance FromCube EdgeOrien where + fromCube = eOrien . edge + +-- + +-- | > numCorners = 8 +numCorners = 8 :: Int + +-- | > numEdges = 12 +numEdges = 12 :: Int + +-- Apply @o@ then @o'@ (as permutation of facelets, from the reference position) +o `oPlus` o' | o < 3 && o' < 3 = (o + o') `mod` 3 + | o < 3 = 3 + ((o'+ o) `mod` 3) + | o' < 3 = 3 + ((o - o') `mod` 3) + | otherwise = (o - o') `mod` 3 + +oInv o | o == 0 = 0 + | o < 3 = 3 - o + | otherwise = o + +-- + +instance Monoid CornerPermu where + mempty = CornerPermu $ idVector numCorners + mappend (CornerPermu b) (CornerPermu c) = CornerPermu $ composeVector b c + +instance Group CornerPermu where + inverse (CornerPermu a) = CornerPermu $ inverseVector a + +instance Monoid EdgePermu where + mempty = EdgePermu $ idVector numEdges + mappend (EdgePermu b) (EdgePermu c) = EdgePermu $ composeVector b c + +instance Group EdgePermu where + inverse (EdgePermu a) = EdgePermu $ inverseVector a + +instance CubeAction CornerPermu where + cubeAction cp_ = (cp_ <>) . fromCube + +instance CubeAction EdgePermu where + cubeAction ep_ = (ep_ <>) . fromCube + +-- Helper function to define the action of 'Cube' on 'CornerOrien' +actionCorner :: CornerOrien -> Corner -> CornerOrien +actionCorner (CornerOrien o) (Corner (CornerPermu gp) (CornerOrien go)) + = CornerOrien $ U.zipWith oPlus (U.backpermute o gp) go + +-- Helper function to define the action of 'Cube' on 'EdgeOrien' +actionEdge :: EdgeOrien -> Edge -> EdgeOrien +actionEdge (EdgeOrien o) (Edge (EdgePermu gp) (EdgeOrien go)) + = EdgeOrien $ U.zipWith (((`mod` 2) .) . (+)) (U.backpermute o gp) go + +instance CubeAction CornerOrien where + cubeAction co_ = actionCorner co_ . corner + +instance CubeAction EdgeOrien where + cubeAction eo_ = actionEdge eo_ . edge + +-- + +instance CubeAction Corner where + cubeAction (Corner cp co) c = + Corner (cp `cubeAction` c) (co `cubeAction` c) + +instance CubeAction Edge where + cubeAction (Edge ep eo) c = + Edge (ep `cubeAction` c) (eo `cubeAction` c) + +-- + +instance Monoid Corner where + mempty = Corner iden idCornerO + where idCornerO = CornerOrien $ U.replicate numCorners 0 + + mappend (Corner bp_ bo_) + c@(Corner cp_ co_) + = Corner dp_ do_ + where dp_ = bp_ <> cp_ + do_ = bo_ `actionCorner` c + +instance Group Corner where + inverse (Corner ap_ (CornerOrien ao)) + = Corner ap_' (CornerOrien ao') + where ap_'@(CornerPermu ap') = inverse ap_ + ao' = U.map oInv . U.backpermute ao $ ap' + +instance Monoid Edge where + mempty = Edge iden idEdgeO + where idEdgeO = EdgeOrien $ U.replicate numEdges 0 + + mappend (Edge bp_ bo_) + c@(Edge cp_ co_) + = Edge dp_ do_ + where dp_ = bp_ <> cp_ + do_ = bo_ `actionEdge` c + +instance Group Edge where + inverse (Edge ap_ (EdgeOrien ao)) + = Edge ap_' (EdgeOrien ao') + where ap_'@(EdgePermu ap') = inverse ap_ + ao' = U.backpermute ao ap' + +-- + +instance Monoid Cube where + mempty = Cube iden iden + mappend (Cube cA eA) (Cube cB eB) = Cube (cA <> cB) (eA <> eB) + +instance Group Cube where + inverse (Cube c e) = Cube (inverse c) (inverse e) + +-- + +-- | Tests whether a cube can be solved with the standard set of moves. +solvable :: Cube -> Bool +solvable (Cube (Corner (CornerPermu cp) (CornerOrien co)) + (Edge (EdgePermu ep) (EdgeOrien eo))) = + signPermutationVector cp == signPermutationVector ep + && U.sum co `mod` 3 == 0 + && U.all (< 3) co + -- Above: the data structure allows to encode all 6 permutations of the 3 facelets + -- so we need to exclude the 3 transpositions, which are represented by 3, 4, 5. + && U.sum eo `mod` 2 == 0 + +-- Conversions + +-- Facelet conversion + +-- | 0 <= o < 6 +symRotate :: Int -> [Int] -> [Int] +symRotate o + | o < 3 = rotate o -- Even permutation + | otherwise = rotate (5 - o) . sym -- Odd permutation + where sym [a,b,c] = [a,c,b] + +toFacelet :: Cube -> Facelets +toFacelet + (Cube + { corner = Corner (CornerPermu cp) (CornerOrien co) + , edge = Edge (EdgePermu ep) (EdgeOrien eo) }) + = unsafeFacelets $ U.create (do + v <- MU.new F.numFacelets + setFacelets v cp co cornerFacelets -- Corners + setFacelets v ep eo edgeFacelets -- Edges + forM_ [4, 13 .. 49] (\x -> MU.write v x x) -- Centers + return v) + where + -- Return an association list + -- (i, j) <- assoc + -- such that in the cube facelet i is replaced by facelet j + -- p: Cubie permutations + -- o: Cubie orientations + -- f: Cubie facelets + -- Parameterized over a choice of cubie family (edges/corners) + setFacelets v p o f + = forM_ + ((zip `on` concat) f orientedFaces) + . uncurry $ MU.write v + where + orientedFaces = zipWith symRotate (U.toList o) cubieFacelets + cubieFacelets = map (f !!) (U.toList p) + +-- | Convert from facelet to cubie permutation. +-- +-- Evaluates to a 'Left' error if a combination of colors does not correspond to +-- a regular cubie from the solved cube: the colors of the facelets on one +-- cubie must be unique, and must not contain facelets of opposite faces. +-- The error is the list of indices of facelets of such an invalid cubie. +-- +-- Another possible error is that the resulting configuration is not a +-- permutation of cubies (at least one cubie is absent, and one is duplicated). +-- In that case, the result is 'Right' 'Nothing'. +colorFaceletsToCube :: ColorFacelets -> Either [Int] (Maybe Cube) +colorFaceletsToCube (fromColorFacelets -> c) = do + (co, cp) <- pack <$> zipWithM findCorner (colorsOfC cornerFacelets) cornerFacelets + (eo, ep) <- pack <$> zipWithM findEdge (colorsOfC edgeFacelets) edgeFacelets + Right $ cube cp co ep eo + where + pack = U.unzip . U.fromList + colorsOfC = (((c U.!) <$>) <$>) + findCorner = findPos cornerColors [0 .. 5] + findEdge = findPos edgeColors [0, 1] + cornerColors = (colorOf <$>) <$> cornerFacelets + edgeColors = (colorOf <$>) <$> edgeFacelets + -- @xs@ is a list of color patterns, @x@ is one pattern, + -- @os@ is a list of permutation indices (orientations). + -- (identity + symmetry for edges, + -- identity + 2 rotations + 3 symmetries for corners) + -- The result @(o, i)@ is the pair of indices of the corresponding + -- orientation and pattern in @os@ and @xs@, such that + -- > symRotate o (xs !! i) = x + -- An error is returned otherwise + findPos :: [[Int]] -> [Int] -> [Int] -> e -> Either e (Int, Int) + findPos xs os x e + = case join . find isJust $ + map + (\o -> (,) o <$> elemIndex x (map (symRotate o) xs)) + os + of + Nothing -> Left e + Just x -> Right x + +stringOfCubeColors :: Cube -> String +stringOfCubeColors = stringOfColorFacelets' . toFacelet + +-- + +-- ** UDSlice + +-- | Position of the 4 UDSlice edges (carried-to) +newtype UDSlicePermu = UDSlicePermu { fromUDSlicePermu :: Vector Int } + deriving (Eq, Show) + +-- | Position of the 4 UDSlice edges up to permutation (carried-to). +-- The vector is always sorted. +newtype UDSlice = UDSlice { fromUDSlice :: Vector Int } + deriving (Eq, Show) + +-- | Position of the 4 UDSlice edges (replaced-by), +-- assuming they are all in that slice already. +newtype UDSlicePermu2 = UDSlicePermu2 { fromUDSlicePermu2 :: Vector Int } + deriving (Eq, Show) + +-- | Position of the 8 other edges (replaced-by), +-- assuming UDSlice edges are in that slice already. +newtype UDEdgePermu2 = UDEdgePermu2 { fromUDEdgePermu2 :: Vector Int } + deriving (Eq, Show) + +type FlipUDSlice = (UDSlice, EdgeOrien) +type FlipUDSlicePermu = (UDSlicePermu, EdgeOrien) + +-- | > numUDSliceEdges = 4 +numUDSliceEdges = 4 :: Int + +unsafeUDSlicePermu = UDSlicePermu +unsafeUDSlicePermu' = UDSlicePermu . U.fromList + +uDSlicePermu :: Vector Int -> Maybe UDSlicePermu +uDSlicePermu v = do + guard $ U.length v == numUDSliceEdges + && U.all (liftA2 (&&) (0 <=) (< numEdges)) v + && (length . nub . U.toList) v == numUDSliceEdges + return (UDSlicePermu v) + +-- | Wrap an increasing list of 4 elements in @[0 .. 11]@. +uDSlice :: Vector Int -> Maybe UDSlice +uDSlice v = do + guard $ U.length v == numUDSliceEdges + && U.and (U.zipWith (<) ((-1) `U.cons` v) (v `U.snoc` 12)) + return (UDSlice v) + +unsafeUDSlice = UDSlice +unsafeUDSlice' = UDSlice . U.fromList + +-- | Wrap a permutation of size 4. +uDSlicePermu2 :: Vector Int -> Maybe UDSlicePermu2 +uDSlicePermu2 v = do + guard $ U.length v == numUDSliceEdges + && isPermutationVector v + return (UDSlicePermu2 v) + +unsafeUDSlicePermu2 = UDSlicePermu2 +unsafeUDSlicePermu2' = UDSlicePermu2 . U.fromList + +-- | Wrap a permutation of size 8. +uDEdgePermu2 :: Vector Int -> Maybe UDEdgePermu2 +uDEdgePermu2 v = do + guard $ U.length v == numEdges - numUDSliceEdges + && isPermutationVector v + return (UDEdgePermu2 v) + +unsafeUDEdgePermu2 = UDEdgePermu2 +unsafeUDEdgePermu2' = UDEdgePermu2 . U.fromList + +vSort = U.fromList . sort . U.toList + +unpermuUDSlice :: UDSlicePermu -> UDSlice +unpermuUDSlice = UDSlice . vSort . fromUDSlicePermu + +edgePermu2 :: UDSlicePermu2 -> UDEdgePermu2 -> EdgePermu +edgePermu2 (UDSlicePermu2 sp) (UDEdgePermu2 ep) + = EdgePermu (ep U.++ U.map (+8) sp) + +-- Projections of the identity cube +neutralUDSlicePermu = UDSlicePermu $ U.enumFromN 8 numUDSliceEdges -- 4 +neutralUDSlice = UDSlice $ U.enumFromN 8 numUDSliceEdges -- 4 +neutralUDSlicePermu2 = UDSlicePermu2 $ U.enumFromN 0 numUDSliceEdges -- 4 +neutralUDEdgePermu2 = UDEdgePermu2 $ U.enumFromN 0 (numEdges - numUDSliceEdges) -- 8 + +actionUDSlicePermu' :: EdgePermu -> Vector Int -> Vector Int +actionUDSlicePermu' (EdgePermu ep) = U.map (fromJust . flip U.elemIndex ep) + +actionUDSlicePermu :: UDSlicePermu -> EdgePermu -> UDSlicePermu +actionUDSlicePermu (UDSlicePermu p) ep + = UDSlicePermu (actionUDSlicePermu' ep p) + +actionUDSlice :: UDSlice -> EdgePermu -> UDSlice +actionUDSlice (UDSlice s) ep = UDSlice (act s) + where + act = vSort . actionUDSlicePermu' ep + +-- 'EdgePermu' should leave UDSlice stable. +actionUDSlicePermu2 :: UDSlicePermu2 -> EdgePermu -> UDSlicePermu2 +actionUDSlicePermu2 (UDSlicePermu2 sp) (EdgePermu ep) = + UDSlicePermu2 $ sp `composeVector` U.map (subtract 8) (U.drop 8 ep) + +-- 'EdgePermu' should leave UDSlice stable. +actionUDEdgePermu2 :: UDEdgePermu2 -> EdgePermu -> UDEdgePermu2 +actionUDEdgePermu2 (UDEdgePermu2 ep') (EdgePermu ep) = + UDEdgePermu2 $ ep' `composeVector` U.take 8 ep + +instance CubeAction UDSlicePermu where + cubeAction p = actionUDSlicePermu p . fromCube + +instance CubeAction UDSlice where + cubeAction s = actionUDSlice s . fromCube + +instance CubeAction UDSlicePermu2 where + cubeAction sp = actionUDSlicePermu2 sp . fromCube + +instance CubeAction UDEdgePermu2 where + cubeAction e = actionUDEdgePermu2 e . fromCube + +instance FromCube UDSlicePermu where + fromCube = cubeAction neutralUDSlicePermu + +instance FromCube UDSlice where + fromCube = cubeAction neutralUDSlice + +instance FromCube UDSlicePermu2 where + fromCube = cubeAction neutralUDSlicePermu2 + +instance FromCube UDEdgePermu2 where + fromCube = cubeAction neutralUDEdgePermu2 + +-- TODO: Make a type class of this (?) +-- | The conjugation is only compatible when the 'Cube' symmetry +-- leaves UDSlice edges stable, and either flips them all or none of them, +-- and either flips all 8 non-UDSlice edges or none of them. +conjugateFlipUDSlice :: Cube -> FlipUDSlice -> FlipUDSlice +conjugateFlipUDSlice c = assert conjugable conjugate + where + (EdgeOrien eo_c, EdgePermu ep_c) = fromCube c + conjugable + = let fromCube_c = UDSlice . vSort . U.drop 8 $ ep_c + in fromCube_c == neutralUDSlice + && isConstant (U.take 8 eo_c) + && isConstant (U.drop 8 eo_c) + isConstant v = U.init v == U.tail v + udsO = eo_c U.! 8 + altO = eo_c U.! 0 + conjugate (uds_@(UDSlice uds), EdgeOrien eo) = (uds_', EdgeOrien eo') + where + eo' = U.zipWith + (\o p -> (o + eo U.! p + bool altO udsO (p `U.elem` uds)) `mod` 2) + eo_c + ep_c + uds_' = cubeAction uds_ c + +-- | Expects UDSlice-stable symmetry +conjugateFlipUDSlicePermu :: Cube -> FlipUDSlicePermu -> FlipUDSlicePermu +conjugateFlipUDSlicePermu c = assert conjugable conjugate + where + (EdgeOrien eo_c, EdgePermu ep_c) = fromCube c + udsp_c = U.drop 8 ep_c + conjugable + = UDSlicePermu (vSort udsp_c) == neutralUDSlicePermu + && isConstant (U.take 8 eo_c) + && isConstant (U.drop 8 eo_c) + isConstant v = U.init v == U.tail v + conjugate fuds@(udsp, _) + = (conjugateUDSlicePermu c udsp, conjugateEdgeOrien' c fuds) + +conjugateEdgeOrien' :: Cube -> FlipUDSlicePermu -> EdgeOrien +conjugateEdgeOrien' c (UDSlicePermu udsp, EdgeOrien eo) + = EdgeOrien $ U.zipWith + (\o p -> (o + eo U.! p + bool altO udsO (p `U.elem` udsp)) `mod` 2) + eo_c + ep_c + where + (EdgeOrien eo_c, EdgePermu ep_c) = fromCube c + udsO = eo_c U.! 8 + altO = eo_c U.! 0 + +conjugateUDSlicePermu :: Cube -> UDSlicePermu -> UDSlicePermu +conjugateUDSlicePermu c (UDSlicePermu udsp) + = cubeAction (UDSlicePermu $ U.map (\i -> udsp U.! (i - 8)) udsp_c) c + where + EdgePermu ep_c = fromCube c + udsp_c = U.drop 8 . fromEdgePermu $ fromCube c + +-- | Expects UDSlice-stable symmetry. +conjugateCornerOrien :: Cube -> CornerOrien -> CornerOrien +conjugateCornerOrien c (CornerOrien co) = cubeAction (CornerOrien (U.map (oPlus (oInv o)) co)) c + where + CornerOrien co_c = fromCube c + o = U.head co_c + diff --git a/src/Rubik/Cube/Facelet.hs b/src/Rubik/Cube/Facelet.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube/Facelet.hs @@ -0,0 +1,85 @@ +{- | + Facelet representation + + Facelets faces are unfolded and laid out like this: + + @ + U + L F R B + D + @ + + Faces (or colors) are ordered @U, L, F, R, B, D@. + + A Rubik's cube is a permutation of facelets numbered as follows: + + > 0 1 2 + > 3 4 5 + > 6 7 8 + > + > 9 10 11 18 19 20 27 28 29 36 37 38 + > 12 13 14 21 22 23 30 31 32 39 40 41 + > 15 16 17 24 25 26 33 34 35 42 43 44 + > + > 45 46 47 + > 48 49 50 + > 51 52 53 + +-} + +module Rubik.Cube.Facelet ( + -- * Facelet permutation + numFacelets, + Facelets, + facelets, + fromFacelets, + + -- * Colors + Color, + colorOf, + colorChar, + + -- * Color list + ColorFacelets, + colorFacelets, + fromColorFacelets, + colorFaceletsOf, + + -- * List conversions + fromFacelets', + facelets', + fromColorFacelets', + colorFacelets', + colorFacelets'', + + -- * Pretty conversion + stringOfFacelets, + stringOfColorFacelets, + stringOfColorFacelets', + + -- * Facelets corresponding to each cubie + + -- | The first letter in the name of a cubie is + -- the color of its reference facelet + -- (illustrated at @http://kociemba.org/math/cubielevel.htm@). + -- + -- Corner colors are given in clockwise order. + -- + -- Corners are lexicographically ordered + -- (@U>L>F>R>B>D@). + -- + -- Edges are gathered by horizontal slices (@U, D, UD@). + + -- ** Centers + centerFacelets, + + -- ** Corners + cornerFacelets, + ulb, ufl, urf, ubr, dlf, dfr, drb, dbl, + + -- ** Edges + edgeFacelets, + ul, uf, ur, ub, dl, df, dr, db, fl, fr, bl, br + ) where + +import Rubik.Cube.Facelet.Internal diff --git a/src/Rubik/Cube/Facelet/Internal.hs b/src/Rubik/Cube/Facelet/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube/Facelet/Internal.hs @@ -0,0 +1,175 @@ +module Rubik.Cube.Facelet.Internal where + +import Rubik.Misc + +import Control.Monad + +import Data.Char ( intToDigit ) +import Data.List +import qualified Data.Vector.Unboxed as U + +-- | There are @54 == 6 * 9@ facelets. +numFacelets :: Int +numFacelets = 6 * 9 + +-- | Cube as a permutation of facelets (replaced-by). +-- +-- Every facelet is represented as an 'Int' in @[0 .. 54]@. +newtype Facelets = Facelets { + -- | The underlying 'Vector' of 'Int'. + fromFacelets :: Vector Int + } deriving (Eq, Show) + +instance Monoid Facelets where + mempty = Facelets $ idVector numFacelets + mappend (Facelets b) (Facelets c) = Facelets $ composeVector b c + +instance Group Facelets where + inverse (Facelets a) = Facelets $ inverseVector a + +-- | See 'fromFacelets'' +fromFacelets' :: Facelets -> [Int] +fromFacelets' = U.toList . fromFacelets + +-- | See 'facelets'. +facelets' :: [Int] -> Maybe Facelets +facelets' = facelets . U.fromList + +-- | This constructor checks that the input is a permutation of '[0 .. 53]'. +facelets :: Vector Int -> Maybe Facelets +facelets v = do + guard $ U.length v == numFacelets + && isPermutationVector v + return (Facelets v) + +-- | Constructor with no safety checks +unsafeFacelets = Facelets +unsafeFacelets' = Facelets . U.fromList + +-- | The standard cube colors are the values between @0@ and @5@. +type Color = Int + +-- | Cube as a list of facelet colors. +newtype ColorFacelets = ColorFacelets { + -- | The underlying 'Vector' of 'Color'. + fromColorFacelets :: Vector Color + } deriving (Eq, Show) + +-- | See 'fromColorFacelets'. +fromColorFacelets' :: ColorFacelets -> [Color] +fromColorFacelets' = U.toList . fromColorFacelets + +-- | See 'colorFacelets'. +colorFacelets' :: [Color] -> Maybe ColorFacelets +colorFacelets' = colorFacelets . U.fromList + +-- | This constructor checks that only standard colors (in @[0 .. 5]@) +-- are used, that the argument has length @54@ and that the centers +-- are colored in order. +-- +-- Note that there may still be more or less than 9 colors of a kind, +-- although that cannot be the case in an actual cube. +colorFacelets :: Vector Color -> Maybe ColorFacelets +colorFacelets v = do + guard $ U.length v == numFacelets + && U.all (\c -> 0 <= c && c < 6) v + && map (v U.!) centerFacelets == [0 .. 5] + return (ColorFacelets v) + +-- | The color of a facelet given its identifier. +colorOf :: Int -> Color +colorOf = (`div` 9) + +-- | Remove permutation information. +-- +-- If the argument cube can be obtained from the solved cube with the usual moves, +-- then the original permutation can be recovered with 'Cubie.colorFaceletsToCube'. +colorFaceletsOf :: Facelets -> ColorFacelets +colorFaceletsOf = ColorFacelets . U.map colorOf . fromFacelets + +-- | A color is mapped to a face, indicated by a @Char@: +-- +-- > map colorChar [0..5] == "ULFRBD" +colorChar :: Color -> Char +colorChar = ("ULFRBD" !!) + +-- | String listing the permutation of facelets numbered in base 9. +-- +-- Base 9 is convenient here because the first digit directly corresponds to a face +-- and the second to the facelet position in that face. +stringOfFacelets :: Facelets -> String +stringOfFacelets + = intercalate " " . map base9 . U.toList . fromFacelets + where base9 n = map intToDigit [n `div` 9, n `mod` 9] + +-- | String listing the facelet colors. +stringOfColorFacelets :: ColorFacelets -> String +stringOfColorFacelets + = intercalate " " . chunk 9 . map colorChar . U.toList . fromColorFacelets + +-- | Only show the colors of the facelets. +stringOfColorFacelets' :: Facelets -> String +stringOfColorFacelets' = stringOfColorFacelets . colorFaceletsOf + +-- + +-- | Convert a 6-color list of length 54 in any representation which implements 'Eq' +-- to 'ColorFacelets'. +colorFacelets'' :: Eq a => [a] -> Maybe ColorFacelets +colorFacelets'' colors = do + guard (length colors == numFacelets) + guard (length (nub centers) == 6) + colorFacelets' =<< sequence ((`lookup` zip centers [0 .. 5]) <$> colors) + where + centers = (colors !!) <$> centerFacelets + +-- + +-- Facelets corresponding to each cubie + +-- | +-- @ +-- centerFacelets +-- = [ 4, -- U +-- 13, -- L +-- 22, -- F +-- 31, -- R +-- 40, -- B +-- 49] -- D +-- @ +centerFacelets :: [Int] +centerFacelets = [4, 13 .. 49] + +-- | Corner facelets +ulb, ufl, urf, ubr, dlf, dfr, drb, dbl :: [Int] +ulb = [ 0, 9, 38] +ufl = [ 6, 18, 11] +urf = [ 8, 27, 20] +ubr = [ 2, 36, 29] +dlf = [45, 17, 24] +dfr = [47, 26, 33] +drb = [53, 35, 42] +dbl = [51, 44, 15] + +-- | > cornerFacelets = [ulb, ufl, urf, ubr, dlf, dfr, drb, dbl] +cornerFacelets :: [[Int]] +cornerFacelets = [ulb, ufl, urf, ubr, dlf, dfr, drb, dbl] + +-- | Edge facelets +ul, uf, ur, ub, dl, df, dr, db, fl, fr, bl, br :: [Int] +ul = [ 3, 10] +uf = [ 7, 19] +ur = [ 5, 28] +ub = [ 1, 37] +dl = [48, 16] +df = [46, 25] +dr = [50, 34] +db = [52, 43] +fl = [21, 14] +fr = [23, 30] +bl = [41, 12] +br = [39, 32] + +-- | > edgeFacelets = [ul, uf, ur, ub, dl, df, dr, db, fl, fr, bl, br] +edgeFacelets :: [[Int]] +edgeFacelets = [ul, uf, ur, ub, dl, df, dr, db, fl, fr, bl, br] diff --git a/src/Rubik/Cube/Moves.hs b/src/Rubik/Cube/Moves.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube/Moves.hs @@ -0,0 +1,65 @@ +{- | Move and cube definitions + -} + +module Rubik.Cube.Moves ( + MoveTag (..), + Move18, Move10, + + -- * Generating moves + u,r,f,d,l,b, + move6, + + -- * 18 elementary moves + move18Names, + move18, + + -- * Other subgroups + move10Names, + move10, + move6', + + -- * Symmetries + surf3, sf2, su4, slr2, + + Symmetry (..), + Symmetric, + UDFix, + rawMoveSym, + rawCast, + + symmetry_urf3, + symmetry_urf3', + mkSymmetry, + + SymCode (..), + symDecode, + sym16Codes, + sym16, + sym16', + sym48Codes, + sym48, + sym48', + composeSym, + invertSym, + + -- * Random cube/move + randomCube, + + -- * Move algebra + BasicMove, + oppositeAndGT, + + ElemMove, + Move, + + reduceMove, + nubMove, + + -- ** Conversions + moveToCube, + + moveToString, + stringToMove, + ) where + +import Rubik.Cube.Moves.Internal diff --git a/src/Rubik/Cube/Moves/Internal.hs b/src/Rubik/Cube/Moves/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Cube/Moves/Internal.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses, DeriveFunctor, DeriveGeneric, ViewPatterns #-} +module Rubik.Cube.Moves.Internal where + +import Rubik.Cube.Coord +import Rubik.Cube.Cubie.Internal +import Rubik.Misc + +import Control.DeepSeq +import Control.Monad.Loops ( iterateUntil ) +import Control.Monad.Random +import Control.Newtype + +import Data.Binary.Storable +import Data.Char ( toLower ) +import Data.Function ( on ) +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U + +import GHC.Generics + +newtype MoveTag m a = MoveTag { unMoveTag :: a } + deriving (Eq, Ord, Functor, Show, Binary, NFData) + +instance Newtype (MoveTag m a) a where + pack = MoveTag + unpack = unMoveTag + +data Move18 +data Move10 + +-- | Associate every elementary move with an 'ElemMove'. +move18Names :: MoveTag Move18 [ElemMove] +move10Names :: MoveTag Move10 [ElemMove] +move18Names = MoveTag [ (n, m) | m <- [U .. D], n <- [1 .. 3] ] +move10Names + = MoveTag $ [ (n, m) | m <- [U, D], n <- [1 .. 3] ] ++ [ (2, m) | m <- [L .. B] ] + +-- Elementary moves + +u_ = + unsafeCube' ([1, 2, 3, 0] ++ [4..7]) + (replicate 8 0) + ([1, 2, 3, 0] ++ [4..11]) + (replicate 12 0) + +-- | Up +u = u_ +-- | Left +l = surf3 ?? d +-- | Front +f = surf3 ?? r +-- | Right +r = surf3 ?? u +-- | Back +b = surf3 ?? l +-- | Down +d = sf2 ?? u + +-- | List of the 6 generating moves. +-- +-- > move6 = [u,l,f,r,b,d] +move6 = [u, l, f, r, b, d] + +-- | List of the 18 elementary moves. +-- +-- > move18 = [u, u <>^ 2, u <>^ 3, ...] +move18 :: MoveTag Move18 [Cube] +move18 = MoveTag $ move6 >>= \x -> [x, x <>^ 2, x <>^ 3] + +-- | Generating set of @G1@ +move6' = [u,d] ++ map (<>^ 2) [l, f, r, b] + +-- | > G1 = +move10 :: MoveTag Move10 [Cube] +move10 = MoveTag $ ([u, d] >>= \x -> [x, x <>^ 2, x <>^ 3]) ++ drop 2 move6' + +-- Symmetries + +-- | Rotation of the whole cube +-- around the diagonal axis through corners URF and LBD +surf3 = + unsafeCube' [4, 5, 2, 1, 6, 3, 0, 7] + [2, 1, 2, 1, 2, 1, 2, 1] + [5, 9, 1, 8, 7, 11, 3, 10, 6, 2, 4, 0] + [1, 0, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1] + +-- | Half-turn of the whole cube +-- around the FB axis +sf2 = + unsafeCube' [6, 5, 4, 7, 2, 1, 0, 3] + (replicate 8 0) + [6, 5, 4, 7, 2, 1, 0, 3, 9, 8, 11, 10] + (replicate 12 0) + +-- | Quarter-turn around the UD axis +su4 = + unsafeCube' [1, 2, 3, 0, 5, 6, 7, 4] + (replicate 8 0) + [1, 2, 3, 0, 5, 6, 7, 4, 9, 11, 8, 10] + (replicate 8 0 ++ [1, 1, 1, 1]) + +-- | Reflection w.r.t. the RL slice plane +slr2 = + unsafeCube' [3, 2, 1, 0, 5, 4, 7, 6] + (replicate 8 5) + [2, 1, 0, 3, 6, 5, 4, 7, 9, 8, 11, 10] + (replicate 12 0) + +-- | Index of a symmetry +newtype SymCode s = SymCode { unSymCode :: Int } deriving (Eq, Ord, Show) +data Symmetry sym = Symmetry + { symAsCube :: Cube + , symAsMovePerm :: [Int] + } +data Symmetric sym a + +rawMoveSym :: Symmetry sym -> [a] -> [a] +rawMoveSym sym moves = composeList moves (symAsMovePerm sym) + +rawCast :: RawCoord a -> RawCoord (Symmetric sym a) +rawCast = RawCoord . unRawCoord + +symmetry_urf3 = Symmetry surf3 [ 3 * f + i | f <- [2, 5, 3, 0, 1, 4], i <- [0, 1, 2] ] +symmetry_urf3' = Symmetry (surf3 <>^ 2) (composeList sym sym) + where sym = symAsMovePerm symmetry_urf3 + +mkSymmetry :: Cube -> Symmetry sym +mkSymmetry s = Symmetry s (fmap f moves) + where + f m = fromJust $ findIndex (== s <> m <> inverse s) moves + MoveTag moves = move18 + +-- x <- [0..47] +-- 2 * 4 * 2 * 3 = 48 +-- 2 * 4 * 2 = 16 +-- | Translate an integer to a symmetry. +symDecode :: SymCode s -> Cube +symDecode = (es V.!) . unSymCode + where es = V.generate 48 eSym' + eSym' x = (surf3 <>^ x1) + <> (sf2 <>^ x2) + <> (su4 <>^ x3) + <> (slr2 <>^ x4) + where x4 = x `mod` 2 + x3 = (x `div` 2) `mod` 4 + x2 = (x `div` 8) `mod` 2 + x1 = x `div` 16 -- < 3 + +data UDFix +-- | Octahedral group +data CubeSyms + +-- | Symmetries which preserve the UD axis +-- (generated by 'sf2', 'su4' and 'slr2') +sym16Codes :: [SymCode UDFix] +sym16Codes = map SymCode [0..15] + +sym16 :: [Symmetry UDFix] +sym16 = map mkSymmetry sym16' + +sym16' = map symDecode sym16Codes + +-- | All symmetries of the whole cube +sym48Codes :: [SymCode CubeSyms] +sym48Codes = map SymCode [0..47] + +sym48 :: [Symmetry CubeSyms] +sym48 = map mkSymmetry sym48' + +sym48' = map symDecode sym48Codes + +-- + +composeSym :: SymCode sym -> SymCode sym -> SymCode sym +composeSym = \(SymCode i) (SymCode j) -> SymCode (symMatrix U.! flatIndex 48 i j) + where + symMatrix = U.fromList [ c i j | i <- [0 .. 47], j <- [0 .. 47] ] + c i j = fromJust $ findIndex (== s i <> s j) sym48' + s = symDecode . SymCode + +invertSym :: SymCode sym -> SymCode sym +invertSym = \(SymCode i) -> SymCode (symMatrix U.! i) + where + symMatrix = U.fromList (fmap inv [0 .. 47]) + inv j = fromJust $ findIndex (== inverse (s j)) sym48' + s = symDecode . SymCode + +-- | Minimal set of moves +data BasicMove = U | L | F | R | B | D + deriving (Enum, Eq, Ord, Show, Read, Generic) + +instance NFData BasicMove + +-- | Quarter turns, clock- and anti-clockwise, half turns +type ElemMove = (Int, BasicMove) + +-- | Moves generated by 'BasicMove', 'group'-ed +type Move = [ElemMove] + +infixr 5 `consMove` + +-- Trivial reductions +consMove :: ElemMove -> Move -> Move +consMove nm [] = [nm] +consMove nm@(n, m) (nm'@(n', m') : moves) + | m == m' = case (n + n') `mod` 4 of + 0 -> moves + p -> (p, m) : moves + | oppositeAndGT m m' = nm' `consMove` nm `consMove` moves +consMove nm moves = nm : moves + +-- | Relation between faces +-- +-- @oppositeAndGT X Y == True@ if X and Y are opposite faces and @X > Y@. +oppositeAndGT :: BasicMove -> BasicMove -> Bool +oppositeAndGT = curry (`elem` [(D, U), (R, L), (B, F)]) + +-- | Perform "trivial" reductions of the move sequence. +reduceMove :: Move -> Move +reduceMove = foldr consMove [] + +-- | Scramble the solved cube. +moveToCube :: Move -> Cube +moveToCube = moveToCube' . reduceMove + +moveToCube' :: Move -> Cube +moveToCube' [] = iden +moveToCube' (m : ms) = elemMoveToCube m <> moveToCube' ms + +basicMoveToCube :: BasicMove -> Cube +basicMoveToCube = (move6 !!) . fromEnum + +elemMoveToCube :: ElemMove -> Cube +elemMoveToCube (n, m) = unMoveTag move18 !! (fromEnum m * 3 + n - 1) + +-- | Show the move sequence. +moveToString :: Move -> String +moveToString = + intercalate " " + . (mapMaybe $ \(n, m) + -> (show m ++) <$> lookup (n `mod` 4) [(1, ""), (2, "2"), (3, "'")]) + +-- | Associates s character in @"ULFRBD"@ or the same in lowercase +-- to a generating move. +decodeMove :: Char -> Maybe BasicMove +decodeMove = (`lookup` zip "ulfrbd" [U .. D]) . toLower + +-- | Reads a space-free sequence of moves. +-- If the string is incorrectly formatted, +-- the first wrong character is returned. +-- +-- @([ulfrbd][23']?)*@ +stringToMove :: String -> Either Char Move +stringToMove [] = return [] +stringToMove (x : xs) = do + m <- maybe (Left x) Right $ decodeMove x + let (m_, next) = + case xs of + o : next | o `elem` ['\'', '3'] -> ((3, m), next) + '2' : next -> ((2, m), next) + _ -> ((1, m), xs) + (m_ :) <$> stringToMove next + +-- | Remove moves that result in duplicate actions on the Rubik's cube +nubMove :: [Move] -> [Move] +nubMove = nubBy ((==) `on` moveToCube) + +-- * Random cube + +-- | Decode a whole @Cube@ from coordinates. +coordToCube + :: RawCoord CornerPermu + -> RawCoord CornerOrien + -> RawCoord EdgePermu + -> RawCoord EdgeOrien + -> Cube +coordToCube n1 n2 n3 n4 = Cube (Corner cp co) (Edge ep eo) + where + cp = decode n1 + co = decode n2 + ep = decode n3 + eo = decode n4 + +-- | Generate a random solvable 'Cube'. +-- +-- Relies on 'randomRIO'. +randomCube :: MonadRandom m => m Cube +randomCube = iterateUntil solvable $ + coordToCube + <$> randomRawCoord + <*> randomRawCoord + <*> randomRawCoord + <*> randomRawCoord diff --git a/src/Rubik/Distances.hs b/src/Rubik/Distances.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Distances.hs @@ -0,0 +1,85 @@ +{- | Pruning tables -} + +{-# Language FlexibleContexts, RankNTypes, ScopedTypeVariables, TypeFamilies, + ViewPatterns #-} +module Rubik.Distances where + +import Control.Monad +import Control.Monad.ST +import Control.Monad.Primitive +import Control.Monad.Ref + +import Data.Foldable +import Data.Function +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as MG +import qualified Data.Vector.Generic.Mutable.Loops as MG +import qualified Data.MBitVector as MBV + +type Coord = Int + +{-# INLINE distances #-} +distances :: (Traversable t, Eq a, Integral a, Show a, G.Vector v a) + => Int -> Coord -> (Coord -> t Coord) -> v a +distances n root neighbors = runST (distancesM MG.iForM_ n root neighbors) + +-- | Given a graph (via a neighbors function), find the distances from a root +-- to all nodes. +{-# INLINE distancesM #-} +distancesM :: forall a m t r v + . ( Traversable t, Eq a, Integral a, Show a + , G.Vector v a, PrimMonad m, MonadRef r m ) + => MG.ILoop m (G.Mutable v) a -> Int -> Coord -> (Coord -> t Coord) -> m (v a) +distancesM forV n root neighbors = do + mv <- MG.replicate n (-1) + mb <- MBV.replicate n False + count <- newRef (0 :: Int) + fill forV n root neighbors mv mb count 0 + G.unsafeFreeze mv + +-- We use two algorithms to fill the vector @mv@ with the distance from the +-- root to every node. The first @fill@ is more efficient when @mv@ is +-- either small or mostly empty, and the second @fill'@ when @mv@ is large +-- and almost full. + +-- Mark nodes at distance d from the root, by DFS. The values of the bit vector +-- marks visited nodes depending on the parity of d. +{-# INLINE fill #-} +fill forV n root neighbors mv mb count = fix $ \go d -> do + c <- readRef count + fillFrom neighbors mv mb count d 0 root + c' <- readRef count + -- Unless there are no more reachable untouched cells. + unless (c == c' || c' == n) $ + if c' < n `div` 10 + then go (d+1) + else fill' forV n neighbors mv count d + +-- This is in fact not quite a textbook DFS : we bound the recursion +-- depth by the distance of the current node to the root, in order not to +-- explode the stack. The search remains complete though. +{-# INLINE fillFrom #-} +fillFrom neighbors mv mb count d = fix $ \go dx x -> do + dx' <- MG.read mv x + if dx' == -1 + then do + modifyRef' count (+1) + MG.unsafeWrite mv x d + MBV.put mb x (fromIntegral $ d `mod` 2) + else do + test <- mb `MBV.test` x + when (dx == dx' && test == even d) $ do -- Unvisited + mb `MBV.complement` x + for_ (neighbors x) (go (dx+1)) + +-- For every node at distance d, mark all neighbors at +-- distance (d+1) from the root, by simply traversing the array. +{-# INLINE fill' #-} +fill' forV n neighbors mv count = fix $ \go d -> do + c <- readRef count + forV mv $ \x d' -> + when (d' == d) $ do + ys <- (filterM (\t -> fmap (-1 ==) (MG.read mv t)) . toList . neighbors) x + for_ ys $ \y -> modifyRef' count (+1) >> MG.unsafeWrite mv y (d+1) + c' <- readRef count + unless (c == c' || c' == n) $ go (d+1) diff --git a/src/Rubik/IDA.hs b/src/Rubik/IDA.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/IDA.hs @@ -0,0 +1,94 @@ +{- | + - Implementation of the IDA* search algorithm + -} +{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, + FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} +module Rubik.IDA where + +import qualified Data.Set as S + +-- | Type of outgoing edges, labelled and weighted. +data Succ label length node = Succ { + eLabel :: label, + eCost :: length, + eSucc :: node + } + +data Search f a l node = Search { + goal :: node -> Bool, + estm :: node -> a, + edges :: node -> f (Succ l a node) + } + +type Result a l = Maybe [l] +data SearchResult a l = Next !a | Found [l] | Stop + +instance Ord a => Monoid (SearchResult a l) where + {-# INLINE mempty #-} + mempty = Stop + {-# INLINE mappend #-} + mappend f@(Found _) _ = f + mappend _ f@(Found _) = f + mappend (Next a) (Next b) = Next (min a b) + mappend Stop x = x + mappend x Stop = x + +-- | Depth-first search up to depth @bound@, +-- and reduce results from the leaves. +dfSearch + :: (Foldable f, Num a, Ord a) + => Search f a l node + -> node -> a -> [l] -> a -> SearchResult a l +{-# INLINE dfSearch #-} +dfSearch (Search goal estm edges) n g ls bound + = dfs n g ls bound + where + dfs n g ls bound + | g == bound && g == f && goal n = Found (reverse ls) + | f > bound = Next f + | otherwise + = foldMap searchSucc $ edges n + where + isGoal = goal n + f = g + estm n + searchSucc (Succ eLabel eCost eSucc) + = dfs eSucc (g + eCost) (eLabel : ls) bound + +-- | IDA* search +-- +-- All paths to goal(s) are returned, grouped by length. +-- +-- Only searches as deep as necessary thanks to lazy evaluation. +-- +-- TODO: Possible memory leak, solving hard cubes eats a lot of memory. +search + :: forall f a l node . (Foldable f, Num a, Ord a) + => Search f a l node + -> node {- ^ root -} -> Maybe [l] +{-# INLINE search #-} +search s root = rootSearch (estm s root) + where + -- Search from the root up to a distance @d@ + -- for increasing values of @d@. + rootSearch :: a -> Maybe [l] + rootSearch d = + case dfSearch s root 0 [] d of + Stop -> Nothing + Found ls -> Just ls + Next d' -> rootSearch d' + +data SelfAvoid node = SelfAvoid (S.Set node) node + +selfAvoid (Search goal estm edges) = Search { + goal = goal . node, + estm = estm . node, + edges = edges' + } + where + node (SelfAvoid _ n) = n + edges' (SelfAvoid trace n) + = [ Succ l c (SelfAvoid (S.insert s trace) s) + | Succ l c s <- edges n, S.notMember s trace ] + +selfAvoidRoot root = (root, S.singleton root) + diff --git a/src/Rubik/Misc.hs b/src/Rubik/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Misc.hs @@ -0,0 +1,212 @@ +{- | + General functions for the __twentyseven__ project +-} + +module Rubik.Misc where + +--import Math.Combinatorics.Exact.Binomial ( choose ) + +import Control.Applicative + +import Data.Maybe +import Data.Monoid +import Data.Proxy (Proxy(..)) +import Data.List +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as MU +import qualified Data.Vector.Generic as G + +-- | Convert 2D indices to 1D. +-- +-- > \n x y -> x * n + y +flatIndex :: Int -> Int -> Int -> Int +flatIndex n x y = x * n + y + +-- * Applicative + +zipWith' :: Applicative f => (a -> b -> c) -> f a -> f b -> f c +{-# INLINE zipWith' #-} +zipWith' f x y = f <$> x <*> y + +sequence' :: Applicative f => [f a] -> f [a] +{-# INLINE sequence' #-} +sequence' = foldr (liftA2 (:)) (pure []) + +-- * Lists + +-- | Rotation: +-- +-- > rotate 3 [1,2,3,4,5,6,7] == [4,5,6,7] ++ [1,2,3] +rotate :: Int -> [a] -> [a] +rotate n l = l2 ++ l1 + where (l1, l2) = splitAt n l + +-- | Substitute the @n@-th element. +subs :: Int -> a -> [a] -> [a] +subs 0 x (a : as) = x : as +subs n x (a : as) = a : subs (n - 1) x as + +-- | Insert before the @n@-th element. +insert' :: Int -> a -> [a] -> [a] +insert' 0 x l = x : l +insert' n x (h : t) = h : insert' (n-1) x t + +-- | If @l@ is a permutation list (replaced-by) of length @n@, +-- @inverseList n l@ is its inverse permutation. +inverseList :: Int -> [Int] -> [Int] +inverseList n l = [fromJust $ elemIndex i l | i <- [0 .. n - 1]] + +-- | Backpermute. Substitute every index in the second list with the +-- corresponding element in the first. +composeList :: [a] -> [Int] -> [a] +composeList = map . (!!) + +-- | Strict in every element of the list. +listSeq :: [a] -> b -> b +listSeq [] b = b +listSeq (a : as) b = a `seq` listSeq as b + +-- * Vectors + +-- | Unboxed vectors +type Vector = U.Vector + +-- | Permutation of @[0 .. length v]@. +isPermutationVector :: Vector Int -> Bool +isPermutationVector v = all (`U.elem` v) [0 .. U.length v - 1] + +-- | Sign of a permutation vector. +signPermutationVector :: Vector Int -> Int +signPermutationVector v = + length [ (x, y) | x <- [0 .. n - 1], + y <- [x + 1 .. n - 1], + v U.! x < v U.! y ] `mod` 2 + where n = U.length v + +-- | > idVector n == fromList [0 .. n - 1] +idVector :: Int -> Vector Int +idVector = U.enumFromN 0 + +-- | If @v@ is a permutation, +-- @inverseVector v@ is its inverse permutation. +inverseVector :: Vector Int -> Vector Int +inverseVector u = U.create (do + v <- MU.new n + iForM_ u . flip $ MU.write v + return v) + where + n = U.length u + iForM_ u = U.forM_ (U.indexed u) . uncurry + +-- | Permutation composition: @(p . q) x == p (q x)@. +-- +-- > composeVector u v ! i == u ! (v ! i) +composeVector :: U.Unbox a => Vector a -> Vector Int -> Vector a +composeVector = U.backpermute + +-- * Groups + +infixr 8 <>^ + +-- | Class for groups: +-- +-- > a <> (b <> c) == (a <> b) <> c -- Associative property +-- +-- > a <> iden == a -- Neutral element +-- > iden <> a == a +-- +-- > a <> inverse a == iden -- Inverse +-- > inverse a <> a == iden +-- +class Monoid a => Group a where + inverse :: a -> a + +-- | Alias for 'mempty' +iden :: Group a => a +iden = mempty + +instance (Group a, Group b) => Group (a, b) where + inverse (a, b) = (inverse a, inverse b) + +-- | Exponentiation, negative indices are supported. +(<>^) :: (Integral int, Group a) => a -> int -> a +_ <>^ 0 = iden +a <>^ 1 = a +a <>^ n + | n < 0 = inverse a <>^ (-n) + | n `mod` 2 == 0 = a2 + | otherwise = a <> a2 + where a2 = a_n_2 <> a_n_2 + a_n_2 = a <>^ (n `div` 2) + +-- | Conjugation: +-- +-- > s `conjugate` a = inverse s <> a <> s +conjugate, (??) :: Group a => a -> a -> a +conjugate s a = inverse s <> a <> s +(??) = conjugate + +-- * Combinatorics + +-- | Factorial +fact :: Int -> Int +fact 0 = 1 +fact n = n * fact (n - 1) + +-- | Binomial coefficient: +-- +-- > choose n k == fact n `div` (fact k) * (fact (n - k)) +choose :: Int -> Int -> Int +choose = \n k -> if k < 0 then 0 else c !! n U.! k + where c = [U.fromList $ line n | n <- [0..]] + line n = do + k <- [0..n] + if k == 0 || k == n + then return 1 + else let cn = c !! (n - 1) in + return $ cn U.! k + cn U.! (k - 1) + +-- | Interpolation search for @Int@ +iFind :: (Integral a, Ord a, G.Vector v a) => a -> v a -> Maybe Int +iFind x v | x < G.head v || G.last v < x = Nothing +iFind x v = find 0 n + where + n = G.length v + find _ 0 = Nothing + find a m = case compare x (v G.! (a + p)) of + LT -> find a p + EQ -> Just (a + p) + GT -> find (a + p + 1) (m - p - 1) + where + s = v G.! a + t = v G.! (a + m - 1) + p = fromIntegral $ ((x - s) * (fromIntegral m - 1)) `div` (t - s) + +-- | Flipped "if" +bool :: a -> a -> Bool -> a +bool x _ False = x +bool _ y True = y + +-- | Equal sized chunks +chunk :: Int -> [a] -> [[a]] +chunk _ [] = [] +chunk n xs = x1 : chunk n x2 + where (x1, x2) = splitAt n xs + +-- | Generalized partition +partition' :: (a -> a -> Bool) -> [a] -> [[a]] +partition' (==) [] = [] +partition' (==) (a : as) = (a : as') : partition' (==) as'' + where (as', as'') = partition (== a) as + +tagOf :: tag a b -> tag' a b' -> tag a b +tagOf = const + +asProxyTypeOf :: a -> proxy a -> a +asProxyTypeOf = const + +proxyUnwrap :: proxy (f a) -> Proxy a +proxyUnwrap _ = Proxy + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip (<$>) diff --git a/src/Rubik/Solver.hs b/src/Rubik/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Solver.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TypeFamilies, TypeOperators, + ViewPatterns #-} +module Rubik.Solver where + +import Rubik.Cube +import Rubik.IDA +import Rubik.Misc +import Rubik.Symmetry + +import Control.Applicative + +import Data.Coerce +import Data.Foldable +import Data.Int (Int8) +import Data.Maybe +import Data.Tuple.Extra +import qualified Data.Vector as V +import qualified Data.Vector.Storable.Allocated as S + +type MaybeFace = Int +type SubIndex = Int +type DInt = Int8 + +data Projection x a0 as a = Projection + { convertP :: x -> a + , isIdenP :: a -> Bool + , indexP :: as -> a -> a + , subIndexSize :: Int + , unfoldP :: a0 -> SubIndex -> [as] + , subIndexP :: a -> SubIndex + } + +type Projection' m a = Projection Cube (MoveTag m [RawMove a]) (RawMove a) (RawCoord a) +type SymProjection m sym a = Projection Cube (MoveTag m [SymMove sym a]) (SymMove sym a) (SymCoord sym a) + +newtype Distance m a = Distance { distanceP :: a -> DInt } + +infixr 4 |*|, |.| + +{-# INLINE (|*|) #-} +(|*|) :: (TupleCons b0, TupleCons bs, TupleCons b) + => Projection x a0 as a + -> Projection x b0 bs b + -> Projection x (a0 :| b0) (as :| bs) (a :| b) +a |*| b = Projection + { convertP = liftA2 (|:|) (convertP a) (convertP b) + , isIdenP = \(split -> (a_, b_)) -> isIdenP a a_ && isIdenP b b_ + , indexP = \(split -> (as_, bs_)) (split -> (a_, b_)) -> indexP a as_ a_ |:| indexP b bs_ b_ + , subIndexSize = subIndexSize a * subIndexSize b + , unfoldP = \(split -> (a0_, b0_)) ci -> + let (ai, bi) = ci `divMod` subIndexSize b + in zipWith (|:|) (unfoldP a a0_ ai) (unfoldP b b0_ bi) + , subIndexP = \(split -> (a_, b_)) -> flatIndex (subIndexSize b) (subIndexP a a_) (subIndexP b b_) } + +{-# INLINE (|.|) #-} +(|.|) :: forall x a0 as a b0 bs b + . Projection x a0 as a + -> Projection x b0 bs b + -> Projection x (a0, b0) (as, bs) (a, b) +a |.| b = a |*| (coerce b :: Projection x (Tuple1 b0) (Tuple1 bs) (Tuple1 b)) + +{-# INLINE (>$<) #-} +(>$<) :: forall m a b. (b -> a) -> Distance m a -> Distance m b +(>$<) = coerce (flip (.) :: (b -> a) -> (a -> DInt) -> (b -> DInt)) + +{-# INLINE maxDistance #-} +maxDistance :: forall f m a. Foldable f => f (Distance m a) -> Distance m a +maxDistance = foldl' (\(Distance f) (Distance g) -> Distance $ \x -> max (f x) (g x)) (Distance $ const 0) + +-- | ==Branching reduction +-- +-- The @Int@ projection keeps track of the latest move (@== 6@ +-- for the starting point). +-- +-- 18 moves +-- +-- We can indeed reduce the branching factor from 18 to 15 +-- by considering that successive moves on the same face +-- can and will be shortened as a single move. +-- +-- Furthermore, since moves on opposite faces commute, we may force +-- them to be in an arbitrary order, reducing the branching factor +-- to 12 after half of the moves (U, L, F). +-- +-- 10 moves +-- +-- Instead of a factor 10, we have factors +-- +-- - 9 after R, B; +-- - 8 after L, F; +-- - 7 after D; +-- - 4 after U. + +{-# INLINE solveWith #-} +solveWith + :: Eq a + => MoveTag m [ElemMove] -> a0 + -> Projection Cube a0 as a + -> Distance m a + -> Cube -> Move +solveWith (MoveTag moveNames) ms ps pd + = fromJust . search Search{..} . tag . convertP ps + where + goal = isIdenP ps . snd + estm = distanceP pd . snd + edges (i, t) + = fmap + (\(l, succs, j') -> + let x = indexP ps succs t in Succ l 1 (j', x)) + (succVector V.! (subIndexP ps t * 7 + i)) + -- For every move, filter out "larger" moves for an arbitrary total order of faces + succVector = V.fromList $ do + subi <- [0 .. subIndexSize ps - 1] + let as = unfoldP ps ms subi + i' <- [0 .. 6] + return + [ (l, m, fromEnum j) + | (l@(_, j), m) <- zip moveNames as + , i' == 6 || (let i = toEnum i' in not (i == j || oppositeAndGT j i)) ] + +type Tag a = (Int, a) + +tag :: a -> Tag a +tag = (,) 6 + +{-# INLINE rawProjection #-} +rawProjection :: (FromCube a, RawEncodable a) => Projection' m a +rawProjection = Projection + { convertP = convert + , isIdenP = (== convert iden) + , indexP = (!$) + , subIndexSize = 1 + , unfoldP = \(MoveTag as) _ -> as + , subIndexP = \_ -> 0 + } + where + convert = encode . fromCube + +{-# INLINE symProjection #-} +symProjection :: (FromCube a, RawEncodable a) + => (a -> SymCoord sym a) -> SymProjection m sym a +symProjection convert = Projection + { convertP = convert' + , isIdenP = let (x0, _) = convert' iden in \(x, _) -> x == x0 + , indexP = symMove' 16 + , subIndexSize = 16 + , unfoldP = \(MoveTag as) i -> [ as !! j | j <- symAsMovePerm (sym16 !! i) ] + , subIndexP = \(_, SymCode i) -> i + } + where + convert' = convert . fromCube + +-- TODO newtype this +{-# INLINE symmetricProj #-} +symmetricProj :: Eq c => Symmetry sym + -> Projection Cube (MoveTag m [b]) as c + -> Projection Cube (MoveTag m [b]) as c +symmetricProj sym proj = proj + { convertP = convert + , unfoldP = \as i -> rawMoveSym sym (unfoldP proj as i) + } + where + convert = convertP proj . conjugate (inverse (symAsCube sym)) + +{-# INLINE distanceWith2 #-} +distanceWith2 + :: (RawEncodable a, RawEncodable b) + => S.Vector DInt -> Distance m (RawCoord a, RawCoord b) +distanceWith2 v = Distance $ \(RawCoord a_, b@(RawCoord b_)) -> + v S.! flatIndex (range b) a_ b_ diff --git a/src/Rubik/Solver/Optimal.hs b/src/Rubik/Solver/Optimal.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Solver/Optimal.hs @@ -0,0 +1,51 @@ +module Rubik.Solver.Optimal where + +import Rubik.Cube +import Rubik.Solver +import Rubik.Tables.Moves +import Rubik.Tables.Distances +import Rubik.Tables.Internal + +import qualified Data.Vector.Generic as G + +{-# INLINE optiProj #-} +optiProj + = fudsp |*| sfudsp |*| s sfudsp |*| co |*| sco |*| s sco |.| cp + where + fudsp = symProjFlipUDSlicePermu + sfudsp = s fudsp + co = rawProjection :: Projection' Move18 CornerOrien + sco = s co + cp = symProjCornerPermu + s x = symmetricProj symmetry_urf3 x + +{-# INLINE optiDist #-} +optiDist = maxDistance + [ maxOrEqualPlusOne + ( (\((,,,,,,) fudsp _ _ co _ _ _) -> (fudsp, co)) >$< fudsp_co + , (\((,,,,,,) _ fudsp _ _ co _ _) -> (fudsp, co)) >$< fudsp_co + , (\((,,,,,,) _ _ fudsp _ _ co _) -> (fudsp, co)) >$< fudsp_co + ) + , (\((,,,,,,) _ _ _ co _ _ cp) -> (cp, co)) >$< cp_co + ] + +{-# INLINE maxOrEqualPlusOne #-} +maxOrEqualPlusOne (Distance f, Distance g, Distance h) + = Distance $ \x -> let a = f x ; b = g x ; c = h x + in if a == b && b == c && a /= 0 then a + 1 + else a `max` b `max` c + +solve :: Cube -> Move +solve = solveWith move18Names moves optiProj optiDist + where + moves = (,,,,,,) m_fudsp m_fudsp m_fudsp m_co m_co m_co move18SymCornerPermu + m_fudsp = move18SymFlipUDSlicePermu + m_co = move18CornerOrien + +{-# INLINE toIdx #-} +toIdx = uncurry $ indexWithSym invertedSym16CornerOrien (range ([] :: [CornerOrien])) + +{-# INLINE fudsp_co #-} +fudsp_co = toIdx >$< Distance (fromIntegral . (dSym_CornerOrien_FlipUDSlicePermu G.!)) +{-# INLINE cp_co #-} +cp_co = toIdx >$< Distance (dSym_CornerOrien_CornerPermu G.!) diff --git a/src/Rubik/Solver/TwoPhase.hs b/src/Rubik/Solver/TwoPhase.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Solver/TwoPhase.hs @@ -0,0 +1,69 @@ +{- | Two phase algorithm to solve a Rubik's cube -} + +{-# LANGUAGE RecordWildCards, ViewPatterns #-} +module Rubik.Solver.TwoPhase where + +import Rubik.Cube +import Rubik.Misc +import Rubik.Solver +import Rubik.Tables.Moves +import Rubik.Tables.Distances + +import Data.Function ( on ) +import Data.Monoid + +{-# INLINE phase1Proj #-} +phase1Proj + = rawProjection + |*| rawProjection + |.| rawProjection + +phase1Convert = convertP phase1Proj + +phase1Dist = maxDistance + [ (\((,,) co _ uds) -> (co, uds)) >$< distanceWith2 d_CornerOrien_UDSlice + , (\((,,) _ eo uds) -> (eo, uds)) >$< distanceWith2 d_EdgeOrien_UDSlice + ] + +phase1 :: Cube -> Move +phase1 = solveWith move18Names moves phase1Proj phase1Dist + where + moves = (,,) move18CornerOrien move18EdgeOrien move18UDSlice + +-- | > phase1Solved (phase1 c) +phase1Solved :: Cube -> Bool +phase1Solved = ((==) `on` phase1Convert) iden + +-- + +phase2Proj + = rawProjection + |*| rawProjection + |.| rawProjection + +phase2Convert = convertP phase2Proj + +phase2Dist = maxDistance + [ (\((,,) cp _ udsp) -> (cp, udsp)) >$< distanceWith2 d_CornerPermu_UDSlicePermu2 + , (\((,,) _ udep udsp) -> (udep, udsp)) >$< distanceWith2 d_UDEdgePermu2_UDSlicePermu2 + ] + +phase2 :: Cube -> Move +phase2 = solveWith move10Names moves phase2Proj phase2Dist + where + moves = (,,) move10CornerPermu move10UDEdgePermu2 move10UDSlicePermu2 + +-- | > phase1Solved c ==> phase2Solved (phase2 c) +phase2Solved :: Cube -> Bool +phase2Solved = (== iden) + +-- | Solve a scrambled Rubik's cube. +-- +-- Make sure the cube is actually solvable with 'Cubie.solvable', +-- before calling this function. +solve :: Cube -> Move +solve c = + let s1 = phase1 c + c1 = c <> moveToCube s1 + s2 = phase2 c1 + in reduceMove $ s1 ++ s2 diff --git a/src/Rubik/Symmetry.hs b/src/Rubik/Symmetry.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Symmetry.hs @@ -0,0 +1,182 @@ +{- | + - Tables of symmetry classes + -} +{-# Language GeneralizedNewtypeDeriving, ScopedTypeVariables, ViewPatterns #-} +module Rubik.Symmetry where + +import Rubik.Cube +import Rubik.Misc + +import Control.DeepSeq +import Control.Monad + +import Data.Binary.Storable +import Data.Foldable +import Data.List +import Data.Maybe +import Data.Ord +import qualified Data.Heap as H +import qualified Data.Vector as V +import qualified Data.Vector.Storable.Allocated as S + +-- | Smallest representative of a symmetry class. +-- (An element of the symClasses table) +type SymRepr a = RawCoord a + +type SymClass' = Int +-- | Symmetry class. (Index of the smallest representative in the symClasses table) +newtype SymClass symType a = SymClass { unSymClass :: SymClass' } + deriving (Eq, Ord, Show) + +type SymCoord sym a = (SymClass sym a, SymCode sym) + +-- | An @Int@ representing a pair @(Repr, Sym)@. +-- +-- If @x = symClass * symOrder + symCode@, +-- where @symClass :: SymClass@ is the index of the symmetry class with +-- smallest representative @r :: SymRepr@ (for an arbitrary order relation), +-- @symOrder@ is the size of the symmetry group, +-- @symCode :: Sym@ is the index of a symmetry @s@; +-- then @s^(-1) <> r <> s@ is the value represented by @x@. +type SymCoord' = Int +type SymOrder' = Int + +newtype Action s a = Action [a -> a] +newtype SymClassTable s a = SymClassTable { unSymClassTable :: S.Vector RawCoord' } + deriving (Eq, Ord, Show, Binary, NFData) +newtype SymReprTable s a = SymReprTable { unSymReprTable :: S.Vector Int } + deriving (Eq, Ord, Show, Binary, NFData) +newtype SymMove s a = SymMove (S.Vector SymCoord') + deriving (Eq, Ord, Show, Binary, NFData) + +type Symmetries sym a = MoveTag sym (V.Vector (RawMove a)) + +-- | Compute the table of smallest representatives for all symmetry classes. +-- The @RawCoord'@ coordinate of that representative is a @Repr@. +-- The table is sorted in increasing order. +symClasses + :: RawEncodable a + => Action s a {- ^ Symmetry group, including the identity, + - represented by its action on @a@ -} + -> SymClassTable s a {- ^ Smallest representative -} +symClasses = SymClassTable . S.fromList . fmap unRawCoord . symClasses' + +symClasses' :: forall a s. RawEncodable a => Action s a -> [RawCoord a] +symClasses' action@(Action sym) + = foldFilter (H.empty :: H.MinHeap (RawCoord a)) + (fmap RawCoord [0 .. range action - 1]) + where + foldFilter _ [] = [] + foldFilter (H.view -> Nothing) (x : xs) = x : foldFilter (heapOf x) xs + foldFilter (h@(H.view -> Just (y, ys))) (x : xs) + | x < y = x : foldFilter (H.union h (heapOf x)) xs + | otherwise = foldFilter ys xs + heapOf :: RawCoord a -> H.MinHeap (RawCoord a) + heapOf x + = let dx = decode x + nub' = map head . group . sort + in H.fromAscList . tail . nub' $ map (\z -> (encode . z) dx) sym + +symClassTable + :: Int + -> SymReprTable s a + -> SymClassTable s a +symClassTable nSym (SymReprTable s) + = SymClassTable . S.ifilter (==) $ S.map (`div` nSym) s + +symReprTable + :: forall a s t. (RawEncodable a, Foldable t) + => Int -- ^ Number of symmetries @nSym@ + -> (RawCoord a -> t (RawCoord a)) + -> SymReprTable s a +symReprTable nSym f + = SymReprTable (symReprTable' (range ([] :: [a])) nSym f') + where + f' = fmap unRawCoord . toList . f . RawCoord + +{-# INLINE symReprTable' #-} +symReprTable' + :: Foldable t + => Int -- ^ Number of elements @n@ + -> Int -- ^ Number of symmetries @nSym@ + -> (Int -> t Int) -- ^ @f x@, symmetrical elements to @x@, including itself + -> S.Vector Int + -- ^ @v@, where @(y, i) = (v ! x) `divMod` nSym@ gives + -- the representative @y@ of the symmetry class of @x@ + -- and the index of one symmetry mapping @x@ to @y@: + -- + -- > f x !! i == y. +symReprTable' n nSym f + = S.create $ do + v <- S.replicate n (-1) + forM_ [0 .. n-1] $ \x -> do + let ys = f x + y <- S.read v x + when (y == -1) . + forM_ ((zip [0 ..] . toList . f) x) $ \(i, x') -> + S.write v x' (flatIndex nSym x i) + return v + +-- | +symMoveTable + :: RawEncodable a + => Action s a {- ^ Symmetry group -} + -> SymClassTable s a {- ^ (Sorted) table of representatives -} + -> (a -> a) {- ^ Endofunction to encode -} + -> SymMove s a +symMoveTable action@(Action syms) classes f + = SymMove (S.map move (unSymClassTable classes)) + where + n = length syms + move = flat . symCoord action classes . f . decode . RawCoord + flat (SymClass c, SymCode s) = flatIndex n c s + +symMoveTable' + :: RawEncodable a + => Int -- ^ Symmetry group order + -> SymReprTable s a + -> SymClassTable s a + -> (a -> a) + -> SymMove s a +symMoveTable' nSym reps classes f + = SymMove (S.map move (unSymClassTable classes)) + where + move = flat . symCoord' nSym reps classes . encode . f . decode . RawCoord + flat (SymClass c, SymCode s) = flatIndex nSym c s + +{-# INLINE symMove #-} +symMove :: SymOrder' -> SymMove s a -> SymClass s a -> SymCoord s a +symMove n (SymMove v) (SymClass x) = (SymClass y, SymCode i) + where (y, i) = (v S.! x) `divMod` n + +{-# INLINE symMove' #-} +symMove' n v (x, j) = (y, i `composeSym` j) + where (y, i) = symMove n v x + +reprToClass :: SymClassTable s a -> RawCoord a -> SymClass s a +reprToClass (SymClassTable cls) = SymClass . fromJust . flip iFind cls . unRawCoord + +-- | Find the representative as the one corresponding to the smallest coordinate +symCoord :: RawEncodable a => Action s a -> SymClassTable s a + -> a -> SymCoord s a +symCoord (Action syms) classes x + = (reprToClass classes r, SymCode s) + where + xSym = [ encode (s x) | s <- syms ] + (r, s) = minimumBy (comparing fst) (zip xSym [0 ..]) + +symCoord' :: Int -> SymReprTable s a -> SymClassTable s a -> RawCoord a -> SymCoord s a +symCoord' nSym (SymReprTable reps) (SymClassTable classes) (RawCoord x) + = (SymClass r, SymCode i) + where + (y, i) = (reps S.! x) `divMod` nSym + r = fromJust $ iFind r classes + +symToRaw + :: SymClassTable s a -> (RawCoord a -> SymCode s -> RawCoord a) + -> SymCoord s a -> RawCoord a +symToRaw (SymClassTable classes) sym (SymClass c, i) + = sym (RawCoord (classes S.! c)) i + +sym :: Symmetries s a -> RawCoord a -> SymCode s -> RawCoord a +sym (MoveTag syms) r (SymCode i) = syms V.! i !$ r diff --git a/src/Rubik/Tables/Distances.hs b/src/Rubik/Tables/Distances.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Tables/Distances.hs @@ -0,0 +1,48 @@ +module Rubik.Tables.Distances where + +import Rubik.Cube +import Rubik.Solver +import Rubik.Tables.Internal +import Rubik.Tables.Moves +import qualified Data.Vector.Storable.Allocated as S +import qualified Data.Vector.HalfByte as HB + +d_CornerOrien_UDSlice + = distanceTable2 "dist_CornerOrien_UDSlice" move18CornerOrien move18UDSlice + +d_EdgeOrien_UDSlice + = distanceTable2 "dist_EdgeOrien_UDSlice" move18EdgeOrien move18UDSlice + +d_UDEdgePermu2_UDSlicePermu2 + = distanceTable2 "dist_EdgePermu2" move10UDEdgePermu2 move10UDSlicePermu2 + +d_CornerPermu_UDSlicePermu2 + = distanceTable2 "dist_CornerPermu_UDSlicePermu2" move10CornerPermu move10UDSlicePermu2 + +dSym_CornerOrien_FlipUDSlicePermu + = saved' "dist_SymFlipUDSlicePermu_CornerOrien" $ + distanceWithSym2' + move18SymFlipUDSlicePermu move18CornerOrien + invertedSym16CornerOrien + symProjFlipUDSlicePermu + rawProjection + n1 + n2 + :: HB.Vector' + where + n1 = 1523864 + n2 = range ([] :: [CornerOrien]) + +dSym_CornerOrien_CornerPermu + = saved' "dist_SymCornerPermu_CornerOrien" $ + distanceWithSym2' + move18SymCornerPermu move18CornerOrien + invertedSym16CornerOrien + symProjCornerPermu + rawProjection + n1 + n2 + :: S.Vector DInt + where + n1 = 2768 + n2 = range ([] :: [CornerOrien]) diff --git a/src/Rubik/Tables/Internal.hs b/src/Rubik/Tables/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Tables/Internal.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE FlexibleContexts, LambdaCase, RecordWildCards, + ScopedTypeVariables, ViewPatterns #-} +module Rubik.Tables.Internal where + +import Rubik.Cube.Cubie +import Rubik.Cube.Coord +import Rubik.Cube.Moves +import Rubik.Distances +import Rubik.Misc +import Rubik.Solver +import Rubik.Symmetry +import Control.Exception +import Control.DeepSeq +import Control.Newtype +import Data.Binary.Storable +import Data.Coerce +import Data.IORef +import qualified Data.Vector as V +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Storable.Allocated as S +import System.Directory +import System.FilePath +import System.IO.Unsafe + +{-# NOINLINE tsPath #-} +tsPath :: IORef FilePath +tsPath = unsafePerformIO (do + home <- getHomeDirectory + newIORef (home ".27")) + +{-# NOINLINE precompute #-} +precompute :: IORef Bool +precompute = unsafePerformIO (newIORef False) + +{-# NOINLINE overwrite #-} +overwrite :: IORef Bool +overwrite = unsafePerformIO (newIORef False) + +{-# NOINLINE noFiles #-} +noFiles :: IORef Bool +noFiles = unsafePerformIO (newIORef False) + +{-# NOINLINE debug #-} +debug :: IORef Bool +debug = unsafePerformIO (newIORef False) + +setTsPath :: FilePath -> IO () +setTsPath = writeIORef tsPath + +setTsPathFromHome :: FilePath -> IO () +setTsPathFromHome p = do + home <- getHomeDirectory + setTsPath (home p) + +setOverwrite :: Bool -> IO () +setOverwrite = writeIORef overwrite + +setPrecompute :: Bool -> IO () +setPrecompute = writeIORef precompute + +setNoFiles :: Bool -> IO () +setNoFiles = writeIORef noFiles + +setDebug :: Bool -> IO () +setDebug = writeIORef debug + +{-# NOINLINE saved #-} +saved :: Binary a => FilePath -> a -> a +saved f a = unsafePerformIO $ do + noFiles <- readIORef noFiles + if noFiles then return a else preload f a + +preload :: Binary a => FilePath -> a -> IO a +preload f a = do + tsPath <- readIORef tsPath + createDirectoryIfMissing True tsPath + let path = tsPath f + fileExists <- doesFileExist path + precompute <- readIORef precompute + overwrite <- readIORef overwrite + putStrLn <- bool (\_ -> return ()) putStrLn <$> readIORef debug + putStrLn $ ">" ++ f + a' <- if precompute && (overwrite || not fileExists) then do + putStrLn ("!" ++ f) + evaluate a + encodeFile path a + return a + else if not precompute && not fileExists + then fail $ f ++ " not found. You may need to set -p or -d." + else decodeFile path + putStrLn $ "<" ++ f + return a' + +saved' :: (NFData a, Binary a) => FilePath -> a -> a +saved' f = saved f . force + +rawMoveTables :: (CubeAction a, RawEncodable a) + => MoveTag m [Cube] -> MoveTag m [RawMove a] +rawMoveTables moves = (over MoveTag . fmap) moveTable moves + +savedRawMoveTables + :: forall a m. (CubeAction a, RawEncodable a) + => String -> MoveTag m [Cube] -> MoveTag m [RawMove a] +savedRawMoveTables name moves@(MoveTag moves') + = saved' name (rawMoveTables moves) + +rawSymTables :: RawEncodable a + => (Cube -> a -> a) -> [Symmetry sym] -> Symmetries sym a +rawSymTables conj syms + = MoveTag . V.fromList $ symTable conj <$> symAsCube <$> syms + +savedRawSymTables :: forall a sym. RawEncodable a + => String -> (Cube -> a -> a) -> [Symmetry sym] + -> Symmetries sym a +savedRawSymTables name conj syms + = saved' name (rawSymTables conj syms) + +move18to10 :: MoveTag Move18 [as] -> MoveTag Move10 [as] +move18to10 (MoveTag as) = MoveTag + (composeList as [ n - 1 + 3 * fromEnum m | (n, m) <- unMoveTag move10Names ]) + +distanceTable2 + :: (FromCube a, FromCube b, RawEncodable a, RawEncodable b) + => String -> MoveTag m [RawMove a] -> MoveTag m [RawMove b] + -> S.Vector DInt +distanceTable2 name m1 m2 + = saved name (distanceWith2' m1 m2 proj1 proj2 n1 n2) + where + proj1 = rawProjection + proj2 = rawProjection + n1 = range (proxyUnwrap proj1) + n2 = range (proxyUnwrap proj2) + +distanceWith2' + :: G.Vector v DInt + => MoveTag m [RawMove a] -> MoveTag m [RawMove b] + -> Projection' m a -> Projection' m b -> Int -> Int -> v DInt +distanceWith2' (MoveTag m1) (MoveTag m2) proj1 proj2 n1 n2 + = distances n root neighbors + where + n = n1 * n2 + root = flatIndex n2 (unRawCoord (convertP proj1 iden)) (unRawCoord (convertP proj2 iden)) + neighbors ((`divMod` n2) -> (x1, x2)) + = zipWith (\v1 v2 -> flatIndex n2 + (unRawCoord . indexP proj1 v1 $ RawCoord x1) + (unRawCoord . indexP proj2 v2 $ RawCoord x2)) m1 m2 + +{-# INLINE indexWithSym #-} +indexWithSym + :: MoveTag sym (V.Vector (RawMove b)) + -- Conjugation by the inverse: s <> b <> s^-1 + -> Int + -> SymCoord sym a + -> RawCoord b + -> Int +indexWithSym sb nb (SymClass xa, i) xb = flatIndex nb xa (symB sb i xb) + where + symB :: MoveTag sym (V.Vector (RawMove b)) -> SymCode sym -> RawCoord b -> Int + symB (MoveTag s) (SymCode i) (RawCoord xb) = unRawMove (s V.! i) S.! xb + +distanceWithSym2' + :: (G.Vector v d, Integral d, Show d) + => MoveTag m [SymMove sym a] -> MoveTag m [RawMove b] + -> Symmetries sym b + -> SymProjection m sym a + -> Projection' m b + -> Int + -> Int + -> v d +distanceWithSym2' (MoveTag ma) (MoveTag mb) sb a b na nb + = distances n root neighbors + where + n = na * nb + root = flatIndex nb (unSymClass . fst $ convertP a iden) (unRawCoord (convertP b iden)) + neighbors ((`divMod` nb) -> (xa, xb)) + = zipWith (\va vb -> + let ya = indexP a va (SymClass xa, SymCode 0 :: SymCode sym) + yb = indexP b vb (RawCoord xb) + in indexWithSym sb nb ya yb) ma mb + +castDistance :: Distance m (RawCoord a) -> Distance m (RawCoord (Symmetric sym a)) +castDistance = coerce diff --git a/src/Rubik/Tables/Moves.hs b/src/Rubik/Tables/Moves.hs new file mode 100644 --- /dev/null +++ b/src/Rubik/Tables/Moves.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, ViewPatterns #-} +module Rubik.Tables.Moves where + +import Rubik.Cube +import Rubik.Misc +import Rubik.Solver +import Rubik.Symmetry +import Rubik.Tables.Internal + +import Data.Bifunctor +import Data.Bits +import Data.Maybe +import Data.Monoid +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Storable.Allocated as S + +type Moves m a = MoveTag m [RawMove a] + +move18CornerOrien = savedRawMoveTables "move18CornerOrien" move18 + :: Moves Move18 CornerOrien + +move18CornerPermu = savedRawMoveTables "move18CornerPermu" move18 + :: Moves Move18 CornerPermu + +move18EdgeOrien = savedRawMoveTables "move18EdgeOrien" move18 + :: Moves Move18 EdgeOrien + +move18UDSlicePermu = savedRawMoveTables "move18UDSlicePermu" move18 + :: Moves Move18 UDSlicePermu + +move18UDSlice = savedRawMoveTables "move18UDSlice" move18 + :: Moves Move18 UDSlice + +move10CornerPermu = move18to10 move18CornerPermu + :: Moves Move10 CornerPermu + +move10UDSlicePermu2 = savedRawMoveTables "move10UDSlicePermu2" move10 + :: Moves Move10 UDSlicePermu2 + +move10UDEdgePermu2 = savedRawMoveTables "move10UDEdgePermu2" move10 + :: Moves Move10 UDEdgePermu2 + +--move18SymFlipUDSlicePermu +-- = (savedSymMoveTables +-- "move10symFlipUDSlicePermu" +-- move18 +-- rawFlipUDSlicePermu +-- actionFlipUDSlicePermu +-- symReprFlipUDSlicePermu +-- conjugateFlipUDSlicePermu) + +sym16CornerOrien + = savedRawSymTables "sym16CornerOrien" conjugateCornerOrien sym16 + :: Symmetries UDFix CornerOrien + +invertedSym16CornerOrien + = MoveTag $ V.fromList + [ unMoveTag sym16CornerOrien V.! j + | i <- [0 .. 15], let SymCode j = invertSym (SymCode i) ] + :: Symmetries UDFix CornerOrien + +sym16CornerPermu + = savedRawSymTables "sym16CornerPermu" (conjugate . fromCube) sym16 + :: Symmetries UDFix CornerPermu + +invertedSym16CornerPermu + = MoveTag $ V.fromList + [ unMoveTag sym16CornerPermu V.! j + | i <- [0 .. 15], let SymCode j = invertSym (SymCode i) ] + :: Symmetries UDFix CornerPermu + +{-# INLINE symProjCornerPermu #-} +symProjCornerPermu + = symProjection (rawToSymCornerPermu . encode) + :: SymProjection Move18 UDFix CornerPermu + +move18SymCornerPermu :: MoveTag Move18 [SymMove UDFix CornerPermu] +move18SymCornerPermu + = saved' "move18SymCornerPermu" . MoveTag $ fmap + (\moveCP -> + SymMove . S.map (f moveCP) $ unSymClassTable classCornerPermu) + (unMoveTag move18CornerPermu) + where + f (RawMove moveCP) = (\(SymClass c, SymCode i) -> flatIndex 16 c i) . rawToSymCornerPermu . RawCoord . (moveCP S.!) + +{-# INLINE symProjFlipUDSlicePermu #-} +symProjFlipUDSlicePermu + = symProjection + (rawToSymFlipUDSlicePermu . encode) + :: SymProjection Move18 UDFix FlipUDSlicePermu + +rawToSymCornerPermu (RawCoord x) = (SymClass c, SymCode i) + where + (r, i) = (unSymReprTable reprCornerPermu S.! x) `divMod` 16 + c = fromJust . iFind r $ unSymClassTable classCornerPermu + +{-# INLINE symToRawCornerPermu #-} +symToRawCornerPermu = symToRaw classCornerPermu (sym sym16CornerPermu) + +classCornerPermu :: SymClassTable UDFix CornerPermu +classCornerPermu + = saved' "classCornerPermu" $ symClassTable 16 reprCornerPermu + +reprCornerPermu :: SymReprTable UDFix CornerPermu +reprCornerPermu + = saved' "reprCornerPermu" $ symReprTable 16 $ + \cp -> [ (encode . conj s . decode) cp | s <- sym16' ] + where + conj (fromCube -> s) (cp :: CornerPermu) = inverse s <> cp <> s + +move18SymFlipUDSlicePermu :: MoveTag Move18 [SymMove UDFix FlipUDSlicePermu] +move18SymFlipUDSlicePermu + = saved' "move18SymFlipUDSlicePermu" . MoveTag $ zipWith + (\moveUDSP moveEO -> + SymMove $ S.map (f moveUDSP moveEO) (unSymClassTable classFlipUDSlicePermu)) + (unMoveTag move18UDSlicePermu) (unMoveTag move18EdgeOrien) + where + nEO = range ([] :: [EdgeOrien]) + f (RawMove moveUDSP) (RawMove moveEO) x = + let (i, j) = x `divMod` nEO + z = flatIndex nEO (moveUDSP S.! i) (moveEO S.! j) + (SymClass c, SymCode s) = rawToSymFlipUDSlicePermu (RawCoord z) + in flatIndex 16 c s + +rawToSymFlipUDSlicePermu + :: RawCoord FlipUDSlicePermu -> SymCoord UDFix FlipUDSlicePermu +rawToSymFlipUDSlicePermu (RawCoord z) = (SymClass c, SymCode i) + where + (r, i) = (unSymReprTable reprFlipUDSlicePermu S.! z) `divMod` 16 + c = fromJust . iFind r $ unSymClassTable classFlipUDSlicePermu + +rawToSymFlipUDSlicePermu' + :: RawCoord UDSlicePermu -> RawCoord EdgeOrien + -> SymCoord UDFix FlipUDSlicePermu +rawToSymFlipUDSlicePermu' + = rawToSymFlipUDSlicePermu .: flatCoord + where (.:) = (.) (.) (.) + +{-# INLINE symToRawFlipUDSlicePermu #-} +symToRawFlipUDSlicePermu = symToRaw classFlipUDSlicePermu $ \x (SymCode i) -> + ( uncurry flatCoord + . (V.! i) + . uncurry conjugateFlipUDSlicePermu_ + . splitCoord + ) x + +classFlipUDSlicePermu :: SymClassTable UDFix FlipUDSlicePermu +classFlipUDSlicePermu + = saved' "classFlipUDSlicePermu" $ symClassTable 16 reprFlipUDSlicePermu + +reprFlipUDSlicePermu :: SymReprTable UDFix FlipUDSlicePermu +reprFlipUDSlicePermu + = saved' "reprFlipUDSlicePermu" . symReprTable 16 $ + fmap (uncurry flatCoord) . uncurry conjugateFlipUDSlicePermu_ . splitCoord + +conjugateFlipUDSlicePermu' + :: SymCode UDFix -> FlipUDSlicePermu -> FlipUDSlicePermu +conjugateFlipUDSlicePermu' (SymCode c) (udsp, eo) + = bimap decode decode (conjugateFlipUDSlicePermu_ i j V.! c) + where + i = encode udsp + j = encode eo + +{-# INLINE conjugateFlipUDSlicePermu_ #-} +conjugateFlipUDSlicePermu_ + :: RawCoord UDSlicePermu -> RawCoord EdgeOrien + -> V.Vector (RawCoord UDSlicePermu, RawCoord EdgeOrien) +conjugateFlipUDSlicePermu_ (RawCoord i) (RawCoord j) + = V.zipWith4 f conjUDSP udspComp eoComp cubeComp + where + conjUDSP = conjUDSlicePermu V.! i + udspComp = udspComponentOfConjEdgeOrien V.! i + eoComp = eoComponentOfConjEdgeOrien V.! j + cubeComp = cubeComponentOfConjEdgeOrien + f conjUDSP udspComp eoComp cubeComp + = (conjUDSP, RawCoord (udspComp `xor` eoComp `xor` cubeComp)) + +conjugateUDSlicePermu' + :: SymCode UDFix -> UDSlicePermu -> UDSlicePermu +conjugateUDSlicePermu' (SymCode c) udsp + = decode (conjUDSlicePermu V.! i V.! c) + where RawCoord i = encode udsp + +-- x :: UDSlicePermu -> [ s^(-1) <> x <> s | s <- symUDFix ] +conjUDSlicePermu :: V.Vector (V.Vector (RawCoord UDSlicePermu)) +conjUDSlicePermu = V.generate (range ([] :: [UDSlicePermu])) $ \i -> + V.fromList [ encode . conjugateUDSlicePermu c . decode $ RawCoord i | c <- sym16' ] + +-- | 11 bits describing edge orientations, as obtained by @encodeEdgeOrien'@ +type EOComponent = Int +type EOComponents = V.Vector Int + +udspComponentOfConjEdgeOrien :: V.Vector EOComponents +udspComponentOfConjEdgeOrien + = V.generate (range ([] :: [UDSlicePermu])) $ \i -> + let udsp = fromUDSlicePermu . decode $ RawCoord i + in V.fromList $ map (encodeEdgeOrien' . orien udsp) sym16' + where + orien udsp c = + let (fromEdgeOrien -> eo_c, fromEdgePermu -> ep_c) = fromCube c + altO = eo_c U.! 0 + udsO = eo_c U.! 8 + in U.map (\p -> bool altO udsO (p `U.elem` udsp)) ep_c + +eoComponentOfConjEdgeOrien :: V.Vector EOComponents +eoComponentOfConjEdgeOrien + = V.generate (range ([] :: [EdgeOrien])) $ \j -> + let eo = fromEdgeOrien . decode $ RawCoord j + in V.fromList $ map (encodeEdgeOrien' . orien eo) sym16' + where + orien eo = U.backpermute eo . fromEdgePermu . fromCube + +cubeComponentOfConjEdgeOrien :: EOComponents +cubeComponentOfConjEdgeOrien + = V.fromList $ map (encodeEdgeOrien' . fromEdgeOrien . fromCube) sym16' diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +flags: {} +packages: + - '.' +extra-deps: [] + # These deps are for tests and the first one needs fixing anyway. + #- HUnit-Plus-0.1.0 + #- cabal-test-quickcheck-0.1.6 +resolver: lts-5.8 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE LambdaCase, RecordWildCards, ScopedTypeVariables, ViewPatterns #-} +module Test where + +import Rubik.Cube +import Rubik.Cube.Facelet.Internal +import Rubik.Cube.Cubie.Internal +import Rubik.Cube.Moves.Internal +import Rubik.Tables.Moves +import Rubik.Misc +import Rubik.Symmetry + +import Control.Applicative +import Control.Monad +import Data.List +import Data.List.Split (chunksOf) +import Data.Maybe +import Data.Monoid +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Primitive.Pinned as P +import Distribution.TestSuite +import Distribution.TestSuite.QuickCheck +import Test.HUnitPlus +import Test.QuickCheck +import qualified Test.QuickCheck as Gen +import System.Environment + +-- If the test suite receives some command line arguments, only tests whose +-- fully qualified name has a prefix among them are run. +tests :: IO [Test] +tests = (filterTests . rename) + [ testGroup "Cube" + [ testGroup "Facelets" + [ testProperty "permutation-to-facelet" $ + forAll (shuffle [0 .. 53]) (isJust . facelets') + , testGroupInstance genFacelets + , testProperty "facelet-colors" $ + forAll genCenteredFacelets (\(colorFaceletsOf -> c) -> + (colorFacelets' . fromColorFacelets') c === Just c) + ] + , testGroup "Cubie" + [ testGroup "CornerPermu" + [ testGenerator genCornerPermu (cornerPermu . fromCornerPermu) + , testGroupInstance genCornerPermu + , testCubeAction genCornerPermu genCubeFull + ] + , testGroup "CornerOrien" + [ testGenerator genCornerOrienFull (cornerOrien . fromCornerOrien) + , testCubeAction genCornerOrienFull genCubeFull + ] + , testGroup "Corner" + [ testGroupInstance genCornerFull + , testCubeAction genCornerFull genCubeFull + ] + , testGroup "EdgePermu" + [ testGenerator genEdgePermu (edgePermu . fromEdgePermu) + , testGroupInstance genEdgePermu + , testCubeAction genEdgePermu genCube + ] + , testGroup "EdgeOrien" + [ testGenerator genEdgeOrien (edgeOrien . fromEdgeOrien) + ] + , testGroup "Edge" + [ testGroupInstance genEdge + , testCubeAction genEdge genCube + ] + , testGroup "Cube" + [ testGroupInstance genCubeFull + ] + , testGroup "UDSlicePermu" + [ testGenerator genUDSlicePermu (uDSlicePermu . fromUDSlicePermu) + , testCubeAction genUDSlicePermu genCube + ] + , testGroup "UDSlice" + [ testGenerator genUDSlice (uDSlice . fromUDSlice) + , testCubeAction genUDSlice genCube + ] + , testGroup "UDSlicePermu2" + [ testGenerator genUDSlicePermu2 (uDSlicePermu2 . fromUDSlicePermu2) + , testCubeAction genUDSlicePermu2 genCubeUDFixFull + ] + , testGroup "UDEdgePermu2" + [ testGenerator genUDEdgePermu2 (uDEdgePermu2 . fromUDEdgePermu2) + , testCubeAction genUDEdgePermu2 genCubeUDFixFull + ] + , testGroup "EdgePermu2" + [ testGenerator genEdgePermu2 (edgePermu . fromEdgePermu) + ] + , testGroup "FlipUDSlicePermu" + [ testConjugate genCubeUDFixSym genCubeFull conjugateFlipUDSlicePermu + ] + , testGroup "ToFacelet" + [ testGroupMorphism genCubeFull toFacelet + ] + ] + , testGroup "Coord" + [ testCoord "CornerPermu" + genCornerPermu (cornerPermu . fromCornerPermu) + , testCoord "CornerOrien" + genCornerOrien (cornerOrien . fromCornerOrien) + , testCoord "EdgePermu" + genEdgePermu (edgePermu . fromEdgePermu) + , testCoord "EdgeOrien" + genEdgeOrien (edgeOrien . fromEdgeOrien) + , testCoord "UDSlicePermu" + genUDSlicePermu (uDSlicePermu . fromUDSlicePermu) + , testCoord "UDSlice" + genUDSlice (uDSlice . fromUDSlice) + , testCoord "UDSlicePermu2" + genUDSlicePermu2 (uDSlicePermu2 . fromUDSlicePermu2) + , testCoord "UDEdgePermu2" + genUDEdgePermu2 (uDEdgePermu2 . fromUDEdgePermu2) + , testCoord "FlipUDSlicePermu" + genFlipUDSlicePermu Just + ] + , testGroup "Moves" + [ testMoves "" + "UUUUUUUUU LLLLLLLLL FFFFFFFFF RRRRRRRRR BBBBBBBBB DDDDDDDDD" + , testMoves "uuuu" + "UUUUUUUUU LLLLLLLLL FFFFFFFFF RRRRRRRRR BBBBBBBBB DDDDDDDDD" + , testMoves "u" + "UUUUUUUUU FFFLLLLLL RRRFFFFFF BBBRRRRRR LLLBBBBBB DDDDDDDDD" + , testMoves "l" + "BUUBUUBUU LLLLLLLLL UFFUFFUFF RRRRRRRRR BBDBBDBBD FDDFDDFDD" + , testMoves "f" + "UUUUUULLL LLDLLDLLD FFFFFFFFF URRURRURR BBBBBBBBB RRRDDDDDD" + , testMoves "r" + "UUFUUFUUF LLLLLLLLL FFDFFDFFD RRRRRRRRR UBBUBBUBB DDBDDBDDB" + , testMoves "b" + "RRRUUUUUU ULLULLULL FFFFFFFFF RRDRRDRRD BBBBBBBBB DDDDDDLLL" + , testMoves "d" + "UUUUUUUUU LLLLLLBBB FFFFFFLLL RRRRRRFFF BBBBBBRRR DDDDDDDDD" + , testMoves "ulfrbd" + "LBBBURFFR ULRULDDDD UUBFFDBLD UULRRDFFD UUFBBLRRF LFRLDRLBB" + , testCube "sURF" surf3 + "FFFFUFFFF DDDDLDDDD RRRRFRRRR UUUURUUUU LLLLBLLLL BBBBDBBBB" + , testCube "sF" sf2 + "DDDDUDDDD RRRRLRRRR FFFFFFFFF LLLLRLLLL BBBBBBBBB UUUUDUUUU" + , testCube "sU" su4 + "UUUUUUUUU FFFFLFFFF RRRRFRRRR BBBBRBBBB LLLLBLLLL DDDDDDDDD" + , testCube "sLR" slr2 + "UUUUUUUUU RRRRLRRRR FFFFFFFFF LLLLRLLLL BBBBBBBBB DDDDDDDDD" + ] + ] + , testGroup "Tables" + [ testGroup "Moves" + [ testMoveTables "move18CornerPermu" + move18 move18CornerPermu + , testMoveTables "move18CornerOrien" + move18 move18CornerOrien + , testMoveTables "move18EdgeOrien" + move18 move18EdgeOrien + , testMoveTables "move18UDSlicePermu" + move18 move18UDSlicePermu + , testMoveTables "move18UDSlice" + move18 move18UDSlice + , testMoveTables "move10UDSlicePermu2" + move10 move10UDSlicePermu2 + , testMoveTables "move10UDEdgePermu2" + move10 move10UDEdgePermu2 + ] + , testUDSlicePermu + , testFlipUDSlicePermu + , testRawToSymFlipUDSlicePermu + , testSymReprTable "srFUDSP" + reprFlipUDSlicePermu conjugateFlipUDSlicePermu + , testMoveSymTables "msFUDSP" move18 move18SymFlipUDSlicePermu + ] + ] + +-- * Facelets + +genFacelets = unsafeFacelets' <$> shuffle [0 .. 53] + +-- | Centers remain fixed +genCenteredFacelets = unsafeFacelets' <$> do + let chunks = chunksOf 9 [4 .. 53] + shuffled <- (shuffle . ([0 .. 3] ++) . concat . fmap tail) chunks + let (x, y) = splitAt 4 shuffled + facelets = (x ++) . concat . zipWith (:) (fmap head chunks) . chunksOf 8 + return (facelets y) + +-- * Cubies + +genCornerPermu = unsafeCornerPermu' <$> shuffle [0 .. 7] +genCornerOrien = unsafeCornerOrien' + . (\x -> (3 - sum x) `mod` 3 : x) <$> replicateM 7 (Gen.choose (0, 2)) +genCornerOrienFull = unsafeCornerOrien' <$> replicateM 8 (Gen.choose (0,5)) +genCorner = liftA2 Corner genCornerPermu genCornerOrien +genCornerFull = liftA2 Corner genCornerPermu genCornerOrienFull +genEdgePermu = unsafeEdgePermu' <$> shuffle [0 .. 11] +genEdgeOrien = unsafeEdgeOrien' + . (\x -> sum x `mod` 2 : x) <$> replicateM 11 (Gen.choose (0, 1)) +genEdge = liftA2 Edge genEdgePermu genEdgeOrien +genCube = liftA2 Cube genCorner genEdge +genCubeFull = liftA2 Cube genCornerFull genEdge +genCubeSolvable = genCube `suchThat` solvable +genUDSlicePermu = unsafeUDSlicePermu' . take 4 <$> shuffle [0 .. 11] +genUDSlice = unpermuUDSlice <$> genUDSlicePermu +genUDSlicePermu2 = unsafeUDSlicePermu2' <$> shuffle [0 .. 3] +genUDEdgePermu2 = unsafeUDEdgePermu2' <$> shuffle [0 .. 7] +genEdgePermu2 = liftA2 edgePermu2 genUDSlicePermu2 genUDEdgePermu2 +genEdge2 = liftA2 Edge genEdgePermu2 genEdgeOrien +genFlipUDSlicePermu = liftA2 (,) genUDSlicePermu genEdgeOrien +genCubeUDFixFull = liftA2 Cube genCornerFull genEdge2 +genCubeUDFixSym = elements sym16' + +testConjugate :: (FromCube a, Eq a, Show a) + => Gen Cube -> Gen Cube -> (Cube -> a -> a) -> Test +testConjugate genSym genCube conj + = testProperty "conjugate" $ + forAll genSym $ \s -> forAll genCube $ \c -> + fromCube (inverse s <> c <> s) === conj s (fromCube c) + +-- * Coord + +testCoord :: forall a. (RawEncodable a, Show a, Eq a) + => String -> Gen a -> (a -> Maybe a) -> Test +testCoord name gen check = testGroup name $ + [ testProperty "coord-bijection-1" $ + forAll genCoord $ join ((===) . encode . decode) + , testProperty "coord-bijection-2" $ + forAll gen $ join ((===) . decode . encode) + , testProperty "coord-range" $ + forAll gen $ liftA2 (&&) (range gen >) (>= 0) . unRawCoord . encode + , testProperty "coord-correct" $ + forAll genCoord $ isJust . check . decode + ] + where + genCoord = RawCoord <$> Gen.choose (0, range gen-1) :: Gen (RawCoord a) + +testMoveTables :: (CubeAction a, RawEncodable a) + => String -> MoveTag m [Cube] -> MoveTag m [RawMove a] + -> Test +testMoveTables name (MoveTag cubes) (MoveTag moves) + = testProperty name $ + conjoin $ zipWith propMoveTable1 cubes moves + +propMoveTable1 :: forall a. (CubeAction a, RawEncodable a) + => Cube -> RawMove a -> Property +propMoveTable1 c m'@(RawMove m) + = forAll genCoord $ \x -> + RawCoord (m P.! unRawCoord x) + === (encode . (`cubeAction` c) . decode) x + where + genCoord = RawCoord <$> Gen.choose (0, range m'-1) :: Gen (RawCoord a) + +-- * Moves + +testMoves :: String -> String -> Test +testMoves moves result = '.' : moves ~: + (stringOfCubeColors . moveToCube <$> stringToMove moves) ~?= Right result + +testCube :: String -> Cube -> String -> Test +testCube name c result = name ~: stringOfCubeColors c ~?= result + +-- * Move tables + +-- ** FlipUDSlice implementation + +testUDSlicePermu + = testProperty "UDSlicePermu" $ + forAll (Gen.choose (0, 15)) $ \c -> forAll genUDSlicePermu $ \udsp -> + conjugateUDSlicePermu (sym16' !! c) udsp + === conjugateUDSlicePermu' (SymCode c) udsp + +testFlipUDSlicePermu + = testProperty "FlipUDSlicePermu" $ + forAll (Gen.choose (0, 15)) $ \c -> forAll genFlipUDSlicePermu $ \fudsp -> + counterexample ((show $ sym16' !! c) ++ "XXQS") $ + conjugateFlipUDSlicePermu (sym16' !! c) fudsp + === conjugateFlipUDSlicePermu' (SymCode c) fudsp + +testRawToSymFlipUDSlicePermu + = testProperty "raw-to-sym-fudsp" $ + forAll genCoordFUDSP $ \z -> + let (SymClass c, sc) = rawToSymFlipUDSlicePermu z + in encode + ( conjugateFlipUDSlicePermu' sc + . decode . RawCoord + $ unSymClassTable classFlipUDSlicePermu P.! c) + === z + where + genCoordFUDSP = RawCoord <$> Gen.choose (0, range ([] :: [FlipUDSlicePermu]) -1) + +testMoveSymTables :: () + => String -> MoveTag m [Cube] -> MoveTag m [SymMove UDFix FlipUDSlicePermu] + -> Test +testMoveSymTables name (MoveTag cubes) (MoveTag moves) + = testProperty name $ + conjoin $ zipWith propMoveSymTable1 cubes moves + +propMoveSymTable1 c (SymMove m) + -- = forAll (Gen.choose (0, P.length m-1)) $ \x -> + = case G.find (\x -> x >= 16 * P.length m) m of + Nothing -> property True + Just x -> counterexample (show (x, P.length m)) False + +testSymReprTable name (SymReprTable repr) conj + = testProperty name $ + forAll (Gen.choose (0, P.length repr-1)) $ \x -> + let y = repr P.! x + (r, i) = y `divMod` 16 + in (encode . conj (sym16' !! i) . decode . RawCoord) r + === RawCoord x + +-- * Typeclass laws + +testMonoid0 :: (Monoid a, Eq a, Show a) => proxy a -> Test +testMonoid0 proxy = + "mempty-mappend-mempty" ~: + mempty <> mempty ~?= mempty `asProxyTypeOf` proxy + +testMonoid :: (Monoid a, Eq a, Show a) => Gen a -> Test +testMonoid gen = testGroup "Monoid" + [ testProperty "left-identity" $ + forAll gen (\x -> mempty <> x === x) + , testProperty "right-identity" $ + forAll gen (\x -> x <> mempty === x) + , testProperty "associativity" $ + forAll gen $ \x -> forAll gen $ \y -> forAll gen $ \z -> + (x <> y) <> z === x <> (y <> z) + , testMonoid0 gen + ] + +testGroup0 :: (Group a, Eq a, Show a) => proxy a -> Test +testGroup0 proxy = + "inverse-mempty" ~: + inverse mempty ~?= mempty `asProxyTypeOf` proxy + +testGroupInstance :: (Group a, Eq a, Show a) => Gen a -> Test +testGroupInstance gen = testGroup "Group" + [ testProperty "inverse-left" $ + forAll gen (\x -> inverse x <> x === mempty) + , testProperty "inverse-right" $ + forAll gen (\x -> x <> inverse x === mempty) + , testGroup0 gen + , testMonoid gen + ] + +testMonoidMorphism :: (Monoid a, Monoid b, Eq a, Eq b, Show a, Show b) + => Gen a -> (a -> b) -> Test +testMonoidMorphism gen f = testGroup "MonoidM" + [ "morphism-iden" ~: f mempty ~?= mempty + , testProperty "morphism-compose" $ + forAll gen $ \x -> forAll gen $ \y -> + f (x <> y) === f x <> f y + ] + +testGroupMorphism :: (Group a, Group b, Eq a, Eq b, Show a, Show b) + => Gen a -> (a -> b) -> Test +testGroupMorphism gen f = testGroup "GroupM" + [ testMonoidMorphism gen f + , testProperty "morphism-inverse" $ + forAll gen $ \x -> (inverse . f) x === (f . inverse) x + ] + +testCubeAction + :: (CubeAction a, FromCube a, Eq a, Show a) + => Gen a -> Gen Cube -> Test +testCubeAction gen genCube = testGroup "CubeAction" + [ testProperty "id-cube-action" $ + forAll gen $ \x -> cubeAction x iden === x + , testProperty "from-cube-action" $ + forAll genCube $ \x -> forAll genCube $ \c -> + cubeAction (fromCube x) c === fromCube (x <> c) `asProxyTypeOf` gen + ] + +testGenerator :: (Eq a, Show a) => Gen a -> (a -> Maybe b) -> Test +testGenerator gen p = testProperty "generator" $ forAll gen (isJust . p) + +-- * Utilities + +-- Qualify test names +rename :: [Test] -> [Test] +rename = fmap (rename' "") + +rename' :: String -> Test -> Test +rename' pfx (Test t) = Test t{ name = pfx ++ name t } +rename' pfx (Group name conc tests) + = Group name conc (fmap (rename' (pfx ++ name ++ "/")) tests) +rename' pfx (ExtraOptions opts test) = ExtraOptions opts (rename' pfx test) + +filterTests :: [Test] -> IO [Test] +filterTests tests = do + getArgs <&> \case + [] -> tests + pfxs -> filterTests' pfxs tests + +filterTests' pfxs = (>>= filterTest pfxs) + +filterTest pfxs test@(Test t) = [test | any (`isPrefixOf` name t) pfxs] +filterTest pfxs (Group name conc tests) + = let tests' = filterTests' pfxs tests + in [Group name conc tests' | (not . null) tests'] +filterTest pfxs (ExtraOptions opts test) = ExtraOptions opts <$> filterTest pfxs test diff --git a/twentyseven.cabal b/twentyseven.cabal new file mode 100644 --- /dev/null +++ b/twentyseven.cabal @@ -0,0 +1,105 @@ +name: twentyseven +version: 0.0.0 +synopsis: Rubik's cube solver +description: + Solve 3×3×3 Rubik's cubes in the fewest possible moves. Or, if you can't + wait, get /close enough/ with the two-phase solver. +homepage: https://github.com/lysxia/twentyseven +license: MIT +license-file: LICENSE +author: Li-yao Xia +maintainer: li-yao.xia@ens.fr +category: Algorithms +build-type: Simple +extra-source-files: README.md stack.yaml +cabal-version: >=1.10 + +library + exposed-modules: + Data.Binary.Storable + Data.Tuple.Extra + Data.Vector.Generic.Mutable.Loops + Data.Vector.Storable.Allocated + Data.MBitVector + Data.Vector.HalfByte + Rubik.Cube + Rubik.Cube.Facelet + Rubik.Cube.Facelet.Internal + Rubik.Cube.Coord + Rubik.Cube.Cubie + Rubik.Cube.Cubie.Internal + Rubik.Cube.Moves + Rubik.Cube.Moves.Internal + Rubik.Tables.Distances + Rubik.Tables.Moves + Rubik.Tables.Internal + Rubik.Distances + Rubik.IDA + Rubik.Misc + Rubik.Solver + Rubik.Solver.Optimal + Rubik.Solver.TwoPhase + Rubik.Symmetry + other-modules: + Data.Tuple.Template + other-extensions: + DeriveFunctor + FlexibleInstances + FlexibleContexts + MagicHash + MultiParamTypeClasses + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TypeFamilies + TypeOperators + ViewPatterns + build-depends: + base >=4.8 && <5, + deepseq, + directory, + filepath, + heap >=1.0, + primitive >=0.6, + vector >=0.10, + containers >=0.5, + monad-loops, + MonadRandom, + mtl >= 2.1, + newtype >= 0.2, + ref-fd >=0.4, + template-haskell + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -fwarn-unused-imports + +executable twentyseven + main-is: twentyseven.hs + hs-source-dirs: exec-src + other-extensions: + NamedFieldPuns + RecordWildCards + build-depends: + base >=4.8 && <5, + optparse-applicative, + time <1.6, + transformers, + twentyseven + default-language: Haskell2010 + +Test-Suite test-twentyseven + type: detailed-0.9 + hs-source-dirs: test + test-module: Test + other-extensions: + LambdaCase + build-depends: + base >=4.8, + Cabal >=1.9.3, + cabal-test-quickcheck >=0.1.6, + HUnit-Plus >=1.1.0, + QuickCheck >=2.8, + split, + vector, + twentyseven + default-language: Haskell2010