 
 ; Adds a new element to the front of the finger tree
 (defmulti push-front (fn [tree value] (class tree)))
-(defmethod push-front finger-tree-empty [_ a]
-    (finger-tree-single. a))
-(defmethod push-front finger-tree-single [{r :v} a]
-    (finger-tree-deep. [a] (delay (finger-tree-empty.)) [r]))
-(defmethod push-front finger-tree-deep [{l :l m :m r :r} a]
+(defmethod push-front finger-tree-empty [tree a]
+    (make-finger-tree-single (:monoid tree) a))
+(defmethod push-front finger-tree-single [{r :e monoid :monoid} a]
+    (make-finger-tree-deep monoid [a] (delay (make-finger-tree-empty monoid)) [r]))
+(defmethod push-front finger-tree-deep [{monoid :monoid l :l m :m r :r} a]
     (if (<= (count l) 3)
-        (finger-tree-deep. (cons a l) m r)
-        (finger-tree-deep.
+        (make-finger-tree-deep monoid (cons a l) m r)
+        (make-finger-tree-deep
+            monoid
             [a (first l)]
             (let [m-forced (force m)]
-                (delay (push-front m-forced (apply make-node-3 (rest l)))))
+                (delay (push-front m-forced (apply make-node-3 monoid (rest l)))))
             r)))
 
 ; Adds a new element to the back of the finger tree
 (defmulti push-back (fn [tree value] (class tree)))
-(defmethod push-back finger-tree-empty [_ a]
-    (finger-tree-single. a))
-(defmethod push-back finger-tree-single [{r :v} a]
-    (finger-tree-deep. [r] (delay (finger-tree-empty.)) [a]))
-(defmethod push-back finger-tree-deep [{l :l m :m r :r} a]
+(defmethod push-back finger-tree-empty [{monoid :monoid} a]
+    (make-finger-tree-single monoid a))
+(defmethod push-back finger-tree-single [{r :e monoid :monoid} a]
+    (make-finger-tree-deep monoid [r] (delay (make-finger-tree-empty monoid)) [a]))
+(defmethod push-back finger-tree-deep [{monoid :monoid l :l m :m r :r} a]
     (if (<= (count r) 3)
-        (finger-tree-deep. l m (snoc a r))
-        (finger-tree-deep.
+        (make-finger-tree-deep monoid l m (snoc a r))
+        (make-finger-tree-deep
+            monoid
             l
             (let [m-forced (force m)]
-                (delay (push-back m-forced (apply make-node-3 (tser r)))))
+                (delay (push-back m-forced (apply make-node-3 monoid (tser r)))))
             [(last r) a])))
 
-(defn nodes [a b & r]
+(defn nodes [monoid a b & r]
     (case (count r)
-        0 [(node-2. a b)]
-        1 [(node-3. a b (first r))]
-        2 [(node-2. a b) (apply make-node-2 r)]
-        (cons (node-3. a b (first r)) (apply nodes (rest r)))))
+        0 [(make-node-2 monoid a b)]
+        1 [(make-node-3 monoid a b (first r))]
+        2 [(make-node-2 monoid a b) (apply make-node-2 monoid r)]
+        (cons (make-node-3 monoid a b (first r)) (apply nodes monoid (rest r)))))
 
 (defmulti app3 (fn [l m r] [(class l) (class r)]))
 (defmethod app3 [finger-tree-empty ::any] [l m r]

(defmethod concatenate [::any finger-tree-empty] [a _] a)
(defmethod concatenate [finger-tree-empty ::any] [_ b] b)
(defmethod concatenate [::any finger-tree-single] [a b]
    (push-back a (:v b)))
(defmethod concatenate [finger-tree-single ::any] [a b]
    (push-front (:v a) b))
(defmethod concatenate [finger-tree-deep finger-tree-deep] [a b]
    (finger-tree-deep.
        (:l a)
        (app3 (force (:m a)) (apply nodes (concat (:r a) (:l b))) (force (:m b)))
        (:r b)))

; Functions to print finger-trees to graphviz

; :mode=clojure:

(defrecord monoid [measure-fn combine-fn])
(defrecord node-2 [v a b])
(defrecord node-3 [v a b c])
(defrecord finger-tree-empty [monoid])
(defrecord finger-tree-single [monoid e])
(defrecord finger-tree-deep [monoid v l m r])

(derive Object ::any)

; Extract the (possibly cached) measure from an object.
; Some parts of the structure cache the monoid, which makes the argument redundant..
(defmulti extract-measure (fn [object monoid] (class object)))
(defmethod extract-measure node-2 [{v :v} _] v)
(defmethod extract-measure node-3 [{v :v} _] v)
(defmethod extract-measure finger-tree-empty [{{cf :combine-fn} :monoid} _] (cf))
(defmethod extract-measure finger-tree-single [{monoid :monoid e :e} _] (extract-measure e monoid))
(defmethod extract-measure finger-tree-deep [{v :v} _] (force v))
(defmethod extract-measure ::any [e {mf :measure-fn}] (mf e))

; Constructor functions
(defn make-node-2 [monoid a b]
    (node-2.
        (apply
            (:combine-fn monoid)
            (map (fn [e] (extract-measure e monoid)) [a b]))
        a b))
(defn make-node-3 [monoid a b c]
    (node-3.
        (apply
            (:combine-fn monoid)
            (map (fn [e] (extract-measure e monoid)) [a b c]))
        a b c))
(defn make-finger-tree-empty [monoid]
    (finger-tree-empty. monoid))
(defn make-finger-tree-single [monoid e]
    (finger-tree-single. monoid e))
(defn make-finger-tree-deep [monoid l m r]
    (finger-tree-deep.
        monoid
        (delay (apply
            (:combine-fn monoid)
            (map
                (fn [e] (extract-measure e monoid))
                (concat
                    l
                    ((fn [v] (if (nil? v) [] [v])) (force m))
                    r))))
        l m r))

; Reverse cons
(defn snoc [a lst] (concat lst [a]))
