{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Diagrams.TwoD.Tilings (
Q236, rt2, rt3, rt6
, toFloating
, Q2, toV2, toP2
, TilingPoly(..)
, polySides, polyFromSides
, polyCos, polySin
, polyRotation, polyExtRotation
, Tiling(..)
, Edge, mkEdge
, Polygon(..)
, TilingState(..), initTilingState
, TilingM
, generateTiling
, t3, t4, t6
, mk3Tiling, t4612, t488, t31212
, t3636
, semiregular
, rot
, t3464, t33434, t33344, t33336L, t33336R
, drawEdge
, drawPoly
, polyColor
, drawTiling
, drawTilingStyled
) where
import Control.Monad.State
#if __GLASGOW_HASKELL__ >= 704
import Control.Monad.Writer hiding ((<>))
#else
import Control.Monad.Writer
#endif
import Data.Function (on)
import Data.List (mapAccumL, sort)
import qualified Data.Foldable as F
import qualified Data.Set as S
import Data.Colour
import Diagrams.Prelude
data Q236 = Q236 Rational Rational Rational Rational
deriving (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)
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
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
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
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
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
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
data Tiling = Tiling { Tiling -> [TilingPoly]
curConfig :: [TilingPoly]
, Tiling -> Int -> Tiling
follow :: Int -> Tiling
}
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)
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
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)
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
type TilingM w a = WriterT w (State TilingState) a
generateTiling :: forall w. Monoid w
=> Tiling
-> Q2
-> Q2
-> (Q2 -> Bool)
-> (Edge -> w)
-> (Polygon -> w)
-> w
generateTiling :: 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
| 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
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
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 })
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
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'
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 })
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..]
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)
genPolyVs :: TilingPoly
-> Q2
-> Q2
-> 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
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
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
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
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
)
)
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
(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)
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)
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)
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)
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."
t4612 :: Tiling
t4612 :: Tiling
t4612 = [Int] -> Tiling
mk3Tiling [Int
4,Int
6,Int
12]
t488 :: Tiling
t488 :: Tiling
t488 = [Int] -> Tiling
mk3Tiling [Int
4,Int
8,Int
8]
t31212 :: Tiling
t31212 :: Tiling
t31212 = [Int] -> Tiling
mk3Tiling [Int
3,Int
12,Int
12]
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)
semiregular :: [Int]
-> [Int]
-> 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])
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]
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]
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]
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]
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]