Try and implement basic linguistic stuff for english

Mainate.cabal

@@ -19,6 +19,8 @@ extra-source-files:  CHANGELOG.md
 
 library
   exposed-modules:   Graph
+                   , Lang.En.Grapheme
+                   , Lang.En.Morpheme
                    , Stream
                    , Transducer
                    , Tree

src/Graph.hs

@@ -3,93 +3,86 @@
 module Graph (
       Graph(..)
     , Vertex(..)
-    , Zipper(..)
+    , editVertex
-    , editLabel
     , follow
-    , open
     , rewind
     , singleton
+    , stitch
     , weave
   ) where
 
-import Data.Map (Map)
+import Data.Map ((!), Map)
-import qualified Data.Map as Map (delete, empty, insert, lookup, toList)
+import qualified Data.Map as Map (adjust, empty, insert, lookup, singleton, size, toList)
+import Data.Set (Set)
+import qualified Data.Set as Set (insert, member, singleton)
 import Tree (Tree(..), Structure(..))
 
+type VertexID = Int
+
 data Vertex edge label = Vertex {
       label :: label
-    , edges :: Map edge (Vertex edge label)
+    , edges :: Map edge VertexID
-  } deriving (Functor, Show)
-
-instance Show edge => Tree (Vertex edge) where
-  getStructure (Vertex {label, edges}) = Node [
-      ("(" ++ label ++ ")", Node $ recurseOnEdge <$> Map.toList edges)
-    ]
-    where
-      recurseOnEdge (edge, vertex) = (show edge, getStructure vertex)
-
-singleton :: label -> Vertex edge label
-singleton label = Vertex {label, edges = Map.empty}
-
-data Zipper edge label = Top | Zipper {
-      origin :: Zipper edge label
-    , from :: label
-    , by :: edge
-    , siblingEdges :: Map edge (Vertex edge label)
   } deriving (Functor, Show)
 
 data Graph edge label = Graph {
-      focus :: Vertex edge label
+      vertices :: Map VertexID (Vertex edge label)
-    , context :: Zipper edge label
+    , focus :: VertexID
+    , root :: VertexID
   } deriving (Functor, Show)
 
-instance (Ord edge, Show edge) => Tree (Graph edge) where
+getStructureWithoutLoop :: Show edge => Set VertexID -> Graph edge String -> Structure
-  getStructure = getStructure . zipUp
+getStructureWithoutLoop visitedIDs graph@(Graph {focus, vertices}) = Node [(
+      "(" ++ show focus ++ ":" ++ label ++ ")"
+    , Node $ recurseOnEdge <$> Map.toList edges
+  )]
+  where
+    Vertex label edges = vertices ! focus
+    recurseOnEdge (edge, vertexID) = (
+          show edge
+        , if Set.member vertexID visitedIDs
+          then Node [("(:" ++ show vertexID ++ ")", Node [])]
+          else getStructureWithoutLoop (Set.insert vertexID visitedIDs) $ graph {focus = vertexID}
+      )
 
-open :: Vertex edge label -> Graph edge label
+instance Show edge => Tree (Graph edge) where
-open focus = Graph {focus, context = Top}
+  getStructure graph = 
+    getStructureWithoutLoop (Set.singleton $ root graph) (rewind graph)
 
-zipUp :: Ord edge => Graph edge label -> Vertex edge label
+vertex :: label -> Vertex edge label
-zipUp graph =
+vertex label = Vertex {label, edges = Map.empty}
-  case context graph of
+
-    Top -> focus graph
+singleton :: label -> Graph edge label
-    Zipper {origin, from, by, siblingEdges} -> zipUp $ Graph {
+singleton label = Graph {
-          context = origin
+      vertices = Map.singleton 0 $ vertex label
-        , focus = Vertex {
+    , focus = 0
-              label = from
+    , root = 0
-            , edges = Map.insert by (focus graph) siblingEdges
-          }
   }
 
-rewind :: Ord edge => Graph edge label -> Graph edge label
+rewind :: Graph edge label -> Graph edge label
-rewind = open . zipUp
+rewind graph = graph {focus = root graph}
 
 follow :: Ord edge => Graph edge label -> edge -> Maybe (Graph edge label)
-follow (Graph {focus, context}) edge =
+follow graph@(Graph {vertices, focus}) edge =
-  Map.lookup edge (edges focus) >>= \vertex -> Just $ Graph {
+  setFocus <$> Map.lookup edge (edges $ vertices ! focus)
-      focus = vertex
+  where
-    , context = Zipper {
+    setFocus vertexID = graph {focus = vertexID}
-          origin = context
-        , from = label $ focus
-        , by = edge
-        , siblingEdges = Map.delete edge $ edges focus
-      }
-  }
 
-weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label
+stitch :: (Monoid label, Ord edge) => Graph edge label -> edge -> Graph edge label
-weave = foldl $ \graph edge ->
+stitch graph edge =
   case graph `follow` edge of
-    Nothing -> Graph {
+    Nothing ->
-          focus = singleton mempty
+      let newVertexID = Map.size $ vertices graph in
-        , context = Zipper {
+      let link aVertex = aVertex {edges = Map.insert edge newVertexID $ edges aVertex} in
-              origin = context graph
+      graph {
-            , from = label $ focus graph
+          vertices =
-            , by = edge
+            Map.adjust link (focus graph) . Map.insert newVertexID (vertex mempty) $ vertices graph
-            , siblingEdges = edges $ focus graph
+        , focus = newVertexID
-          }
       }
     Just newGraph -> newGraph
 
-editLabel :: Graph edge label -> (label -> label) -> Graph edge label
+weave :: (Monoid label, Ord edge) => Graph edge label -> [edge] -> Graph edge label
-editLabel graph@(Graph {focus}) labelEditor =
+weave = foldl stitch
-  graph {focus = focus {label = labelEditor $ label focus}}
+
+editVertex :: Graph edge label -> (Vertex edge label -> Vertex edge label) -> Graph edge label
+editVertex graph@(Graph {vertices, focus}) vertexEditor =
+  graph {vertices = Map.adjust vertexEditor focus vertices}

src/Lang/En/Grapheme.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Lang.En.Grapheme (
+      Grapheme(..)
+    , Output(..)
+    , Regular(..)
+    , graphemes
+    , parse
+  ) where
+
+import Data.Char (toLower, isLower)
+import Data.List (groupBy)
+import qualified Data.Map as Map (empty, insert, lookup)
+import Data.String (IsString(..))
+--import Graph (Graph(..))
+import Stream (Stream)
+import Transducer (Transducer(..), fromList, run)
+--import Transducer (Transducer(..), RunState(..), Stack(..), fromList)
+
+data Regular =
+    A
+  | Ae
+  | Ai
+  | Ay
+  | E
+  | Ea
+  | Ee
+  | Ei
+  | B
+  | C
+  | Ck
+  | D
+  | F
+  | G
+  | Gh
+  | L
+  | P
+  | S
+  | T
+  | Th
+  | W
+  | Wh
+  deriving (Bounded, Enum, Eq, Ord, Read, Show)
+
+{-
+card :: Int
+card = fromEnum (maxBound :: Regular)
+-}
+
+data Grapheme = Grapheme Regular | Punctuation String deriving (Eq, Ord, Show)
+
+instance Read Grapheme where
+  readsPrec _ next =
+      [(maybe (Punctuation next) Grapheme $ Map.lookup next stringToGrapheme, "")]
+    where
+      stringToGrapheme = foldr insert Map.empty [minBound .. maxBound]
+      insert regular = Map.insert (show regular) regular
+      
+
+instance {-# OVERLAPS #-} IsString [Grapheme] where
+  fromString = fmap read . groupBy (const isLower)
+
+data Output = Output {
+      rawText :: String
+    , grapheme :: Grapheme
+  } deriving (Eq, Show)
+
+{-
+instance Enum Grapheme where
+  fromEnum (Regular r) = fromEnum r
+  fromEnum (Noise c) = card + fromEnum c
+
+  toEnum n
+    | n < card = Regular $ toEnum n
+    | otherwise = Noise $ toEnum (n - card)
+-}
+
+auto :: Regular -> ([Char], Either [Char] Grapheme)
+auto r = (toLower <$> show r, Right (Grapheme r))
+
+punctuation :: String -> ([Char], Either [Char] Grapheme)
+punctuation signs = (signs, Right (Punctuation signs))
+
+{-
+groupSpaces :: RunState Char Char Grapheme -> Maybe (RunState Char Char Grapheme)
+groupSpaces state@(RunState {transducer, stack = Stack (' ':ls)})
+  | focus (graph transducer) == 0 = Just $ state {stack = Stack ls}
+groupSpaces _ = Nothing
+-}
+
+graphemes :: Transducer Char Char Grapheme
+graphemes = (fromList $ punctuations ++ regulars) {
+    projector = toLower
+  }
+  where
+    regulars = auto <$> [minBound .. maxBound]
+    punctuations = punctuation <$> ["?", "!", ".", ",", ":", " "]
+
+parse :: Stream Char -> Stream Output
+parse = fmap (uncurry Output) . run graphemes

src/Lang/En/Morpheme.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Lang.En.Morpheme (
+      Morpheme(..)
+    , Output(..)
+    , morphemes
+    , parse
+  ) where
+
+import Data.String (fromString)
+import Lang.En.Grapheme (Grapheme(..))
+import qualified Lang.En.Grapheme as Grapheme (Output(..))
+import Stream (Stream)
+import Transducer (Transducer(..), fromList, run)
+
+data Regular =
+    LY
+  | ED
+  | UN
+  | CAT
+  | DOG
+  | EaT
+  | SLEeP
+  | A
+  | ThE
+  | GOoD
+  | KINd
+  | ANd
+  | Space
+  deriving (Bounded, Enum, Eq, Ord, Show)
+
+data Morpheme = Morpheme Regular | Punctuation String deriving (Eq, Ord, Show)
+
+auto :: Morpheme -> ([Grapheme], Either [Grapheme] Morpheme)
+auto morpheme = (fromString $ show morpheme, Right morpheme)
+
+morphemes :: Transducer Grapheme.Output Grapheme Morpheme
+morphemes = (fromList $ auto <$> [minBound .. maxBound]) {
+      projector = Grapheme.grapheme
+    , rules = []
+  }
+
+data Output = Output {
+      rawText :: String
+    , morpheme :: Morpheme
+  } deriving (Eq, Show)
+
+parse :: Stream Grapheme.Output -> Stream Output
+parse = fmap fusionGraphemes . run morphemes
+  where
+    fusionGraphemes (graphemes, morpheme) = Output {
+          rawText = concat $ Grapheme.rawText <$> graphemes
+        , morpheme
+      }

src/Stream.hs

@@ -16,6 +16,7 @@ instance Functor Stream where
     Stream $ (\(a, stream) -> (f a, fmap f stream)) <$> pairs
 
 instance Tree Stream where
+  getStructure (Stream []) = Leaf
   getStructure (Stream pairs) =
     Node $ (\(s, stream) -> (s, getStructure stream)) <$> pairs
 

src/Transducer.hs

@@ -1,34 +1,94 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Transducer (
-      Transducer
+      RunState(..)
+    , Stack(..)
+    , Transducer(..)
     , fromList
     , run
   ) where
 
+import Data.List (find)
+import Data.Map ((!), insert)
+import Data.Maybe (isJust)
+import Graph (Graph(..), Vertex(..), editVertex, follow, rewind, singleton, weave)
 import Stream (Stream(..), merge)
 import qualified Stream (empty)
-import Graph (Graph(..), Vertex(..), Zipper(..), editLabel, follow, open, rewind, singleton, weave)
 
-type Transducer input output = Graph input [output]
+data Transducer input label output = Transducer {
+      graph :: Graph label [output]
+    , rules :: [RunState input label output -> Maybe (RunState input label output)]
+    , projector :: input -> label
+  }
 
-empty :: Transducer input output
+empty :: Graph edge [label]
-empty = open $ singleton []
+empty = singleton []
 
-add :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
+entry :: Ord edge => Graph edge [label] -> ([edge], label) -> Graph edge [label]
-add transducer (path, output) =
+entry transducer (path, output) =
-  rewind $ editLabel (weave transducer path) (output:)
+  rewind $ editVertex (weave transducer path) pushLabel
-
-fromList :: Ord input => [([input], output)] -> Transducer input output
-fromList = foldl add empty
-
-run :: (Ord input, Eq output) => Transducer input output -> Stream input -> Stream output
-run transducer (Stream inputs) = foldl (\(Stream outputs) (input, stream) ->
-    case follow transducer input of
-      Nothing -> case context transducer of
-        Top -> run (rewind transducer) stream
-        _ -> Stream.empty
-      Just newState@(Graph {focus}) ->
-        Stream ((emit stream <$> label focus) ++ outputs) `merge` run newState stream
-  ) Stream.empty inputs
   where
-    emit stream output = (output, run (rewind transducer) stream)
+    pushLabel vertex = vertex {label = output:(label vertex)}
+
+loop :: Ord edge => Graph edge [label] -> ([edge], [edge]) -> Graph edge [label]
+loop transducer ([], loopPath) =
+  case splitAt (length loopPath - 1) loopPath of
+    (_, []) -> transducer
+    (loopBegining, lastInput:_) ->
+      let end = weave transducer loopBegining in
+      rewind $
+        editVertex end $ tieKnot lastInput
+  where
+    tieKnot input vertex =
+      vertex {edges = insert input (focus transducer) $ edges vertex}
+loop transducer (prefix, loopPath) = loop (weave transducer prefix) ([], loopPath)
+
+fromList :: Ord input => [([input], Either [input] output)] -> Transducer input input output
+fromList l = Transducer {graph = foldl add empty l, projector = id, rules = []}
+  where
+    add transducer (path, Left loopPath) = loop transducer (path, loopPath)
+    add transducer (path, Right output) = entry transducer (path, output)
+
+data RunState input label output = RunState {
+      transducer :: Transducer input label output
+    , stack :: Stack input
+  }
+
+initState :: Transducer input label output -> RunState input label output
+initState transducer = RunState {
+      transducer = transducer {graph = rewind $ graph transducer}
+    , stack = Stack []
+  }
+
+newtype Stack a = Stack [a]
+
+push :: a -> Stack a -> Stack a
+push a (Stack s) = Stack (a:s)
+
+content :: Stack a -> [a]
+content (Stack s) = reverse s
+
+tryInput :: (Eq input, Ord label, Eq output) => RunState input label output -> Stream ([input], output) -> (input, Stream input) -> Stream ([input], output)
+tryInput state@(RunState {transducer, stack}) outputsStream (input, stream) =
+  case follow (graph transducer) (projector transducer $ input) of
+    Nothing -> Stream.empty
+    Just newGraph@(Graph {vertices, focus}) ->
+      let newStack = push input stack in
+      let emitted = Stream $ emit newStack <$> label (vertices ! focus) in
+      let continue = runState (state {
+            transducer = transducer {graph = newGraph}
+          , stack = newStack
+        }) stream in
+      emitted `merge` continue `merge` outputsStream
+  where
+    emit aStack output = (
+        (content aStack, output), runState (initState transducer) stream
+      )
+
+runState :: (Eq input, Ord label, Eq output) => RunState input label output -> Stream input -> Stream ([input], output)
+runState state@(RunState {transducer}) (Stream inputs) =
+  case find isJust $ ($ state) <$> rules transducer of
+    Just (Just newState) -> runState newState (Stream inputs)
+    _ -> foldl (tryInput state) Stream.empty inputs
+
+run :: (Eq input, Ord label, Eq output) => Transducer input label output -> Stream input -> Stream ([input], output)
+run transducer = runState $ initState transducer

src/Tree.hs

@@ -3,7 +3,7 @@ module Tree (
     , Structure(..)
   ) where
 
-data Structure = Node [(String, Structure)]
+data Structure = Leaf | Node [(String, Structure)]
 
 class Functor a => Tree a where
   getStructure :: a String -> Structure
@@ -12,7 +12,8 @@ class Functor a => Tree a where
   draw = unlines . getLines . getStructure . fmap show
 
 getLines :: Structure -> [String]
-getLines (Node []) = ["╼"]
+getLines Leaf = ["╼"]
+getLines (Node []) = [""]
 getLines (Node [(s, structure)]) = showBlock '─' (s, structure)
 getLines (Node ((s, structure):pairs)) = concat $
   showBlock '┬' (s, structure) : showBlocks pairs