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