module Diagrams.RubiksCube.Draw
( RubiksCubeBackend
, 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, cube)
import Diagrams.TwoD.Arrow (arrowFromLocatedTrail')
import Diagrams.Trail (trailPoints)
import Data.List (sortBy, mapAccumL)
import Data.Function (on)
import qualified Diagrams.Prelude as P
type RubiksCubeBackend n b = (Renderable (Path V2 n) b, TypeableFloat n, N b ~ n, V b ~ V2)
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
drawSide
:: RubiksCubeBackend n b
=> V2 n
-> V2 n
-> Side (Colour Double)
-> Diagram b
drawSide (dx :: V2 n) 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 :: Int -> Int -> Point V2 n
pos x y = P $ fromIntegral x *^ dx ^+^ fromIntegral y *^ dy
drawField
:: (Renderable (Path V2 n) b, N b ~ n, V b ~ V2)
=> Int -> Int -> Colour Double -> Diagram b
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
drawFoldingPattern
:: RubiksCubeBackend n b
=> RubiksCube (Colour Double)
-> Diagram b
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)
]
data Offsets n =
Offsets { _offsetX :: n
, _offsetY :: n
} deriving (Show, Eq, Read)
makeLenses ''Offsets
instance Fractional n => Default (Offsets n) where
def = Offsets 0.3 0.35
drawRubiksCube
:: RubiksCubeBackend n b
=> Offsets n
-> RubiksCube (Colour Double)
-> Diagram b
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
:: RubiksCubeBackend n b
=> Bool -> [P2 n] -> Diagram b
moveArrow rev points =
lc red $ arrowFromLocatedTrail' opts $ fromVertices $
if rev then reverse points else points
where opts = with & shaftStyle %~ lw ultraThick
& headLength .~ veryLarge
& tailLength .~ veryLarge
& arrowTail .~ lineTail
drawMoveU, drawMoveD, drawMoveL, drawMoveR, drawMoveF, drawMoveB
:: RubiksCubeBackend n b
=> Bool
-> Offsets n
-> RubiksCube (Colour Double)
-> Diagram b
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 off c =
atop (moveArrow rev [p2 (0.5, 2.8), p2 (0.5, 0.2)])
(drawRubiksCube off 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 xDir (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
drawMoveB rev off@(Offsets dx dy) c =
moveArrow rev (trailPoints arrowTrail)
`atop`
drawRubiksCube off c
where backOff = p2 (3.3 + 3 * dx, 0.2 + 3 * dy)
arrowOffsets = [(0 ^& 3.1), ((3.1) ^& 0)]
arrowTrail = P.at (fromOffsets arrowOffsets) backOff
drawMove
:: RubiksCubeBackend n b
=> Move
-> Offsets n
-> RubiksCube (Colour Double)
-> Diagram b
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 B = drawMoveB False
drawMove B' = drawMoveB True
data MovesSettings n =
MovesSettings { _moveSep :: n
, _showStart :: Bool
, _showEnd :: Bool
, _offsets :: Offsets n
} deriving (Eq, Show, Read)
makeLenses ''MovesSettings
instance Fractional n => Default (MovesSettings n) where
def = MovesSettings 1.75 False True def
drawMoves
:: RubiksCubeBackend n b
=> MovesSettings n
-> RubiksCube (Colour Double)
-> [Move]
-> Diagram b
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'))
drawMovesBackward
:: RubiksCubeBackend n b
=> MovesSettings n
-> RubiksCube (Colour Double)
-> [Move]
-> Diagram b
drawMovesBackward settings c moves =
drawMoves settings (c ^. undoMoves moves) moves