module Diagrams.TwoD.Tilings (
Q236, rt2, rt3, rt6
, toDouble
, Q2, toR2, toP2
, TilingPoly(..)
, polySides, polyFromSides
, polyCos, polySin
, polyRotation, polyExtRotation
, Tiling(..)
, Edge, mkEdge
, Polygon(..)
, TilingState(..), initTilingState
, TilingM
, generateTiling
, t3, t4, t6
, mk3Tiling, t4612, t488, t31212
, t3636
, semiregular
, rot
, t3464, t33434, t33344, t33336L, t33336R
, drawEdge
, drawPoly
, polyColor
, drawTiling
, drawTilingStyled
) where
import Control.Monad.State
#if __GLASGOW_HASKELL__ >= 704
import Control.Monad.Writer hiding ((<>))
#else
import Control.Monad.Writer
#endif
import Data.List (mapAccumL, sort)
import Data.Function (on)
import Data.VectorSpace
import Control.Arrow
import qualified Data.Set as S
import qualified Data.Foldable as F
import Data.Colour
import Diagrams.Prelude hiding (e)
data Q236 = Q236 Rational Rational Rational Rational
deriving (Eq, Ord, Show, Read)
toDouble :: Q236 -> Double
toDouble (Q236 a b c d) = fromRational a
+ fromRational b * sqrt 2
+ fromRational c * sqrt 3
+ fromRational d * sqrt 6
rt2, rt3, rt6 :: Q236
rt2 = Q236 0 1 0 0
rt3 = Q236 0 0 1 0
rt6 = rt2*rt3
instance Num Q236 where
(+) = (^+^)
() = (^-^)
(Q236 a1 b1 c1 d1) * (Q236 a2 b2 c2 d2) =
Q236 (a1*a2 + 2*b1*b2 + 3*c1*c2 + 6*d1*d2)
(a1*b2 + b1*a2 + 3*c1*d2 + 3*d1*c2)
(a1*c2 + 2*b1*d2 + c1*a2 + 2*d1*b2)
(a1*d2 + b1*c2 + c1*b2 + d1*a2)
abs (Q236 a b c d) = Q236 (abs a) (abs b) (abs c) (abs d)
fromInteger z = Q236 (fromInteger z) 0 0 0
signum = error "no signum for Q236"
instance AdditiveGroup Q236 where
zeroV = Q236 0 0 0 0
(Q236 a1 b1 c1 d1) ^+^ (Q236 a2 b2 c2 d2)
= Q236 (a1 + a2) (b1 + b2) (c1 + c2) (d1 + d2)
negateV (Q236 a b c d) = Q236 (a) (b) (c) (d)
instance VectorSpace Q236 where
type Scalar Q236 = Rational
s *^ (Q236 a b c d) = Q236 (s * a) (s * b) (s * c) (s * d)
type Q2 = (Q236, Q236)
toR2 :: Q2 -> R2
toR2 = r2 . (toDouble *** toDouble)
toP2 :: Q2 -> P2
toP2 = p2 . (toDouble *** toDouble)
data TilingPoly = Triangle | Square | Hexagon | Octagon | Dodecagon
deriving (Eq, Ord, Show, Read, Enum, Bounded)
polySides :: Num a => TilingPoly -> a
polySides Triangle = 3
polySides Square = 4
polySides Hexagon = 6
polySides Octagon = 8
polySides Dodecagon = 12
polyFromSides :: (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides 3 = Triangle
polyFromSides 4 = Square
polyFromSides 6 = Hexagon
polyFromSides 8 = Octagon
polyFromSides 12 = Dodecagon
polyFromSides n = error $ "Bad polygon number: " ++ show n
polyCos :: TilingPoly -> Q236
polyCos Triangle = (1/2) *^ 1
polyCos Square = 0
polyCos Hexagon = (1/2) *^ 1
polyCos Octagon = (1/2) *^ rt2
polyCos Dodecagon = (1/2) *^ rt3
polySin :: TilingPoly -> Q236
polySin Triangle = (1/2) *^ rt3
polySin Square = 1
polySin Hexagon = (1/2) *^ rt3
polySin Octagon = (1/2) *^ rt2
polySin Dodecagon = (1/2) *^ 1
polyRotation :: TilingPoly -> Q2 -> Q2
polyRotation p (x,y) = (x*c y*s, x*s + y*c)
where c = polyCos p
s = polySin p
polyExtRotation :: TilingPoly -> Q2 -> Q2
polyExtRotation p (x,y) = (x*c y*s, x*s y*c)
where c = polyCos p
s = polySin p
data Tiling = Tiling { curConfig :: [TilingPoly]
, follow :: Int -> Tiling
}
data Edge = Edge Q2 Q2
deriving (Eq, Ord, Show)
mkEdge :: Q2 -> Q2 -> Edge
mkEdge v1 v2 | v1 <= v2 = Edge v1 v2
| otherwise = Edge v2 v1
newtype Polygon = Polygon { polygonVertices :: [Q2] }
deriving Show
instance Eq Polygon where
(Polygon vs1) == (Polygon vs2) = sort vs1 == sort vs2
instance Ord Polygon where
compare = compare `on` (sort . polygonVertices)
data TilingState = TP { visitedVertices :: (S.Set Q2)
, visitedEdges :: (S.Set Edge)
, visitedPolygons :: (S.Set Polygon)
}
initTilingState :: TilingState
initTilingState = TP S.empty S.empty S.empty
type TilingM w a = WriterT w (State TilingState) a
generateTiling :: forall w. Monoid w
=> Tiling
-> Q2
-> Q2
-> (Q2 -> Bool)
-> (Edge -> w)
-> (Polygon -> w)
-> w
generateTiling t v d vPred e p
= evalState (execWriterT (generateTiling' t v d)) initTilingState where
generateTiling' :: Tiling -> Q2 -> Q2 -> TilingM w ()
generateTiling' t v d
| not (vPred v) = return ()
| otherwise = do
ts <- get
when (v `S.notMember` visitedVertices ts) $ do
modify (\ts -> ts { visitedVertices = v `S.insert` visitedVertices ts })
let (neighbors, polys) = genNeighbors t v d
edges = S.fromList $ map (mkEdge v) neighbors
edges' = edges `S.difference` visitedEdges ts
polys' = polys `S.difference` visitedPolygons ts
F.mapM_ (tell . e) edges'
F.mapM_ (tell . p) polys'
modify (\ts -> ts { visitedEdges = edges' `S.union` visitedEdges ts })
modify (\ts -> ts { visitedPolygons = polys' `S.union` visitedPolygons ts })
zipWithM_ (\d i -> generateTiling' (follow t i) (v ^+^ d) d)
(map (^-^ v) $ neighbors) [0..]
genNeighbors :: Tiling -> Q2 -> Q2 -> ([Q2], S.Set Polygon)
genNeighbors t v d = (neighbors, S.fromList polys) where
(neighbors, polys)
= unzip . snd
$ mapAccumL
(\d' poly -> (polyRotation poly d', (v ^+^ d', genPolyVs poly v d')))
(negateV d)
(curConfig t)
genPolyVs :: TilingPoly
-> Q2
-> Q2
-> Polygon
genPolyVs p v d = Polygon
. scanl (^+^) v
. take (polySides p 1)
. iterate (polyExtRotation p)
$ d
drawEdge :: Renderable (Path R2) b => Style R2 -> Edge -> Diagram b R2
drawEdge s (Edge v1 v2) = (toP2 v1 ~~ toP2 v2) # applyStyle s
drawPoly :: Renderable (Path R2) b => (Polygon -> Style R2) -> Polygon -> Diagram b R2
drawPoly s p = applyStyle (s p) . fromVertices . map toP2 . polygonVertices $ p
polyColor :: (Floating a, Ord a) => TilingPoly -> Colour a
polyColor Triangle = yellow
polyColor Square = mediumseagreen
polyColor Hexagon = blueviolet
polyColor Octagon = lightsteelblue
polyColor Dodecagon = cornflowerblue
drawTiling :: (Renderable (Path R2) b, Backend b R2)
=> Tiling -> Double -> Double -> Diagram b R2
drawTiling =
drawTilingStyled
(mempty # lw 0.02)
(\p -> mempty
# lw 0
# fc ( polyColor
. polyFromSides
. length
. polygonVertices
$ p
)
)
drawTilingStyled :: (Renderable (Path R2) b, Backend b R2)
=> Style R2 -> (Polygon -> Style R2)
-> Tiling -> Double -> Double -> Diagram b R2
drawTilingStyled eStyle pStyle t w h =
mkDia $ generateTiling t (0,0) (1,0) inRect
(liftA2 (,) (drawEdge eStyle) mempty)
(liftA2 (,) mempty (drawPoly pStyle))
where
inRect ((unr2 . toR2) -> (x,y)) = w/2 <= x && x <= w/2 && h/2 <= y && y <= h/2
mkDia (es, ps) = viewRect (es <> ps)
viewRect = withEnvelope (rect w h :: D R2)
t3 :: Tiling
t3 = Tiling (replicate 6 Triangle) (const t3)
t4 :: Tiling
t4 = Tiling (replicate 4 Square) (const t4)
t6 :: Tiling
t6 = Tiling (replicate 3 Hexagon) (const t6)
mk3Tiling :: [Int] -> Tiling
mk3Tiling (ps@[a,b,c])
= Tiling
(map polyFromSides ps)
(\i -> case i `mod` 3 of
0 -> mk3Tiling (reverse ps)
1 -> mk3Tiling [a,c,b]
2 -> mk3Tiling [b,a,c]
_ -> error "i `mod` 3 is not 0, 1,or 2! the sky is falling!"
)
mk3Tiling _ = error "mk3Tiling may only be called on a list of length 3."
t4612 :: Tiling
t4612 = mk3Tiling [4,6,12]
t488 :: Tiling
t488 = mk3Tiling [4,8,8]
t31212 :: Tiling
t31212 = mk3Tiling [3,12,12]
t3636 :: Tiling
t3636 = mkT [3,6,3,6]
where mkT :: [Int] -> Tiling
mkT ps = Tiling (map polyFromSides ps)
(\i -> mkT $ if even i then reverse ps else ps)
semiregular :: [Int]
-> [Int]
-> Tiling
semiregular ps trans = mkT 0
where mkT i = Tiling
(map polyFromSides (rot i ps))
(\j -> mkT $ rot i trans !! j)
rot :: (Num a, Eq a) => a -> [t] -> [t]
rot 0 xs = xs
rot _ [] = []
rot n (x:xs) = rot (n1) (xs ++ [x])
t3464 :: Tiling
t3464 = semiregular [4,3,4,6] [3,2,1,0]
t33434, t33344, t33336L, t33336R :: Tiling
t33434 = semiregular [3,4,3,4,3] [0,2,1,4,3]
t33344 = semiregular [4,3,3,3,4] [0,4,2,3,1]
t33336L = semiregular [3,3,3,3,6] [4,1,3,2,0]
t33336R = semiregular [3,3,3,3,6] [4,2,1,3,0]