Mainate.cabal

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

src/Graph.hs

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

src/Lang/En/Grapheme.hs

@@ -1,100 +0,0 @@
-{-# 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

@@ -1,53 +0,0 @@
-{-# 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,7 +16,6 @@ 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,94 +1,34 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Transducer (
-      RunState(..)
-    , Stack(..)
-    , Transducer(..)
+      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)
 
-data Transducer input label output = Transducer {
-      graph :: Graph label [output]
-    , rules :: [RunState input label output -> Maybe (RunState input label output)]
-    , projector :: input -> label
-  }
+type Transducer input output = Graph input [output]
 
-empty :: Graph edge [label]
-empty = singleton []
+empty :: Transducer input output
+empty = open $ singleton []
 
-entry :: Ord edge => Graph edge [label] -> ([edge], label) -> Graph edge [label]
-entry transducer (path, output) =
-  rewind $ editVertex (weave transducer path) pushLabel
+add :: Ord input => Transducer input output -> ([input], output) -> Transducer input output
+add transducer (path, output) =
+  rewind $ editLabel (weave transducer path) (output:)
+
+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
-    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
+    emit stream output = (output, run (rewind transducer) stream)

src/Tree.hs

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