{-# LANGUAGE FlexibleContexts #-}
{-# language LambdaCase #-}
{-# options_ghc -Wno-unused-imports #-}
{-# options_ghc -Wno-unused-top-binds #-}
module Data.RPTree.Draw (
writeCsv
, writeDot
)where
import Data.Bifoldable (Bifoldable(..))
import Data.Bifunctor (Bifunctor(..))
import Data.Bitraversable (Bitraversable(..))
import Data.List (intercalate)
import Text.Printf (PrintfArg, printf)
import qualified Text.PrettyPrint.Boxes as B (Box, render, emptyBox, vcat, hcat, text, top, bottom, center1)
import qualified Data.ByteString.Lazy as LBS (ByteString, writeFile)
import qualified Data.ByteString.Builder as BSB (Builder, toLazyByteString, string7, charUtf8)
import qualified Data.Set as S (Set, insert, fromList)
import Control.Monad.State (MonadState(..), modify)
import qualified Data.Text.Lazy as TL (Text)
import qualified Data.Text.Lazy.Builder as TLB (Builder, toLazyText, fromString)
import qualified Data.Text.Lazy.IO as TL (writeFile)
import Control.Monad.Trans.State (State, evalState)
import qualified Data.Vector as V (Vector, replicateM)
import qualified Data.Vector.Generic as VG (Vector(..), map, sum, unfoldr, unfoldrM, length, replicateM, (!))
import qualified Data.Vector.Unboxed as VU (Unbox)
import Data.RPTree.Internal (RPTree(..), RPT(..), DVector, toListDv)
writeCsv :: (Foldable t, VU.Unbox a, Show a, Show b) =>
FilePath
-> t (V.Vector (DVector a, b))
-> IO ()
writeCsv :: FilePath -> t (Vector (DVector a, b)) -> IO ()
writeCsv FilePath
fp t (Vector (DVector a, b))
ds = FilePath -> Text -> IO ()
TL.writeFile FilePath
fp (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> Text
TLB.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ t (Vector (DVector a, b)) -> Builder
forall (t :: * -> *) a b.
(Foldable t, Unbox a, Show a, Show b) =>
t (Vector (DVector a, b)) -> Builder
toCsvV t (Vector (DVector a, b))
ds
toCsvV :: (Foldable t, VU.Unbox a, Show a, Show b) =>
t (V.Vector (DVector a, b)) -> TLB.Builder
toCsvV :: t (Vector (DVector a, b)) -> Builder
toCsvV = (Vector (DVector a, b) -> Builder)
-> t (Vector (DVector a, b)) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Vector (DVector a, b)
v -> ((DVector a, b) -> Builder) -> Vector (DVector a, b) -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(DVector a
r, b
i) -> DVector a -> b -> Builder
forall a b. (Show a, Show b, Unbox a) => DVector a -> b -> Builder
toCsvRow DVector a
r b
i Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline ) Vector (DVector a, b)
v)
toCsvRow :: (Show a, Show b, VU.Unbox a) =>
DVector a
-> b
-> TLB.Builder
toCsvRow :: DVector a -> b -> Builder
toCsvRow DVector a
dv b
i = FilePath -> Builder
TLB.fromString (FilePath -> Builder) -> FilePath -> Builder
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," [a -> FilePath
forall a. Show a => a -> FilePath
show a
x, a -> FilePath
forall a. Show a => a -> FilePath
show a
y, b -> FilePath
forall a. Show a => a -> FilePath
show b
i]
where
(a
x:a
y:[a]
_) = DVector a -> [a]
forall a. Unbox a => DVector a -> [a]
toListDv DVector a
dv
newline :: TLB.Builder
newline :: Builder
newline = FilePath -> Builder
TLB.fromString FilePath
"\n"
writeDot :: Ord t =>
(t -> String)
-> FilePath
-> String
-> RPTree d x t
-> IO ()
writeDot :: (t -> FilePath) -> FilePath -> FilePath -> RPTree d x t -> IO ()
writeDot t -> FilePath
f FilePath
fp FilePath
name RPTree d x t
tt = FilePath -> Text -> IO ()
TL.writeFile FilePath
fp ((t -> FilePath) -> FilePath -> RPTree d x t -> Text
forall a d x.
Ord a =>
(a -> FilePath) -> FilePath -> RPTree d x a -> Text
toDot t -> FilePath
f FilePath
name RPTree d x t
tt)
toDot :: Ord a => (a -> String) -> String -> RPTree d x a -> TL.Text
toDot :: (a -> FilePath) -> FilePath -> RPTree d x a -> Text
toDot a -> FilePath
f FilePath
name (RPTree Vector (SVector d)
_ RPT d x a
tt) = Builder -> Text
TLB.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Builder
open Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
close
where
x :: Builder
x = (Builder -> G a -> Builder) -> Builder -> Set (G a) -> Builder
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Builder -> G a -> Builder
insf Builder
forall a. Monoid a => a
mempty (Set (G a) -> Builder) -> Set (G a) -> Builder
forall a b. (a -> b) -> a -> b
$ RPT d x a -> Set (G a)
forall a d x. Ord a => RPT d x a -> Set (G a)
toEdges RPT d x a
tt
where
insf :: Builder -> G a -> Builder
insf Builder
acc = \case
Edge Int
i1 Int
i2 ->
Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
TLB.fromString ([FilePath] -> FilePath
unwords [Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i1, FilePath
"->", Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i2]) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
Node Int
i a
xs -> Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
TLB.fromString ([FilePath] -> FilePath
unwords [Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i, FilePath
nlab ] ) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
where
nlab :: FilePath
nlab = [FilePath] -> FilePath
unwords [FilePath
"[", FilePath
"label=\"", a -> FilePath
f a
xs,FilePath
"\"]"]
BNode Int
i -> Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
TLB.fromString ([FilePath] -> FilePath
unwords [Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i, FilePath
blab]) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
newline
where
blab :: FilePath
blab = [FilePath] -> FilePath
unwords [FilePath
"[", FilePath
"shape=point", FilePath
"]"]
open :: Builder
open = FilePath -> Builder
TLB.fromString (FilePath -> Builder) -> FilePath -> Builder
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"digraph" , FilePath
name, FilePath
"{\n"]
close :: Builder
close = FilePath -> Builder
TLB.fromString FilePath
"}"
data G a = Edge Int Int
| Node Int a
| BNode Int
deriving (G a -> G a -> Bool
(G a -> G a -> Bool) -> (G a -> G a -> Bool) -> Eq (G a)
forall a. Eq a => G a -> G a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: G a -> G a -> Bool
$c/= :: forall a. Eq a => G a -> G a -> Bool
== :: G a -> G a -> Bool
$c== :: forall a. Eq a => G a -> G a -> Bool
Eq, Eq (G a)
Eq (G a)
-> (G a -> G a -> Ordering)
-> (G a -> G a -> Bool)
-> (G a -> G a -> Bool)
-> (G a -> G a -> Bool)
-> (G a -> G a -> Bool)
-> (G a -> G a -> G a)
-> (G a -> G a -> G a)
-> Ord (G a)
G a -> G a -> Bool
G a -> G a -> Ordering
G a -> G a -> G a
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
forall a. Ord a => Eq (G a)
forall a. Ord a => G a -> G a -> Bool
forall a. Ord a => G a -> G a -> Ordering
forall a. Ord a => G a -> G a -> G a
min :: G a -> G a -> G a
$cmin :: forall a. Ord a => G a -> G a -> G a
max :: G a -> G a -> G a
$cmax :: forall a. Ord a => G a -> G a -> G a
>= :: G a -> G a -> Bool
$c>= :: forall a. Ord a => G a -> G a -> Bool
> :: G a -> G a -> Bool
$c> :: forall a. Ord a => G a -> G a -> Bool
<= :: G a -> G a -> Bool
$c<= :: forall a. Ord a => G a -> G a -> Bool
< :: G a -> G a -> Bool
$c< :: forall a. Ord a => G a -> G a -> Bool
compare :: G a -> G a -> Ordering
$ccompare :: forall a. Ord a => G a -> G a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (G a)
Ord, Int -> G a -> ShowS
[G a] -> ShowS
G a -> FilePath
(Int -> G a -> ShowS)
-> (G a -> FilePath) -> ([G a] -> ShowS) -> Show (G a)
forall a. Show a => Int -> G a -> ShowS
forall a. Show a => [G a] -> ShowS
forall a. Show a => G a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [G a] -> ShowS
$cshowList :: forall a. Show a => [G a] -> ShowS
show :: G a -> FilePath
$cshow :: forall a. Show a => G a -> FilePath
showsPrec :: Int -> G a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> G a -> ShowS
Show)
toEdges :: (Ord a) => RPT d x a -> S.Set (G a)
toEdges :: RPT d x a -> Set (G a)
toEdges = [G a] -> Set (G a)
forall a. Ord a => [a] -> Set a
S.fromList ([G a] -> Set (G a))
-> (RPT d x a -> [G a]) -> RPT d x a -> Set (G a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack Int -> [G a] -> RPT d Int a -> [G a]
forall a d. Stack Int -> Stack (G a) -> RPT d Int a -> Stack (G a)
go [] [] (RPT d Int a -> [G a])
-> (RPT d x a -> RPT d Int a) -> RPT d x a -> [G a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPT d x a -> RPT d Int a
forall (t :: * -> * -> *) x d. Bitraversable t => t x d -> t Int d
labelBranches
where
go :: Stack Int -> Stack (G a) -> RPT d Int a -> Stack (G a)
go Stack Int
s Stack (G a)
acc = \case
Tip Int
i1 a
x ->
let
n :: G a
n = Int -> a -> G a
forall a. Int -> a -> G a
Node Int
i1 a
x
acc' :: Stack (G a)
acc' = G a -> Stack (G a) -> Stack (G a)
forall a. a -> Stack a -> Stack a
push G a
n Stack (G a)
acc
acc'' :: Stack (G a)
acc'' = Stack (G a) -> (Int -> Stack (G a)) -> Maybe Int -> Stack (G a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Stack (G a)
acc' (\Int
i0 -> G a -> Stack (G a) -> Stack (G a)
forall a. a -> Stack a -> Stack a
push (Int -> Int -> G a
forall a. Int -> Int -> G a
Edge Int
i0 Int
i1) Stack (G a)
acc') (Stack Int -> Maybe Int
forall a. Stack a -> Maybe a
pop Stack Int
s)
in
Stack (G a)
acc''
Bin Int
i1 d
_ Margin d
_ RPT d Int a
tl RPT d Int a
tr ->
let
b1 :: G a
b1 = Int -> G a
forall a. Int -> G a
BNode Int
i1
acc' :: Stack (G a)
acc' = G a -> Stack (G a) -> Stack (G a)
forall a. a -> Stack a -> Stack a
push G a
forall a. G a
b1 Stack (G a)
acc
acc'' :: Stack (G a)
acc'' = case Stack Int -> Maybe Int
forall a. Stack a -> Maybe a
pop Stack Int
s of
Maybe Int
Nothing -> Stack (G a)
acc'
Just Int
i0 ->
let
e :: G a
e = Int -> Int -> G a
forall a. Int -> Int -> G a
Edge Int
i0 Int
i1
b0 :: G a
b0 = Int -> G a
forall a. Int -> G a
BNode Int
i0
in G a -> Stack (G a) -> Stack (G a)
forall a. a -> Stack a -> Stack a
push G a
forall a. G a
e (G a -> Stack (G a) -> Stack (G a)
forall a. a -> Stack a -> Stack a
push G a
forall a. G a
b0 Stack (G a)
acc')
s' :: Stack Int
s' = Int -> Stack Int -> Stack Int
forall a. a -> Stack a -> Stack a
push Int
i1 Stack Int
s
in
Stack Int -> Stack (G a) -> RPT d Int a -> Stack (G a)
go Stack Int
s' Stack (G a)
acc'' RPT d Int a
tl Stack (G a) -> Stack (G a) -> Stack (G a)
forall a. Semigroup a => a -> a -> a
<> Stack Int -> Stack (G a) -> RPT d Int a -> Stack (G a)
go Stack Int
s' Stack (G a)
acc RPT d Int a
tr
labelBranches :: Bitraversable t => t x d -> t Int d
labelBranches :: t x d -> t Int d
labelBranches = (State Int (t Int d) -> Int -> t Int d)
-> Int -> State Int (t Int d) -> t Int d
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int (t Int d) -> Int -> t Int d
forall s a. State s a -> s -> a
evalState Int
0 (State Int (t Int d) -> t Int d)
-> (t x d -> State Int (t Int d)) -> t x d -> t Int d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> StateT Int Identity Int)
-> (d -> StateT Int Identity d) -> t x d -> State Int (t Int d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse x -> StateT Int Identity Int
forall (m :: * -> *) x. MonadState Int m => x -> m Int
counter d -> StateT Int Identity d
forall (f :: * -> *) a. Applicative f => a -> f a
pure
counter :: (MonadState Int m) => x -> m Int
counter :: x -> m Int
counter x
_ = do
Int
i <- m Int
forall s (m :: * -> *). MonadState s m => m s
get
(Int -> Int) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Int -> Int
forall a. Enum a => a -> a
succ
Int -> m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
type Stack a = [a]
push :: a -> Stack a -> Stack a
push :: a -> Stack a -> Stack a
push = (:)
pop :: Stack a -> Maybe a
pop :: Stack a -> Maybe a
pop Stack a
xs
| Stack a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Stack a
xs = Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Stack a -> a
forall a. [a] -> a
head Stack a
xs
tt0 :: RPT Integer [a1] [a2]
tt0 :: RPT Integer [a1] [a2]
tt0 = [a1]
-> Integer
-> Margin Integer
-> RPT Integer [a1] [a2]
-> RPT Integer [a1] [a2]
-> RPT Integer [a1] [a2]
forall d l a.
l -> d -> Margin d -> RPT d l a -> RPT d l a -> RPT d l a
Bin [] Integer
0 Margin Integer
forall a. Monoid a => a
mempty RPT Integer [a1] [a2]
forall a a. RPT Integer [a] [a]
tl RPT Integer [a1] [a2]
forall d a a. RPT d [a] [a]
t
where
tl :: RPT Integer [a] [a]
tl = [a]
-> Integer
-> Margin Integer
-> RPT Integer [a] [a]
-> RPT Integer [a] [a]
-> RPT Integer [a] [a]
forall d l a.
l -> d -> Margin d -> RPT d l a -> RPT d l a -> RPT d l a
Bin [] Integer
1 Margin Integer
forall a. Monoid a => a
mempty ([a]
-> Integer
-> Margin Integer
-> RPT Integer [a] [a]
-> RPT Integer [a] [a]
-> RPT Integer [a] [a]
forall d l a.
l -> d -> Margin d -> RPT d l a -> RPT d l a -> RPT d l a
Bin [] Integer
2 Margin Integer
forall a. Monoid a => a
mempty RPT Integer [a] [a]
forall d a a. RPT d [a] [a]
t RPT Integer [a] [a]
forall d a a. RPT d [a] [a]
t) ([a]
-> Integer
-> Margin Integer
-> RPT Integer [a] [a]
-> RPT Integer [a] [a]
-> RPT Integer [a] [a]
forall d l a.
l -> d -> Margin d -> RPT d l a -> RPT d l a -> RPT d l a
Bin [] Integer
3 Margin Integer
forall a. Monoid a => a
mempty RPT Integer [a] [a]
forall d a a. RPT d [a] [a]
t RPT Integer [a] [a]
forall d a a. RPT d [a] [a]
t)
t :: RPT d [a] [a]
t = [a] -> [a] -> RPT d [a] [a]
forall d l a. l -> a -> RPT d l a
Tip [] []
draw :: (Show a, Boxed a, PrintfArg v) => RPTree v l a -> IO ()
draw :: RPTree v l a -> IO ()
draw = RPT v l a -> IO ()
forall a v l. (Show a, Boxed a, PrintfArg v) => RPT v l a -> IO ()
drawRPT (RPT v l a -> IO ())
-> (RPTree v l a -> RPT v l a) -> RPTree v l a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPTree v l a -> RPT v l a
forall d l a. RPTree d l a -> RPT d l a
_rpTree
drawRPT :: (Show a, Boxed a, PrintfArg v) => RPT v l a -> IO ()
drawRPT :: RPT v l a -> IO ()
drawRPT = FilePath -> IO ()
putStrLn (FilePath -> IO ())
-> (RPT v l a -> FilePath) -> RPT v l a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPT v l a -> FilePath
forall a v l.
(Show a, Boxed a, PrintfArg v) =>
RPT v l a -> FilePath
toStringRPT
toStringRPT :: (Show a, Boxed a, PrintfArg v) => RPT v l a -> String
toStringRPT :: RPT v l a -> FilePath
toStringRPT = Box -> FilePath
B.render (Box -> FilePath) -> (RPT v l a -> Box) -> RPT v l a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RPT v l a -> Box
forall a v l. (Show a, Boxed a, PrintfArg v) => RPT v l a -> Box
toBox
toBox :: (Show a, Boxed a, PrintfArg v) => RPT v l a -> B.Box
toBox :: RPT v l a -> Box
toBox = \case
(Bin l
_ v
thr Margin v
_ RPT v l a
tl RPT v l a
tr) ->
FilePath -> Box
txt (v -> FilePath
forall t t. (PrintfArg t, PrintfType t) => t -> t
node v
thr) Box -> Box -> Box
`stack` (RPT v l a -> Box
forall a v l. (Show a, Boxed a, PrintfArg v) => RPT v l a -> Box
toBox RPT v l a
tl Box -> Box -> Box
`byside` RPT v l a -> Box
forall a v l. (Show a, Boxed a, PrintfArg v) => RPT v l a -> Box
toBox RPT v l a
tr)
Tip l
_ a
xs -> a -> Box
forall a. Boxed a => a -> Box
boxed a
xs
where
node :: t -> t
node t
x = FilePath -> t -> t
forall r. PrintfType r => FilePath -> r
printf FilePath
"%5.2f" t
x
class Boxed a where
boxed :: a -> B.Box
instance (Show a) => Boxed [a] where
boxed :: [a] -> Box
boxed = (Box -> a -> Box) -> Box -> [a] -> Box
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Box
bx a
x -> Box
bx Box -> Box -> Box
`stack` FilePath -> Box
txt (a -> FilePath
forall a. Show a => a -> FilePath
show a
x)) (Box -> [a] -> Box) -> Box -> [a] -> Box
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Box
B.emptyBox Int
0 Int
0
instance Boxed () where
boxed :: () -> Box
boxed ()
_ = FilePath -> Box
txt FilePath
"*"
tipData :: (Show a, Foldable t) => t a -> B.Box
tipData :: t a -> Box
tipData = (Box -> a -> Box) -> Box -> t a -> Box
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Box
bx a
x -> Box
bx Box -> Box -> Box
`stack` FilePath -> Box
txt (a -> FilePath
forall a. Show a => a -> FilePath
show a
x)) (Box -> t a -> Box) -> Box -> t a -> Box
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Box
B.emptyBox Int
1 Int
1
txt :: String -> B.Box
txt :: FilePath -> Box
txt FilePath
t = Box
spc Box -> Box -> Box
`byside` FilePath -> Box
B.text FilePath
t Box -> Box -> Box
`byside` Box
spc
where spc :: Box
spc = Int -> Int -> Box
B.emptyBox Int
1 Int
1
byside :: B.Box -> B.Box -> B.Box
byside :: Box -> Box -> Box
byside Box
l Box
r = Alignment -> [Box] -> Box
forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
B.hcat Alignment
B.top [Box
l, Box
r]
stack :: B.Box -> B.Box -> B.Box
stack :: Box -> Box -> Box
stack Box
t Box
b = Alignment -> [Box] -> Box
forall (f :: * -> *). Foldable f => Alignment -> f Box -> Box
B.vcat Alignment
B.center1 [Box
t, Box
b]