Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Puzzle Pong - Irreversible Cube II
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.