{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Graph.CommonGraph where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.IntMap as I
import Data.List (group, sort)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust, isJust)
import qualified Data.Vector.Unboxed as VU
import Data.Word (Word32, Word8)
import Debug.Trace (trace)
import GHC.Generics (Generic)
import Graph.IntMap
( Edge8 (..),
EdgeAttribute (..),
ExtractNodeType (..),
Graph (..),
adjacentNodesByAttr,
)
type UINode = Word32
-- A Graph consists of nodes and edges, graph drawing arranges it from left to right,
-- start to end.
type CGraph n e = Graph n [e]
type CGraphL n e = (Graph n [e], Map UINode (Int, Int))
type Channel = Int -- The nth type of a type node
-- This is path of function and type nodes with spaces that can be filled with options
data EdgeType
= NormalEdge
| VerticalEdge -- When having options, they appear continuously in one column
-- We mark this in the graph with vertical edges from the first
-- option to the second and so on
| VirtualHorEdge -- virtual edges are not displayed but used for layouting and
-- naviagtion with the keyboard
| SeparatingEdge -- to connect graph components that are separate
deriving (Show, Generic, Eq, Ord)
type GraphMoveX = Int
type Column = (GraphMoveX, [UINode])
--instance NodeClass n => Eq n where
-- node1 == node2 = uinode node1 == uinode node2
class NodeClass n where
isDummy :: EdgeClass e => CGraph n e -> UINode -> Bool
isConnNode :: EdgeClass e => CGraph n e -> UINode -> Bool
isFunction :: EdgeClass e => CGraph n e -> UINode -> Bool
isMainArg :: CGraph n e -> UINode -> Bool
isSubLabel :: n -> Bool
isArgLabel :: n -> Bool
subLabels :: n -> Int
connectionNode :: n
dummyNode :: Int -> n -- Depth -> n
nestingFeatures :: n -> Maybe LayerFeatures
updateLayer :: Maybe LayerFeatures -> n -> n
verticalNumber :: n -> Maybe Word32 -- we want to keep the order of vertically connected Nodes,
type ChannelNrIn = Maybe Channel
type ChannelNrOut = Channel
class EdgeClass e where
dummyEdge :: ChannelNrIn -> ChannelNrOut -> e
standard :: EdgeType -> e
edgeType :: e -> EdgeType
channelNrIn :: e -> ChannelNrIn
channelNrOut :: e -> ChannelNrOut
------------------------------------------------------------------------------------------------------
myFromJust :: Int -> Maybe a -> a
myFromJust i term
| isJust term -- Debug.Trace.trace ("myFromJustTrue "++ show i)
=
fromJust term
| otherwise =
Debug.Trace.trace
("myFromJust " ++ show i)
fromJust
term
myhead :: Int -> [a] -> a
myhead i a
| null a = error ("head: empty list " ++ show i)
| otherwise = head a
vhead :: (VU.Unbox a) => Int -> VU.Vector a -> a
vhead i a
| VU.null a = error ("VU.head: empty list " ++ show i)
| otherwise = VU.head a
rmdups :: (Ord a) => [a] -> [a]
rmdups = map (myhead 500) . group . sort
------------------------------------------------------------------------------------------------------
vertBit :: Word8
vertBit = 0x1
virtBit :: Word8
virtBit = 0x2
sepBit :: Word8
sepBit = 0x4
instance EdgeClass e => EdgeAttribute [e] where -- Why can two nodes be connected with more than one edge?
-- To connect one function with several input types that are part of one type node
fastEdgeAttr (e : _) = f (edgeType e)
where
f VerticalEdge = vertBit
f VirtualHorEdge = virtBit
f _ = 0
fastEdgeAttr _ = 0
edgeFromAttr =
Map.fromList
[ (vertBit, [standard VerticalEdge]),
(virtBit, [standard VirtualHorEdge]),
(0, [standard NormalEdge])
]
-- show_e (Just [UIEdge standard Nothing 0 e]) = show e
-- show_e _ = "no Edge"
bases _ = [Edge8 0, Edge8 vertBit, Edge8 virtBit]
childrenSeparating :: EdgeClass e => CGraph n e -> Word32 -> VU.Vector Word32
childrenSeparating gr n = adjacentNodesByAttr gr True n (Edge8 sepBit)
childrenNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
childrenNoVertical gr n =
adjacentNodesByAttr gr True n (Edge8 virtBit)
VU.++ adjacentNodesByAttr gr True n (Edge8 0)
childrenVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
childrenVertical gr n = adjacentNodesByAttr gr True n (Edge8 vertBit)
parentsVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
parentsVertical gr n = adjacentNodesByAttr gr False n (Edge8 vertBit)
parentsNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
parentsNoVertical gr n =
adjacentNodesByAttr gr False n (Edge8 virtBit)
VU.++ adjacentNodesByAttr gr False n (Edge8 0)
verticallyConnectedNodes :: EdgeClass e => CGraph n e -> UINode -> [UINode]
verticallyConnectedNodes g n =
VU.toList $
goUp (parentsVertical g n)
VU.++ VU.cons n (goDown (childrenVertical g n))
where
goUp nodes
| VU.null nodes = VU.empty
| otherwise =
nodes
VU.++ VU.concatMap (goUp . parentsVertical g) nodes
goDown nodes
| VU.null nodes = VU.empty
| otherwise =
nodes
VU.++ VU.concatMap (goDown . childrenVertical g) nodes
------------------------------------------------------------------------------------------------------
data LayerFeatures = LayerFeatures
{ layer :: Int, -- Expanding a fuction generates a new layer
-- (maybe make every new layer a little bit darker)
border :: Maybe Border -- To set the right css values (border, boxshadow)
}
deriving (Show, Generic)
instance FromJSON LayerFeatures
instance ToJSON LayerFeatures
lb :: Int -> Maybe LayerFeatures
lb n = Just (LayerFeatures n (Just LeftBorder))
rb :: Int -> Maybe LayerFeatures
rb n = Just (LayerFeatures n (Just RightBorder))
tb :: Int -> Maybe LayerFeatures
tb n = Just (LayerFeatures n (Just TopBorder))
bb :: Int -> Maybe LayerFeatures
bb n = Just (LayerFeatures n (Just BottomBorder))
ltb :: Int -> Maybe LayerFeatures
ltb n = Just (LayerFeatures n (Just LeftTopBorder))
rtb :: Int -> Maybe LayerFeatures
rtb n = Just (LayerFeatures n (Just RightTopBorder))
lbb :: Int -> Maybe LayerFeatures
lbb n = Just (LayerFeatures n (Just LeftBottomBorder))
rbb :: Int -> Maybe LayerFeatures
rbb n = Just (LayerFeatures n (Just RightBottomBorder))
mid :: Int -> Maybe LayerFeatures
mid n = Just (LayerFeatures n Nothing)
data Border
= LeftBorder
| RightBorder
| TopBorder
| BottomBorder
| LeftTopBorder
| RightTopBorder
| LeftBottomBorder
| RightBottomBorder
deriving (Show, Generic)
instance FromJSON Border
instance ToJSON Border