Skip to content

Instantly share code, notes, and snippets.

@ambuc

ambuc/irrev-cube.hs

Created August 24, 2017 22:49
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save ambuc/84fca250c25f72b46a16dd28eb653708 to your computer and use it in GitHub Desktop.
Save ambuc/84fca250c25f72b46a16dd28eb653708 to your computer and use it in GitHub Desktop.
Download ZIP
Puzzle Pong - Irreversible Cube I
Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment