 ; :mode=clojure:
 
-(defrecord node-2 [a b])
-(defrecord node-3 [a b c])
-(defrecord finger-tree-empty [])
-(defrecord finger-tree-single [v])
-(defrecord finger-tree-deep [l m r])
-
-(defn make-node-2 [a b] (node-2. a b))
-(defn make-node-3 [a b c] (node-3. a b c))
+(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]))


; 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]
    (if (<= (count l) 3)
        (finger-tree-deep. (cons a l) m r)
        (finger-tree-deep.
            [a (first l)]
            (let [m-forced (force m)]
                (delay (push-front m-forced (apply make-node-3 (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]
    (if (<= (count r) 3)
        (finger-tree-deep. l m (snoc a r))
        (finger-tree-deep.
            l
            (let [m-forced (force m)]
                (delay (push-back m-forced (apply make-node-3 (tser r)))))
            [(last r) a])))

(defn nodes [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)))))

(defmulti app3 (fn [l m r] [(class l) (class r)]))
(defmethod app3 [finger-tree-empty ::any] [l m r]

(defmulti print-entry (fn [entry parent-id] (class entry)))
(defmethod print-entry node-2 [node parent-id]
    (do
        (println (object-id node) " [label=\"Node2\\n" (extract-measure node nil) "\"]")
        (println parent-id " -> " (object-id node) " [weight=2]")
        (print-entry (:a node) (object-id node))
        (print-entry (:b node) (object-id node))))
(defmethod print-entry node-3 [node parent-id]
    (do
        (println (object-id node) " [label=\"Node3\\n" (extract-measure node nil) "\"]")
        (println parent-id " -> " (object-id node) " [weight=2]")
        (print-entry (:a node) (object-id node))
        (print-entry (:b node) (object-id node))
        (print-entry (:c node) (object-id node))))
(defmethod print-entry ::any [entry parent-id]
    (do
        (println (object-id entry) " [label=\"" entry "\"]")
        (when parent-id (println parent-id " -> " (object-id entry) " [weight=1]"))))
