{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
module UU.UUAGC.Diagrams
(production, child, agrule, indrule,
shaftL, shaftR, shaftT, shaftB, shaftD,
(#),
AGDiagram, AGBackend, Child) where
import Diagrams.Prelude
import Graphics.SVGFonts (svgText, Spacing (..), TextOpts (..), lin2
,fit_height, set_envelope)
import Data.List (isPrefixOf)
import System.IO.Unsafe (unsafePerformIO)
production :: AGBackend b =>
[String] -> String -> [String] -> [Child b] -> AGDiagram b
production :: forall b.
AGBackend b =>
[String] -> String -> [String] -> [Child b] -> AGDiagram b
production = forall b.
AGBackend b =>
Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node Bool
True
newtype Child b = Child { forall b. Child b -> AGDiagram b
unChild :: AGDiagram b }
child :: AGBackend b => [String] -> String -> [String] -> Child b
child :: forall b. AGBackend b => [String] -> String -> [String] -> Child b
child [String]
i String
n [String]
s = forall b. AGDiagram b -> Child b
Child forall a b. (a -> b) -> a -> b
$ forall b.
AGBackend b =>
Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node Bool
False [String]
i String
n [String]
s []
agrule :: AGBackend b =>
Trail V2 Double -> String -> String -> AGDiagram b -> AGDiagram b
agrule :: forall b.
AGBackend b =>
Trail V2 Double -> String -> String -> AGDiagram b -> AGDiagram b
agrule Trail V2 Double
sh String
s1 String
s2 = forall n b n1 n2.
(TypeableFloat n, Renderable (Path V2 n) b, IsName n1,
IsName n2) =>
ArrowOpts n
-> n1
-> n2
-> Angle n
-> Angle n
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
connectPerim' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Measure n)
headLength forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall n. Num n => n -> Measure n
normalized Double
0.025) forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Trail V2 n)
arrowShaft forall s t a b. ASetter s t a b -> b -> s -> t
.~ Trail V2 Double
sh) String
n1 String
n2 (forall {b}. Floating b => Bool -> Angle b
tb Bool
t1) (forall {b}. Floating b => Bool -> Angle b
tb Bool
t2) where
t1 :: Bool
t1 = String
"lhs." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s1
t2 :: Bool
t2 = String
"lhs." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s2
n1 :: String
n1 | Char
'.' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
s1 = String
s1
| Bool
t1 = String
s1 forall a. [a] -> [a] -> [a]
++ String
".inh"
| Bool
otherwise = String
s1 forall a. [a] -> [a] -> [a]
++ String
".syn"
n2 :: String
n2 = if Bool
t2 then String
s2 forall a. [a] -> [a] -> [a]
++ String
".syn" else String
s2 forall a. [a] -> [a] -> [a]
++ String
".inh"
tb :: Bool -> Angle b
tb Bool
False = b
90 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
deg
tb Bool
True = b
270 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
deg
indrule :: AGBackend b => String -> String -> AGDiagram b -> AGDiagram b
indrule :: forall b.
AGBackend b =>
String -> String -> AGDiagram b -> AGDiagram b
indrule String
s1 String
s2 = forall n b n1 n2.
(TypeableFloat n, Renderable (Path V2 n) b, IsName n1,
IsName n2) =>
ArrowOpts n
-> n1
-> n2
-> Angle n
-> Angle n
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
connectPerim' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Measure n)
headLength forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall n. Num n => n -> Measure n
normalized Double
0.025) forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Trail V2 n)
arrowShaft forall s t a b. ASetter s t a b -> b -> s -> t
.~ Trail V2 Double
shaftB forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (Style V2 n)
shaftStyle forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Style V2 Double -> Style V2 Double
dashed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasStyle a => Double -> a -> a
opacity Double
0.5) String
n1 String
n2 Angle Double
tb Angle Double
tb where
t :: Bool
t = String
"lhs." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s1
n1 :: String
n1 = if Bool
t then String
s1 forall a. [a] -> [a] -> [a]
++ String
".syn" else String
s1 forall a. [a] -> [a] -> [a]
++ String
".inh"
n2 :: String
n2 = if Bool
t then String
s2 forall a. [a] -> [a] -> [a]
++ String
".inh" else String
s2 forall a. [a] -> [a] -> [a]
++ String
".syn"
tb :: Angle Double
tb = if Bool
t then Double
90 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
deg else Double
270 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
deg
dashed :: Style V2 Double -> Style V2 Double
dashed = forall a n.
(N a ~ n, HasStyle a, Typeable n, Num n) =>
[n] -> n -> a -> a
dashingN [N (Style V2 Double)
0.01,N (Style V2 Double)
0.01] N (Style V2 Double)
0
shaftL, shaftR, shaftT, shaftB, shaftD :: Trail V2 Double
shaftL :: Trail V2 Double
shaftL = forall t. TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments [forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (forall n. (n, n) -> V2 n
r2 (Double
0.5,Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
0.5,-Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
1,Double
0))]
shaftR :: Trail V2 Double
shaftR = forall t. TrailLike t => [Segment Closed (V t) (N t)] -> t
fromSegments [forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 (forall n. (n, n) -> V2 n
r2 (Double
0.5,-Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
0.5,Double
0.3)) (forall n. (n, n) -> V2 n
r2 (Double
1,Double
0))]
shaftT :: Trail V2 Double
shaftT = forall n t.
(InSpace V2 n t, OrderedField n, TrailLike t) =>
Direction V2 n -> Angle n -> t
arc forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir (-Double
3forall a. Fractional a => a -> a -> a
/Double
5 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)
shaftB :: Trail V2 Double
shaftB = forall n t.
(InSpace V2 n t, OrderedField n, TrailLike t) =>
Direction V2 n -> Angle n -> t
arc forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir (Double
2forall a. Fractional a => a -> a -> a
/Double
5 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)
shaftD :: Trail V2 Double
shaftD = forall n. OrderedField n => Trail V2 n
straightShaft
type AGDiagram b = QDiagram b V2 Double Any
class (Renderable (Path V2 Double) b, Backend b (V b) Double) => AGBackend b where
instance (Renderable (Path V2 Double) b, Backend b (V b) Double) => AGBackend b
attr :: AGBackend b =>
String -> Bool -> (String -> String) -> AGDiagram b
attr :: forall b.
AGBackend b =>
String -> Bool -> (String -> String) -> AGDiagram b
attr String
s Bool
t String -> String
f = forall {m} {n} {b}.
(Monoid m, Ord n, Floating n) =>
Bool -> QDiagram b V2 n m -> QDiagram b V2 n m -> QDiagram b V2 n m
stack Bool
t (forall n t. (InSpace V2 n t, TrailLike t) => t
unitSquare forall a b. a -> (a -> b) -> b
# forall nm (v :: * -> *) n m b.
(IsName nm, Metric v, OrderedField n, Semigroup m) =>
nm -> QDiagram b v n m -> QDiagram b v n m
named (String -> String
f String
s) forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. Num a => Colour a
black) (forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
0.7 String
s) where
stack :: Bool -> QDiagram b V2 n m -> QDiagram b V2 n m -> QDiagram b V2 n m
stack Bool
True QDiagram b V2 n m
a QDiagram b V2 n m
b = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY QDiagram b V2 n m
a (QDiagram b V2 n m
b forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY n
0.2)
stack Bool
False QDiagram b V2 n m
a QDiagram b V2 n m
b = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside (-forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY) QDiagram b V2 n m
a (forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY n
0.2 forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== QDiagram b V2 n m
b)
node :: AGBackend b =>
Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node :: forall b.
AGBackend b =>
Bool -> [String] -> String -> [String] -> [Child b] -> AGDiagram b
node Bool
top [String]
inh String
s [String]
syn [Child b]
ch = QDiagram b V2 Double Any
res forall a b. a -> (a -> b) -> b
# forall a. [a -> a] -> a -> a
applyAll [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
lines where
res :: QDiagram b V2 Double Any
res = QDiagram b V2 Double Any
toprow
forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
===
(if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Child b]
ch then forall a. Monoid a => a
mempty else forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY Double
2)
forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
===
(forall {a}.
(V a ~ V2, Floating (N a), Juxtaposable a, HasOrigin a,
Monoid a) =>
N a -> [a] -> a
hcats Double
1.5 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall b. Child b -> AGDiagram b
unChild [Child b]
ch) forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerX
lines :: [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
lines = [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
alines forall a. [a] -> [a] -> [a]
++ [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
chLines
chLines :: [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
chLines = [ forall n1 n2 b.
(IsName n1, IsName n2, AGBackend b) =>
n1 -> n2 -> AGDiagram b -> AGDiagram b
line String
name (forall b. AGDiagram b -> Name
getName forall a b. (a -> b) -> a -> b
$ forall b. Child b -> AGDiagram b
unChild Child b
c) forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. (Ord a, Floating a) => Colour a
grey | Child b
c <- [Child b]
ch ]
hcats :: N a -> [a] -> a
hcats N a
s = forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
Monoid' a) =>
CatOpts n -> [a] -> a
hcat' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (CatOpts n) n
sep forall s t a b. ASetter s t a b -> b -> s -> t
.~ N a
s)
els :: [QDiagram b V2 Double Any]
els = [QDiagram b V2 Double Any]
inhs forall a. [a] -> [a] -> [a]
++ [QDiagram b V2 Double Any
lhs] forall a. [a] -> [a] -> [a]
++ [QDiagram b V2 Double Any]
syns
toprow :: QDiagram b V2 Double Any
toprow = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX (
forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside (-forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX) QDiagram b V2 Double Any
lhs
(forall {a}.
(V a ~ V2, Floating (N a), Juxtaposable a, HasOrigin a,
Monoid a) =>
N a -> [a] -> a
hcats Double
0.3 [QDiagram b V2 Double Any]
inhs forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
||| forall (v :: * -> *) n b m.
(Metric v, R1 v, OrderedField n) =>
n -> QDiagram b v n m
strutX Double
0.3))
(forall (v :: * -> *) n b m.
(Metric v, R1 v, OrderedField n) =>
n -> QDiagram b v n m
strutX Double
0.3 forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
||| forall {a}.
(V a ~ V2, Floating (N a), Juxtaposable a, HasOrigin a,
Monoid a) =>
N a -> [a] -> a
hcats Double
0.3 [QDiagram b V2 Double Any]
syns)
inhs :: [QDiagram b V2 Double Any]
inhs = forall a b. (a -> b) -> [a] -> [b]
map (\String
i -> forall b.
AGBackend b =>
String -> Bool -> (String -> String) -> AGDiagram b
attr String
i Bool
top (\String
n -> String
name forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
".inh")) [String]
inh
syns :: [QDiagram b V2 Double Any]
syns = forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> forall b.
AGBackend b =>
String -> Bool -> (String -> String) -> AGDiagram b
attr String
s Bool
top (\String
n -> String
name forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
".syn")) [String]
syn
alines :: [QDiagram b V2 Double Any -> QDiagram b V2 Double Any]
alines = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall n1 n2 b.
(IsName n1, IsName n2, AGBackend b) =>
n1 -> n2 -> AGDiagram b -> AGDiagram b
line (forall a b. (a -> b) -> [a] -> [b]
map forall b. AGDiagram b -> Name
getName [QDiagram b V2 Double Any]
els) (forall a b. (a -> b) -> [a] -> [b]
map forall b. AGDiagram b -> Name
getName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [QDiagram b V2 Double Any]
els) forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. (Ord a, Floating a) => Colour a
grey
name :: String
name = if Bool
top then String
"lhs" else String
s
lhs :: QDiagram b V2 Double Any
lhs = forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside (-forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY) (
forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY
(forall t n.
(TrailLike t, V t ~ V2, N t ~ n, Transformable t) =>
n -> t
circle Double
0.5 forall a b. a -> (a -> b) -> b
# forall nm (v :: * -> *) n m b.
(IsName nm, Metric v, OrderedField n, Semigroup m) =>
nm -> QDiagram b v n m -> QDiagram b v n m
named String
name forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc forall a. (Ord a, Floating a) => Colour a
grey)
(if Bool
top then (forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
0.9 String
s forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY Double
0.1) else forall a. Monoid a => a
mempty))
(forall (v :: * -> *) n b m.
(Metric v, R2 v, OrderedField n) =>
n -> QDiagram b v n m
strutY Double
0.1 forall n a.
(InSpace V2 n a, Juxtaposable a, Semigroup a) =>
a -> a -> a
=== forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
0.9 String
name)
{-# NOINLINE lin2' #-}
lin2' :: PreparedFont Double
lin2' = forall a. IO a -> a
unsafePerformIO forall n. (Read n, RealFloat n) => IO (PreparedFont n)
lin2
text' :: AGBackend b =>
Double -> String -> AGDiagram b
text' :: forall b. AGBackend b => Double -> String -> AGDiagram b
text' Double
d String
s = String
s forall a b. a -> (a -> b) -> b
# forall n. RealFloat n => TextOpts n -> String -> PathInRect n
svgText forall d. Default d => d
def { textFont :: PreparedFont Double
textFont = PreparedFont Double
lin2' } forall a b. a -> (a -> b) -> b
# forall n. RealFloat n => n -> PathInRect n -> PathInRect n
fit_height Double
d forall a b. a -> (a -> b) -> b
# forall b n.
(TypeableFloat n, Renderable (Path V2 n) b) =>
PathInRect n -> QDiagram b V2 n Any
set_envelope forall a b. a -> (a -> b) -> b
# forall a n.
(N a ~ n, HasStyle a, Typeable n) =>
Measure n -> a -> a
lw forall n. OrderedField n => Measure n
none forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Floating n, Typeable n, HasStyle a) =>
Colour Double -> a -> a
fc forall a. Num a => Colour a
black forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, R1 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerX
line :: (IsName n1, IsName n2, AGBackend b) =>
n1 -> n2 -> AGDiagram b -> AGDiagram b
line :: forall n1 n2 b.
(IsName n1, IsName n2, AGBackend b) =>
n1 -> n2 -> AGDiagram b -> AGDiagram b
line n1
a n2
b = forall n b n1 n2.
(TypeableFloat n, Renderable (Path V2 n) b, IsName n1,
IsName n2) =>
ArrowOpts n
-> n1 -> n2 -> QDiagram b V2 n Any -> QDiagram b V2 n Any
connectOutside' (forall d. Default d => d
with forall a b. a -> (a -> b) -> b
& forall n. Lens' (ArrowOpts n) (ArrowHT n)
arrowHead forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall n. ArrowHT n
noHead) n1
a n2
b
getName :: AGDiagram b -> Name
getName :: forall b. AGDiagram b -> Name
getName = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) m n b.
(Metric v, Semigroup m, OrderedField n) =>
QDiagram b v n m -> [(Name, [Point v n])]
names