1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
module Main where
import Data.Char (isAlphaNum, isLetter, isNumber, intToDigit, digitToInt)
import Data.Default (def)
import qualified Data.Text as T
import Data.Text.Read (decimal)
import Main.Utf8 (withUtf8)
import qualified Relude.Extra.Map as Map
import Text.Pandoc.Class (runIOorExplode)
import Text.Pandoc.Definition (Block (..), Inline (..), Pandoc (..))
import Text.Pandoc.Readers (readOrg)
import Text.Pandoc.Writers (writeHtml5String, writeMarkdown)
import Text.Pandoc.Shared (stringify)
import Text.Pandoc.Walk (walkM)
import Numeric (showIntAtBase, readInt)
newtype ZettelId = ZettelId
{ -- | The ZettelId is just Text, however, it should also be possible to convert
-- it to a list of the ID split up into it's parts.
unZettelId :: Text
}
deriving (Show, Eq, Ord)
instance IsString ZettelId where
fromString = ZettelId . fromString
instance ToString ZettelId where
toString = toString . unZettelId
instance Semigroup ZettelId where
ZettelId a <> ZettelId b = ZettelId $ a <> b
instance Monoid ZettelId where
mempty = ZettelId mempty
data Zettel = Zettel
{ -- | The ID that is assigned to the Zettel.
zettelId :: !ZettelId,
-- | The title of the Zettel, which should also be present in the body, however,
-- this is useful to gather metadata about the Zettel.
zettelTitle :: !Text,
-- | The text body of the Zettel, which is stored as a Pandoc document to make it
-- easy to export to other documents.
zettelBody :: Pandoc
}
deriving (Show, Eq)
instance Semigroup Zettel where
Zettel a b c <> Zettel _ _ c' = Zettel a b $ c <> c'
instance Monoid Zettel where
mempty = Zettel mempty mempty mempty
data HeaderState = HeaderState
{ headerStateMap :: Map Text ((ZettelId, Text), [Text]),
headerStateCurrent :: Text
}
isLink :: Inline -> Bool
isLink Link {} = True
isLink _ = False
parseIds :: Text -> Text
parseIds t
| T.null t = ""
| T.head t == '#' && T.all isAlphaNum (T.tail t) = T.tail t
| otherwise = ""
addLinks :: [Inline] -> Block -> State HeaderState Block
addLinks il b = do
let f = filter isLink il
s <- get
let m' =
Map.insertWith
(\(_, y) (z, x) -> (z, x <> y))
(headerStateCurrent s)
((mempty, mempty), filter (not . T.null) (parseIds . stringify <$> f))
(headerStateMap s)
put (HeaderState m' (headerStateCurrent s))
return b
getHeaders :: Block -> State HeaderState Block
getHeaders h@(Header _ (a, _, _) t) = do
s <- get
let m' = Map.insert a ((ZettelId a, stringify t), []) (headerStateMap s)
put (HeaderState m' a)
return h
getHeaders p@(Plain i) = addLinks i p
getHeaders p@(Para i) = addLinks i p
getHeaders p@(LineBlock i) = addLinks (concat i) p
getHeaders p = addLinks [] p
splitId :: ZettelId -> [Text]
splitId (ZettelId zid)
| T.null zid = []
| isNumber (T.head zid) = T.takeWhile isNumber zid : (splitId . ZettelId $ T.dropWhile isNumber zid)
| isLetter (T.head zid) = T.takeWhile isLetter zid : (splitId . ZettelId $ T.dropWhile isLetter zid)
| otherwise = []
combineId :: [Text] -> ZettelId
combineId = ZettelId . fold
intToDigit26 :: Int -> Char
intToDigit26 i
| i <= 25 && i >= 0 = toEnum $ fromEnum 'a' + i
| otherwise = error "Integer out of range."
digitToInt26 :: Char -> Int
digitToInt26 c = fromEnum c - fromEnum 'a'
fromBase :: Int -> String -> Maybe Int
fromBase base = fmap fst . viaNonEmpty head . readInt base ((<base).digitToInt26) digitToInt26
toBase :: Int -> Int -> String
toBase base num = showIntAtBase base intToDigit26 num ""
opOnBase26 :: (Int -> Int) -> Text -> Maybe Text
opOnBase26 f t =
fromString . toBase 26 . f <$> fromBase 26 (toString t)
opOnIdPart :: (Int -> Int) -> Text -> Maybe Text
opOnIdPart f t
| T.null t = Nothing
| isNumber $ T.head t =
case decimal t of
Right (a, _) -> Just . show $ f a
_ -> Nothing
| isLetter $ T.head t = opOnBase26 f t
| otherwise = Nothing
defPredId :: ZettelId -> Maybe ZettelId
defPredId z =
case nonEmpty (splitId z) of
Just ne ->
if last ne == "a" || last ne == "1"
then Just (combineId (init ne))
else combineId . (init ne <>) . (: []) <$> opOnIdPart (subtract 1) (last ne)
Nothing -> Nothing
toDot :: [Text] -> (Text, [Text]) -> Text
toDot _ (t, l) = foldMap (\l' -> "\"" <> l' <> "\"" <> " -> " <> "\"" <> t <> "\"" <> ";\n") l
toDotNodes :: Text -> Text
toDotNodes t
| T.null t = ""
| isNumber $ T.head t = "\"" <> t <> "\"" <> " [color=" <> T.singleton (T.head t) <> "];\n"
| otherwise = ""
addSelfLinks :: ZettelId -> Map Text ((ZettelId, Text), [Text]) -> Map Text ((ZettelId, Text), [Text])
addSelfLinks z m =
Map.insertWith (\((_, _), l') ((z', t), l) -> ((z', t), l ++ l')) (unZettelId z)
addSelfLinks2 :: (a, ((ZettelId, b), [Text])) -> (a, ((ZettelId, b), [Text]))
addSelfLinks2 (a, ((t, b), l)) =
(a, ((t, b), maybeToList (unZettelId <$> defPredId t) <> l))
main :: IO ()
main = withUtf8 $ do
let fl = ["/Users/yannherklotz/Dropbox/zk/verification.org", "/Users/yannherklotz/Dropbox/zk/mathematics.org", "/Users/yannherklotz/Dropbox/zk/hls.org", "/Users/yannherklotz/Dropbox/zk/computing.org", "/Users/yannherklotz/Dropbox/zk/hardware.org"]
fs <- sequence $ readFileText <$> fl
x <- sequence $ runIOorExplode . readOrg def <$> fs
let (_, s) = runState (forM x (walkM getHeaders)) (HeaderState mempty "toplevel")
let allZettel = map addSelfLinks $ Map.toPairs (headerStateMap s)
writeFileText "out.dot" $ "digraph G {\nnode [colorscheme=pastel28,style=filled];\n"
<> fold (toDotNodes . fst <$> allZettel)
<> fold (toDot (foldMap (snd . snd) allZettel)
. (\(a, (_, b)) -> (a, b)) <$> allZettel)
<> "}\n"
-- forM_ allZettel (\(_, ((a, _), _)) -> do
-- t <- runIOorExplode $ writeMarkdown def p
-- writeFileText ("neuron/" <> toString a <> ".md") t
-- )
|
