Puzzle Pong - Irreversible Cube II

irrev-cube-2.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, zip3, zip4, (\\))
import Data.List.Split (chunksOf)
import Data.Monoid ((<>))
import Data.Ord (comparing)
import Text.Printf
import Debug.Trace (trace)
import Cornea (Obj (..), World, mark, seenFrom, solid, render, isometric)
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 deriving (Eq, Show)
data Cardinality = Pos | Neg deriving (Eq, Show)
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 c a = map (\x -> round x :: Int) . rotate (toAngle c) a . map fromIntegral

s2Rot :: Side -> Rotation
s2Rot = uncurry mkRot . s2CA

s2CA :: Side -> (Cardinality, Axis)
s2CA F = (Pos, X); s2CA B = (Neg, X);
s2CA R = (Pos, Y); s2CA L = (Neg, Y);
s2CA U = (Pos, Z); s2CA D = (Neg, Z);

rotate :: Float -> Axis -> [Float] -> [Float]
rotate t X [x,y,z] = [x, cos t * y - sin t * z, sin t * y + cos t * z]
rotate t Y [x,y,z] = [cos t * x + sin t * z, y, -sin t * x + cos t * z]
rotate t Z [x,y,z] = [cos t * x - sin t * y, sin t * x + cos t * y, z]

rotateFace :: Float -> Axis -> Obj -> Obj
rotateFace t a (Face pts) = Face (map (rotate t a) pts)

toAngle :: Cardinality -> Float
toAngle Pos =  pi/2
toAngle Neg = -pi/2

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 = map (\x -> if side `sees` x then s2Rot side x else x)

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

solved :: Cube -> Bool
solved = (== solvedCube)

seed :: [(Cube, [Side])]
seed =  [ (resolve $ twist U solvedCube, [U]) ]

kids :: (Cube, [Side]) -> [(Cube, [Side])]
kids (c, h:hs) = [ (resolve $ twist dir c, dir:h:hs) | dir <- delete h [R,F,U] ]

tween :: Int -> Side -> Cube -> [[Obj]]
tween num side cube = map (`swivel` cube) angles
  where (cardinality, axis) = s2CA side
        angles = map (* toAngle cardinality) $ init
               $ map (/ fromIntegral num) [0..(fromIntegral num)]
        swivel :: Float -> Cube -> [Obj]
        swivel ang = map (\t -> if side `sees` t
                                      then rotateFace ang axis $ toTile t
                                      else toTile t
                             )

toTile :: [Int] -> Obj
toTile [x,y,z] = p2t' [fromIntegral x, fromIntegral y, fromIntegral z]
  where p2t' [ x, y, 2] = Face [ [x+a, y+b,  n] | (a,b) <- rg ]
        p2t' [ x, y,-2] = Face [ [x+a, y+b, -n] | (a,b) <- rg ]
        p2t' [ x, 2, z] = Face [ [x+a,  n, z+b] | (a,b) <- rg ]
        p2t' [ x,-2, z] = Face [ [x+a, -n, z+b] | (a,b) <- rg ]
        p2t' [ 2, y, z] = Face [ [ n, y+a, z+b] | (a,b) <- rg ]
        p2t' [-2, y, z] = Face [ [-n, y+a, z+b] | (a,b) <- rg ]
        rg :: Num a => [(a,a)]
        rg = [(1,1),(1,-1),(-1,-1),(-1,1)] --range
        n = 5 --offset

toImage :: [Obj] -> (Float, Float) -> Image PixelRGBA8
toImage cs v = render 500 500 40 $ world `seenFrom` v
  where world = map (second solid) $ zip cs kolors

animate :: [[Obj]] -> [(Float,Float)] -> [String] -> IO ()
animate cs vs fs = mapM_ (\(c,v,f) -> writePng f $ toImage c v)
                    $ zip3 cs vs fs

moves = reverse $ snd $ head $ filter (solved.fst) $ concat
      $ iterate (concatMap kids) seed

mkFrames r = concatMap (uncurry $ tween r)
       $ zip (reverse moves) (reverse $ scanr twist solvedCube moves)

mkWobble :: Int -> [(Float,Float)]
mkWobble n = zip ps ys
  where ys  = take n [0, (360 / fromIntegral n).. ]
        ps  = [ p x | x <- [0..n] ]
        p x = 20 * sin( 2 * 2 * pi * fromIntegral x / fromIntegral n) + 40

main = do
   let rate      = 20
   let frames    = mkFrames rate
   let views     = mkWobble $ length frames
   let filenames = map (\i -> "/tmp/frame" ++ show i ++ ".png") [100000..]
   animate (mkFrames rate) views filenames