Skip to content

Instantly share code, notes, and snippets.

@ambuc
Created September 2, 2017 15:03
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