let rec create_balanced d =
    let (roots, points) = distant_roots max_degree [] d in
    create_subtrees roots points 

  and create_subtrees roots points =
    match roots with
    | (x,y)::r ->
        let nearest_this_root p =
          let other_root_distance =
            float_list_min (map (fun p1 -> distance (fst p) (fst p1)) r) in
          distance (fst p) x < other_root_distance in
        let (p_near, p_far) = partition nearest_this_root points in
        Node (x,y, (create_balanced p_near)) :: (create_subtrees r p_far)
    | [] -> []