OSM ocaml parser

From OpenStreetMap

Software described on this page or in this section is unlikely to be compatible with API version 0.5 deployed on 8 October, 2007. If you have fixed the software, or concluded that this notice does not apply, remove it.

For handling OSM data in ocaml (good starting point to write converters and/or renderers). The code in this page is licensed under the WTFPL license.

Osm.ml is simple internal form (supports only basic stuff: time-stamps, user and visible attributes are ignored):

type id = string

module SimpleString =  struct 
  type t = string 
  let compare = Pervasives.compare 
end

module StringMap = Map.Make(SimpleString)

type tags = string StringMap.t

type node = {n_id:id;n_tags: tags; n_lat_long:float*float}

type segment = {s_id:id; s_tags: tags; s_from_to: id*id}

type way = {w_id: id; w_tags: tags; w_segs: id list; }


type nodes = node StringMap.t
type segments = segment StringMap.t
type ways = way StringMap.t

type osm = {o_nodes:nodes;o_segments:segments;o_ways:ways} 
let empty_world = {o_nodes=StringMap.empty; o_segments=StringMap.empty; o_ways=StringMap.empty}

let add_tag k v tag_map = StringMap.add k v tag_map
let no_tag = StringMap.empty

let new_node id tags ll =  {n_id=id;n_tags=tags;n_lat_long=ll}
let register_node n osm = {osm with o_nodes= StringMap.add n.n_id n osm.o_nodes}
  
let new_segment id tags from_to =  {s_id=id;s_tags=tags;s_from_to=from_to}
let register_segment s osm = {osm with o_segments= StringMap.add s.s_id s osm.o_segments}

let new_way id tags segs =  {w_id=id;w_tags=tags;w_segs=segs}
let register_way w osm = {osm with o_ways= StringMap.add w.w_id w osm.o_ways}

(* access *)

let get_node osm id = StringMap.find id osm.o_nodes
let get_segment osm id = StringMap.find id osm.o_segments
let get_way osm id = StringMap.find id osm.o_ways

let fold_ways func osm acc =
  StringMap.fold func osm.o_ways acc

let get_tag tags k = StringMap.find k tags
let has_tag tags k = StringMap.mem k tags
let way_tag w k = get_tag w.w_tags k
let way_has_tag w k = has_tag w.w_tags k
let way_has_tag_in w k_list = 
  List.fold_left (fun has k ->
    has || way_has_tag w k) false k_list

let nodes_of_segment s osm = (get_node osm (fst s.s_from_to),get_node osm (snd s.s_from_to))
let coords_of_segment s osm = 
  let _from,_to = nodes_of_segment s osm in
    _from.n_lat_long,_to.n_lat_long

let segments_of_way w osm = List.fold_left (fun acc s_id -> get_segment osm s_id::acc) [] w.w_segs


(* geometric helpers *)
let continuous_runs w osm = 
  try (
    let segs =  segments_of_way w osm in
    let first_point,_ = coords_of_segment (List.hd segs) osm in
    let runs,last_point = List.fold_left (fun acc s ->
      let runs ,previous_end = acc in
	  begin
	    let _from,_to = coords_of_segment s osm in
	      if _from = previous_end then
		(match runs with
		  |curent::old-> (_to::curent)::old
		  |[]-> [[_from;_to]]
		),_to
	      else ([_from;_to]::runs),previous_end
	  end
    ) ([],first_point) segs
  in
      runs
  ) with |_ -> []




let is_area way osm = 
  try (
    let segs =  segments_of_way way osm in
    let first_point,_ = coords_of_segment (List.hd segs) osm in
    let is_continuous,last_point = List.fold_left (fun acc s ->
      let is_c,previous_end = acc in
	if not is_c then acc else
	  begin
	    let _from,_to = coords_of_segment s osm in
	      if _from = previous_end then
		true, _to
	      else false,previous_end
	  end
    ) (true,first_point) segs
  in
    is_continuous && (last_point = first_point)
  ) with |_ -> false

(* layer management helpers *)

type 'a layers = ('a list )StringMap.t
let empty_layers = StringMap.empty


let add_elem_to_layer se layer_id layers =
  let new_layer = try (
    se::(StringMap.find layer_id layers)
  ) with | Not_found -> [se]
  in
    StringMap.add layer_id new_layer layers
let map_layers f layers = 
  let res = ref [] in  
  StringMap.iter (fun lid elems -> res:= f lid elems:: !res) layers;
    List.rev !res    

and an xml "parser", depending on xml-light:

open Xml
open Osm

let parse_tag tag_map = function
  | Element("tag",["k",key;"v",value],[]) 
  | Element("tag",["v",value;"k",key],[]) -> add_tag key value tag_map
  | _ -> tag_map

let parse_tags xml= 
    List.fold_left parse_tag no_tag xml

let parse_node atts children =
  let r_id = ref "" in
  let r_lat = ref 0. in
  let r_long = ref 0. in
  List.iter (function
    |("id",id) -> r_id := id
    |("lat",lat) -> r_lat := float_of_string lat
    |("lon",long) -> r_long := float_of_string long
    |_ -> ()
  ) atts;
    new_node !r_id (parse_tags children) ( !r_lat , !r_long)


let parse_segment atts children =
  let r_id = ref "" in
  let r_from = ref "" in
  let r_to = ref "" in
  List.iter (function
    |("id",id) -> r_id := id
    |("from",from) -> r_from := from
    |("to",x_to) -> r_to := x_to
    |_ -> ()
  ) atts;
    new_segment !r_id (parse_tags children) (!r_from,!r_to)


let parse_way atts children =
  let r_id = ref "" in
  List.iter (function
    |("id",id) -> r_id := id
    |_ -> ()
  ) atts;
    let r_segs = ref [] in
      List.iter (function
	|Element("seg",["id",id],[]) -> r_segs := id:: !r_segs
	|Element("seg",_,_) -> failwith "bad tag format"
	|_ -> ()
      ) children;
      new_way !r_id (parse_tags children) !r_segs


let parse_osm world= function
  |Element("node",atts, children) -> 
     let n = parse_node atts children in
       register_node n world
  |Element("segment",atts,children) -> 
     let s = parse_segment atts children in
       register_segment s world
  |Element("way",atts, children) ->
     let w = parse_way atts children in
       register_way w world
  |_ -> failwith "unknown tag"
let parse fname=
  match parse_file fname with
    |Element("osm",_,children) -> List.fold_left parse_osm empty_world children
    | _ -> failwith "bad osm format"