DFS/BFS by Writer

Main.purs

module Main where

import Prelude

import Data.String (joinWith)
import Control.Monad.Eff.Console (logShow)
import Data.List (List(..), fromFoldable)
import Data.Monoid (class Monoid)
import Control.Monad.Writer (execWriter, tell)
import TryPureScript (render, withConsole)

type Id = Int
data Vertex = Vertex Id (Array Vertex)

tree :: Vertex
tree = 
  Vertex 0 [
    Vertex 1 [Vertex 3 []],
    Vertex 2 [],
    Vertex 3 [Vertex 4 [Vertex 5 []]]
  ]
  
instance showVertex :: Show Vertex where
  show (Vertex id children) = "Vertex " <> show id <> "[" <> childrenString <> "]" 
    where childrenString = joinWith ","  $ map show children 
  
data MaybeFirst a = Nothing | First a

instance showMaybeFirst :: Show a => Show (MaybeFirst a) where
  show Nothing = "Nothing"
  show (First a) = "(First " <> show a <> ")"

derive instance functorFirst :: Functor MaybeFirst

instance applyMaybeFirst :: Apply MaybeFirst where
  apply (First f) (First x) = First (f x)
  apply _ _ = Nothing

instance applicativeMaybeFirst :: Applicative MaybeFirst where
  pure = First

instance semigroupMaybeFirst :: Semigroup (MaybeFirst a) where
  append Nothing x = x
  append a@(First _) _ = a
  
instance monoidMaybeFirst :: Monoid (MaybeFirst a) where
  mempty = Nothing

type Enqueue = Array Vertex -> List Vertex -> List Vertex
           
search :: forall m
         . Monoid (m Vertex)
        => Applicative m 
        => Enqueue 
        -> Id
        -> Vertex
        -> m Vertex
search enqueue id v = execWriter $ go (pure v)
  where
    go Nil = pure unit
    go (Cons v@(Vertex x children) vs) = do
      when (x == id) do
        tell $ pure v
      go (enqueue children vs)
          
dfs :: forall m
     . Monoid (m Vertex)
    => Applicative m
    => Id
    -> Vertex 
    -> m Vertex
dfs = search prepend
  where prepend children vs = fromFoldable children <> vs
  
bfs :: forall m
     . Monoid (m Vertex)
    => Applicative m
    => Id
    -> Vertex 
    -> m Vertex
bfs = search append
  where append children vs = vs <> fromFoldable children

main = render =<< withConsole do
  logShow $ (dfs 3 tree :: List Vertex)
  logShow $ (bfs 3 tree :: List Vertex)
  logShow $ (dfs 3 tree :: MaybeFirst Vertex)
  logShow $ (bfs 3 tree :: MaybeFirst Vertex)