{-# 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        (when, zipWithM_)
import           Control.Monad.State
import           Control.Monad.Writer

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
(Q236 -> Q236 -> Bool) -> (Q236 -> Q236 -> Bool) -> Eq Q236
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Q236 -> Q236 -> Bool
== :: Q236 -> Q236 -> Bool
$c/= :: Q236 -> Q236 -> Bool
/= :: Q236 -> Q236 -> Bool
Eq, Eq Q236
Eq Q236 =>
(Q236 -> Q236 -> Ordering)
-> (Q236 -> Q236 -> Bool)
-> (Q236 -> Q236 -> Bool)
-> (Q236 -> Q236 -> Bool)
-> (Q236 -> Q236 -> Bool)
-> (Q236 -> Q236 -> Q236)
-> (Q236 -> Q236 -> Q236)
-> Ord 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
$ccompare :: Q236 -> Q236 -> Ordering
compare :: Q236 -> Q236 -> Ordering
$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
>= :: Q236 -> Q236 -> Bool
$cmax :: Q236 -> Q236 -> Q236
max :: Q236 -> Q236 -> Q236
$cmin :: Q236 -> Q236 -> Q236
min :: Q236 -> Q236 -> Q236
Ord, Int -> Q236 -> ShowS
[Q236] -> ShowS
Q236 -> String
(Int -> Q236 -> ShowS)
-> (Q236 -> String) -> ([Q236] -> ShowS) -> Show Q236
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Q236 -> ShowS
showsPrec :: Int -> Q236 -> ShowS
$cshow :: Q236 -> String
show :: Q236 -> String
$cshowList :: [Q236] -> ShowS
showList :: [Q236] -> ShowS
Show, ReadPrec [Q236]
ReadPrec Q236
Int -> ReadS Q236
ReadS [Q236]
(Int -> ReadS Q236)
-> ReadS [Q236] -> ReadPrec Q236 -> ReadPrec [Q236] -> Read Q236
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Q236
readsPrec :: Int -> ReadS Q236
$creadList :: ReadS [Q236]
readList :: ReadS [Q236]
$creadPrec :: ReadPrec Q236
readPrec :: ReadPrec Q236
$creadListPrec :: ReadPrec [Q236]
readListPrec :: ReadPrec [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) = Rational -> n
forall a. Fractional a => Rational -> a
fromRational Rational
a
                        n -> n -> n
forall a. Num a => a -> a -> a
+ Rational -> n
forall a. Fractional a => Rational -> a
fromRational Rational
b n -> n -> n
forall a. Num a => a -> a -> a
* n -> n
forall a. Floating a => a -> a
sqrt n
2
                        n -> n -> n
forall a. Num a => a -> a -> a
+ Rational -> n
forall a. Fractional a => Rational -> a
fromRational Rational
c n -> n -> n
forall a. Num a => a -> a -> a
* n -> n
forall a. Floating a => a -> a
sqrt n
3
                        n -> n -> n
forall a. Num a => a -> a -> a
+ Rational -> n
forall a. Fractional a => Rational -> a
fromRational Rational
d n -> n -> n
forall a. Num a => a -> a -> a
* n -> n
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
rt2Q236 -> Q236 -> Q236
forall 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 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
a2) (Rational
b1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
b2) (Rational
c1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c2) (Rational
d1 Rational -> Rational -> Rational
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 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
a2) (Rational
b1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
b2) (Rational
c1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
c2) (Rational
d1 Rational -> Rational -> Rational
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
a1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
a2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
2Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
b1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
b2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
3Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
c1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
c2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
6Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
d1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
d2)
         (Rational
a1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
b2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
b1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
a2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
3Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
c1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
d2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
3Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
d1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
c2)
         (Rational
a1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
c2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
2Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
b1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
d2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
a2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
2Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
d1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
b2)
         (Rational
a1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
d2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
b1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
c2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
c1Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
b2 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
d1Rational -> Rational -> Rational
forall 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 (Rational -> Rational
forall a. Num a => a -> a
abs Rational
a) (Rational -> Rational
forall a. Num a => a -> a
abs Rational
b) (Rational -> Rational
forall a. Num a => a -> a
abs Rational
c) (Rational -> Rational
forall a. Num a => a -> a
abs Rational
d)
  fromInteger :: Integer -> Q236
fromInteger Integer
z = Rational -> Rational -> Rational -> Rational -> Q236
Q236 (Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Integer
z) Rational
0 Rational
0 Rational
0
  signum :: Q236 -> Q236
signum = String -> Q236 -> Q236
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
a3Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
α) (Rational
b3Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
α) (Rational
c3Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
α) (Rational
d3Rational -> Rational -> Rational
forall 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 Q236 -> Q236 -> Q236
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 Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
* Q236
rs'
      (Q236 Rational
a3 Rational
b3 Rational
c3 Rational
d3) = Q236
q' Q236 -> Q236 -> Q236
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 = (Q236 -> n) -> Q2 -> V2 n
forall a b. (a -> b) -> V2 a -> V2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Q236 -> n
forall n. Floating n => Q236 -> n
toFloating

toP2 :: Floating n => Q2 -> P2 n
toP2 :: forall n. Floating n => Q2 -> P2 n
toP2 = V2 n -> Point V2 n
forall (f :: * -> *) a. f a -> Point f a
P (V2 n -> Point V2 n) -> (Q2 -> V2 n) -> Q2 -> Point V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q2 -> V2 n
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
(TilingPoly -> TilingPoly -> Bool)
-> (TilingPoly -> TilingPoly -> Bool) -> Eq TilingPoly
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TilingPoly -> TilingPoly -> Bool
== :: TilingPoly -> TilingPoly -> Bool
$c/= :: TilingPoly -> TilingPoly -> Bool
/= :: TilingPoly -> TilingPoly -> Bool
Eq, Eq TilingPoly
Eq TilingPoly =>
(TilingPoly -> TilingPoly -> Ordering)
-> (TilingPoly -> TilingPoly -> Bool)
-> (TilingPoly -> TilingPoly -> Bool)
-> (TilingPoly -> TilingPoly -> Bool)
-> (TilingPoly -> TilingPoly -> Bool)
-> (TilingPoly -> TilingPoly -> TilingPoly)
-> (TilingPoly -> TilingPoly -> TilingPoly)
-> Ord 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
$ccompare :: TilingPoly -> TilingPoly -> Ordering
compare :: TilingPoly -> TilingPoly -> Ordering
$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
>= :: TilingPoly -> TilingPoly -> Bool
$cmax :: TilingPoly -> TilingPoly -> TilingPoly
max :: TilingPoly -> TilingPoly -> TilingPoly
$cmin :: TilingPoly -> TilingPoly -> TilingPoly
min :: TilingPoly -> TilingPoly -> TilingPoly
Ord, Int -> TilingPoly -> ShowS
[TilingPoly] -> ShowS
TilingPoly -> String
(Int -> TilingPoly -> ShowS)
-> (TilingPoly -> String)
-> ([TilingPoly] -> ShowS)
-> Show TilingPoly
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TilingPoly -> ShowS
showsPrec :: Int -> TilingPoly -> ShowS
$cshow :: TilingPoly -> String
show :: TilingPoly -> String
$cshowList :: [TilingPoly] -> ShowS
showList :: [TilingPoly] -> ShowS
Show, ReadPrec [TilingPoly]
ReadPrec TilingPoly
Int -> ReadS TilingPoly
ReadS [TilingPoly]
(Int -> ReadS TilingPoly)
-> ReadS [TilingPoly]
-> ReadPrec TilingPoly
-> ReadPrec [TilingPoly]
-> Read TilingPoly
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TilingPoly
readsPrec :: Int -> ReadS TilingPoly
$creadList :: ReadS [TilingPoly]
readList :: ReadS [TilingPoly]
$creadPrec :: ReadPrec TilingPoly
readPrec :: ReadPrec TilingPoly
$creadListPrec :: ReadPrec [TilingPoly]
readListPrec :: ReadPrec [TilingPoly]
Read, Int -> TilingPoly
TilingPoly -> Int
TilingPoly -> [TilingPoly]
TilingPoly -> TilingPoly
TilingPoly -> TilingPoly -> [TilingPoly]
TilingPoly -> TilingPoly -> TilingPoly -> [TilingPoly]
(TilingPoly -> TilingPoly)
-> (TilingPoly -> TilingPoly)
-> (Int -> TilingPoly)
-> (TilingPoly -> Int)
-> (TilingPoly -> [TilingPoly])
-> (TilingPoly -> TilingPoly -> [TilingPoly])
-> (TilingPoly -> TilingPoly -> [TilingPoly])
-> (TilingPoly -> TilingPoly -> TilingPoly -> [TilingPoly])
-> Enum 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
$csucc :: TilingPoly -> TilingPoly
succ :: TilingPoly -> TilingPoly
$cpred :: TilingPoly -> TilingPoly
pred :: TilingPoly -> TilingPoly
$ctoEnum :: Int -> TilingPoly
toEnum :: Int -> TilingPoly
$cfromEnum :: TilingPoly -> Int
fromEnum :: TilingPoly -> Int
$cenumFrom :: TilingPoly -> [TilingPoly]
enumFrom :: TilingPoly -> [TilingPoly]
$cenumFromThen :: TilingPoly -> TilingPoly -> [TilingPoly]
enumFromThen :: TilingPoly -> TilingPoly -> [TilingPoly]
$cenumFromTo :: TilingPoly -> TilingPoly -> [TilingPoly]
enumFromTo :: TilingPoly -> TilingPoly -> [TilingPoly]
$cenumFromThenTo :: TilingPoly -> TilingPoly -> TilingPoly -> [TilingPoly]
enumFromThenTo :: TilingPoly -> TilingPoly -> TilingPoly -> [TilingPoly]
Enum, TilingPoly
TilingPoly -> TilingPoly -> Bounded TilingPoly
forall a. a -> a -> Bounded a
$cminBound :: TilingPoly
minBound :: TilingPoly
$cmaxBound :: TilingPoly
maxBound :: 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  = String -> TilingPoly
forall a. HasCallStack => String -> a
error (String -> TilingPoly) -> String -> TilingPoly
forall a b. (a -> b) -> a -> b
$ String
"Bad polygon number: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
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
1Q236 -> Q236 -> Q236
forall a. Fractional a => a -> a -> a
/Q236
2
polyCos TilingPoly
Square    = Q236
0
polyCos TilingPoly
Hexagon   = -Q236
1Q236 -> Q236 -> Q236
forall a. Fractional a => a -> a -> a
/Q236
2
polyCos TilingPoly
Octagon   = -Q236
1Q236 -> Q236 -> Q236
forall a. Fractional a => a -> a -> a
/Q236
2
polyCos TilingPoly
Dodecagon = -Q236
1Q236 -> Q236 -> Q236
forall a. Fractional a => a -> a -> a
/Q236
2 Q236 -> Q236 -> Q236
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
1Q236 -> Q236 -> Q236
forall a. Fractional a => a -> a -> a
/Q236
2) Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
* Q236
rt3
polySin TilingPoly
Square    = Q236
1
polySin TilingPoly
Hexagon   = (Q236
1Q236 -> Q236 -> Q236
forall a. Fractional a => a -> a -> a
/Q236
2) Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
* Q236
rt3
polySin TilingPoly
Octagon   = (Q236
1Q236 -> Q236 -> Q236
forall a. Fractional a => a -> a -> a
/Q236
2) Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
* Q236
rt2
polySin TilingPoly
Dodecagon = Q236
1Q236 -> Q236 -> Q236
forall 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) = Q236 -> Q236 -> Q2
forall a. a -> a -> V2 a
V2 (Q236
xQ236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
*Q236
c Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
- Q236
yQ236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
*Q236
s) (Q236
xQ236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
*Q236
s Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
+ Q236
yQ236 -> Q236 -> Q236
forall 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) = Q236 -> Q236 -> Q2
forall a. a -> a -> V2 a
V2 (-Q236
xQ236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
*Q236
c Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
- Q236
yQ236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
*Q236
s) (Q236
xQ236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
*Q236
s Q236 -> Q236 -> Q236
forall a. Num a => a -> a -> a
- Q236
yQ236 -> Q236 -> Q236
forall 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
(Edge -> Edge -> Bool) -> (Edge -> Edge -> Bool) -> Eq Edge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
/= :: Edge -> Edge -> Bool
Eq, Eq Edge
Eq Edge =>
(Edge -> Edge -> Ordering)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Edge)
-> (Edge -> Edge -> Edge)
-> Ord 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
$ccompare :: Edge -> Edge -> Ordering
compare :: Edge -> Edge -> Ordering
$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
>= :: Edge -> Edge -> Bool
$cmax :: Edge -> Edge -> Edge
max :: Edge -> Edge -> Edge
$cmin :: Edge -> Edge -> Edge
min :: Edge -> Edge -> Edge
Ord, Int -> Edge -> ShowS
[Edge] -> ShowS
Edge -> String
(Int -> Edge -> ShowS)
-> (Edge -> String) -> ([Edge] -> ShowS) -> Show Edge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Edge -> ShowS
showsPrec :: Int -> Edge -> ShowS
$cshow :: Edge -> String
show :: Edge -> String
$cshowList :: [Edge] -> ShowS
showList :: [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 Q2 -> Q2 -> Bool
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
(Int -> Polygon -> ShowS)
-> (Polygon -> String) -> ([Polygon] -> ShowS) -> Show Polygon
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Polygon -> ShowS
showsPrec :: Int -> Polygon -> ShowS
$cshow :: Polygon -> String
show :: Polygon -> String
$cshowList :: [Polygon] -> ShowS
showList :: [Polygon] -> ShowS
Show

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

instance Ord Polygon where
  compare :: Polygon -> Polygon -> Ordering
compare = [Q2] -> [Q2] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Q2] -> [Q2] -> Ordering)
-> (Polygon -> [Q2]) -> Polygon -> Polygon -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ([Q2] -> [Q2]
forall a. Ord a => [a] -> [a]
sort ([Q2] -> [Q2]) -> (Polygon -> [Q2]) -> Polygon -> [Q2]
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 Set Q2
forall a. Set a
S.empty Set Edge
forall a. Set a
S.empty Set Polygon
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
  = State TilingState w -> TilingState -> w
forall s a. State s a -> s -> a
evalState (WriterT w (State TilingState) () -> State TilingState w
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (Tiling -> Q2 -> Q2 -> WriterT w (State TilingState) ()
generateTiling' Tiling
t Q2
v Q2
d)) TilingState
initTilingState where

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

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

          -- otherwise, mark it as visited
          (TilingState -> TilingState) -> WriterT w (State TilingState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TilingState
ts -> TilingState
ts { visitedVertices = v `S.insert` visitedVertices 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  = [Edge] -> Set Edge
forall a. Ord a => [a] -> Set a
S.fromList ([Edge] -> Set Edge) -> [Edge] -> Set Edge
forall a b. (a -> b) -> a -> b
$ (Q2 -> Edge) -> [Q2] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (Q2 -> Q2 -> Edge
mkEdge Q2
v) [Q2]
neighbors
              edges' :: Set Edge
edges' = Set Edge
edges Set Edge -> Set Edge -> Set Edge
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 Set Polygon -> Set Polygon -> Set Polygon
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` TilingState -> Set Polygon
visitedPolygons TilingState
ts

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

          -- remember that we generated them
          (TilingState -> TilingState) -> WriterT w (State TilingState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TilingState
ts -> TilingState
ts { visitedEdges = edges' `S.union` visitedEdges ts })
          (TilingState -> TilingState) -> WriterT w (State TilingState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TilingState
ts -> TilingState
ts { visitedPolygons = polys' `S.union` visitedPolygons ts })

          -- follow edges and continue recursively
          (Q2 -> Int -> WriterT w (State TilingState) ())
-> [Q2] -> [Int] -> WriterT w (State TilingState) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\Q2
d Int
i -> Tiling -> Q2 -> Q2 -> WriterT w (State TilingState) ()
generateTiling' (Tiling -> Int -> Tiling
follow Tiling
t Int
i) (Q2
v Q2 -> Q2 -> Q2
forall a. Num a => V2 a -> V2 a -> V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Q2
d) Q2
d)
            ((Q2 -> Q2) -> [Q2] -> [Q2]
forall a b. (a -> b) -> [a] -> [b]
map (Q2 -> Q2 -> Q2
forall a. Num a => V2 a -> V2 a -> V2 a
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, [Polygon] -> Set Polygon
forall a. Ord a => [a] -> Set a
S.fromList [Polygon]
polys) where
  ([Q2]
neighbors, [Polygon]
polys)
    = [(Q2, Polygon)] -> ([Q2], [Polygon])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Q2, Polygon)] -> ([Q2], [Polygon]))
-> ((Q2, [(Q2, Polygon)]) -> [(Q2, Polygon)])
-> (Q2, [(Q2, Polygon)])
-> ([Q2], [Polygon])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q2, [(Q2, Polygon)]) -> [(Q2, Polygon)]
forall a b. (a, b) -> b
snd
      ((Q2, [(Q2, Polygon)]) -> ([Q2], [Polygon]))
-> (Q2, [(Q2, Polygon)]) -> ([Q2], [Polygon])
forall a b. (a -> b) -> a -> b
$ (Q2 -> TilingPoly -> (Q2, (Q2, Polygon)))
-> Q2 -> [TilingPoly] -> (Q2, [(Q2, Polygon)])
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 Q2 -> Q2 -> Q2
forall a. Num a => V2 a -> V2 a -> V2 a
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')))
          (Q2 -> Q2
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
                ([Q2] -> Polygon) -> (Q2 -> [Q2]) -> Q2 -> Polygon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q2 -> Q2 -> Q2) -> Q2 -> [Q2] -> [Q2]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Q2 -> Q2 -> Q2
forall a. Num a => V2 a -> V2 a -> V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
(^+^) Q2
v
                ([Q2] -> [Q2]) -> (Q2 -> [Q2]) -> Q2 -> [Q2]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Q2] -> [Q2]
forall a. Int -> [a] -> [a]
take (TilingPoly -> Int
forall a. Num a => TilingPoly -> a
polySides TilingPoly
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                ([Q2] -> [Q2]) -> (Q2 -> [Q2]) -> Q2 -> [Q2]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q2 -> Q2) -> Q2 -> [Q2]
forall a. (a -> a) -> a -> [a]
iterate (TilingPoly -> Q2 -> Q2
polyExtRotation TilingPoly
p)
                (Q2 -> Polygon) -> Q2 -> Polygon
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) = (Q2 -> P2 n
forall n. Floating n => Q2 -> P2 n
toP2 Q2
v1 P2 n -> P2 n -> QDiagram b V2 n Any
forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, TrailLike t) =>
Point v n -> Point v n -> t
~~ Q2 -> P2 n
forall n. Floating n => Q2 -> P2 n
toP2 Q2
v2) QDiagram b V2 n Any
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. a -> (a -> b) -> b
# Style (V (QDiagram b V2 n Any)) (N (QDiagram b V2 n Any))
-> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle Style (V (QDiagram b V2 n Any)) (N (QDiagram b V2 n Any))
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 = Style (V (QDiagram b V2 n Any)) (N (QDiagram b V2 n Any))
-> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. HasStyle a => Style (V a) (N a) -> a -> a
applyStyle (Polygon -> Style V2 n
s Polygon
p) (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (Polygon -> QDiagram b V2 n Any)
-> Polygon
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Trail' Loop V2 n) -> QDiagram b V2 n Any
forall n b.
(TypeableFloat n, Renderable (Path V2 n) b) =>
Located (Trail' Loop V2 n) -> QDiagram b V2 n Any
strokeLocLoop (Located (Trail' Loop V2 n) -> QDiagram b V2 n Any)
-> (Polygon -> Located (Trail' Loop V2 n))
-> Polygon
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trail' Line V2 n -> Trail' Loop V2 n)
-> Located (Trail' Line V2 n) -> Located (Trail' Loop V2 n)
forall a b. SameSpace a b => (a -> b) -> Located a -> Located b
mapLoc Trail' Line V2 n -> Trail' Loop V2 n
forall (v :: * -> *) n. Trail' Line v n -> Trail' Loop v n
closeLine (Located (Trail' Line V2 n) -> Located (Trail' Loop V2 n))
-> (Polygon -> Located (Trail' Line V2 n))
-> Polygon
-> Located (Trail' Loop V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point
   (V (Located (Trail' Line V2 n))) (N (Located (Trail' Line V2 n)))]
-> Located (Trail' Line V2 n)
[Point V2 n] -> Located (Trail' Line V2 n)
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices ([Point V2 n] -> Located (Trail' Line V2 n))
-> (Polygon -> [Point V2 n])
-> Polygon
-> Located (Trail' Line V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q2 -> Point V2 n) -> [Q2] -> [Point V2 n]
forall a b. (a -> b) -> [a] -> [b]
map Q2 -> Point V2 n
forall n. Floating n => Q2 -> P2 n
toP2 ([Q2] -> [Point V2 n])
-> (Polygon -> [Q2]) -> Polygon -> [Point V2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> [Q2]
polygonVertices (Polygon -> QDiagram b V2 n Any) -> Polygon -> QDiagram b V2 n Any
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  = Colour a
forall a. (Ord a, Floating a) => Colour a
yellow
polyColor TilingPoly
Square    = Colour a
forall a. (Ord a, Floating a) => Colour a
mediumseagreen
polyColor TilingPoly
Hexagon   = Colour a
forall a. (Ord a, Floating a) => Colour a
blueviolet
polyColor TilingPoly
Octagon   = Colour a
forall a. (Ord a, Floating a) => Colour a
lightsteelblue
polyColor TilingPoly
Dodecagon = Colour a
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 =
  Style V2 n
-> (Polygon -> Style V2 n)
-> Tiling
-> n
-> n
-> QDiagram b V2 n Any
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
forall a. Monoid a => a
mempty
    (\Polygon
p -> Style V2 n
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 ((QDiagram b V2 n Any, QDiagram b V2 n Any) -> QDiagram b V2 n Any)
-> (QDiagram b V2 n Any, QDiagram b V2 n Any)
-> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ Tiling
-> Q2
-> Q2
-> (Q2 -> Bool)
-> (Edge -> (QDiagram b V2 n Any, QDiagram b V2 n Any))
-> (Polygon -> (QDiagram b V2 n Any, QDiagram b V2 n Any))
-> (QDiagram b V2 n Any, QDiagram b V2 n Any)
forall w.
Monoid w =>
Tiling
-> Q2 -> Q2 -> (Q2 -> Bool) -> (Edge -> w) -> (Polygon -> w) -> w
generateTiling Tiling
t (Q236 -> Q236 -> Q2
forall a. a -> a -> V2 a
V2 Q236
0 Q236
0) (Q236 -> Q236 -> Q2
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
            ((QDiagram b V2 n Any
 -> QDiagram b V2 n Any
 -> (QDiagram b V2 n Any, QDiagram b V2 n Any))
-> (Edge -> QDiagram b V2 n Any)
-> (Edge -> QDiagram b V2 n Any)
-> Edge
-> (QDiagram b V2 n Any, QDiagram b V2 n Any)
forall a b c.
(a -> b -> c) -> (Edge -> a) -> (Edge -> b) -> Edge -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Style V2 n -> Edge -> QDiagram b V2 n Any
forall n b.
(Renderable (Path V2 n) b, TypeableFloat n) =>
Style V2 n -> Edge -> QDiagram b V2 n Any
drawEdge Style V2 n
eStyle) Edge -> QDiagram b V2 n Any
forall a. Monoid a => a
mempty)
            ((QDiagram b V2 n Any
 -> QDiagram b V2 n Any
 -> (QDiagram b V2 n Any, QDiagram b V2 n Any))
-> (Polygon -> QDiagram b V2 n Any)
-> (Polygon -> QDiagram b V2 n Any)
-> Polygon
-> (QDiagram b V2 n Any, QDiagram b V2 n Any)
forall a b c.
(a -> b -> c) -> (Polygon -> a) -> (Polygon -> b) -> Polygon -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Polygon -> QDiagram b V2 n Any
forall a. Monoid a => a
mempty ((Polygon -> Style V2 n) -> Polygon -> QDiagram b V2 n Any
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 (Q2 -> V2 n
forall n. Floating n => Q2 -> V2 n
toV2 -> V2 n
x n
y) = -n
wn -> n -> n
forall a. Fractional a => a -> a -> a
/n
2 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
x Bool -> Bool -> Bool
&& n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
wn -> n -> n
forall a. Fractional a => a -> a -> a
/n
2 Bool -> Bool -> Bool
&& -n
hn -> n -> n
forall a. Fractional a => a -> a -> a
/n
2 n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
y Bool -> Bool -> Bool
&& n
y n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
hn -> n -> n
forall 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 QDiagram b V2 n Any -> QDiagram b V2 n Any -> QDiagram b V2 n Any
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 = D V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
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 (n -> n -> D V2 n
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 (Int -> TilingPoly -> [TilingPoly]
forall a. Int -> a -> [a]
replicate Int
6 TilingPoly
Triangle) (Tiling -> Int -> Tiling
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 (Int -> TilingPoly -> [TilingPoly]
forall a. Int -> a -> [a]
replicate Int
4 TilingPoly
Square) (Tiling -> Int -> Tiling
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 (Int -> TilingPoly -> [TilingPoly]
forall a. Int -> a -> [a]
replicate Int
3 TilingPoly
Hexagon) (Tiling -> Int -> Tiling
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
          ((Int -> TilingPoly) -> [Int] -> [TilingPoly]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TilingPoly
forall a. (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides [Int]
ps)
          (\Int
i -> case Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 of
                   Int
0 -> [Int] -> Tiling
mk3Tiling ([Int] -> [Int]
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
_ -> String -> Tiling
forall a. HasCallStack => String -> a
error String
"i `mod` 3 is not 0, 1,or 2! the sky is falling!"
          )
mk3Tiling [Int]
_ = String -> Tiling
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 ((Int -> TilingPoly) -> [Int] -> [TilingPoly]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TilingPoly
forall a. (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides [Int]
ps)
                        (\Int
i -> [Int] -> Tiling
mkT ([Int] -> Tiling) -> [Int] -> Tiling
forall a b. (a -> b) -> a -> b
$ if Int -> Bool
forall a. Integral a => a -> Bool
even Int
i then [Int] -> [Int]
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
                  ((Int -> TilingPoly) -> [Int] -> [TilingPoly]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TilingPoly
forall a. (Num a, Eq a, Show a) => a -> TilingPoly
polyFromSides (Int -> [Int] -> [Int]
forall a t. (Num a, Eq a) => a -> [t] -> [t]
rot Int
i [Int]
ps))
                  (\Int
j -> Int -> Tiling
mkT (Int -> Tiling) -> Int -> Tiling
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a t. (Num a, Eq a) => a -> [t] -> [t]
rot Int
i [Int]
trans [Int] -> Int -> Int
forall a. HasCallStack => [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) = a -> [t] -> [t]
forall a t. (Num a, Eq a) => a -> [t] -> [t]
rot (a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1) ([t]
xs [t] -> [t] -> [t]
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