{-# LANGUAGE RecordWildCards #-}

-- | The geometry behind the SVG rendering of cubes, and nothing else.
--
-- Rzk renders a (sub)shape of a cube as an SVG diagram: the vertices, edges and
-- faces of the unit cube are projected to the plane through a camera, and each
-- of them is labelled with the term that inhabits it. This module holds the part
-- of that story which knows nothing about terms: the projection matrices, the
-- camera, and 'renderCube', which draws a cube given only a function saying what
-- (if anything) to draw on each of its parts.
--
-- Nothing here mentions the type checker, so it is shared by both term
-- representations during the free-foil migration.
module Rzk.Render.Geometry where

import           Data.List (intercalate, tails)

-- | The name of a vertex of the unit cube, as a string of coordinates
-- (e.g. @"010"@).
type PointId = String

-- | The name of a subshape of the unit cube: its vertices, in order, joined by
-- dashes (e.g. @"000-011"@ for an edge, @"000"@ for a vertex).
type ShapeId = [PointId]

type Point2D a = (a, a)
type Point3D a = (a, a, a)
type Edge3D a = (Point3D a, Point3D a)
type Face3D a = (Point3D a, Point3D a, Point3D a)
type Volume3D a = (Point3D a, Point3D a, Point3D a, Point3D a)

data CubeCoords2D a b = CubeCoords2D
  { forall a b. CubeCoords2D a b -> [(Point3D a, Point2D b)]
vertices :: [(Point3D a, Point2D b)]
  , forall a b.
CubeCoords2D a b -> [(Edge3D a, (Point2D b, Point2D b))]
edges    :: [(Edge3D a, (Point2D b, Point2D b))]
  , forall a b.
CubeCoords2D a b -> [(Face3D a, (Point2D b, Point2D b, Point2D b))]
faces    :: [(Face3D a, (Point2D b, Point2D b, Point2D b))]
  , forall a b.
CubeCoords2D a b
-> [(Volume3D a, (Point2D b, Point2D b, Point2D b, Point2D b))]
volumes  :: [(Volume3D a, (Point2D b, Point2D b, Point2D b, Point2D b))]
  }

data Matrix3D a = Matrix3D
  a a a
  a a a
  a a a

data Matrix4D a = Matrix4D
  a a a a
  a a a a
  a a a a
  a a a a

data Vector3D a = Vector3D a a a

data Vector4D a = Vector4D a a a a

rotateX :: Floating a => a -> Matrix3D a
rotateX :: forall a. Floating a => a -> Matrix3D a
rotateX a
theta = a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  a
1 a
0 a
0
  a
0 (a -> a
forall a. Floating a => a -> a
cos a
theta) (- a -> a
forall a. Floating a => a -> a
sin a
theta)
  a
0 (a -> a
forall a. Floating a => a -> a
sin a
theta) (a -> a
forall a. Floating a => a -> a
cos a
theta)

rotateY :: Floating a => a -> Matrix3D a
rotateY :: forall a. Floating a => a -> Matrix3D a
rotateY a
theta = a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  (a -> a
forall a. Floating a => a -> a
cos a
theta) a
0 (a -> a
forall a. Floating a => a -> a
sin a
theta)
  a
0 a
1 a
0
  (- a -> a
forall a. Floating a => a -> a
sin a
theta) a
0 (a -> a
forall a. Floating a => a -> a
cos a
theta)

rotateZ :: Floating a => a -> Matrix3D a
rotateZ :: forall a. Floating a => a -> Matrix3D a
rotateZ a
theta = a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
forall a. a -> a -> a -> a -> a -> a -> a -> a -> a -> Matrix3D a
Matrix3D
  (a -> a
forall a. Floating a => a -> a
cos a
theta) (- a -> a
forall a. Floating a => a -> a
sin a
theta) a
0
  (a -> a
forall a. Floating a => a -> a
sin a
theta) (a -> a
forall a. Floating a => a -> a
cos a
theta) a
0
  a
0 a
0 a
1

data Camera a = Camera
  { forall a. Camera a -> Point3D a
cameraPos         :: Point3D a
  , forall a. Camera a -> a
cameraFoV         :: a
  , forall a. Camera a -> a
cameraAspectRatio :: a
  , forall a. Camera a -> a
cameraAngleY      :: a
  , forall a. Camera a -> a
cameraAngleX      :: a
  }

viewRotateX :: Floating a => Camera a -> Matrix4D a
viewRotateX :: forall a. Floating a => Camera a -> Matrix4D a
viewRotateX Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = Matrix3D a -> Matrix4D a
forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (a -> Matrix3D a
forall a. Floating a => a -> Matrix3D a
rotateX a
cameraAngleX)

viewRotateY :: Floating a => Camera a -> Matrix4D a
viewRotateY :: forall a. Floating a => Camera a -> Matrix4D a
viewRotateY Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = Matrix3D a -> Matrix4D a
forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (a -> Matrix3D a
forall a. Floating a => a -> Matrix3D a
rotateY a
cameraAngleY)

viewTranslate :: Num a => Camera a -> Matrix4D a
viewTranslate :: forall a. Num a => Camera a -> Matrix4D a
viewTranslate Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
forall a.
a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
Matrix4D
  a
1 a
0 a
0 a
0
  a
0 a
1 a
0 a
0
  a
0 a
0 a
1 a
0
  (-a
x) (-a
y) (-a
z) a
1
  where
    (a
x, a
y, a
z) = Point3D a
cameraPos

project2D :: Floating a => Camera a -> Matrix4D a
project2D :: forall a. Floating a => Camera a -> Matrix4D a
project2D Camera{a
Point3D a
cameraPos :: forall a. Camera a -> Point3D a
cameraFoV :: forall a. Camera a -> a
cameraAspectRatio :: forall a. Camera a -> a
cameraAngleY :: forall a. Camera a -> a
cameraAngleX :: forall a. Camera a -> a
cameraPos :: Point3D a
cameraFoV :: a
cameraAspectRatio :: a
cameraAngleY :: a
cameraAngleX :: a
..} = a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
forall a.
a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
Matrix4D
  (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l)) a
0 ((a
r a -> a -> a
forall a. Num a => a -> a -> a
+ a
l) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l)) a
0
  a
0 (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
b)) ((a
t a -> a -> a
forall a. Num a => a -> a -> a
+ a
b) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
b)) a
0
  a
0 a
0 (- (a
f a -> a -> a
forall a. Num a => a -> a -> a
+ a
n) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
f a -> a -> a
forall a. Num a => a -> a -> a
- a
n)) (- a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
f a -> a -> a
forall a. Num a => a -> a -> a
* a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
f a -> a -> a
forall a. Num a => a -> a -> a
- a
n))
  a
0 a
0 (-a
1) a
0
  where
    n :: a
n = a
1
    f :: a
f = a
2
    r :: a
r = a
n a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
tan (a
cameraFoV a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2)
    l :: a
l = -a
r
    t :: a
t = a
r a -> a -> a
forall a. Num a => a -> a -> a
* a
cameraAspectRatio
    b :: a
b = -a
t


matrixVectorMult4D :: Num a => Matrix4D a -> Vector4D a -> Vector4D a
matrixVectorMult4D :: forall a. Num a => Matrix4D a -> Vector4D a -> Vector4D a
matrixVectorMult4D
  (Matrix4D
    a
a1 a
a2 a
a3 a
a4
    a
b1 a
b2 a
b3 a
b4
    a
c1 a
c2 a
c3 a
c4
    a
d1 a
d2 a
d3 a
d4)
  (Vector4D a
a a
b a
c a
d)
    = a -> a -> a -> a -> Vector4D a
forall a. a -> a -> a -> a -> Vector4D a
Vector4D a
a' a
b' a
c' a
d'
  where
    a' :: a
a' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a1, a
b1, a
c1, a
d1] [a
a, a
b, a
c, a
d])
    b' :: a
b' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a2, a
b2, a
c2, a
d2] [a
a, a
b, a
c, a
d])
    c' :: a
c' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a3, a
b3, a
c3, a
d3] [a
a, a
b, a
c, a
d])
    d' :: a
d' = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(*) [a
a4, a
b4, a
c4, a
d4] [a
a, a
b, a
c, a
d])

matrix3Dto4D :: Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D :: forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D
  (Matrix3D
    a
a1 a
b1 a
c1
    a
a2 a
b2 a
c2
    a
a3 a
b3 a
c3) = a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
forall a.
a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> a
-> Matrix4D a
Matrix4D
      a
a1 a
b1 a
c1 a
0
      a
a2 a
b2 a
c2 a
0
      a
a3 a
b3 a
c3 a
0
      a
0 a
0 a
0 a
1

fromAffine :: Fractional a => Vector4D a -> (Point2D a, a)
fromAffine :: forall a. Fractional a => Vector4D a -> (Point2D a, a)
fromAffine (Vector4D a
a a
b a
c a
d) = ((a
x, a
y), a
zIndex)
  where
    x :: a
x = a
a a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
d
    y :: a
y = a
b a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
d
    zIndex :: a
zIndex = a
c a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
d

point3Dto2D :: Floating a => Camera a -> a -> Point3D a -> (Point2D a, a)
point3Dto2D :: forall a.
Floating a =>
Camera a -> a -> Point3D a -> (Point2D a, a)
point3Dto2D Camera a
camera a
rotY (a
x, a
y, a
z) = Vector4D a -> (Point2D a, a)
forall a. Fractional a => Vector4D a -> (Point2D a, a)
fromAffine (Vector4D a -> (Point2D a, a)) -> Vector4D a -> (Point2D a, a)
forall a b. (a -> b) -> a -> b
$
  (Matrix4D a -> Vector4D a -> Vector4D a)
-> Vector4D a -> [Matrix4D a] -> Vector4D a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Matrix4D a -> Vector4D a -> Vector4D a
forall a. Num a => Matrix4D a -> Vector4D a -> Vector4D a
matrixVectorMult4D (a -> a -> a -> a -> Vector4D a
forall a. a -> a -> a -> a -> Vector4D a
Vector4D a
x a
y a
z a
1) ([Matrix4D a] -> Vector4D a) -> [Matrix4D a] -> Vector4D a
forall a b. (a -> b) -> a -> b
$ [Matrix4D a] -> [Matrix4D a]
forall a. [a] -> [a]
reverse
    [ Matrix3D a -> Matrix4D a
forall a. Num a => Matrix3D a -> Matrix4D a
matrix3Dto4D (a -> Matrix3D a
forall a. Floating a => a -> Matrix3D a
rotateY a
rotY)
    , Camera a -> Matrix4D a
forall a. Num a => Camera a -> Matrix4D a
viewTranslate Camera a
camera
    , Camera a -> Matrix4D a
forall a. Floating a => Camera a -> Matrix4D a
viewRotateY Camera a
camera
    , Camera a -> Matrix4D a
forall a. Floating a => Camera a -> Matrix4D a
viewRotateX Camera a
camera
    , Camera a -> Matrix4D a
forall a. Floating a => Camera a -> Matrix4D a
project2D Camera a
camera
    ]

-- | What to draw on one part (vertex, edge or face) of a cube.
data RenderObjectData = RenderObjectData
  { RenderObjectData -> String
renderObjectDataLabel     :: String
  , RenderObjectData -> String
renderObjectDataFullLabel :: String
  , RenderObjectData -> String
renderObjectDataColor     :: String
  }

limitLength :: Int -> String -> String
limitLength :: Int -> String -> String
limitLength Int
n String
s
  | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = Int -> String -> String
forall a. Int -> [a] -> [a]
take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"…"
  | Bool
otherwise    = String
s

-- | Apply the term-hiding policy to a cell's render data: drop the @\<title\>@
-- (the full term) from every cell, and blank the visible label of a
-- proof-coloured (interior) cell. Boundary cells (coloured otherwise) keep
-- their given labels. A no-op when not hiding.
hideTermData :: Bool -> String -> RenderObjectData -> RenderObjectData
hideTermData :: Bool -> String -> RenderObjectData -> RenderObjectData
hideTermData Bool
False String
_ RenderObjectData
d = RenderObjectData
d
hideTermData Bool
True  String
mainColor RenderObjectData
d
  | RenderObjectData -> String
renderObjectDataColor RenderObjectData
d String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
mainColor =
      RenderObjectData
d { renderObjectDataLabel = "", renderObjectDataFullLabel = "" }
  | Bool
otherwise = RenderObjectData
d { renderObjectDataFullLabel = "" }

renderCube
  :: (Floating a, Show a)
  => Camera a
  -> a
  -> (String -> Maybe RenderObjectData)
  -> String
renderCube :: forall a.
(Floating a, Show a) =>
Camera a -> a -> (String -> Maybe RenderObjectData) -> String
renderCube Camera a
camera a
rotY String -> Maybe RenderObjectData
renderDataOf' = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
  [ String
"<svg class=\"rzk-render\" viewBox=\"-175 -200 350 375\" width=\"150\" height=\"150\">"
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <path d=\"M " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y1
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" L " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y2
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" L " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x3 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y3
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Z\" style=\"fill: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; opacity: 0.2\"><title>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataFullLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</title></path>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
        String
"  <text x=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</text>"
      | (String
faceId, (((a
x1, a
y1), (a
x2, a
y2), (a
x3, a
y3)), Int
_)) <- [(String, (((a, a), (a, a), (a, a)), Int))]
faces
      , Just RenderObjectData{String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataColor :: String
renderObjectDataFullLabel :: String
renderObjectDataLabel :: String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
faceId]
      , let x :: a
x = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3
      , let y :: a
y = (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3 ]
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <polyline points=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x2 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"," String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y2
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" stroke=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" stroke-width=\"3\" marker-end=\"url(#arrow)\"><title>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataFullLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</title></polyline>" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
        String
"  <text x=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" stroke=\"white\" stroke-width=\"10\" stroke-opacity=\".8\" paint-order=\"stroke\">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</text>"
      | (String
edge, (((a
x1, a
y1), (a
x2, a
y2)), Int
_)) <- [(String, (((a, a), (a, a)), Int))]
edges
      , Just RenderObjectData{String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataColor :: String
renderObjectDataFullLabel :: String
renderObjectDataLabel :: String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
edge]
      , let x :: a
x = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2
      , let y :: a
y = (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
2 ]
  , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
      [ String
"  <text x=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" y=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\" fill=\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataColor String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\">" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
renderObjectDataLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"</text>"
      | (String
v, ((a
x, a
y), a
_)) <- [(String, ((a, a), a))]
vertices
      , Just RenderObjectData{String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataColor :: String
renderObjectDataLabel :: String
renderObjectDataFullLabel :: String
..} <- [String -> Maybe RenderObjectData
renderDataOf String
v]]
  , String
"</svg>" ]
  where
    renderDataOf :: String -> Maybe RenderObjectData
renderDataOf String
shapeId =
      case String -> Maybe RenderObjectData
renderDataOf' String
shapeId of
        Maybe RenderObjectData
Nothing -> Maybe RenderObjectData
forall a. Maybe a
Nothing
        Just RenderObjectData{String
renderObjectDataLabel :: RenderObjectData -> String
renderObjectDataFullLabel :: RenderObjectData -> String
renderObjectDataColor :: RenderObjectData -> String
renderObjectDataLabel :: String
renderObjectDataFullLabel :: String
renderObjectDataColor :: String
..} -> RenderObjectData -> Maybe RenderObjectData
forall a. a -> Maybe a
Just RenderObjectData
          -- FIXME: move constants to configurable parameters
          { renderObjectDataLabel :: String
renderObjectDataLabel = String -> Int -> String -> String
forall {t :: * -> *}.
Foldable t =>
t Char -> Int -> String -> String
hideWhenLargerThan String
shapeId Int
5 String
renderObjectDataLabel
          , renderObjectDataFullLabel :: String
renderObjectDataFullLabel = Int -> String -> String
limitLength Int
30 String
renderObjectDataFullLabel
          , String
renderObjectDataColor :: String
renderObjectDataColor :: String
.. }

    hideWhenLargerThan :: t Char -> Int -> String -> String
hideWhenLargerThan t Char
shapeId Int
n String
s
      | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = if Char
'-' Char -> t Char -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Char
shapeId then String
"" else String
"•"
      | Bool
otherwise = String
s

    vertices :: [(String, ((a, a), a))]
vertices =
      [ (Integer -> String
forall a. Show a => a -> String
show Integer
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
y String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
z, ((a
500 a -> a -> a
forall a. Num a => a -> a -> a
* a
x'', a
500 a -> a -> a
forall a. Num a => a -> a -> a
* a
y''), a
zIndex))
      | Integer
x <- [Integer
0,Integer
1]
      , Integer
y <- [Integer
0,Integer
1]
      , Integer
z <- [Integer
0,Integer
1]
      , let f :: Integer -> a
f Integer
c = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
c a -> a -> a
forall a. Num a => a -> a -> a
- a
1
      , let x' :: a
x' = Integer -> a
forall a. Num a => Integer -> a
f Integer
x
      , let y' :: a
y' = Integer -> a
forall a. Num a => Integer -> a
f (Integer
1Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
y)
      , let z' :: a
z' = Integer -> a
forall a. Num a => Integer -> a
f Integer
z
      , let ((a
x'', a
y''), a
zIndex) = Camera a -> a -> Point3D a -> ((a, a), a)
forall a.
Floating a =>
Camera a -> a -> Point3D a -> (Point2D a, a)
point3Dto2D Camera a
camera a
rotY (a
x', a
y', a
z') ]

    radius :: a
radius = a
20

    mkEdge :: b -> (b, b) -> (b, b) -> ((b, b), (b, b))
mkEdge b
r (b
x1, b
y1) (b
x2, b
y2) = ((b
x1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
dx, b
y1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
dy), ((b
x2 b -> b -> b
forall a. Num a => a -> a -> a
- b
dx), (b
y2 b -> b -> b
forall a. Num a => a -> a -> a
- b
dy)))
      where
        d :: b
d = b -> b
forall a. Floating a => a -> a
sqrt ((b
x2 b -> b -> b
forall a. Num a => a -> a -> a
- b
x1)b -> Int -> b
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
2 :: Int) b -> b -> b
forall a. Num a => a -> a -> a
+ (b
y2 b -> b -> b
forall a. Num a => a -> a -> a
- b
y1)b -> Int -> b
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
2 :: Int))
        dx :: b
dx = b
r b -> b -> b
forall a. Num a => a -> a -> a
* (b
x2 b -> b -> b
forall a. Num a => a -> a -> a
- b
x1) b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
d
        dy :: b
dy = b
r b -> b -> b
forall a. Num a => a -> a -> a
* (b
y2 b -> b -> b
forall a. Num a => a -> a -> a
- b
y1) b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
d

    scaleAround :: (b, b) -> b -> (b, b) -> (b, b)
scaleAround (b
cx, b
cy) b
s (b
x, b
y) = (b
cx b -> b -> b
forall a. Num a => a -> a -> a
+ b
s b -> b -> b
forall a. Num a => a -> a -> a
* (b
x b -> b -> b
forall a. Num a => a -> a -> a
- b
cx), b
cy b -> b -> b
forall a. Num a => a -> a -> a
+ b
s b -> b -> b
forall a. Num a => a -> a -> a
* (b
y b -> b -> b
forall a. Num a => a -> a -> a
- b
cy))

    mkFace :: (a, a) -> (a, a) -> (a, a) -> ((a, a), (a, a), (a, a))
mkFace (a
x1, a
y1) (a
x2, a
y2) (a
x3, a
y3) = ((a, a)
p1, (a, a)
p2, (a, a)
p3)
      where
        cx :: a
cx = (a
x1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
x3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3
        cy :: a
cy = (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
3
        p1 :: (a, a)
p1 = (a, a) -> a -> (a, a) -> (a, a)
forall {b}. Num b => (b, b) -> b -> (b, b) -> (b, b)
scaleAround (a
cx, a
cy) a
0.85 (a
x1, a
y1)
        p2 :: (a, a)
p2 = (a, a) -> a -> (a, a) -> (a, a)
forall {b}. Num b => (b, b) -> b -> (b, b) -> (b, b)
scaleAround (a
cx, a
cy) a
0.85 (a
x2, a
y2)
        p3 :: (a, a)
p3 = (a, a) -> a -> (a, a) -> (a, a)
forall {b}. Num b => (b, b) -> b -> (b, b) -> (b, b)
scaleAround (a
cx, a
cy) a
0.85 (a
x3, a
y3)

    edges :: [(String, (((a, a), (a, a)), Int))]
edges =
      [ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
fromName, String
toName], (a -> (a, a) -> (a, a) -> ((a, a), (a, a))
forall {b}. Floating b => b -> (b, b) -> (b, b) -> ((b, b), (b, b))
mkEdge a
radius (a, a)
from (a, a)
to, Int
0 :: Int))
      | (String
fromName, ((a, a)
from, a
_)) : [(String, ((a, a), a))]
vs <- [(String, ((a, a), a))] -> [[(String, ((a, a), a))]]
forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vertices
      , (String
toName, ((a, a)
to, a
_)) <- [(String, ((a, a), a))]
vs
      , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Char -> Char -> Bool) -> String -> String -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
(<=) String
fromName String
toName)
      ]

    faces :: [(String, (((a, a), (a, a), (a, a)), Int))]
faces =
      [ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String
name1, String
name2, String
name3], ((a, a) -> (a, a) -> (a, a) -> ((a, a), (a, a), (a, a))
forall {a}.
Fractional a =>
(a, a) -> (a, a) -> (a, a) -> ((a, a), (a, a), (a, a))
mkFace (a, a)
v1 (a, a)
v2 (a, a)
v3, Int
0 :: Int))
      | (String
name1, ((a, a)
v1, a
_)) : [(String, ((a, a), a))]
vs <- [(String, ((a, a), a))] -> [[(String, ((a, a), a))]]
forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vertices
      , (String
name2, ((a, a)
v2, a
_)) : [(String, ((a, a), a))]
vs' <- [(String, ((a, a), a))] -> [[(String, ((a, a), a))]]
forall a. [a] -> [[a]]
tails [(String, ((a, a), a))]
vs
      , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Char -> Char -> Bool) -> String -> String -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
(<=) String
name1 String
name2)
      , (String
name3, ((a, a)
v3, a
_)) <- [(String, ((a, a), a))]
vs'
      , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Char -> Char -> Bool) -> String -> String -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
(<=) String
name2 String
name3)
      ]


defaultCamera :: Floating a => Camera a
defaultCamera :: forall a. Floating a => Camera a
defaultCamera = Camera
  { cameraPos :: Point3D a
cameraPos = (a
0, a
7, a
10)
  , cameraAngleY :: a
cameraAngleY = a
forall a. Floating a => a
pi
  , cameraAngleX :: a
cameraAngleX = a
forall a. Floating a => a
pia -> a -> a
forall a. Fractional a => a -> a -> a
/a
5
  , cameraFoV :: a
cameraFoV = a
forall a. Floating a => a
pia -> a -> a
forall a. Fractional a => a -> a -> a
/a
15
  , cameraAspectRatio :: a
cameraAspectRatio = a
1
  }