diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 2015 Tim Baumann
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,21 @@
+# diagrams-rubiks-cube [![Hackage version][hackage-image]][hackage-url] [![Hackage dependencies][hackage-deps-image]][hackage-deps-url]
+
+Haskell library for drawing the Rubik's Cube.
+
+![Move sequence][moves-image]
+
+## Installation
+
+```bash
+$ cabal install diagrams-rubiks-cube
+```
+
+## Documentation
+
+See the docs on [Hackage][hackage-url].
+
+[moves-image]: https://cdn.rawgit.com/timjb/diagrams-rubiks-cube/master/diagrams/src_Diagrams_RubiksCube_Draw_drawMovesExample.svg
+[hackage-image]: https://img.shields.io/hackage/v/diagrams-rubiks-cube.svg?style=flat
+[hackage-url]: http://hackage.haskell.org/package/diagrams-rubiks-cube
+[hackage-deps-image]: https://img.shields.io/hackage-deps/v/diagrams-rubiks-cube.svg?style=flat
+[hackage-deps-url]: http://packdeps.haskellers.com/feed?needle=diagrams-rubiks-cube.svg
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/diagrams-rubiks-cube.cabal b/diagrams-rubiks-cube.cabal
new file mode 100644
--- /dev/null
+++ b/diagrams-rubiks-cube.cabal
@@ -0,0 +1,32 @@
+name: diagrams-rubiks-cube
+version: 0.1.0.0
+synopsis: Library for drawing the Rubik's Cube.
+description: Includes a facets model of the Rubik's Cube and a 'diagrams'-based renderer.
+homepage: https://github.com/timjb/rubiks-cube
+license: MIT
+license-file: LICENSE
+author: Tim Baumann
+maintainer: tim@timbaumann.info
+copyright: 2015 Tim Baumann
+category: Graphics
+build-type: Simple
+extra-source-files: README.md, diagrams/*.svg
+extra-doc-files: diagrams/*.svg
+cabal-version: >= 1.10
+
+source-repository head
+ type: git
+ location: https://github.com/timjb/diagrams-rubiks-cube.git
+
+library
+ ghc-options: -Wall
+ exposed-modules: Diagrams.RubiksCube,
+ Diagrams.RubiksCube.Move,
+ Diagrams.RubiksCube.Model,
+ Diagrams.RubiksCube.Draw
+ build-depends: base >= 4.6 && < 5,
+ diagrams-lib >= 1.2.0.7 && < 1.3,
+ lens >= 4.6.0.1 && < 5,
+ data-default-class >= 0.0.1 && < 0.1
+ hs-source-dirs: src
+ default-language: Haskell2010
diff --git a/diagrams/src_Diagrams_RubiksCube_Draw_drawCubeExample.svg b/diagrams/src_Diagrams_RubiksCube_Draw_drawCubeExample.svg
new file mode 100644
--- /dev/null
+++ b/diagrams/src_Diagrams_RubiksCube_Draw_drawCubeExample.svg
@@ -0,0 +1,4 @@
+
+
+
diff --git a/diagrams/src_Diagrams_RubiksCube_Draw_drawMoveExample.svg b/diagrams/src_Diagrams_RubiksCube_Draw_drawMoveExample.svg
new file mode 100644
--- /dev/null
+++ b/diagrams/src_Diagrams_RubiksCube_Draw_drawMoveExample.svg
@@ -0,0 +1,4 @@
+
+
+
diff --git a/diagrams/src_Diagrams_RubiksCube_Draw_drawMovesExample.svg b/diagrams/src_Diagrams_RubiksCube_Draw_drawMovesExample.svg
new file mode 100644
--- /dev/null
+++ b/diagrams/src_Diagrams_RubiksCube_Draw_drawMovesExample.svg
@@ -0,0 +1,4 @@
+
+
+
diff --git a/diagrams/src_Diagrams_RubiksCube_Draw_drawSideDia.svg b/diagrams/src_Diagrams_RubiksCube_Draw_drawSideDia.svg
new file mode 100644
--- /dev/null
+++ b/diagrams/src_Diagrams_RubiksCube_Draw_drawSideDia.svg
@@ -0,0 +1,4 @@
+
+
+
diff --git a/diagrams/src_Diagrams_RubiksCube_Draw_offsetsDia.svg b/diagrams/src_Diagrams_RubiksCube_Draw_offsetsDia.svg
new file mode 100644
--- /dev/null
+++ b/diagrams/src_Diagrams_RubiksCube_Draw_offsetsDia.svg
@@ -0,0 +1,4 @@
+
+
+
diff --git a/diagrams/src_Diagrams_RubiksCube_Draw_solvedCube.svg b/diagrams/src_Diagrams_RubiksCube_Draw_solvedCube.svg
new file mode 100644
--- /dev/null
+++ b/diagrams/src_Diagrams_RubiksCube_Draw_solvedCube.svg
@@ -0,0 +1,4 @@
+
+
+
diff --git a/src/Diagrams/RubiksCube.hs b/src/Diagrams/RubiksCube.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/RubiksCube.hs
@@ -0,0 +1,9 @@
+module Diagrams.RubiksCube
+ ( module Diagrams.RubiksCube.Move
+ , module Diagrams.RubiksCube.Model
+ , module Diagrams.RubiksCube.Draw
+ ) where
+
+import Diagrams.RubiksCube.Move
+import Diagrams.RubiksCube.Model
+import Diagrams.RubiksCube.Draw
diff --git a/src/Diagrams/RubiksCube/Draw.hs b/src/Diagrams/RubiksCube/Draw.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/RubiksCube/Draw.hs
@@ -0,0 +1,278 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
+
+module Diagrams.RubiksCube.Draw
+ ( solvedRubiksCube
+ , drawSide
+ , drawFoldingPattern
+ , Offsets (..), offsetX, offsetY
+ , drawRubiksCube
+ , drawMove
+ , MovesSettings (..), moveSep, showStart, showEnd, offsets
+ , drawMoves, drawMovesBackward
+ ) where
+
+import Diagrams.RubiksCube.Move (Move (..))
+import Diagrams.RubiksCube.Model
+
+import Control.Lens hiding ((#))
+import Diagrams.Prelude hiding (center)
+import Data.List (sortBy, mapAccumL)
+import Data.Function (on)
+import qualified Diagrams.Prelude as P
+import Data.Default.Class
+
+-- > import Diagrams.RubiksCube.Draw
+-- > solvedCube = drawFoldingPattern solvedRubiksCube
+
+-- | The solved cube.
+--
+-- <>
+solvedRubiksCube :: RubiksCube (Colour Double)
+solvedRubiksCube = RubiksCube (Cube f b l r u d)
+ where
+ f = pure orange
+ b = pure red
+ l = pure white
+ r = pure yellow
+ u = pure green
+ d = pure blue
+
+-- > import Diagrams.RubiksCube
+-- > drawSideDia =
+-- > let side = drawSide (r2 (1,0)) (r2 (0,1)) (pure yellow & topLeft .~ green)
+-- > dxArrow = arrowBetween (p2 (4,1)) (p2 (5,1))
+-- > dxLabel = position [(p2 (4.5, 0.7), scale 0.4 (text "dx"))]
+-- > dyArrow = arrowBetween (p2 (4,1)) (p2 (4,2))
+-- > dyLabel = position [(p2 (3.65, 1.5), scale 0.4 (text "dy"))]
+-- > in mconcat [side, dxArrow, dxLabel, dyArrow, dyLabel]
+
+-- | Draws one 3x3 side of the cube.
+--
+-- <>
+drawSide
+ :: Renderable (Path R2) b
+ => R2 -- ^ dx
+ -> R2 -- ^ dy
+ -> Side (Colour Double)
+ -> Diagram b R2
+drawSide dx dy side = mconcat $ do
+ (y, row) <- count rows
+ let Vec3 l c r = side ^. row
+ [drawField 0 y l, drawField 1 y c, drawField 2 y r]
+ where
+ count = zip [(0 :: Int)..]
+ rows = [bottomRow, middleRow, topRow]
+ pos x y = p2 $ unr2 $ fromIntegral x *^ dx ^+^ fromIntegral y *^ dy
+ drawField :: Renderable (Path R2) b => Int -> Int -> Colour Double -> Diagram b R2
+ drawField x y color =
+ fromVertices [pos x y, pos (x+1) y, pos (x+1) (y+1), pos x (y+1), pos x y]
+ # mapLoc closeTrail # trailLike # fc color
+
+-- | Draw the folding pattern of the cube. The front side is at the center of
+-- the pattern.
+drawFoldingPattern
+ :: Renderable (Path R2) b
+ => RubiksCube (Colour Double)
+ -> Diagram b R2
+drawFoldingPattern c' =
+ let c = c' ^. cube
+ drawSide' = drawSide (r2 (1,0)) (r2 (0,1))
+ in hcat $ map P.center
+ [ drawSide' (c ^. leftSide)
+ , drawSide' (c ^. upSide) ===
+ drawSide' (c ^. frontSide) ===
+ drawSide' (c ^. downSide)
+ , drawSide' (c ^. rightSide)
+ , drawSide' (c ^. backSide)
+ ]
+
+-- > import Diagrams.RubiksCube
+-- > offsetsDia =
+-- > let off = Offsets 2 1
+-- > c = drawRubiksCube off solvedRubiksCube
+-- > oxArrow = arrowBetween (p2 (3,-1)) (p2 (5,-1))
+-- > oxLabel = position [(p2 (4, -1.75), scale 0.8 (text "offX"))]
+-- > oyArrow = arrowBetween (p2 (7,0)) (p2 (7,1))
+-- > oyLabel = position [(p2 (8, 0.5), scale 0.8 (text "offY"))]
+-- > line start end = fromVertices [p2 start, p2 end]
+-- > lines = mconcat
+-- > [ line (3,-1) (3,0)
+-- > , line (5,-1) (5,2)
+-- > , line (3,0) (7,0)
+-- > , line (5,1) (7,1)
+-- > ] # lc lightgray # dashingN [0.01,0.01] 0
+-- > in mconcat [c, oxArrow, oxLabel, oyArrow, oyLabel, lines] # pad 1.1
+
+-- | <>
+data Offsets =
+ Offsets { _offsetX :: Double
+ , _offsetY :: Double
+ } deriving (Show, Eq, Read)
+
+makeLenses ''Offsets
+
+instance Default Offsets where
+ def = Offsets 0.3 0.35
+
+-- | Draw the Rubik's cube in parallel perspective.
+--
+-- <>
+--
+-- > import Diagrams.RubiksCube
+-- > import Control.Lens
+-- > drawCubeExample =
+-- > let c = solvedRubiksCube ^. undoMoves [R,U,R',U']
+-- > in drawRubiksCube with c
+drawRubiksCube
+ :: Renderable (Path R2) b
+ => Offsets
+ -> RubiksCube (Colour Double)
+ -> Diagram b R2
+drawRubiksCube (Offsets dx dy) c' = position $
+ [ f ] ++
+ sides ++
+ [ b ]
+ where
+ sides = map snd $ sortBy (compare `on` fst) $
+ [ (-dx, r)
+ , (dx, l)
+ , (-dy, u)
+ , (dy, d)
+ ]
+ dx' = r2 (1,0)
+ dy' = r2 (0,1)
+ dz' = r2 (dx,dy)
+ drawSide' dx1 dx2 side = drawSide dx1 dx2 (c' ^. cube . side)
+ f = (p2 (0, 0), drawSide' dx' dy' frontSide)
+ b = (p2 (3*dx, 3+3*dy), drawSide' dx' (-dy') backSide)
+ r = (p2 (3,0), drawSide' dz' dy' rightSide)
+ l = (p2 (3*dx, 3*dy), drawSide' (-dz') dy' leftSide)
+ u = (p2 (0,3), drawSide' dx' dz' upSide)
+ d = (p2 (3*dx, 3*dy), drawSide' dx' (-dz') downSide)
+
+moveArrow
+ :: Renderable (Path R2) b
+ => Bool -> P2 -> P2 -> Diagram b R2
+moveArrow rev s e =
+ (if rev then arrowBetween' opts e s else arrowBetween' opts s e) # lc red
+ where opts = with & shaftStyle %~ lw ultraThick & headLength .~ veryLarge
+
+drawMoveU, drawMoveD, drawMoveL, drawMoveR, drawMoveF
+ :: Renderable (Path R2) b
+ => Bool -- ^ invert
+ -> Offsets
+ -> RubiksCube (Colour Double)
+ -> Diagram b R2
+drawMoveU rev off c =
+ atop (moveArrow rev (p2 (2.8, 2.5)) (p2 (0.2, 2.5)))
+ (drawRubiksCube off c)
+drawMoveD rev (Offsets dx dy) c =
+ atop (moveArrow rev (p2 (0.2, 0.5)) (p2 (2.8, 0.5)))
+ (drawRubiksCube (Offsets dx (-dy)) c)
+drawMoveL rev (Offsets dx dy) c =
+ atop (moveArrow rev (p2 (0.5, 2.8)) (p2 (0.5, 0.2)))
+ (drawRubiksCube (Offsets dx dy) c)
+drawMoveR rev off c =
+ atop (moveArrow rev (p2 (2.5, 0.2)) (p2 (2.5, 2.8)))
+ (drawRubiksCube off c)
+drawMoveF rev off c =
+ arr (opts & arrowShaft .~ quarterTurn) (p2 (1.5, 2.6)) (p2 (2.5, 1.3))
+ `atop`
+ arr (opts & arrowShaft .~ quarterTurn) (p2 (1.5, 0.4)) (p2 (0.5, 1.7))
+ `atop`
+ drawRubiksCube off c
+ where
+ quarterTurn = arc (0 @@ turn) (1/4 @@ turn) # (if rev then id else reverseTrail)
+ opts = with & shaftStyle %~ lw ultraThick & headLength .~ veryLarge
+ arr opts' s e = (if rev then arrowBetween' opts' e s else arrowBetween' opts' s e)
+ # lc red
+
+-- | Draw the Rubik's cube in parallel perspective with an arrow indicating the
+-- next move. If the the bottom layer is moved, the cube will be shown from below.
+--
+-- <>
+--
+-- > import Diagrams.RubiksCube
+-- > import Control.Lens
+-- > drawMoveExample =
+-- > let c = solvedRubiksCube ^. undoMoves [L,U,L',U']
+-- > in drawMove L with c
+drawMove
+ :: Renderable (Path R2) b
+ => Move
+ -> Offsets
+ -> RubiksCube (Colour Double)
+ -> Diagram b R2
+drawMove U = drawMoveU False
+drawMove U' = drawMoveU True
+drawMove D = drawMoveD False
+drawMove D' = drawMoveD True
+drawMove L = drawMoveL False
+drawMove L' = drawMoveL True
+drawMove R = drawMoveR False
+drawMove R' = drawMoveR True
+drawMove F = drawMoveF False
+drawMove F' = drawMoveF True
+drawMove _ = error "can't draw back moves!"
+
+data MovesSettings =
+ MovesSettings { _moveSep :: Double -- ^ space between cubes
+ , _showStart :: Bool -- ^ show the start configuration?
+ , _showEnd :: Bool -- ^ show the end configuration?
+ , _offsets :: Offsets
+ } deriving (Eq, Show, Read)
+
+makeLenses ''MovesSettings
+
+instance Default MovesSettings where
+ def = MovesSettings 1.75 False True def
+
+-- | Draws a sequence of moves.
+--
+-- <>
+--
+-- > import Diagrams.RubiksCube
+-- > import Control.Lens
+-- > drawMovesExample =
+-- > let moves = [R, F', R', D', F, F]
+-- > startPos = solvedRubiksCube ^. undoMoves moves
+-- > settings = with & showStart .~ True
+-- > in drawMoves settings startPos moves
+drawMoves
+ :: Renderable (Path R2) b
+ => MovesSettings
+ -> RubiksCube (Colour Double) -- ^ the start configuration
+ -> [Move]
+ -> Diagram b R2
+drawMoves settings c moves =
+ let ((j, c'), ps) = mapAccumL iter (0 :: Int, c) moves
+ allCubes = (if settings ^. showStart then ((pos ((-1) :: Int), drawRubiksCube off c) :) else id) $
+ (if settings ^. showEnd then ((pos j, drawRubiksCube off c') :) else id) ps
+ in position allCubes
+ where
+ off = settings ^. offsets
+ pos i = p2 (fromIntegral i * (3 + settings ^. moveSep), 0)
+ iter (i, c') m =
+ let c'' = c' ^. move m
+ in ((i+1, c''), (pos i, drawMove m off c'))
+
+-- | Like 'drawMoves', but takes the end configuration instead of the start
+-- configuration. The previous example can be simplified with this:
+--
+-- > import Diagrams.RubiksCube
+-- > import Control.Lens
+-- > drawMovesExample' =
+-- > let moves = [R, F', R', D', F, F]
+-- > endPos = solvedRubiksCube
+-- > settings = with & showStart .~ True
+-- > in drawMovesBackward settings endPos moves
+drawMovesBackward
+ :: Renderable (Path R2) b
+ => MovesSettings
+ -> RubiksCube (Colour Double) -- ^ the end configuration
+ -> [Move]
+ -> Diagram b R2
+drawMovesBackward settings c moves =
+ drawMoves settings (c ^. undoMoves moves) moves
diff --git a/src/Diagrams/RubiksCube/Model.hs b/src/Diagrams/RubiksCube/Model.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/RubiksCube/Model.hs
@@ -0,0 +1,416 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE Rank2Types #-}
+
+module Diagrams.RubiksCube.Model (
+ -- * Constructing cubes
+ Side (..)
+ , topLeft, topCenter, topRight
+ , middleLeft, middleCenter, middleRight
+ , bottomLeft, bottomCenter, bottomRight
+ , rotateSideCW, rotateSideCCW
+ , Cube (..), frontSide, backSide, leftSide, rightSide, upSide, downSide
+ , RubiksCube (..), cube
+ -- * Selecting rows and columns
+ , Vec3 (..)
+ , topRow, middleRow, bottomRow
+ , leftCol, centerCol, rightCol
+ -- * Traversing facets
+ -- ** By layer
+ , topLayerFacets, middleLayerFacets, bottomLayerFacets
+ -- ** By position
+ , centerFacets, cornerFacets, edgeFacets
+ -- * Rotating the whole cube
+ , Aut
+ , rotateLeft, rotateRight
+ , rotateDown, rotateUp
+ , rotateCW, rotateCCW
+ -- * Moving layers of the cube
+ , move, doMoves, undoMoves
+ ) where
+
+import Control.Lens
+import Diagrams.RubiksCube.Move (Move (..))
+import Data.Foldable (Foldable)
+import Control.Applicative (Applicative (..), (<$>))
+
+-- | The type of automorphisms
+type Aut a = Iso' a a
+
+-- | A list of fixed length 3.
+data Vec3 a = Vec3 a a a deriving (Show, Eq, Functor, Foldable, Traversable)
+
+instance Applicative Vec3 where
+ pure v = Vec3 v v v
+ Vec3 f1 f2 f3 <*> Vec3 v1 v2 v3 =
+ Vec3 (f1 v1) (f2 v2) (f3 v3)
+
+instance Reversing (Vec3 a) where
+ reversing (Vec3 a b c) = Vec3 c b a
+
+-- | A list of fixed length 4.
+data Vec4 a = Vec4 a a a a deriving (Show, Eq, Functor, Foldable, Traversable)
+
+instance Applicative Vec4 where
+ pure v = Vec4 v v v v
+ Vec4 f1 f2 f3 f4 <*> Vec4 v1 v2 v3 v4 =
+ Vec4 (f1 v1) (f2 v2) (f3 v3) (f4 v4)
+
+cycRight :: Vec4 a -> Vec4 a
+cycRight (Vec4 a b c d) = Vec4 d a b c
+
+cycLeft :: Vec4 a -> Vec4 a
+cycLeft (Vec4 a b c d) = Vec4 b c d a
+
+cycleLeft :: Aut (Vec4 a)
+cycleLeft = iso cycLeft cycRight
+
+cycleRight :: Aut (Vec4 a)
+cycleRight = iso cycRight cycLeft
+
+-- | One side of the Rubik's Cube with 3*3 facets.
+data Side a =
+ Side { _topLeft :: a
+ , _topCenter :: a
+ , _topRight :: a
+ , _middleLeft :: a
+ , _middleCenter :: a
+ , _middleRight :: a
+ , _bottomLeft :: a
+ , _bottomCenter :: a
+ , _bottomRight :: a
+ } deriving (Show, Eq, Functor, Foldable, Traversable)
+
+instance Applicative Side where
+ pure v = Side v v v v v v v v v
+ Side f1 f2 f3 f4 f5 f6 f7 f8 f9 <*> Side v1 v2 v3 v4 v5 v6 v7 v8 v9 =
+ Side (f1 v1) (f2 v2) (f3 v3) (f4 v4) (f5 v5) (f6 v6) (f7 v7) (f8 v8) (f9 v9)
+
+makeLenses ''Side
+
+instance Reversing (Side a) where
+ reversing (Side tl tc tr ml mc mr bl bc br) =
+ Side br bc bl mr mc ml tr tc tl
+
+rotCW :: Side a -> Side a
+rotCW (Side tl tc tr ml mc mr bl bc br) =
+ Side bl ml tl bc mc tc br mr tr
+
+rotCCW :: Side a -> Side a
+rotCCW (Side tl tc tr ml mc mr bl bc br) =
+ Side tr mr br tc mc bc tl ml bl
+
+-- | Rotate the side clockwise.
+rotateSideCW :: Aut (Side a)
+rotateSideCW = iso rotCW rotCCW
+
+-- | Rotate the side counter-clockwise.
+rotateSideCCW :: Aut (Side a)
+rotateSideCCW = iso rotCCW rotCW
+
+-- | The top three facets (from left to right).
+topRow :: Lens' (Side a) (Vec3 a)
+topRow = lens getter setter
+ where
+ getter (Side tl tc tr _ _ _ _ _ _) = Vec3 tl tc tr
+ setter (Side _ _ _ ml mc mr bl bc br) (Vec3 tl tc tr) =
+ Side tl tc tr ml mc mr bl bc br
+
+-- | The middle three facets (from left to right).
+middleRow :: Lens' (Side a) (Vec3 a)
+middleRow = lens getter setter
+ where
+ getter (Side _ _ _ ml mc mr _ _ _) = Vec3 ml mc mr
+ setter (Side tl tc tr _ _ _ bl bc br) (Vec3 ml mc mr) =
+ Side tl tc tr ml mc mr bl bc br
+
+-- | The bottom three facets (from left to right).
+bottomRow :: Lens' (Side a) (Vec3 a)
+bottomRow = lens getter setter
+ where
+ getter (Side _ _ _ _ _ _ bl bc br) = Vec3 bl bc br
+ setter (Side tl tc tr ml mc mr _ _ _) (Vec3 bl bc br) =
+ Side tl tc tr ml mc mr bl bc br
+
+-- | The left column (from top to down).
+leftCol :: Lens' (Side a) (Vec3 a)
+leftCol = lens getter setter
+ where
+ getter (Side tl _ _ ml _ _ bl _ _) = Vec3 tl ml bl
+ setter (Side _ tc tr _ mc mr _ bc br) (Vec3 tl ml bl) =
+ Side tl tc tr ml mc mr bl bc br
+
+-- | The center column (from top to down).
+centerCol :: Lens' (Side a) (Vec3 a)
+centerCol = lens getter setter
+ where
+ getter (Side _ tc _ _ mc _ _ bc _) = Vec3 tc mc bc
+ setter (Side tl _ tr ml _ mr bl _ br) (Vec3 tc mc bc) =
+ Side tl tc tr ml mc mr bl bc br
+
+-- | The right column (from top to down).
+rightCol :: Lens' (Side a) (Vec3 a)
+rightCol = lens getter setter
+ where
+ getter (Side _ _ tr _ _ mr _ _ br) = Vec3 tr mr br
+ setter (Side tl tc _ ml mc _ bl bc _) (Vec3 tr mr br) =
+ Side tl tc tr ml mc mr bl bc br
+
+-- | The four corners.
+sideCorners :: Traversal' (Side a) a
+sideCorners f (Side tl tc tr ml mc mr bl bc br) =
+ (\tl' tr' bl' br' -> Side tl' tc tr' ml mc mr bl' bc br')
+ <$> f tl <*> f tr <*> f bl <*> f br
+
+-- | The four edges.
+sideEdges :: Traversal' (Side a) a
+sideEdges f (Side tl tc tr ml mc mr bl bc br) =
+ (\tc' ml' mr' bc' -> Side tl tc' tr ml' mc mr' bl bc' br)
+ <$> f tc <*> f ml <*> f mr <*> f bc
+
+-- | A cube with six sides.
+--
+-- @
+-- +---+
+-- | u |
+-- +---+---+---+---+
+-- | l | f | r | b |
+-- +---+---+---+---+
+-- | d |
+-- +---+
+-- @
+data Cube a =
+ Cube { _frontSide :: a
+ , _backSide :: a
+ , _leftSide :: a
+ , _rightSide :: a
+ , _upSide :: a
+ , _downSide :: a
+ } deriving (Show, Eq, Functor, Foldable, Traversable)
+
+instance Applicative Cube where
+ pure v = Cube v v v v v v
+ Cube ff fb fl fr fu fd <*> Cube vf vb vl vr vu vd =
+ Cube (ff vf) (fb vb) (fl vl) (fr vr) (fu vu) (fd vd)
+
+rotRight' :: Cube a -> Cube a
+rotRight' (Cube f b l r u d) = Cube l r b f u d
+
+rotLeft' :: Cube a -> Cube a
+rotLeft' (Cube f b l r u d) = Cube r l f b u d
+
+rotateRight' :: Aut (Cube a)
+rotateRight' = iso rotRight' rotLeft'
+
+_rotateLeft' :: Aut (Cube a)
+_rotateLeft' = from rotateRight'
+
+rotDown' :: Reversing a => Cube a -> Cube a
+rotDown' (Cube f b l r u d) = Cube u (reversing d) l r (reversing b) f
+
+rotUp' :: Reversing a => Cube a -> Cube a
+rotUp' (Cube f b l r u d) = Cube d (reversing u) l r f (reversing b)
+
+rotateDown' :: Reversing a => Aut (Cube a)
+rotateDown' = iso rotDown' rotUp'
+
+_rotateUp' :: Reversing a => Aut (Cube a)
+_rotateUp' = from rotateDown'
+
+makeLenses ''Cube
+
+-- | A normal Rubik's cube with 6 sides with 9 facets each.
+newtype RubiksCube a =
+ RubiksCube { _cube :: Cube (Side a)
+ } deriving (Show, Eq, Functor)
+
+instance Applicative RubiksCube where
+ pure = RubiksCube . pure . pure
+ RubiksCube f <*> RubiksCube v = RubiksCube ((<*>) <$> f <*> v)
+
+makeLenses ''RubiksCube
+
+cong :: Traversal' s a -> Aut a -> Aut s
+cong t i = withIso i $ \f g -> iso (over t f) (over t g)
+
+-- | Rotate the whole Rubik's Cube such that the front side becomes the new
+-- right side and the top and bottom sides stay fixed.
+rotateRight :: Aut (RubiksCube a)
+rotateRight =
+ cong cube $ rotateRight'
+ . cong upSide rotateSideCCW
+ . cong downSide rotateSideCW
+
+-- | Rotate the whole Rubik's Cube such that the front side becomes the new
+-- left side and the top and bottom sides stay fixed.
+rotateLeft :: Aut (RubiksCube a)
+rotateLeft = from rotateRight
+
+-- | Rotate the whole Rubik's Cube such that the front side becomes the new
+-- bottom side and the left and right sides stay fixed.
+rotateDown :: Aut (RubiksCube a)
+rotateDown =
+ cong cube $ rotateDown'
+ . cong leftSide rotateSideCW
+ . cong rightSide rotateSideCCW
+
+-- | Rotate the whole Rubik's Cube such that the front side becomes the new
+-- top side and the left and right sides stay fixed.
+rotateUp :: Aut (RubiksCube a)
+rotateUp = from rotateDown
+
+-- | Rotate the whole Rubik's Cube such that the top side becomes the new
+-- right side and the front and back sides stay fixed.
+rotateCW :: Aut (RubiksCube a)
+rotateCW = rotateUp . rotateLeft . rotateDown
+
+-- | Rotate the whole Rubik's Cube such that the top side becomes the new
+-- left side and the front and back sides stay fixed.
+rotateCCW :: Aut (RubiksCube a)
+rotateCCW = from rotateCW
+
+type RowsLens a = Lens' (Cube (Side a)) (Vec4 (Vec3 a))
+type ColsLens a = Lens' (Cube (Side a)) (Vec4 (Vec3 a))
+
+horizontalRows :: Lens' (Side a) (Vec3 a) -> RowsLens a
+horizontalRows rowLens = lens getter setter
+ where
+ getter (Cube f b l r _u _d) =
+ fmap (view rowLens) (Vec4 f r b l)
+ setter (Cube f b l r u d) (Vec4 f' r' b' l') =
+ Cube (set rowLens f' f) (set rowLens b' b)
+ (set rowLens l' l) (set rowLens r' r) u d
+
+upRows :: RowsLens a
+upRows = horizontalRows topRow
+
+middleRows :: RowsLens a
+middleRows = horizontalRows middleRow
+
+downRows :: RowsLens a
+downRows = horizontalRows bottomRow
+
+moveU :: Aut (RubiksCube a)
+moveU =
+ cong cube $ cong upRows cycleLeft
+ . cong upSide rotateSideCW
+
+moveD :: Aut (RubiksCube a)
+moveD =
+ cong cube $ cong downRows cycleRight
+ . cong downSide rotateSideCW
+
+verticalCols :: Lens' (Side a) (Vec3 a) -> ColsLens a
+verticalCols colLens = lens getter setter
+ where
+ getter (Cube f b _l _r u d) =
+ Vec4 (f ^. colLens) (u ^. colLens) (b ^. reversed . colLens) (d ^. colLens)
+ setter (Cube f b l r u d) (Vec4 f' u' b' d') =
+ Cube (set colLens f' f) (set (reversed . colLens) b' b) l r
+ (set colLens u' u) (set colLens d' d)
+
+leftCols :: ColsLens a
+leftCols = verticalCols leftCol
+
+_centerCols :: ColsLens a
+_centerCols = verticalCols centerCol
+
+rightCols :: ColsLens a
+rightCols = verticalCols rightCol
+
+moveL :: Aut (RubiksCube a)
+moveL =
+ cong cube $ cong leftCols cycleLeft
+ . cong leftSide rotateSideCW
+
+moveR :: Aut (RubiksCube a)
+moveR =
+ cong cube $ cong rightCols cycleRight
+ . cong rightSide rotateSideCW
+
+ringCols :: Lens' (Side a) (Vec3 a) -> ColsLens a
+ringCols colLens = lens getter setter
+ where
+ getter (Cube _f _b l r u d) =
+ Vec4 (r ^. colLens) (u ^. rotateSideCW . colLens)
+ (l ^. reversed . colLens) (d ^. rotateSideCCW . colLens)
+ setter (Cube f b l r u d) (Vec4 r' u' l' d') =
+ Cube f b (set (reversed . colLens) l' l) (set colLens r' r)
+ (set (rotateSideCW . colLens) u' u) (set (rotateSideCCW . colLens) d' d)
+
+frontCols :: ColsLens a
+frontCols = ringCols leftCol
+
+_betweenCols :: ColsLens a
+_betweenCols = ringCols centerCol
+
+backCols :: ColsLens a
+backCols = ringCols rightCol
+
+moveF :: Aut (RubiksCube a)
+moveF =
+ cong cube $ cong frontCols cycleLeft
+ . cong frontSide rotateSideCW
+
+moveB :: Aut (RubiksCube a)
+moveB =
+ cong cube $ cong backCols cycleRight
+ . cong backSide rotateSideCW
+
+-- | Perform a move.
+move :: Move -> Aut (RubiksCube a)
+move D = moveD
+move D' = from moveD
+move U = moveU
+move U' = from moveU
+move L = moveL
+move L' = from moveL
+move R = moveR
+move R' = from moveR
+move F = moveF
+move F' = from moveF
+move B = moveB
+move B' = from moveB
+
+-- | Perform a list of moves.
+doMoves :: [Move] -> Aut (RubiksCube a)
+doMoves [] = iso id id
+doMoves (m:ms) = move m . doMoves ms
+
+-- | Undo the actions of a list of moves.
+undoMoves :: [Move] -> Aut (RubiksCube a)
+undoMoves = from . doMoves
+
+-- | The 21=4*3+9 facets in the top layer.
+topLayerFacets :: Traversal' (RubiksCube a) a
+topLayerFacets f =
+ cube $ \c ->
+ (\upSide' upRows' -> c & upSide .~ upSide' & upRows .~ upRows')
+ <$> (traverse f (c ^. upSide))
+ <*> (traverse (traverse f) (c ^. upRows))
+
+-- | The 12=4*3 facets in the middle layer.
+middleLayerFacets :: Traversal' (RubiksCube a) a
+middleLayerFacets = cube.middleRows.traverse.traverse
+
+-- | The 21=4*3+9 facets in the bottom layer.
+bottomLayerFacets :: Traversal' (RubiksCube a) a
+bottomLayerFacets f =
+ cube $ \c ->
+ (\downSide' downRows' -> c & downSide .~ downSide' & downRows .~ downRows')
+ <$> (traverse f (c ^. downSide))
+ <*> (traverse (traverse f) (c ^. downRows))
+
+-- | The six facets that are the center of their side.
+centerFacets :: Traversal' (RubiksCube a) a
+centerFacets = cube.traverse.middleCenter
+
+-- | The 24=6*4=8*3 corner facets.
+cornerFacets :: Traversal' (RubiksCube a) a
+cornerFacets = cube.traverse.sideCorners
+
+-- | The 24=6*4=12*2 edge facets.
+edgeFacets :: Traversal' (RubiksCube a) a
+edgeFacets = cube.traverse.sideEdges
diff --git a/src/Diagrams/RubiksCube/Move.hs b/src/Diagrams/RubiksCube/Move.hs
new file mode 100644
--- /dev/null
+++ b/src/Diagrams/RubiksCube/Move.hs
@@ -0,0 +1,39 @@
+module Diagrams.RubiksCube.Move
+ ( Move (..)
+ , mirror
+ , invert
+ ) where
+
+-- | A move in .
+data Move = D | D' | U | U' | L | L' | R | R' | F | F' | B | B'
+ deriving (Eq, Show, Read)
+
+-- | The opposite move.
+invert :: Move -> Move
+invert D = D'
+invert D' = D
+invert U = U'
+invert U' = U
+invert L = L'
+invert L' = L
+invert R = R'
+invert R' = R
+invert F = F'
+invert F' = F
+invert B = B'
+invert B' = B
+
+-- | Swaps left and right.
+mirror :: Move -> Move
+mirror D = D'
+mirror D' = D
+mirror U = U'
+mirror U' = U
+mirror L = R'
+mirror L' = R
+mirror R = L'
+mirror R' = L
+mirror F = F'
+mirror F' = F
+mirror B = B'
+mirror B' = B