twentyseven (empty) → 0.0.0

raw patch · 32 files changed

+4226/−0 lines, 32 filesdep +Cabaldep +HUnit-Plusdep +MonadRandomsetup-changed

Dependencies added: Cabal, HUnit-Plus, MonadRandom, QuickCheck, base, cabal-test-quickcheck, containers, deepseq, directory, filepath, heap, monad-loops, mtl, newtype, optparse-applicative, primitive, ref-fd, split, template-haskell, time, transformers, twentyseven, vector

Files

• LICENSE +22/−0
• README.md +150/−0
• Setup.hs +2/−0
• exec-src/twentyseven.hs +144/−0
• src/Data/Binary/Storable.hs +43/−0
• src/Data/MBitVector.hs +37/−0
• src/Data/Tuple/Extra.hs +22/−0
• src/Data/Tuple/Template.hs +51/−0
• src/Data/Vector/Generic/Mutable/Loops.hs +20/−0
• src/Data/Vector/HalfByte.hs +153/−0
• src/Data/Vector/Storable/Allocated.hs +152/−0
• src/Rubik/Cube.hs +13/−0
• src/Rubik/Cube/Coord.hs +318/−0
• src/Rubik/Cube/Cubie.hs +73/−0
• src/Rubik/Cube/Cubie/Internal.hs +587/−0
• src/Rubik/Cube/Facelet.hs +85/−0
• src/Rubik/Cube/Facelet/Internal.hs +175/−0
• src/Rubik/Cube/Moves.hs +65/−0
• src/Rubik/Cube/Moves/Internal.hs +297/−0
• src/Rubik/Distances.hs +85/−0
• src/Rubik/IDA.hs +94/−0
• src/Rubik/Misc.hs +212/−0
• src/Rubik/Solver.hs +170/−0
• src/Rubik/Solver/Optimal.hs +51/−0
• src/Rubik/Solver/TwoPhase.hs +69/−0
• src/Rubik/Symmetry.hs +182/−0
• src/Rubik/Tables/Distances.hs +48/−0
• src/Rubik/Tables/Internal.hs +182/−0
• src/Rubik/Tables/Moves.hs +216/−0
• stack.yaml +8/−0
• test/Test.hs +395/−0
• twentyseven.cabal +105/−0

@@ -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.+

@@ -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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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)

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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 (>>)

@@ -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

@@ -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 <y 0 .. y k> == encodeCV <y 0 .. y (k-1)> + 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)

@@ -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

@@ -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+

@@ -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

@@ -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]

@@ -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

@@ -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 = <U, D, L2, F2, R2, B2>+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

@@ -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)

@@ -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)+

@@ -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 (<$>)

@@ -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_

@@ -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.!)

@@ -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

@@ -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

@@ -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])

@@ -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

@@ -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'

@@ -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

@@ -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

@@ -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