Puzzle Pong - Irreversible Cube I
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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