{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Tilings
-- Copyright   :  (c) 2011 Brent Yorgey
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  byorgey@cis.upenn.edu
--
-- Tools for generating and drawing plane tilings made of regular
-- polygons.
--
-----------------------------------------------------------------------------
module Diagrams.TwoD.Tilings (

  -- * The ring Q[sqrt 2, sqrt 3]

    Q236, rt2, rt3, rt6

  , toFloating

  , Q2, toV2, toP2

  -- * Regular polygons

  , TilingPoly(..)
  , polySides, polyFromSides
  , polyCos, polySin
  , polyRotation, polyExtRotation

  -- * Tilings

  -- ** Types
  , Tiling(..)
  , Edge, mkEdge

  , Polygon(..)

  -- ** Generation

  , TilingState(..), initTilingState
  , TilingM

  , generateTiling

  -- ** Pre-defined tilings

  , t3, t4, t6
  , mk3Tiling, t4612, t488, t31212

  , t3636
  , semiregular
  , rot
  , t3464, t33434, t33344, t33336L, t33336R

  -- * Diagrams

  , 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

------------------------------------------------------------
-- The ring Q[sqrt(2), sqrt(3)]
------------------------------------------------------------

-- Instead of using Doubles, which can't be compared for equality, it
-- suffices to use elements of the rationals with sqrt(2) and sqrt(3)
-- adjoined.

-- | @Q236 a b c d@ represents @a + b sqrt(2) + c sqrt(3) + d
--   sqrt(6)@.  Note that the @Ord@ instance is suitable for use in
--   `Map` and `Set`, but does not correspond to numeric ordering
--   (@Q236@ is not an ordered field under this ordering).
data Q236 = Q236 Rational Rational Rational Rational
  deriving (Q236 -> Q236 -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Q236 -> Q236 -> Bool
$c/= :: Q236 -> Q236 -> Bool
== :: Q236 -> Q236 -> Bool
$c== :: Q236 -> Q236 -> Bool
Eq, Eq Q236
Q236 -> Q236 -> Bool
Q236 -> Q236 -> Ordering
Q236 -> Q236 -> Q236
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Q236 -> Q236 -> Q236
$cmin :: Q236 -> Q236 -> Q236
max :: Q236 -> Q236 -> Q236
$cmax :: Q236 -> Q236 -> Q236
>= :: Q236 -> Q236 -> Bool
$c>= :: Q236 -> Q236 -> Bool
> :: Q236 -> Q236 -> Bool
$c> :: Q236 -> Q236 -> Bool
<= :: Q236 -> Q236 -> Bool
$c<= :: Q236 -> Q236 -> Bool
< :: Q236 -> Q236 -> Bool
$c< :: Q236 -> Q236 -> Bool
compare :: Q236 -> Q236 -> Ordering
$ccompare :: Q236 -> Q236 -> Ordering
Ord, Int -> Q236 -> ShowS
[Q236] -> ShowS
Q236 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Q236] -> ShowS
$cshowList :: [Q236] -> ShowS
show :: Q236 -> String
$cshow :: Q236 -> String
showsPrec :: Int -> Q236 -> ShowS
$cshowsPrec :: Int -> Q236 -> ShowS
Show, ReadPrec [Q236]
ReadPrec Q236
Int -> ReadS Q236
ReadS [Q236]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Q236]
$creadListPrec :: ReadPrec [Q236]
readPrec :: ReadPrec Q236
$creadPrec :: ReadPrec Q236
readList :: ReadS [Q236]
$creadList :: ReadS [Q236]
readsPrec :: Int -> ReadS Q236
$creadsPrec :: Int -> ReadS Q236
Read)

-- | Convert a @Q236@ value to a @Double@.
toFloating :: Floating n => Q236 -> n
toFloating :: forall n. Floating n => Q236 -> n
toFloating (Q236 Rational
a Rational
b Rational
c Rational
d) = forall a. Fractional a => Rational -> a
fromRational Rational
a
                        forall a. Num a => a -> a -> a
+ forall a. Fractional a => Rational -> a
fromRational Rational
b forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt n
2
                        forall a. Num a => a -> a -> a
+ forall a. Fractional a => Rational -> a
fromRational Rational
c forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt n
3
                        forall a. Num a => a -> a -> a
+ forall a. Fractional a => Rational -> a
fromRational Rational
d forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
sqrt n
6

rt2, rt3, rt6 :: Q236
rt2 :: Q236
rt2 = Rational -> Rational -> Rational -> Rational -> Q236
Q236 Rational
0 Rational
1 Rational
0 Rational
0
rt3 :: Q236
rt3 = Rational -> Rational -> Rational -> Rational -> Q236
Q236 Rational
0 Rational
0 Rational
1 Rational
0
rt6 :: Q236
rt6 = Q236
rt2forall a. Num a => a -> a -> a
*Q236
rt3

instance Num Q236 where
  (Q236 Rational
a1 Rational
b1 Rational
c1 Rational
d1) + :: Q236 -> Q236 -> Q236
+ (Q236 Rational
a2 Rational
b2 Rational
c2 Rational
d2)
      = Rational -> Rational -> Rational -> Rational -> Q236
Q236 (Rational
a1 forall a. Num a => a -> a -> a
+ Rational
a2) (Rational
b1 forall a. Num a => a -> a -> a
+ Rational
b2) (Rational
c1 forall a. Num a => a -> a -> a
+ Rational
c2) (Rational
d1 forall a. Num a => a -> a -> a
+ Rational
d2)
  (Q236 Rational
a1 Rational
b1 Rational
c1 Rational
d1) - :: Q236 -> Q236 -> Q236
- (Q236 Rational
a2 Rational
b2 Rational
c2 Rational
d2)
      = Rational -> Rational -> Rational -> Rational -> Q236
Q236 (Rational
a1 forall a. Num a => a -> a -> a
- Rational
a2) (Rational
b1 forall a. Num a => a -> a -> a
- Rational
b2) (Rational
c1 forall a. Num a => a -> a -> a
- Rational
c2) (Rational
d1 forall a. Num a => a -> a -> a
- Rational
d2)
  (Q236 Rational
a1 Rational
b1 Rational
c1 Rational
d1) * :: Q236 -> Q236 -> Q236
* (Q236 Rational
a2 Rational
b2 Rational
c2 Rational
d2) =
    Rational -> Rational -> Rational -> Rational -> Q236
Q236 (Rational
a1forall a. Num a => a -> a -> a
*Rational
a2 forall a. Num a => a -> a -> a
+ Rational
2forall a. Num a => a -> a -> a
*Rational
b1forall a. Num a => a -> a -> a
*Rational
b2 forall a. Num a => a -> a -> a
+ Rational
3forall a. Num a => a -> a -> a
*Rational
c1forall a. Num a => a -> a -> a
*Rational
c2 forall a. Num a => a -> a -> a
+ Rational
6forall a. Num a => a -> a -> a
*Rational
d1forall a. Num a => a -> a -> a
*Rational
d2)
         (Rational
a1forall a. Num a => a -> a -> a
*Rational
b2 forall a. Num a => a -> a -> a
+ Rational
b1forall a. Num a => a -> a -> a
*Rational
a2 forall a. Num a => a -> a -> a
+ Rational
3forall a. Num a => a -> a -> a
*Rational
c1forall a. Num a => a -> a -> a
*Rational
d2 forall a. Num a => a -> a -> a
+ Rational
3forall a. Num a => a -> a -> a
*Rational
d1forall a. Num a => a -> a -> a
*Rational
c2)
         (Rational
a1forall a. Num a => a -> a -> a
*Rational
c2 forall a. Num a => a -> a -> a
+ Rational
2forall a. Num a => a -> a -> a
*Rational
b1forall a. Num a => a -> a -> a
*Rational
d2 forall a. Num a => a -> a -> a
+ Rational
c1forall a. Num a => a -> a -> a
*Rational
a2 forall a. Num a => a -> a -> a
+ Rational
2forall a. Num a => a -> a -> a
*Rational
d1forall a. Num a => a -> a -> a
*Rational
b2)
         (Rational
a1forall a. Num a => a -> a -> a
*Rational
d2 forall a. Num a => a -> a -> a
+ Rational
b1forall a. Num a => a -> a -> a
*Rational
c2 forall a. Num a => a -> a -> a
+ Rational
c1forall a. Num a => a -> a -> a
*Rational
b2 forall a. Num a => a -> a -> a
+ Rational
d1forall a. Num a => a -> a -> a
*Rational
a2)
  abs :: Q236 -> Q236
abs (Q236 Rational
a Rational
b Rational
c Rational
d) = Rational -> Rational -> Rational -> Rational -> Q236
Q236 (forall a. Num a => a -> a
abs Rational
a) (forall a. Num a => a -> a
abs Rational
b) (forall a. Num a => a -> a
abs Rational
c) (forall a. Num a => a -> a
abs Rational
d)
  fromInteger :: Integer -> Q236
fromInteger Integer
z = Rational -> Rational -> Rational -> Rational -> Q236
Q236 (forall a. Num a => Integer -> a
fromInteger Integer
z) Rational
0 Rational
0 Rational
0
  signum :: Q236 -> Q236
signum = forall a. HasCallStack => String -> a
error String
"no signum for Q236"

instance Fractional Q236 where
  recip :: Q236 -> Q236
recip q :: Q236
q@(Q236 Rational
a Rational
b Rational
c Rational
d) = Rational -> Rational -> Rational -> Rational -> Q236
Q236 (Rational
a3forall a. Fractional a => a -> a -> a
/Rational
α) (Rational
b3forall a. Fractional a => a -> a -> a
/Rational
α) (Rational
c3forall a. Fractional a => a -> a -> a
/Rational
α) (Rational
d3forall a. Fractional a => a -> a -> a
/Rational
α)
    where
      q' :: Q236
q'                 = Rational -> Rational -> Rational -> Rational -> Q236
Q236 Rational
a (-Rational
b) (-Rational
c) Rational
d
      rs :: Q236
rs@(Q236 Rational
r Rational
0 Rational
0 Rational
s)  = Q236
q forall a. Num a => a -> a -> a
* Q236
q'
      rs' :: Q236
rs'                = Rational -> Rational -> Rational -> Rational -> Q236
Q236 Rational
r Rational
0 Rational
0 (-Rational
s)
      (Q236 Rational
α Rational
0 Rational
0 Rational
0)     = Q236
rs forall a. Num a => a -> a -> a
* Q236
rs'
      (Q236 Rational
a3 Rational
b3 Rational
c3 Rational
d3) = Q236
q' forall a. Num a => a -> a -> a
* Q236
rs'
  fromRational :: Rational -> Q236
fromRational Rational
r = Rational -> Rational -> Rational -> Rational -> Q236
Q236 Rational
r Rational
0 Rational
0 Rational
0

type Q2 = V2 Q236

toV2 :: Floating n => Q2 -> V2 n
toV2 :: forall n. Floating n => Q2 -> V2 n
toV2 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall n. Floating n => Q236 -> n
toFloating

toP2 :: Floating n => Q2 -> P2 n
toP2 :: forall n. Floating n => Q2 -> P2 n
toP2 = forall (f :: * -> *) a. f a -> Point f a
P forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Floating n => Q2 -> V2 n
toV2

------------------------------------------------------------
-- Polygons
------------------------------------------------------------

-- | Regular polygons which may appear in a tiling of the plane.
data TilingPoly = Triangle | Square | Hexagon | Octagon | Dodecagon
  deriving (TilingPoly -> TilingPoly -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TilingPoly -> TilingPoly -> Bool
$c/= :: TilingPoly -> TilingPoly -> Bool
== :: TilingPoly -> TilingPoly -> Bool
$c== :: TilingPoly -> TilingPoly -> Bool
Eq, Eq TilingPoly
TilingPoly -> TilingPoly -> Bool
TilingPoly -> TilingPoly -> Ordering
TilingPoly -> TilingPoly -> TilingPoly
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TilingPoly -> TilingPoly -> TilingPoly
$cmin :: TilingPoly -> TilingPoly -> TilingPoly
max :: TilingPoly -> TilingPoly -> TilingPoly
$cmax :: TilingPoly -> TilingPoly -> TilingPoly
>= :: TilingPoly -> TilingPoly -> Bool
$c>= :: TilingPoly -> TilingPoly -> Bool
> :: TilingPoly -> TilingPoly -> Bool
$c> :: TilingPoly -> TilingPoly -> Bool
<= :: TilingPoly -> TilingPoly -> Bool
$c<= :: TilingPoly -> TilingPoly -> Bool
< :: TilingPoly -> TilingPoly -> Bool
$c< :: TilingPoly -> TilingPoly -> Bool
compare :: TilingPoly -> TilingPoly -> Ordering
$ccompare :: TilingPoly -> TilingPoly -> Ordering
Ord, Int -> TilingPoly -> ShowS
[TilingPoly] -> ShowS
TilingPoly -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TilingPoly] -> ShowS
$cshowList :: [TilingPoly] -> ShowS
show :: TilingPoly -> String
$cshow :: TilingPoly -> String
showsPrec :: Int -> TilingPoly -> ShowS
$cshowsPrec :: Int -> TilingPoly -> ShowS
Show, ReadPrec [TilingPoly]
ReadPrec TilingPoly
Int -> ReadS TilingPoly
ReadS [TilingPoly]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TilingPoly]
$creadListPrec :: ReadPrec [TilingPoly]
readPrec :: ReadPrec TilingPoly
$creadPrec :: ReadPrec TilingPoly
readList :: ReadS [TilingPoly]
$creadList :: ReadS [TilingPoly]
readsPrec :: Int -> ReadS TilingPoly
$creadsPrec :: Int -> ReadS TilingPoly
Read, Int -> TilingPoly
TilingPoly -> Int
TilingPoly -> [TilingPoly]
TilingPoly -> TilingPoly
TilingPoly -> TilingPoly -> [TilingPoly]
TilingPoly -> TilingPoly -> TilingPoly -> [TilingPoly]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TilingPoly -> TilingPoly -> TilingPoly -> [TilingPoly]
$cenumFromThenTo :: TilingPoly -> TilingPoly -> TilingPoly -> [TilingPoly]
enumFromTo :: TilingPoly -> TilingPoly -> [TilingPoly]
$cenumFromTo :: TilingPoly -> TilingPoly -> [TilingPoly]
enumFromThen :: TilingPoly -> TilingPoly -> [TilingPoly]
$cenumFromThen :: TilingPoly -> TilingPoly -> [TilingPoly]
enumFrom :: TilingPoly -> [TilingPoly]
$cenumFrom :: TilingPoly -> [TilingPoly]
fromEnum :: TilingPoly -> Int
$cfromEnum :: TilingPoly -> Int
toEnum :: Int -> TilingPoly
$ctoEnum :: Int -> TilingPoly
pred :: TilingPoly -> TilingPoly
$cpred :: TilingPoly -> TilingPoly
succ :: TilingPoly -> TilingPoly
$csucc :: TilingPoly -> TilingPoly
Enum, TilingPoly
forall a. a -> a -> Bounded a
maxBound :: TilingPoly
$cmaxBound :: TilingPoly
minBound :: TilingPoly
$cminBound :: TilingPoly
Bounded)

polySides :: Num a => TilingPoly -> a
polySides :: forall a. Num a => TilingPoly -> a
polySides TilingPoly
Triangle  = a
3
polySides TilingPoly
Square    = a
4
polySides TilingPoly
Hexagon   = a
6
polySides TilingPoly
Octagon   = a
8
polySides TilingPoly
Dodecagon = a
12

polyFromSides :: (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides :: forall a. (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides a
3  = TilingPoly
Triangle
polyFromSides a
4  = TilingPoly
Square
polyFromSides a
6  = TilingPoly
Hexagon
polyFromSides a
8  = TilingPoly
Octagon
polyFromSides a
12 = TilingPoly
Dodecagon
polyFromSides a
n  = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Bad polygon number: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
n

-- | Cosine of a polygon's internal angle.
polyCos :: TilingPoly -> Q236
polyCos :: TilingPoly -> Q236
polyCos TilingPoly
Triangle  = Q236
1forall a. Fractional a => a -> a -> a
/Q236
2
polyCos TilingPoly
Square    = Q236
0
polyCos TilingPoly
Hexagon   = -Q236
1forall a. Fractional a => a -> a -> a
/Q236
2
polyCos TilingPoly
Octagon   = -Q236
1forall a. Fractional a => a -> a -> a
/Q236
2
polyCos TilingPoly
Dodecagon = -Q236
1forall a. Fractional a => a -> a -> a
/Q236
2 forall a. Num a => a -> a -> a
* Q236
rt3

-- | Sine of a polygon's internal angle.
polySin :: TilingPoly -> Q236
polySin :: TilingPoly -> Q236
polySin TilingPoly
Triangle  = (Q236
1forall a. Fractional a => a -> a -> a
/Q236
2) forall a. Num a => a -> a -> a
* Q236
rt3
polySin TilingPoly
Square    = Q236
1
polySin TilingPoly
Hexagon   = (Q236
1forall a. Fractional a => a -> a -> a
/Q236
2) forall a. Num a => a -> a -> a
* Q236
rt3
polySin TilingPoly
Octagon   = (Q236
1forall a. Fractional a => a -> a -> a
/Q236
2) forall a. Num a => a -> a -> a
* Q236
rt2
polySin TilingPoly
Dodecagon = Q236
1forall a. Fractional a => a -> a -> a
/Q236
2

{-
   R_th = ( cos th  -sin th )
          ( sin th   cos th )

-}

-- | Rotate by polygon internal angle.
polyRotation :: TilingPoly -> Q2 -> Q2
polyRotation :: TilingPoly -> Q2 -> Q2
polyRotation TilingPoly
p (V2 Q236
x Q236
y) = forall a. a -> a -> V2 a
V2 (Q236
xforall a. Num a => a -> a -> a
*Q236
c forall a. Num a => a -> a -> a
- Q236
yforall a. Num a => a -> a -> a
*Q236
s) (Q236
xforall a. Num a => a -> a -> a
*Q236
s forall a. Num a => a -> a -> a
+ Q236
yforall a. Num a => a -> a -> a
*Q236
c)
  where c :: Q236
c = TilingPoly -> Q236
polyCos TilingPoly
p
        s :: Q236
s = TilingPoly -> Q236
polySin TilingPoly
p

{-
   (cos th  sin th)  ( -1  0 )  =  (-cos th  -sin th)
   (-sin th  cos th) ( 0  -1 )     (sin th   -cos th)
-}

-- | Rotate by polygon external angle.
polyExtRotation :: TilingPoly -> Q2 -> Q2
polyExtRotation :: TilingPoly -> Q2 -> Q2
polyExtRotation TilingPoly
p (V2 Q236
x Q236
y) = forall a. a -> a -> V2 a
V2 (-Q236
xforall a. Num a => a -> a -> a
*Q236
c forall a. Num a => a -> a -> a
- Q236
yforall a. Num a => a -> a -> a
*Q236
s) (Q236
xforall a. Num a => a -> a -> a
*Q236
s forall a. Num a => a -> a -> a
- Q236
yforall a. Num a => a -> a -> a
*Q236
c)
  where c :: Q236
c = TilingPoly -> Q236
polyCos TilingPoly
p
        s :: Q236
s = TilingPoly -> Q236
polySin TilingPoly
p

------------------------------------------------------------
-- Tilings
------------------------------------------------------------

-- | A tiling, represented as a sort of zipper. @curConfig@ indicates
--   the polygons around the current vertex, in couterclockwise order
--   starting from the edge along which we entered the vertex.
--   @follow@ allows one to move along an edge to an adjacent vertex,
--   where the edges are numbered counterclockwise from zero,
--   beginning with the edge along which we entered the current
--   vertex.
data Tiling = Tiling { Tiling -> [TilingPoly]
curConfig :: [TilingPoly]
                     , Tiling -> Int -> Tiling
follow    :: Int -> Tiling
                     }

-- | An edge is represented by a pair of vertices.  Do not use the
--   @Edge@ constructor directly; use 'mkEdge' instead.
data Edge = Edge Q2 Q2
  deriving (Edge -> Edge -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c== :: Edge -> Edge -> Bool
Eq, Eq Edge
Edge -> Edge -> Bool
Edge -> Edge -> Ordering
Edge -> Edge -> Edge
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Edge -> Edge -> Edge
$cmin :: Edge -> Edge -> Edge
max :: Edge -> Edge -> Edge
$cmax :: Edge -> Edge -> Edge
>= :: Edge -> Edge -> Bool
$c>= :: Edge -> Edge -> Bool
> :: Edge -> Edge -> Bool
$c> :: Edge -> Edge -> Bool
<= :: Edge -> Edge -> Bool
$c<= :: Edge -> Edge -> Bool
< :: Edge -> Edge -> Bool
$c< :: Edge -> Edge -> Bool
compare :: Edge -> Edge -> Ordering
$ccompare :: Edge -> Edge -> Ordering
Ord, Int -> Edge -> ShowS
[Edge] -> ShowS
Edge -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Edge] -> ShowS
$cshowList :: [Edge] -> ShowS
show :: Edge -> String
$cshow :: Edge -> String
showsPrec :: Int -> Edge -> ShowS
$cshowsPrec :: Int -> Edge -> ShowS
Show)

-- | Smart constructor for @Edge@, which puts the vertices in a
--   canonical order.
mkEdge :: Q2 -> Q2 -> Edge
mkEdge :: Q2 -> Q2 -> Edge
mkEdge Q2
v1 Q2
v2 | Q2
v1 forall a. Ord a => a -> a -> Bool
<= Q2
v2  = Q2 -> Q2 -> Edge
Edge Q2
v1 Q2
v2
             | Bool
otherwise = Q2 -> Q2 -> Edge
Edge Q2
v2 Q2
v1

-- | A polygon is represented by a list of its vertices, in
--   counterclockwise order.  However, the @Eq@ and @Ord@ instances
--   for polygons ignore the order.
newtype Polygon = Polygon { Polygon -> [Q2]
polygonVertices :: [Q2] }
  deriving Int -> Polygon -> ShowS
[Polygon] -> ShowS
Polygon -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Polygon] -> ShowS
$cshowList :: [Polygon] -> ShowS
show :: Polygon -> String
$cshow :: Polygon -> String
showsPrec :: Int -> Polygon -> ShowS
$cshowsPrec :: Int -> Polygon -> ShowS
Show

instance Eq Polygon where
  (Polygon [Q2]
vs1) == :: Polygon -> Polygon -> Bool
== (Polygon [Q2]
vs2) = forall a. Ord a => [a] -> [a]
sort [Q2]
vs1 forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
sort [Q2]
vs2

instance Ord Polygon where
  compare :: Polygon -> Polygon -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> [Q2]
polygonVertices)

-- | The state maintained while generating a tiling, recording which
--   vertices have been visited and which edges and polygons have been
--   drawn.
data TilingState = TP { TilingState -> Set Q2
visitedVertices :: S.Set Q2
                      , TilingState -> Set Edge
visitedEdges    :: S.Set Edge
                      , TilingState -> Set Polygon
visitedPolygons :: S.Set Polygon
                      }

initTilingState :: TilingState
initTilingState :: TilingState
initTilingState = Set Q2 -> Set Edge -> Set Polygon -> TilingState
TP forall a. Set a
S.empty forall a. Set a
S.empty forall a. Set a
S.empty

-- | The @TilingM@ monad tracks a @TilingState@, and can output
--   elements of some monoid @w@ along the way.
type TilingM w a = WriterT w (State TilingState) a

generateTiling :: forall w. Monoid w
               => Tiling        -- ^ The tiling to generate
               -> Q2            -- ^ The location of the starting vertex.
               -> Q2            -- ^ The starting direction, i.e. the
                                --   direction along which we came into
                                --   the starting vertex.
               -> (Q2 -> Bool)  -- ^ Predicate on vertices specifying
                                --   which should be visited.  The
                                --   vertices for which the predicate
                                --   evaluates to True must form a
                                --   single connected component.
               -> (Edge -> w)          -- ^ what to do with edges
               -> (Polygon -> w)       -- ^ what to do with polygons
               -> w
generateTiling :: forall w.
Monoid w =>
Tiling
-> Q2 -> Q2 -> (Q2 -> Bool) -> (Edge -> w) -> (Polygon -> w) -> w
generateTiling Tiling
t Q2
v Q2
d Q2 -> Bool
vPred Edge -> w
e Polygon -> w
p
  = forall s a. State s a -> s -> a
evalState (forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (Tiling -> Q2 -> Q2 -> TilingM w ()
generateTiling' Tiling
t Q2
v Q2
d)) TilingState
initTilingState where

  generateTiling' :: Tiling -> Q2 -> Q2 -> TilingM w ()
  generateTiling' :: Tiling -> Q2 -> Q2 -> TilingM w ()
generateTiling' Tiling
t Q2
v Q2
d
      -- stop if the current vertex fails the predicate
    | Bool -> Bool
not (Q2 -> Bool
vPred Q2
v) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
        TilingState
ts <- forall s (m :: * -> *). MonadState s m => m s
get

        -- stop if we've seen this vertex before
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Q2
v forall a. Ord a => a -> Set a -> Bool
`S.notMember` TilingState -> Set Q2
visitedVertices TilingState
ts) forall a b. (a -> b) -> a -> b
$ do

          -- otherwise, mark it as visited
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TilingState
ts -> TilingState
ts { visitedVertices :: Set Q2
visitedVertices = Q2
v forall a. Ord a => a -> Set a -> Set a
`S.insert` TilingState -> Set Q2
visitedVertices TilingState
ts })

          -- get the neighboring vertices and the polygons surrounding
          -- this vertex, and filter out ones we've already generated
          let ([Q2]
neighbors, Set Polygon
polys) = Tiling -> Q2 -> Q2 -> ([Q2], Set Polygon)
genNeighbors Tiling
t Q2
v Q2
d
              edges :: Set Edge
edges  = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Q2 -> Q2 -> Edge
mkEdge Q2
v) [Q2]
neighbors
              edges' :: Set Edge
edges' = Set Edge
edges forall a. Ord a => Set a -> Set a -> Set a
`S.difference` TilingState -> Set Edge
visitedEdges TilingState
ts
              polys' :: Set Polygon
polys' = Set Polygon
polys forall a. Ord a => Set a -> Set a -> Set a
`S.difference` TilingState -> Set Polygon
visitedPolygons TilingState
ts

          -- generate some edges and polygons
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ (forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> w
e) Set Edge
edges'
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ (forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> w
p) Set Polygon
polys'

          -- remember that we generated them
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TilingState
ts -> TilingState
ts { visitedEdges :: Set Edge
visitedEdges = Set Edge
edges' forall a. Ord a => Set a -> Set a -> Set a
`S.union` TilingState -> Set Edge
visitedEdges TilingState
ts })
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TilingState
ts -> TilingState
ts { visitedPolygons :: Set Polygon
visitedPolygons = Set Polygon
polys' forall a. Ord a => Set a -> Set a -> Set a
`S.union` TilingState -> Set Polygon
visitedPolygons TilingState
ts })

          -- follow edges and continue recursively
          forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\Q2
d Int
i -> Tiling -> Q2 -> Q2 -> TilingM w ()
generateTiling' (Tiling -> Int -> Tiling
follow Tiling
t Int
i) (Q2
v forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Q2
d) Q2
d)
            (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Q2
v) [Q2]
neighbors) [Int
0..]

-- | Generate the neighboring vertices and polygons of a given vertex.
genNeighbors :: Tiling -> Q2 -> Q2 -> ([Q2], S.Set Polygon)
genNeighbors :: Tiling -> Q2 -> Q2 -> ([Q2], Set Polygon)
genNeighbors Tiling
t Q2
v Q2
d = ([Q2]
neighbors, forall a. Ord a => [a] -> Set a
S.fromList [Polygon]
polys) where
  ([Q2]
neighbors, [Polygon]
polys)
    = forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
      forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL
          (\Q2
d' TilingPoly
poly -> (TilingPoly -> Q2 -> Q2
polyRotation TilingPoly
poly Q2
d', (Q2
v forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Q2
d', TilingPoly -> Q2 -> Q2 -> Polygon
genPolyVs TilingPoly
poly Q2
v Q2
d')))
          (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Q2
d)
          (Tiling -> [TilingPoly]
curConfig Tiling
t)

-- | Generate the vertices of the given polygon, with one vertex at the given point
--   and an adjacent vertex at the given offset.
genPolyVs :: TilingPoly
          -> Q2          -- ^ one vertex
          -> Q2          -- ^ vector to second vertex
          -> Polygon
genPolyVs :: TilingPoly -> Q2 -> Q2 -> Polygon
genPolyVs TilingPoly
p Q2
v Q2
d = [Q2] -> Polygon
Polygon
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
(^+^) Q2
v
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take (forall a. Num a => TilingPoly -> a
polySides TilingPoly
p forall a. Num a => a -> a -> a
- Int
1)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> a -> [a]
iterate (TilingPoly -> Q2 -> Q2
polyExtRotation TilingPoly
p)
                forall a b. (a -> b) -> a -> b
$ Q2
d

------------------------------------------------------------
-- Diagrams
------------------------------------------------------------

-- | Draw an edge with the given style.
drawEdge :: (Renderable (Path V2 n) b, TypeableFloat n) =>
            Style V2 n -> Edge -> QDiagram b V2 n Any
drawEdge :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Style V2 n -> Edge -> QDiagram b V2 n Any
drawEdge Style V2 n
s (Edge Q2
v1 Q2
v2) = (forall n. Floating n => Q2 -> P2 n
toP2 Q2
v1 forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, TrailLike t) =>
Point v n -> Point v n -> t
~~ forall n. Floating n => Q2 -> P2 n
toP2 Q2
v2) forall a b. a -> (a -> b) -> b
# forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle Style V2 n
s

-- | Draw a polygon with the given style.
drawPoly :: (Renderable (Path V2 n) b, TypeableFloat n) =>
            (Polygon -> Style V2 n) -> Polygon -> QDiagram b V2 n Any
drawPoly :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
(Polygon -> Style V2 n) -> Polygon -> QDiagram b V2 n Any
drawPoly Polygon -> Style V2 n
s Polygon
p = forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle (Polygon -> Style V2 n
s Polygon
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n b.
(TypeableFloat n, Renderable (Path V2 n) b) =>
Located (Trail' Loop V2 n) -> QDiagram b V2 n Any
strokeLocLoop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. SameSpace a b => (a -> b) -> Located a -> Located b
mapLoc forall (v :: * -> *) n. Trail' Line v n -> Trail' Loop v n
closeLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n. Floating n => Q2 -> P2 n
toP2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> [Q2]
polygonVertices forall a b. (a -> b) -> a -> b
$ Polygon
p

-- Simple per-polygon color scheme
polyColor :: (Floating a, Ord a) => TilingPoly -> Colour a
polyColor :: forall a. (Floating a, Ord a) => TilingPoly -> Colour a
polyColor TilingPoly
Triangle  = forall a. (Ord a, Floating a) => Colour a
yellow
polyColor TilingPoly
Square    = forall a. (Ord a, Floating a) => Colour a
mediumseagreen
polyColor TilingPoly
Hexagon   = forall a. (Ord a, Floating a) => Colour a
blueviolet
polyColor TilingPoly
Octagon   = forall a. (Ord a, Floating a) => Colour a
lightsteelblue
polyColor TilingPoly
Dodecagon = forall a. (Ord a, Floating a) => Colour a
cornflowerblue

-- | Draw a tiling, with a given width and height and default colors
--   for the polygons.
drawTiling :: (Renderable (Path V2 n) b, TypeableFloat n)
           => Tiling -> n -> n -> QDiagram b V2 n Any
drawTiling :: forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Tiling -> n -> n -> QDiagram b V2 n Any
drawTiling =
  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
    forall a. Monoid a => a
mempty
    (\Polygon
p -> forall a. Monoid a => a
mempty
           # lw none
           # fc ( polyColor
                . polyFromSides
                . length
                . polygonVertices
                $ p
                )
    )

-- | Draw a tiling with customizable styles for the polygons.  This is
--   just an example, which you can use as the basis of your own
--   tiling-drawing routine.
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 :: 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 Style V2 n
eStyle Polygon -> Style V2 n
pStyle Tiling
t n
w n
h =
  (QDiagram b V2 n Any, QDiagram b V2 n Any) -> QDiagram b V2 n Any
mkDia forall a b. (a -> b) -> a -> b
$ forall w.
Monoid w =>
Tiling
-> Q2 -> Q2 -> (Q2 -> Bool) -> (Edge -> w) -> (Polygon -> w) -> w
generateTiling Tiling
t (forall a. a -> a -> V2 a
V2 Q236
0 Q236
0) (forall a. a -> a -> V2 a
V2 Q236
1 Q236
0) Q2 -> Bool
inRect

            -- draw the edges and polygons into separate
            -- diagrams, so we can make sure all the edges are
            -- overlaid on top of all the polygons at the end
            (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Style V2 n -> Edge -> QDiagram b V2 n Any
drawEdge Style V2 n
eStyle) forall a. Monoid a => a
mempty)
            (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) forall a. Monoid a => a
mempty (forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
(Polygon -> Style V2 n) -> Polygon -> QDiagram b V2 n Any
drawPoly Polygon -> Style V2 n
pStyle))
  where
    inRect :: Q2 -> Bool
inRect (forall n. Floating n => Q2 -> V2 n
toV2 -> V2 n
x n
y) = -n
wforall a. Fractional a => a -> a -> a
/n
2 forall a. Ord a => a -> a -> Bool
<= n
x Bool -> Bool -> Bool
&& n
x forall a. Ord a => a -> a -> Bool
<= n
wforall a. Fractional a => a -> a -> a
/n
2 Bool -> Bool -> Bool
&& -n
hforall a. Fractional a => a -> a -> a
/n
2 forall a. Ord a => a -> a -> Bool
<= n
y Bool -> Bool -> Bool
&& n
y forall a. Ord a => a -> a -> Bool
<= n
hforall a. Fractional a => a -> a -> a
/n
2
    mkDia :: (QDiagram b V2 n Any, QDiagram b V2 n Any) -> QDiagram b V2 n Any
mkDia (QDiagram b V2 n Any
es, QDiagram b V2 n Any
ps) = QDiagram b V2 n Any -> QDiagram b V2 n Any
viewRect (QDiagram b V2 n Any
es forall a. Semigroup a => a -> a -> a
<> QDiagram b V2 n Any
ps)
    viewRect :: QDiagram b V2 n Any -> QDiagram b V2 n Any
viewRect = forall (v :: * -> *) n a m b.
(InSpace v n a, Monoid' m, Enveloped a) =>
a -> QDiagram b v n m -> QDiagram b v n m
withEnvelope (forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect n
w n
h :: D V2 n)

------------------------------------------------------------
-- Some pre-defined tilings
------------------------------------------------------------

-- Regular tilings

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t3D.svg#diagram=t3D&width=300>>
t3 :: Tiling
t3 :: Tiling
t3 = [TilingPoly] -> (Int -> Tiling) -> Tiling
Tiling (forall a. Int -> a -> [a]
replicate Int
6 TilingPoly
Triangle) (forall a b. a -> b -> a
const Tiling
t3)

-- > import Diagrams.TwoD.Tilings
-- > t3D = drawTiling t3 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t4D.svg#diagram=t4D&width=300>>
t4 :: Tiling
t4 :: Tiling
t4 = [TilingPoly] -> (Int -> Tiling) -> Tiling
Tiling (forall a. Int -> a -> [a]
replicate Int
4 TilingPoly
Square) (forall a b. a -> b -> a
const Tiling
t4)

-- > import Diagrams.TwoD.Tilings
-- > t4D = drawTiling t4 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t6D.svg#diagram=t6D&width=300>>
t6 :: Tiling
t6 :: Tiling
t6 = [TilingPoly] -> (Int -> Tiling) -> Tiling
Tiling (forall a. Int -> a -> [a]
replicate Int
3 TilingPoly
Hexagon) (forall a b. a -> b -> a
const Tiling
t6)

-- > import Diagrams.TwoD.Tilings
-- > t6D = drawTiling t6 10 10

-- Semi-regular tilings

-- | Create a tiling with the same 3 polygons surrounding each vertex.
--   The argument is the number of sides of the polygons surrounding a vertex.
mk3Tiling :: [Int] -> Tiling
mk3Tiling :: [Int] -> Tiling
mk3Tiling (ps :: [Int]
ps@[Int
a,Int
b,Int
c])
      = [TilingPoly] -> (Int -> Tiling) -> Tiling
Tiling
          (forall a b. (a -> b) -> [a] -> [b]
map forall a. (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides [Int]
ps)
          (\Int
i -> case Int
i forall a. Integral a => a -> a -> a
`mod` Int
3 of
                   Int
0 -> [Int] -> Tiling
mk3Tiling (forall a. [a] -> [a]
reverse [Int]
ps)
                   Int
1 -> [Int] -> Tiling
mk3Tiling [Int
a,Int
c,Int
b]
                   Int
2 -> [Int] -> Tiling
mk3Tiling [Int
b,Int
a,Int
c]
                   Int
_ -> forall a. HasCallStack => String -> a
error String
"i `mod` 3 is not 0, 1,or 2! the sky is falling!"
          )
mk3Tiling [Int]
_ = forall a. HasCallStack => String -> a
error String
"mk3Tiling may only be called on a list of length 3."

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t4612D.svg#diagram=t4612D&width=300>>
t4612 :: Tiling
t4612 :: Tiling
t4612 = [Int] -> Tiling
mk3Tiling [Int
4,Int
6,Int
12]

-- > import Diagrams.TwoD.Tilings
-- > t4612D = drawTiling t4612 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t488D.svg#diagram=t488D&width=300>>
t488 :: Tiling
t488 :: Tiling
t488 = [Int] -> Tiling
mk3Tiling [Int
4,Int
8,Int
8]

-- > import Diagrams.TwoD.Tilings
-- > t488D = drawTiling t488 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t31212D.svg#diagram=t31212D&width=300>>
t31212 :: Tiling
t31212 :: Tiling
t31212 = [Int] -> Tiling
mk3Tiling [Int
3,Int
12,Int
12]

-- > import Diagrams.TwoD.Tilings
-- > t31212D = drawTiling t31212 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t3636D.svg#diagram=t3636D&width=300>>
t3636 :: Tiling
t3636 :: Tiling
t3636 = [Int] -> Tiling
mkT [Int
3,Int
6,Int
3,Int
6]
  where mkT :: [Int] -> Tiling
        mkT :: [Int] -> Tiling
mkT [Int]
ps = [TilingPoly] -> (Int -> Tiling) -> Tiling
Tiling (forall a b. (a -> b) -> [a] -> [b]
map forall a. (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides [Int]
ps)
                        (\Int
i -> [Int] -> Tiling
mkT forall a b. (a -> b) -> a -> b
$ if forall a. Integral a => a -> Bool
even Int
i then forall a. [a] -> [a]
reverse [Int]
ps else [Int]
ps)

-- > import Diagrams.TwoD.Tilings
-- > t3636D = drawTiling t3636 10 10

-- | Create a tiling where every vertex is the same up to rotation and
--   translation (but /not/ reflection).  Arbitrarily pick one of the
--   edges emanating from a vertex and number the edges
--   counterclockwise starting with 0 for the chosen edge.
semiregular :: [Int]   -- ^ The number of sides of the polygons
                       --   surrounding a typical vertex,
                       --   counterclockwise starting from edge 0.
            -> [Int]   -- ^ The transition list: if the /i/th entry of
                       --   this list is /j/, it indicates that the edge
                       --   labeled /i/ is labeled /j/ with respect to
                       --   the vertex on its other end.
            -> Tiling
semiregular :: [Int] -> [Int] -> Tiling
semiregular [Int]
ps [Int]
trans = Int -> Tiling
mkT Int
0
  where mkT :: Int -> Tiling
mkT Int
i = [TilingPoly] -> (Int -> Tiling) -> Tiling
Tiling
                  (forall a b. (a -> b) -> [a] -> [b]
map forall a. (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides (forall a t. (Num a, Eq a) => a -> [t] -> [t]
rot Int
i [Int]
ps))
                  (\Int
j -> Int -> Tiling
mkT forall a b. (a -> b) -> a -> b
$ forall a t. (Num a, Eq a) => a -> [t] -> [t]
rot Int
i [Int]
trans forall a. [a] -> Int -> a
!! Int
j)

rot :: (Num a, Eq a) => a -> [t] -> [t]
rot :: forall a t. (Num a, Eq a) => a -> [t] -> [t]
rot a
0 [t]
xs     = [t]
xs
rot a
_ []     = []
rot a
n (t
x:[t]
xs) = forall a t. (Num a, Eq a) => a -> [t] -> [t]
rot (a
nforall a. Num a => a -> a -> a
-a
1) ([t]
xs forall a. [a] -> [a] -> [a]
++ [t
x])

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t3464D.svg#diagram=t3464D&width=300>>
t3464 :: Tiling
t3464 :: Tiling
t3464 = [Int] -> [Int] -> Tiling
semiregular [Int
4,Int
3,Int
4,Int
6] [Int
3,Int
2,Int
1,Int
0]

-- > import Diagrams.TwoD.Tilings
-- > t3464D = drawTiling t3464 10 10

{-

The above is worth a few lines of explanation.  There is only one type
of vertex, of degree 4, hence there are four possible states depending
on which edge one entered the vertex on.  We can arbitrarily choose
state 0 to be the one in which the surrounding polygons, ccw from the
edge on which the vertex was entered, are 4,3,4,6.  The second list
then records the states in which one ends up after following edges 0,
1, 2... (numbered ccw with edge 0 being the one entered on) starting
from state 0.  The transitions from other states can be worked out by
appropriate cyclic shifts.

The tilings below are worked out in a similar manner.

-}

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t33434D.svg#diagram=t33434D&width=300>>
t33434 :: Tiling
t33434 :: Tiling
t33434  = [Int] -> [Int] -> Tiling
semiregular [Int
3,Int
4,Int
3,Int
4,Int
3] [Int
0,Int
2,Int
1,Int
4,Int
3]

-- > import Diagrams.TwoD.Tilings
-- > t33434D = drawTiling t33434 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t33344D.svg#diagram=t33344D&width=300>>
t33344 :: Tiling
t33344 :: Tiling
t33344  = [Int] -> [Int] -> Tiling
semiregular [Int
4,Int
3,Int
3,Int
3,Int
4] [Int
0,Int
4,Int
2,Int
3,Int
1]

-- > import Diagrams.TwoD.Tilings
-- > t33344D = drawTiling t33344 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t33336LD.svg#diagram=t33336LD&width=300>>
t33336L :: Tiling
t33336L :: Tiling
t33336L = [Int] -> [Int] -> Tiling
semiregular [Int
3,Int
3,Int
3,Int
3,Int
6] [Int
4,Int
1,Int
3,Int
2,Int
0]

-- > import Diagrams.TwoD.Tilings
-- > t33336LD = drawTiling t33336L 10 10

-- | <<diagrams/src_Diagrams_TwoD_Tilings_t33336RD.svg#diagram=t33336RD&width=300>>
t33336R :: Tiling
t33336R :: Tiling
t33336R = [Int] -> [Int] -> Tiling
semiregular [Int
3,Int
3,Int
3,Int
3,Int
6] [Int
4,Int
2,Int
1,Int
3,Int
0]

-- > import Diagrams.TwoD.Tilings
-- > t33336RD = drawTiling t33336R 10 10