Binary Search Tree in PureScript

Main.purs

module Main where

import Prelude
import Effect (Effect)
import Effect.Console (logShow, log)
import Data.List (fromFoldable)
import Data.Array (replicate, concatMap)
import Data.String.Common (joinWith)
import Data.Foldable (foldMap)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

data Tree a
  = Empty
  | Node a (Tree a) (Tree a)

showDF :: forall a. Show a => Tree a -> String
showDF = showAtLevel 0
  where
    showAtLevel l Empty =
      foldMap identity
      [ pad l
      , "E"
      ]
    showAtLevel i (Node v l r) =
      foldMap identity
      [ pad i
      , show v
      , "\n"
      , showAtLevel (i+1) l
      , "\n"
      , showAtLevel (i+1) r
      ]
    pad i = joinWith "" $ replicate (i*2) " "

showBF :: forall a. Show a => Tree a -> String
showBF t = joinWith "" $ step [t]
  where
    step [] = []
    step ts = concatMap elems ts <> ["\n"] <> step (concatMap subtrees ts)
    elems (Empty)      = ["E", " "]
    elems (Node v _ _) = [show v, " "]
    subtrees (Empty)      = []
    subtrees (Node _ l r) = [l, r]

insert :: forall a. Ord a => a -> Tree a -> Tree a
insert v' (Empty) = Node v' Empty Empty
insert v' t@(Node v l r)
  | v' < v    = Node v (insert v' l) r
  | v' > v    = Node v l (insert v' r)
  | otherwise = t

contains :: forall a. Ord a => a -> Tree a -> Boolean
contains v' (Empty) = false
contains v' t@(Node v l r)
  | v' < v    = contains v' l
  | v' > v    = contains v' r
  | otherwise = true

max :: forall a. Ord a => Tree a -> Maybe a
max = max' Nothing
  where
    max' m (Empty)      = m
    max' m (Node v _ r) = max' (Just v) r

min :: forall a. Ord a => Tree a -> Maybe a
min = min' Nothing
  where
    min' m (Empty)      = m
    min' m (Node v l _) = min' (Just v) l

delete :: forall a. Ord a => a -> Tree a -> Tree a
delete v' (Empty) = Empty
delete v' (Node v l r)
  | v' < v = Node v (delete v' l) r
  | v' > v = Node v l (delete v' r)
  | otherwise =
    case Tuple (max l) (min r) of
      Tuple Nothing  Nothing  -> Empty
      Tuple (Just _) Nothing  -> l
      Tuple Nothing  (Just _) -> r
      Tuple (Just _) (Just m) -> Node m l (delete m r)

main :: Effect Unit
main = do
  log $ showDF t
  -- 1
  --   E
  --   2
  --     E
  --     E
  log $ showBF t
  -- 1
  -- E 2
  -- E E
  logShow $ contains 1 t -- true
  logShow $ contains 2 t -- true
  logShow $ contains 3 t -- false
  logShow $ max t -- Just 2
  logShow $ min t -- Just 1
  log $ showBF $ delete 1 t
  -- 2
  -- E E
  log $ showBF $ delete 2 t
  -- 1
  -- E E
  log $ showBF $ delete 3 t
  -- 1
  -- E 2
  -- E E
  where t = insert 2 $ insert 1 Empty