Add hs files

2 files changed, 186 insertions, 34 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 91fa612..04c234c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,23 +1,63 @@
 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.Walk (walkM)
-import Text.Pandoc.Definition (Block(..), Inline(..))
+import Text.Pandoc.Writers (writeHtml5String, writeMarkdown)
 import Text.Pandoc.Shared (stringify)
-import Data.Default (def)
-import Text.Pandoc.Class (runIOorExplode)
-import qualified Relude.Extra.Map as Map
-import qualified Data.Text as T
-import Data.Char (isAlphaNum)
+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 (Text, [Text])
-                               , headerStateCurrent :: Text
-                               }
+data HeaderState = HeaderState
+  { headerStateMap :: Map Text ((ZettelId, Text), [Text]),
+    headerStateCurrent :: Text
+  }
 
 isLink :: Inline -> Bool
-isLink Link{} = True
+isLink Link {} = True
 isLink _ = False
 
 parseIds :: Text -> Text
@@ -26,33 +66,107 @@ parseIds 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 (stringify t) (a, []) (headerStateMap s)
-  put (HeaderState m' (stringify t))
+  let m' = Map.insert a ((ZettelId a, stringify t), []) (headerStateMap s)
+  put (HeaderState m' a)
   return h
-getHeaders p@(Para i) = do
-  let f = filter isLink i
-  s <- get
-  let m' = Map.insertWith (\(_, x) (w, y) -> (w, x <> y))
-             (headerStateCurrent s)
-             ("", filter (not . T.null) (parseIds . stringify <$> f))
-             (headerStateMap s)
-  put (HeaderState m' (headerStateCurrent s))
-  return p
-getHeaders a = return a
+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)
 
-toDot :: (Text, [Text]) -> Text
-toDot (t, []) = "\"" <> t <> "\"" <> ";\n"
-toDot (t, l) = foldMap (\l' -> "\"" <> t <> "\"" <> " -> " <> "\"" <> l' <> "\"" <> ";\n") l
+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
-  f <- readFileText "random.org"
-  x <- runIOorExplode (readOrg def ("#+options: H:15\n" <> f))
-  let (_, s) = runState (walkM getHeaders x) (HeaderState mempty "toplevel")
-  putTextLn "digraph G {\n"
-  putTextLn $ fold (toDot <$> toList (headerStateMap s))
-  putTextLn "}\n"
-  return ()
+  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
+--                     )
diff --git a/src/Zettel.hs b/src/Zettel.hs
new file mode 100644
index 0000000..5c07af9
--- /dev/null
+++ b/src/Zettel.hs
@@ -0,0 +1,38 @@
+module Zettel where
+
+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