{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Diagrams.TwoD.Tilings (
Q236, rt2, rt3, rt6
, toFloating
, Q2, toV2, 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.Function (on)
import Data.List (mapAccumL, sort)
import qualified Data.Foldable as F
import qualified Data.Set as S
import Data.Colour
import Diagrams.Prelude
data Q236 = Q236 Rational Rational Rational Rational
deriving (Eq, Ord, Show, Read)
toFloating :: Floating n => Q236 -> n
toFloating (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) (b1 + b2) (c1 + c2) (d1 + d2)
(Q236 a1 b1 c1 d1) - (Q236 a2 b2 c2 d2)
= Q236 (a1 - a2) (b1 - b2) (c1 - c2) (d1 - d2)
(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 Fractional Q236 where
recip q@(Q236 a b c d) = Q236 (a3/α) (b3/α) (c3/α) (d3/α)
where
q' = Q236 a (-b) (-c) d
rs@(Q236 r 0 0 s) = q * q'
rs' = Q236 r 0 0 (-s)
(Q236 α 0 0 0) = rs * rs'
(Q236 a3 b3 c3 d3) = q' * rs'
fromRational r = Q236 r 0 0 0
type Q2 = V2 Q236
toV2 :: Floating n => Q2 -> V2 n
toV2 = fmap toFloating
toP2 :: Floating n => Q2 -> P2 n
toP2 = P . toV2
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
polyCos Square = 0
polyCos Hexagon = -1/2
polyCos Octagon = -1/2
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
polyRotation :: TilingPoly -> Q2 -> Q2
polyRotation p (V2 x y) = V2 (x*c - y*s) (x*s + y*c)
where c = polyCos p
s = polySin p
polyExtRotation :: TilingPoly -> Q2 -> Q2
polyExtRotation p (V2 x y) = V2 (-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')))
(negated 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 V2 n) b, TypeableFloat n) =>
Style V2 n -> Edge -> QDiagram b V2 n Any
drawEdge s (Edge v1 v2) = (toP2 v1 ~~ toP2 v2) # applyStyle s
drawPoly :: (Renderable (Path V2 n) b, TypeableFloat n) =>
(Polygon -> Style V2 n) -> Polygon -> QDiagram b V2 n Any
drawPoly s p = applyStyle (s p) . strokeLocLoop . mapLoc closeLine . 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 V2 n) b, TypeableFloat n)
=> Tiling -> n -> n -> QDiagram b V2 n Any
drawTiling =
drawTilingStyled
mempty
(\p -> mempty
# lw none
# fc ( polyColor
. polyFromSides
. length
. polygonVertices
$ p
)
)
drawTilingStyled :: forall b n. (Renderable (Path V2 n) b, TypeableFloat n)
=> Style V2 n -> (Polygon -> Style V2 n)
-> Tiling -> n -> n -> QDiagram b V2 n Any
drawTilingStyled eStyle pStyle t w h =
mkDia $ generateTiling t (V2 0 0) (V2 1 0) inRect
(liftA2 (,) (drawEdge eStyle) mempty)
(liftA2 (,) mempty (drawPoly pStyle))
where
inRect (toV2 -> V2 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 V2 n)
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 (n-1) (xs ++ [x])
t3464 :: Tiling
t3464 = semiregular [4,3,4,6] [3,2,1,0]
t33434 :: Tiling
t33434 = semiregular [3,4,3,4,3] [0,2,1,4,3]
t33344 :: Tiling
t33344 = semiregular [4,3,3,3,4] [0,4,2,3,1]
t33336L :: Tiling
t33336L = semiregular [3,3,3,3,6] [4,1,3,2,0]
t33336R :: Tiling
t33336R = semiregular [3,3,3,3,6] [4,2,1,3,0]