{-# 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 (Int -> EdgeType -> ShowS
[EdgeType] -> ShowS
EdgeType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeType] -> ShowS
$cshowList :: [EdgeType] -> ShowS
show :: EdgeType -> String
$cshow :: EdgeType -> String
showsPrec :: Int -> EdgeType -> ShowS
$cshowsPrec :: Int -> EdgeType -> ShowS
Show, forall x. Rep EdgeType x -> EdgeType
forall x. EdgeType -> Rep EdgeType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EdgeType x -> EdgeType
$cfrom :: forall x. EdgeType -> Rep EdgeType x
Generic, EdgeType -> EdgeType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeType -> EdgeType -> Bool
$c/= :: EdgeType -> EdgeType -> Bool
== :: EdgeType -> EdgeType -> Bool
$c== :: EdgeType -> EdgeType -> Bool
Eq, Eq EdgeType
EdgeType -> EdgeType -> Bool
EdgeType -> EdgeType -> Ordering
EdgeType -> EdgeType -> EdgeType
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 :: EdgeType -> EdgeType -> EdgeType
$cmin :: EdgeType -> EdgeType -> EdgeType
max :: EdgeType -> EdgeType -> EdgeType
$cmax :: EdgeType -> EdgeType -> EdgeType
>= :: EdgeType -> EdgeType -> Bool
$c>= :: EdgeType -> EdgeType -> Bool
> :: EdgeType -> EdgeType -> Bool
$c> :: EdgeType -> EdgeType -> Bool
<= :: EdgeType -> EdgeType -> Bool
$c<= :: EdgeType -> EdgeType -> Bool
< :: EdgeType -> EdgeType -> Bool
$c< :: EdgeType -> EdgeType -> Bool
compare :: EdgeType -> EdgeType -> Ordering
$ccompare :: EdgeType -> EdgeType -> Ordering
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 :: forall a. Int -> Maybe a -> a
myFromJust Int
i Maybe a
term
  | forall a. Maybe a -> Bool
isJust Maybe a
term -- Debug.Trace.trace ("myFromJustTrue "++ show i)
    =
    forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
term
  | Bool
otherwise =
    forall a. String -> a -> a
Debug.Trace.trace
      (String
"myFromJust " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i)
      forall a. HasCallStack => Maybe a -> a
fromJust
      Maybe a
term

myhead :: Int -> [a] -> a
myhead :: forall a. Int -> [a] -> a
myhead Int
i [a]
a
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
a = forall a. HasCallStack => String -> a
error (String
"head: empty list " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i)
  | Bool
otherwise = forall a. [a] -> a
head [a]
a

vhead :: (VU.Unbox a) => Int -> VU.Vector a -> a
vhead :: forall a. Unbox a => Int -> Vector a -> a
vhead Int
i Vector a
a
  | forall a. Unbox a => Vector a -> Bool
VU.null Vector a
a = forall a. HasCallStack => String -> a
error (String
"VU.head: empty list " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i)
  | Bool
otherwise = forall a. Unbox a => Vector a -> a
VU.head Vector a
a

rmdups :: (Ord a) => [a] -> [a]
rmdups :: forall a. Ord a => [a] -> [a]
rmdups = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> a
myhead Int
500) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort

------------------------------------------------------------------------------------------------------

vertBit :: Word8
vertBit :: Word8
vertBit = Word8
0x1

virtBit :: Word8
virtBit :: Word8
virtBit = Word8
0x2

sepBit :: Word8
sepBit :: Word8
sepBit = Word8
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] -> Word8
fastEdgeAttr (e
e : [e]
_) = EdgeType -> Word8
f (forall e. EdgeClass e => e -> EdgeType
edgeType e
e)
    where
      f :: EdgeType -> Word8
f EdgeType
VerticalEdge = Word8
vertBit
      f EdgeType
VirtualHorEdge = Word8
virtBit
      f EdgeType
_ = Word8
0
  fastEdgeAttr [e]
_ = Word8
0
  edgeFromAttr :: Map Word8 [e]
edgeFromAttr =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Word8
vertBit, [forall e. EdgeClass e => EdgeType -> e
standard EdgeType
VerticalEdge]),
        (Word8
virtBit, [forall e. EdgeClass e => EdgeType -> e
standard EdgeType
VirtualHorEdge]),
        (Word8
0, [forall e. EdgeClass e => EdgeType -> e
standard EdgeType
NormalEdge])
      ]

  -- show_e (Just [UIEdge standard Nothing 0 e]) = show e
  -- show_e _ = "no Edge"
  bases :: [e] -> [Edge8]
bases [e]
_ = [Word8 -> Edge8
Edge8 Word8
0, Word8 -> Edge8
Edge8 Word8
vertBit, Word8 -> Edge8
Edge8 Word8
virtBit]

childrenSeparating :: EdgeClass e => CGraph n e -> Word32 -> VU.Vector Word32
childrenSeparating :: forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
childrenSeparating CGraph n e
gr Word32
n = forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> Word32 -> Edge8 -> Vector Word32
adjacentNodesByAttr CGraph n e
gr Bool
True Word32
n (Word8 -> Edge8
Edge8 Word8
sepBit)

childrenNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
childrenNoVertical :: forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
childrenNoVertical Graph n [e]
gr Word32
n =
  forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> Word32 -> Edge8 -> Vector Word32
adjacentNodesByAttr Graph n [e]
gr Bool
True Word32
n (Word8 -> Edge8
Edge8 Word8
virtBit)
    forall a. Unbox a => Vector a -> Vector a -> Vector a
VU.++ forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> Word32 -> Edge8 -> Vector Word32
adjacentNodesByAttr Graph n [e]
gr Bool
True Word32
n (Word8 -> Edge8
Edge8 Word8
0)

childrenVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
childrenVertical :: forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
childrenVertical Graph n [e]
gr Word32
n = forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> Word32 -> Edge8 -> Vector Word32
adjacentNodesByAttr Graph n [e]
gr Bool
True Word32
n (Word8 -> Edge8
Edge8 Word8
vertBit)

parentsVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
parentsVertical :: forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
parentsVertical Graph n [e]
gr Word32
n = forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> Word32 -> Edge8 -> Vector Word32
adjacentNodesByAttr Graph n [e]
gr Bool
False Word32
n (Word8 -> Edge8
Edge8 Word8
vertBit)

parentsNoVertical :: EdgeClass e => Graph n [e] -> Word32 -> VU.Vector Word32
parentsNoVertical :: forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
parentsNoVertical Graph n [e]
gr Word32
n =
  forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> Word32 -> Edge8 -> Vector Word32
adjacentNodesByAttr Graph n [e]
gr Bool
False Word32
n (Word8 -> Edge8
Edge8 Word8
virtBit)
    forall a. Unbox a => Vector a -> Vector a -> Vector a
VU.++ forall el nl.
EdgeAttribute el =>
Graph nl el -> Bool -> Word32 -> Edge8 -> Vector Word32
adjacentNodesByAttr Graph n [e]
gr Bool
False Word32
n (Word8 -> Edge8
Edge8 Word8
0)

verticallyConnectedNodes :: EdgeClass e => CGraph n e -> UINode -> [UINode]
verticallyConnectedNodes :: forall e n. EdgeClass e => CGraph n e -> Word32 -> [Word32]
verticallyConnectedNodes CGraph n e
g Word32
n =
  forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$
    Vector Word32 -> Vector Word32
goUp (forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
parentsVertical CGraph n e
g Word32
n)
      forall a. Unbox a => Vector a -> Vector a -> Vector a
VU.++ forall a. Unbox a => a -> Vector a -> Vector a
VU.cons Word32
n (Vector Word32 -> Vector Word32
goDown (forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
childrenVertical CGraph n e
g Word32
n))
  where
    goUp :: Vector Word32 -> Vector Word32
goUp Vector Word32
nodes
      | forall a. Unbox a => Vector a -> Bool
VU.null Vector Word32
nodes = forall a. Unbox a => Vector a
VU.empty
      | Bool
otherwise =
        Vector Word32
nodes
          forall a. Unbox a => Vector a -> Vector a -> Vector a
VU.++ forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap (Vector Word32 -> Vector Word32
goUp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
parentsVertical CGraph n e
g) Vector Word32
nodes
    goDown :: Vector Word32 -> Vector Word32
goDown Vector Word32
nodes
      | forall a. Unbox a => Vector a -> Bool
VU.null Vector Word32
nodes = forall a. Unbox a => Vector a
VU.empty
      | Bool
otherwise =
        Vector Word32
nodes
          forall a. Unbox a => Vector a -> Vector a -> Vector a
VU.++ forall a b.
(Unbox a, Unbox b) =>
(a -> Vector b) -> Vector a -> Vector b
VU.concatMap (Vector Word32 -> Vector Word32
goDown forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e n. EdgeClass e => CGraph n e -> Word32 -> Vector Word32
childrenVertical CGraph n e
g) Vector Word32
nodes

------------------------------------------------------------------------------------------------------

data LayerFeatures = LayerFeatures
  { LayerFeatures -> Int
layer :: Int, -- Expanding a fuction generates a new layer
  -- (maybe make every new layer a little bit darker)
    LayerFeatures -> Maybe Border
border :: Maybe Border -- To set the right css values (border, boxshadow)
  }
  deriving (Int -> LayerFeatures -> ShowS
[LayerFeatures] -> ShowS
LayerFeatures -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LayerFeatures] -> ShowS
$cshowList :: [LayerFeatures] -> ShowS
show :: LayerFeatures -> String
$cshow :: LayerFeatures -> String
showsPrec :: Int -> LayerFeatures -> ShowS
$cshowsPrec :: Int -> LayerFeatures -> ShowS
Show, forall x. Rep LayerFeatures x -> LayerFeatures
forall x. LayerFeatures -> Rep LayerFeatures x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LayerFeatures x -> LayerFeatures
$cfrom :: forall x. LayerFeatures -> Rep LayerFeatures x
Generic)

instance FromJSON LayerFeatures

instance ToJSON LayerFeatures

lb :: Int -> Maybe LayerFeatures
lb :: Int -> Maybe LayerFeatures
lb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
LeftBorder))

rb :: Int -> Maybe LayerFeatures
rb :: Int -> Maybe LayerFeatures
rb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
RightBorder))

tb :: Int -> Maybe LayerFeatures
tb :: Int -> Maybe LayerFeatures
tb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
TopBorder))

bb :: Int -> Maybe LayerFeatures
bb :: Int -> Maybe LayerFeatures
bb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
BottomBorder))

ltb :: Int -> Maybe LayerFeatures
ltb :: Int -> Maybe LayerFeatures
ltb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
LeftTopBorder))

rtb :: Int -> Maybe LayerFeatures
rtb :: Int -> Maybe LayerFeatures
rtb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
RightTopBorder))

lbb :: Int -> Maybe LayerFeatures
lbb :: Int -> Maybe LayerFeatures
lbb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
LeftBottomBorder))

rbb :: Int -> Maybe LayerFeatures
rbb :: Int -> Maybe LayerFeatures
rbb Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n (forall a. a -> Maybe a
Just Border
RightBottomBorder))

mid :: Int -> Maybe LayerFeatures
mid :: Int -> Maybe LayerFeatures
mid Int
n = forall a. a -> Maybe a
Just (Int -> Maybe Border -> LayerFeatures
LayerFeatures Int
n forall a. Maybe a
Nothing)

data Border
  = LeftBorder
  | RightBorder
  | TopBorder
  | BottomBorder
  | LeftTopBorder
  | RightTopBorder
  | LeftBottomBorder
  | RightBottomBorder
  deriving (Int -> Border -> ShowS
[Border] -> ShowS
Border -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Border] -> ShowS
$cshowList :: [Border] -> ShowS
show :: Border -> String
$cshow :: Border -> String
showsPrec :: Int -> Border -> ShowS
$cshowsPrec :: Int -> Border -> ShowS
Show, forall x. Rep Border x -> Border
forall x. Border -> Rep Border x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Border x -> Border
$cfrom :: forall x. Border -> Rep Border x
Generic)

instance FromJSON Border

instance ToJSON Border