-
- %token CR EOF COLON SEMICOLON COMMA OPENP CLOSEP
- %token <int> EDGE_LABEL
- %token <float> REAL
- %token <string> LABEL
-
- %start tree
- %type<Newick_bark.newick_bark Gtree.gtree> tree
- %%
-
- %{
- open Ppatteries
-
- (* parse state *)
- type 'a ps = {
- stree: Stree.stree;
- bark: 'a IntMap.t;
- }
- (* list parse state *)
- type 'a lps = {
- stree_l: Stree.stree list;
- bark_l: 'a IntMap.t;
- }
-
- let combine = IntMap.fold IntMap.add
- let empty_lps = {stree_l = []; bark_l = IntMap.empty}
- let lps_append lp lps =
- {stree_l = lp.stree :: lps.stree_l; bark_l = combine lp.bark lps.bark_l}
-
- let node_num = ref (-1)
- let add_bark add_fun ?label x s =
- let label =
- match label with
- | None -> Stree.top_id s.stree
- | Some x -> x
- in {
- stree = s.stree;
- bark = add_fun label x s.bark;
- }
- let add_bl = add_bark Newick_bark.map_set_bl
- let add_name = add_bark Newick_bark.map_set_name
- let add_boot = add_bark Newick_bark.map_set_boot
- let add_id id lp = {
- stree = Stree.of_id id lp.stree;
- bark =
- try
- let value, bark' = Stree.top_id lp.stree
- |> flip IntMap.extract lp.bark
- in
- IntMap.add id value bark'
- with Not_found -> lp.bark
- }
-
- let add_leaf () =
- incr node_num;
- {
- stree = Stree.leaf !node_num;
- bark = IntMap.empty;
- }
- let add_internal ls =
- incr node_num;
- {
- stree = Stree.node !node_num ls.stree_l;
- bark = ls.bark_l;
- }
-
- %}
-
- named_leaf:
- | LABEL
- { add_leaf () |> add_name $1 }
- | REAL
- { add_leaf () |> add_name (string_of_float $1) }
-
- subtree_list:
- | subtree COMMA subtree_list
- { lps_append $1 $3 }
- | subtree
- { lps_append $1 empty_lps }
-
- subtree:
- | subtree_list { add_internal $1 }
- | named_leaf { $1 }
-
- tree:
- | subtree
- { Gtree.gtree $1.stree $1.bark }
-