/irrev-cube.hs
Created Aug 24, 2017
Puzzle Pong - Irreversible Cube I
| 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment