diff --git a/.gitignore b/.gitignore
index da20957573b945adb8542dfdfb99c68b9c8c666c..1910193313905b3d221358da66f945645b6dee28 100644
--- a/.gitignore
+++ b/.gitignore
@@ -23,3 +23,5 @@ cabal.project.local~
 .ghc.environment.*
 
 .DS_Store
+
+result
diff --git a/package.yaml b/package.yaml
index e458c08913f9f8bbee703768c9d879b4737ede4d..4b6f4f7f083f70aee90800274baaa337ae24f103 100644
--- a/package.yaml
+++ b/package.yaml
@@ -10,20 +10,28 @@ ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
 dependencies:
   - base >= 4.9 && < 5
   - transformers
+  - free
+  - data-fix
   - mtl
   - language-c
 
 library:
   source-dirs: src
 
-# tests:
-#   template-test:
-#     source-dirs: test/src
-#     main: Main.hs
-#     dependencies:
-#       - template
-#       - hedgehog
-#       - hspec
-#       - hspec-discover
-#       - hspec-expectations-pretty-diff
-#       - hspec-hedgehog
+tests:
+  rtree-test:
+    source-dirs: test/src
+    main: Main.hs
+    dependencies:
+      - rtree
+      - diagrams
+      - diagrams-lib
+      - diagrams-core
+      - diagrams-contrib
+      - diagrams-svg
+      # - template
+      # - hedgehog
+      # - hspec
+      # - hspec-discover
+      # - hspec-expectations-pretty-diff
+      # - hspec-hedgehog
diff --git a/rtree.cabal b/rtree.cabal
index f8feff16867f52bbdeb167cf1cb54fe3a5472ecb..102208a5df085cbe23777c5615a511699ebe71f3 100644
--- a/rtree.cabal
+++ b/rtree.cabal
@@ -18,7 +18,32 @@ library
   ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
   build-depends:
       base >=4.9 && <5
+    , data-fix
+    , free
     , language-c
     , mtl
     , transformers
   default-language: Haskell2010
+
+test-suite rtree-test
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+      Paths_rtree
+  hs-source-dirs:
+      test/src
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
+  build-depends:
+      base >=4.9 && <5
+    , data-fix
+    , diagrams
+    , diagrams-contrib
+    , diagrams-core
+    , diagrams-lib
+    , diagrams-svg
+    , free
+    , language-c
+    , mtl
+    , rtree
+    , transformers
+  default-language: Haskell2010
diff --git a/src/Control/RTree.hs b/src/Control/RTree.hs
index 3a6ffc32f430be1289627cf12257b9d0a44dfb62..857cc8208a937e66684edb96490a8d6bfc21315a 100644
--- a/src/Control/RTree.hs
+++ b/src/Control/RTree.hs
@@ -1,95 +1,98 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 
 {- |
-
 Module: Control.RTree
 -}
 module Control.RTree where
 
-import Control.Monad
+import Control.Applicative (Alternative ((<|>)))
 import Data.Functor
-import Data.Functor.Identity
+import Data.Functor.Classes
 import qualified Data.List.NonEmpty as NE
 
--- | The reduction tree, parameterized by a genrative functor 'f'.
-data ReduceT f i
-  = Done i
-  | f (ReduceT f i) :<| ReduceT f i
+import Data.Coerce (coerce)
+import "free" Control.Monad.Free
 
-type RTree i = ReduceT Identity i
+-- | The reduction tree
+data RTreeF f
+  = f :<| f
+  | Lab String f f
+  deriving (Show, Eq, Functor)
 
-{- | The reduction tree is a functor, but only over order-embeddings,
-this means that i@f a <= f b@ iff @a <= b@.
--}
-instance (Functor f) => Functor (ReduceT f) where
-  fmap f = \case
-    Done i -> Done (f i)
-    mi :<| ri -> fmap (fmap f) mi :<| fmap f ri
-
-instance (Functor f) => Applicative (ReduceT f) where
-  pure = Done
-  (<*>) = ap
-
-instance (Functor f) => Monad (ReduceT f) where
-  ma >>= fa = case ma of
-    Done i -> fa i
-    mi :<| ri -> ((>>= fa) <$> mi) :<| (ri >>= fa)
-
--- | Change the underlying monad using a natural transformation.
-liftR :: (Functor f) => (forall a. f a -> g a) -> ReduceT f i -> ReduceT g i
-liftR nat = \case
-  Done i -> Done i
-  lhs :<| rhs -> nat (liftR nat <$> lhs) :<| liftR nat rhs
+instance Show1 RTreeF where
+  liftShowsPrec = undefined
 
--- | Extract the input from the reducer.
-extract :: ReduceT f i -> i
-extract = \case
-  Done i -> i
-  _ :<| rhs -> extract rhs
+newtype RTree i = RTree {rtreeFree :: Free RTreeF i}
+  deriving (Show)
+  deriving (Functor, Applicative, Monad) via (Free RTreeF)
 
--- | Reduce an input using a monad.
-reduce :: (MonadPlus m) => (i -> m ()) -> ReduceT m i -> m i
-reduce fn rt = case rt of
-  Done i -> fn i $> i
-  lhs :<| rhs -> do
-    (lhs >>= reduce fn) `mplus` reduce fn rhs
+instance MonadFree RTreeF RTree where
+  wrap x = RTree (Free (fmap rtreeFree x))
 
 infixr 3 <|
+infixl 3 |>
+
+(<|) :: (MonadFree RTreeF r) => r i -> r i -> r i
+r1 <| r2 = wrap (r1 :<| r2)
+
+lab :: (MonadFree RTreeF r) => String -> r i -> r i -> r i
+lab l r1 r2 = wrap (Lab l r1 r2)
+
+(|>) :: (MonadFree RTreeF r) => r i -> r i -> r i
+r1 |> r2 = wrap (r2 :<| r1)
+
+foldR :: (RTreeF a -> a) -> RTree a -> a
+foldR fn = coerce $ iter fn
+
+-- | Extract the input from the reducer.
+extract :: RTree i -> i
+extract = foldR \case
+  (_ :<| e) -> e
+  Lab _ _ e -> e
 
--- Combinators
-(<|) :: (Applicative f) => ReduceT f i -> ReduceT f i -> ReduceT f i
-f <| b = pure f :<| b
+-- | Reduce an input using a monad.
+reduce :: (Alternative m) => (i -> m ()) -> RTree i -> m i
+reduce fn =
+  ( foldR \case
+      lhs :<| rhs -> lhs <|> rhs
+      Lab _ lhs rhs -> lhs <|> rhs
+  )
+    . fmap (\i -> fn i $> i)
 
 -- | Split the world on a fact. False it does not happen, and True it does happen.
-given :: (Applicative f) => ReduceT f Bool
+given :: RTree Bool
 given = pure False <| pure True
 
--- | A reducer is something that takes an inputs and returns a reduction tree.
-type Reducer m i = i -> ReduceT m i
-
 {- | A reducer should extract itself
 @
  extract . red = id
 @
 -}
-lawReduceId :: (Eq i) => Reducer m i -> i -> Bool
+lawReduceId :: (Eq i) => (i -> RTree i) -> i -> Bool
 lawReduceId red i = extract (red i) == i
 
 -- | Reducing a list one element at a time.
-rList :: (Applicative m) => Reducer m [a]
+rList :: [a] -> RTree [a]
 rList = \case
-  [] -> Done []
+  [] -> pure []
   a : as -> rList as <| (a :) <$> rList as
 
 {- | Binary reduction on the list assumming suffixes all contain eachother:
 @[] < [c] < [b, c] < [a,b,c]@
 -}
-rSuffixList :: (Applicative m) => Reducer m [a]
+rSuffixList :: [a] -> RTree [a]
 rSuffixList as = do
-  res <- binarySearch (NE.reverse (NE.tails as))
+  res <- exponentialSearch (NE.tails as)
   case res of
     [] -> pure []
     a : as' -> (a :) <$> rSuffixList as'
@@ -97,23 +100,41 @@ rSuffixList as = do
 {- | Given a progression of inputs that are progressively larger, pick the smallest using
 binary search.
 -}
-binarySearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
+binarySearch :: NE.NonEmpty i -> RTree i
 binarySearch = \case
-  a NE.:| [] -> Done a
-  d -> binarySearch f <| binarySearch l
+  a NE.:| [] -> pure a
+  d -> binarySearch l <| binarySearch f
    where
     (NE.fromList -> f, NE.fromList -> l) = NE.splitAt (NE.length d `div` 2) d
 
+{- | Given a progression of inputs that are progressively larger, pick the smallest using
+binary search.
+-}
+exponentialSearch :: NE.NonEmpty i -> RTree i
+exponentialSearch = go 1
+ where
+  go n = \case
+    d
+      | n >= NE.length d -> binarySearch d
+      | otherwise -> go (n * 2) l <| binarySearch f
+     where
+      (NE.fromList -> f, NE.fromList -> l) = NE.splitAt n d
+
+nonEmptyOr :: String -> [a] -> NE.NonEmpty a
+nonEmptyOr msg ls = case NE.nonEmpty ls of
+  Just a -> a
+  Nothing -> error msg
+
 -- | Given a list of orderd options,  the
-linearSearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
-linearSearch = foldr1 (<|) . fmap Done
+linearSearch :: NE.NonEmpty i -> RTree i
+linearSearch = foldr1 (<|) . fmap pure
 
 -- | Given a list of orderd options,  the
-linearSearch' :: (Applicative m) => [i] -> ReduceT m (Maybe i)
+linearSearch' :: [i] -> RTree (Maybe i)
 linearSearch' is = linearSearch (NE.fromList $ fmap Just is ++ [Nothing])
 
 -- | Given
-ddmin :: (Applicative m) => [i] -> ReduceT m [i]
+ddmin :: [i] -> RTree [i]
 ddmin = \case
   [] -> pure []
   [a] -> pure [a]
diff --git a/test/src/Main.hs b/test/src/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..5be905a2dd31a3b13ab2c87066c4ec657e7a9035
--- /dev/null
+++ b/test/src/Main.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# HLINT ignore "Redundant bracket" #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+import Control.RTree
+
+import Control.RTree (exponentialSearch)
+import qualified Data.List.NonEmpty as NE
+import "diagrams-contrib" Diagrams.TwoD.Layout.Tree
+import "diagrams-lib" Diagrams.Prelude hiding (Empty, (<|))
+import "diagrams-svg" Diagrams.Backend.SVG ()
+import "diagrams-svg" Diagrams.Backend.SVG.CmdLine
+
+type Var = String
+
+data Exp
+  = Num Int
+  | Add Exp Exp
+  | Let Var Exp Exp
+  | Var Var
+
+replace :: Var -> Exp -> Exp -> Exp
+replace v e = \case
+  Num n -> Num n
+  Add e1 e2 -> Add (replace v e e1) (replace v e e2)
+  Let v1 e1 e2
+    | v1 /= v -> Let v1 (replace v e e1) (replace v e e2)
+    | otherwise -> Let v1 e1 e2
+  Var v'
+    | v == v' -> e
+    | otherwise -> Var v'
+
+instance Show Exp where
+  showsPrec n = \case
+    Num n' -> shows n'
+    Add e1 e2 ->
+      showParen (n > 2) (showsPrec 2 e1 . showString " + " . showsPrec 3 e2)
+    Let v e1 e2 ->
+      showParen (n > 0)
+        $ showString v
+        . showString ":="
+        . showsPrec 1 e1
+        . showString "; "
+        . shows e2
+    Var v -> showString v
+
+expR :: Exp -> RTree Exp
+expR = \case
+  Num n ->
+    pure (Num 0) <| pure (Num n)
+  Add e1 e2 ->
+    expR e1 <| expR e2 <| (Add <$> expR e1 <*> expR e2)
+  Let v e1 e2 ->
+    expR (replace v e1 e2) <| Let v <$> expR e1 <*> expR e2
+  Var v -> pure (Var v)
+
+genD :: (Show e) => RTree e -> BTree (QDiagram SVG V2 Double Any)
+genD =
+  foldR
+    ( \(lhs :<| rhs) ->
+        BNode
+          ( triangle 0.2
+              # rotate (90 @@ deg)
+              <> circle 0.2
+              # fc white
+              # lc white
+          )
+          lhs
+          rhs
+    )
+    . fmap
+      ( \i ->
+          BNode
+            ( text (show i)
+                # fontSizeL 0.3
+                <> circle 0.3
+                # fc white
+                # lc white
+            )
+            Empty
+            Empty
+      )
+
+--   ( text n
+--       # fontSizeL (0.5 :: (Double))
+--       <> circle 0.3
+--       # fc white
+--   )
+
+main :: IO ()
+main = do
+  let Just t' =
+        uniqueXLayout
+          1
+          1.2
+          -- (genD (binarySearch (1 NE.:| [2, 3, 4, 5, 7, 6, 8 :: Int])))
+          -- (genD (binarySearch (1 NE.:| [2, 3, 4, 5, 7, 6, 8 :: Int])))
+          (genD (rSuffixList [1, 2, 3, 4, 5 :: Int]))
+  -- (genD (expR (Let "x" (Num 10) (Add (Num 2) (Add (Var "x") (Num 3))))))
+  defaultMain
+    $ renderTree id (~~) (forceLayoutTree t')
+    # centerXY
+    # pad 1.1
diff --git a/test/test.sh b/test/test.sh
new file mode 100755
index 0000000000000000000000000000000000000000..2cfc4fb41e8db6554cd188a531713f181181b853
--- /dev/null
+++ b/test/test.sh
@@ -0,0 +1 @@
+cabal test --test-options='-o test.svg -w 600 -h 400' --test-show-details=streaming