zenith/src/Zenith/Tree.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

module Zenith.Tree where

import Data.HexString

class Monoid v =>
      Measured a v
  where
  measure :: a -> Integer -> v

class Node v where
  getLevel :: v -> Level
  getTag :: v -> String
  getPosition :: v -> Integer
  isFull :: v -> Bool

type Level = Int

type OrchardCommitment = String

instance Measured [Char] OrchardNode where
  measure oc p = OrchardNode p oc 0 True

data Tree v
  = Leaf !v
  | Branch !v !(Tree v) !(Tree v)
  | EmptyLeaf
  deriving (Eq)

instance (Node v, Show v) => Show (Tree v) where
  show EmptyLeaf = "()"
  show (Leaf v) = "(" ++ show v ++ ")"
  show (Branch s x y) = "<" ++ getTag s ++ ">\n" ++ show x ++ "\n" ++ show y

instance (Monoid v, Node v) => Semigroup (Tree v) where
  (<>) EmptyLeaf x = x
  (<>) (Leaf x) EmptyLeaf = branch (Leaf x) EmptyLeaf
  (<>) (Leaf x) (Leaf y) = branch (Leaf x) (Leaf y)
  (<>) (Leaf x) Branch {} = Leaf x
  (<>) (Branch s x y) EmptyLeaf = branch (Branch s x y) EmptyLeaf
  (<>) (Branch s x y) (Leaf w)
    | isFull s = Branch s x y <> mkSubTree (getLevel s) (Leaf w)
    | isFull (value x) = branch x (y <> Leaf w)
    | otherwise = branch (x <> Leaf w) y
  (<>) (Branch s x y) (Branch s1 x1 y1)
    | getLevel s == getLevel s1 = branch (Branch s x y) (Branch s1 x1 y1)
    | otherwise = Branch s x y

value :: Monoid v => Tree v -> v
value EmptyLeaf = mempty
value (Leaf v) = v
value (Branch v _ _) = v

branch :: Monoid v => Tree v -> Tree v -> Tree v
branch x y = Branch (value x <> value y) x y

leaf :: Measured a v => a -> Integer -> Tree v
leaf a p = Leaf (measure a p)

data OrchardNode = OrchardNode
  { on_position :: !Integer
  , on_value :: !String
  , on_level :: !Level
  , on_full :: !Bool
  } deriving (Eq)

instance Semigroup OrchardNode where
  (<>) x y =
    OrchardNode
      (max (on_position x) (on_position y))
      (on_value x <> on_value y)
      (1 + on_level x)
      (on_full x && on_full y)

instance Monoid OrchardNode where
  mempty = OrchardNode 0 "" 0 False
  mappend = (<>)

instance Node OrchardNode where
  getLevel = on_level
  getTag = on_value
  getPosition = on_position
  isFull = on_full

instance Show OrchardNode where
  show = on_value

instance Measured OrchardNode OrchardNode where
  measure o p = OrchardNode p (on_value o) (on_level o) (on_full o)

mkSubTree :: Node v => Monoid v => Level -> Tree v -> Tree v
mkSubTree level t =
  if getLevel (value subtree) == level
    then subtree
    else mkSubTree level subtree
  where
    subtree = t <> EmptyLeaf