Puzzle Pong - Irreversible Cube I

irrev-cube.hs

import Codec.Picture( PixelRGBA8( .. ), writePng, Image)                                                  
import Control.Arrow (first,second)                                                                       
import Data.Function (on)                                                                                 
import Data.List (sort, nub, sortBy, groupBy, nubBy, delete, zip4, (\\), zipWith4)                        
import Data.List.Split (chunksOf)                                                                         
import Data.Monoid ((<>))                                                                                 
import Data.Ord (comparing)                                                                               
import Debug.Trace (trace)                                                                                
import Graphics.Rasterific                                                                                
import Graphics.Rasterific.Texture (uniformTexture)                                                       
import Graphics.Rasterific.Transformations (translate, skewX, skewY, rotate, scale)                       
import qualified Data.Map.Strict as M                                                                     
--------------------------------------                                                                    
data Side  = F | B | U | D | L | R deriving (Eq, Bounded, Show, Enum, Ord)                                
data Axis = X | Y | Z                                                                                     
data Cardinality = Pos | Neg                                                                              
type Rotation = (Coord -> Coord)                                                                          
type Coord = [Int]                                                                                        
type Tile  = Coord                                                                                        
type Cube  = [Tile]                                                                                       
                                                                                                          
kolors :: [PixelRGBA8]                                                                                    
kolors =  [ PixelRGBA8 255 x 0 255 | x <- [000,050,100,150] ] -- reds                                     
       ++ [ PixelRGBA8 x 0 128 255 | x <- [000,050,100,128] ] -- purples                                  
       ++ [ PixelRGBA8 0 x 255 255 | x <- [000,050,100,128] ] -- cyans                                    
       ++ [ PixelRGBA8 x 255 0 255 | x <- [150,170,190,210] ] -- greens                                   
       ++ [ PixelRGBA8 255 0 x 255 | x <- [255,200,150,100] ] -- pinks                                    
       ++ [ PixelRGBA8 x  x  x 255 | x <- [100,125,150,175] ] -- greys                                    
                                                                                                          
solvedCube :: Cube                                                                                        
solvedCube =  [ [ a, b, 2] | a <- [1,-1], b <- [1,-1] ] -- F                                              
           ++ [ [ a, b,-2] | a <- [1,-1], b <- [1,-1] ] -- B                                              
           ++ [ [ a, 2, b] | a <- [1,-1], b <- [1,-1] ] -- R                                              
           ++ [ [ a,-2, b] | a <- [1,-1], b <- [1,-1] ] -- L                                              
           ++ [ [ 2, a, b] | a <- [1,-1], b <- [1,-1] ] -- U                                              
           ++ [ [-2, a, b] | a <- [1,-1], b <- [1,-1] ] -- D                                             
                                                                                                          
mkRot :: Cardinality -> Axis -> Rotation                                                                  
mkRot Pos X = \[x,y,z] -> [x,-z,y]; mkRot Neg X = \[x,y,z] -> [x,z,-y];                                   
mkRot Pos Y = \[x,y,z] -> [z,y,-x]; mkRot Neg Y = \[x,y,z] -> [-z,y,x];                                   
mkRot Pos Z = \[x,y,z] -> [-y,x,z]; mkRot Neg Z = \[x,y,z] -> [y,-x,z];                                   
                                                                                                          
pivot :: Cardinality -> Axis -> Cube -> Cube                                                              
pivot r a = map (mkRot r a)                                                                               
resolve :: Cube -> Cube                                                                                   
resolve c = resolve' $ head c                                                                             
  where resolve' [ 1, 1, 2] = c                                                                           
        resolve' [ _, _, 2] = resolve $ pivot Pos Z c                                                     
        resolve' [ _, _,-2] = resolve $ pivot Pos X $ pivot Pos X c                                       
        resolve' [ _, 2, _] = resolve $ pivot Pos X c                                                     
        resolve' [ _,-2, _] = resolve $ pivot Neg X c                                                     
        resolve' [ 2, _, _] = resolve $ pivot Neg Y c                                                     
        resolve' [-2, _, _] = resolve $ pivot Pos Y c                                                     
                                                                                                          
twist :: Side -> Cube -> Cube                                                                             
twist side = resolve . map (\x -> if side `sees` x then rotate' x else x)                                 
  where rotate' = s2Rot side                                                                              
                                                                                                          
        sees :: Side -> (Coord -> Bool)                                                                   
        (sees) F = (>0) . (!!0); (sees) R = (>0) . (!!1); (sees) U = (>0) . (!!2);                        
        (sees) B = (<0) . (!!0); (sees) L = (<0) . (!!1); (sees) D = (<0) . (!!2);                        
                                                                                                          
        s2Rot :: Side -> Rotation                                                                         
        s2Rot F = mkRot Pos X; s2Rot B = mkRot Neg X;                                                     
        s2Rot R = mkRot Pos Y; s2Rot L = mkRot Neg Y;                                                     
        s2Rot U = mkRot Pos Z; s2Rot D = mkRot Neg Z;                                                     
                                                                                                          
solved :: Cube -> Bool                                                                                    
solved = (== solvedCube)                                                                                  
                                                                                                          
seed :: [(Cube, [Side])]                                                                                  
seed =  [ (twist U solvedCube, [U]) ]                                                                     
                                                                                                          
kids :: (Cube, [Side]) -> [(Cube, [Side])]                                                                
kids (c, h:hs) = [ (twist dir c, dir:h:hs) | dir <- delete h [R,F,U] ]                                    

drawCube :: Cube -> Image PixelRGBA8                                                                      
drawCube c = renderDrawing 600 600 (PixelRGBA8 255 255 255 255)                                           
           $ mapM_ (uncurry drawTile)                                                                     
           $ sortBy (comparing $ sum . fst)                                                               
           $ zip c kolors                                                                                 
                                                                                                          
drawTile :: Tile -> PixelRGBA8 -> Drawing PixelRGBA8 ()                                                   
drawTile crd clr = withTransformation (center<>resize<>move0<>turn<>skew<>move1)                          
                 $ withTexture        (uniformTexture clr)                                                
                 $ fill $ rectangle (V2 0 0) 100 100                                                      
  where [x ,y ,z ] = crd                                                                                  
        [x',y',z'] = [fromIntegral x, fromIntegral y, fromIntegral z]                                     
        center              = translate (V2 300 300)                                                      
        resize | abs z == 2 = scale 1.0 1.0                                                               
               | otherwise  = scale 0.9 0.9                                                               
        move0  | x ==   2   = translate (V2 (-250)    50 ) --F                                            
               | x ==  -2   = translate (V2   150  (-200)) --B                                            
               | y ==   2   = translate (V2   150    120 ) --R                                            
               | y ==  -2   = translate (V2 (-250) (-140)) --L                                            
               | z ==   2   = translate (V2     0  (-230)) --U                                            
               | z ==  -2   = translate (V2     0    120 ) --D                                            
               | otherwise  = translate (V2     0      0 )                                                
        turn   | abs z == 2 = rotate 0.7853                                                               
               | otherwise  = rotate 0                                                                    
        skew   | abs z == 2 = skewX (-0.2) <> skewY (-0.2)                                                
               | abs y == 2 =                 skewY (-0.6)                                                
               | abs x == 2 =                 skewY   0.6                                                 
               | otherwise  = skewX 0                                                                     
        move1  | abs z == 2 = translate (V2 ( 50*y') ( 50*x'))                                            
               | abs y == 2 = translate (V2 (-50*x') (-50*z'))                                            
               | abs x == 2 = translate (V2 ( 50*y') (-50*z'))                                            
               | otherwise  = translate (V2    0        0    )                                            
                                                                                                          
main = do                                                                                                                                                                                                           
   let seq = snd $ head $ filter (solved.fst)                                                             
           $ concat $ iterate (concatMap kids) seed                                                       
   mapM_ ( \(n,c) -> writePng ("frame" ++ show n ++ ".png")                                               
                   $ drawCube $ resolve c                                                                 
         ) $ zip [10..] $ scanr twist solvedCube seq