Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

292 lines (261 sloc) 12.385 kb
(* Lexicon *)
type feature =
(* Selection *)
Categorial of string (* f *)
| Categorial' of string (* *f *)
| Selection of string (* =f *)
(* Affixes *)
| Raising of string (* =>f *)
| Lowering of string (* f=> *)
(* Movement *)
| Licensee of string (* -x *)
| Licensor of string (* +x *)
;;
type morpheme = M of string;;
type subtree = { spec: morpheme list; head: morpheme list; comp: morpheme list; features: feature list };;
module Derivation =
struct
type t = subtree * subtree list;;
let compare = compare;;
(* make_subtree : morpheme list -> morpheme list -> morpheme list -> feature list -> subtree *)
let make_subtree spec head comp features =
{ spec = spec; head = head; comp = comp; features = features }
;;
end
;;
module Lexicon = Set.Make( Derivation );;
(* val make_lexeme : string -> feature list -> subtree * subtree list = <fun> *)
let make_lexeme head features =
( (Derivation.make_subtree [] [ M( head ) ] [] features), [] )
;;
(* val add_lexeme : Lexicon.t -> Lexicon.elt -> Lexicon.t = <fun> *)
let add_lexeme lexicon entry = Lexicon.add entry lexicon;;
(* val add_lexemes : Lexicon.t -> Lexicon.elt list -> Lexicon.t = <fun> *)
let rec add_lexemes lexicon entries =
match entries with
[] -> lexicon
| h::t -> add_lexemes (add_lexeme lexicon h) t
;;
exception InvalidDerivation of string;;
(* val replace_head : subtree -> morpheme list -> subtree = <fun> *)
let replace_head subtree head =
Derivation.make_subtree subtree.spec head subtree.comp subtree.features
;;
(* val replace_features : subtree -> feature list -> subtree = <fun> *)
let replace_features subtree features =
Derivation.make_subtree subtree.spec subtree.head subtree.comp features
;;
(* val get_first_feature : subtree -> feature = <fun> *)
let rec get_first_feature subexp =
List.hd subexp.features
;;
(* val get_first_licensee : subtree -> feature = <fun> *)
let rec get_first_licensee subexp =
try
List.find (function | Licensee(_) -> true | _ -> false) subexp.features
with
Not_found -> raise (InvalidDerivation "get_first_licensee")
;;
(* val get_first_features : subtree list -> feature list = <fun> *)
let rec get_first_features subexps =
match subexps with
[] -> []
| h::t -> (get_first_feature h)::(get_first_features t)
;;
(* val get_first_licensees : subtree list -> feature list = <fun> *)
let rec get_first_licensees subexps =
match subexps with
[] -> []
| h::t -> (get_first_licensee h)::(get_first_licensees t)
;;
(* val merge : subtree * subtree -> subtree * subtree -> subtree * subtree = <fun> *)
let merge tree1 tree2 =
let merge_selection st_merge st_move ct_merge ct_move =
let st_f = List.tl (st_merge.features) in
let ct_f = List.tl (ct_merge.features) in
match ct_f with
[] ->
(
(Derivation.make_subtree [] st_merge.head ( ct_merge.spec @ ct_merge.head @ ct_merge.comp ) st_f),
st_move @ ct_move
)
| _::_ ->
let ct_move_new = replace_features ct_merge ct_f in
if ( List.mem (get_first_feature ct_move_new) (get_first_features st_move) ) || ( List.mem (get_first_licensee ct_move_new) (get_first_licensees st_move) )
then raise (InvalidDerivation "IMM")
else
(
(replace_features st_merge st_f),
st_move @ ct_move @ [ ct_move_new ]
)
in
let merge_raising st_merge st_move ct_merge ct_move =
merge_selection (replace_head st_merge ( ct_merge.head @ st_merge.head )) st_move (replace_head ct_merge []) ct_move
in
let merge_lowering st_merge st_move ct_merge ct_move =
merge_selection (replace_head st_merge []) st_move (replace_head ct_merge ( ct_merge.head @ st_merge.head )) ct_move
in
let t1_merge = fst tree1 in
let t2_merge = fst tree2 in
let t1_move = snd tree1 in
let t2_move = snd tree2 in
let f1 = List.hd t1_merge.features in
let f2 = List.hd t2_merge.features in
match ( f1, f2 ) with
( Selection(s), Categorial(c) )
| ( Selection(s), Categorial'(c) ) when s = c -> merge_selection t1_merge t1_move t2_merge t2_move
| ( Categorial(c), Selection(s) )
| ( Categorial'(c), Selection(s) ) when s = c -> merge_selection t2_merge t2_move t1_merge t1_move
| ( Raising(r), Categorial(c) )
| ( Raising(r), Categorial'(c) ) when r = c -> merge_raising t1_merge t1_move t2_merge t2_move
| ( Categorial(c), Raising(r) )
| ( Categorial'(c), Raising(r) ) when r = c -> merge_raising t2_merge t2_move t1_merge t1_move
| ( Lowering(l), Categorial(c) )
| ( Lowering(l), Categorial'(c) ) when l = c -> merge_lowering t1_merge t1_move t2_merge t2_move
| ( Categorial(c), Lowering(l) )
| ( Categorial'(c), Lowering(l) ) when l = c -> merge_lowering t2_merge t2_move t1_merge t1_move
| _ -> raise (InvalidDerivation "merge")
;;
(* XXX: There's gotta be a way to combine this with merge to reduce code duplication! *)
(* val cmerge : subtree * subtree list -> subtree * subtree list -> subtree * subtree list = <fun> *)
let cmerge tree1 tree2 =
let cmerge_selection st_merge st_move ct_merge ct_move =
let st_f = List.tl (st_merge.features) in
let ct_f = ct_merge.features in
match ct_f with
[] ->
(
(Derivation.make_subtree [] st_merge.head ( ct_merge.spec @ ct_merge.head @ ct_merge.comp ) st_f),
st_move @ ct_move
)
| _::_ ->
let ct_move_new = replace_features ct_merge ct_f in
if ( List.mem (get_first_feature ct_move_new) (get_first_features st_move) ) || ( List.mem (get_first_licensee ct_move_new) (get_first_licensees st_move) )
then raise (InvalidDerivation "IMM")
else
(
(replace_features st_merge st_f),
st_move @ ct_move @ [ ct_move_new ]
)
in
let cmerge_raising st_merge st_move ct_merge ct_move =
cmerge_selection (replace_head st_merge ( ct_merge.head @ st_merge.head )) st_move (replace_head ct_merge []) ct_move
in
let cmerge_lowering st_merge st_move ct_merge ct_move =
cmerge_selection (replace_head st_merge []) st_move (replace_head ct_merge ( ct_merge.head @ st_merge.head )) ct_move
in
let t1_merge = fst tree1 in
let t2_merge = fst tree2 in
let t1_move = snd tree1 in
let t2_move = snd tree2 in
let f1 = List.hd t1_merge.features in
let f2 = List.hd t2_merge.features in
match ( f1, f2 ) with
| ( Selection(s), Categorial'(c) ) when s = c -> cmerge_selection t1_merge t1_move t2_merge t2_move
| ( Categorial'(c), Selection(s) ) when s = c -> cmerge_selection t2_merge t2_move t1_merge t1_move
| ( Raising(r), Categorial'(c) ) when r = c -> cmerge_raising t1_merge t1_move t2_merge t2_move
| ( Categorial'(c), Raising(r) ) when r = c -> cmerge_raising t2_merge t2_move t1_merge t1_move
| ( Lowering(l), Categorial'(c) ) when l = c -> cmerge_lowering t1_merge t1_move t2_merge t2_move
| ( Categorial'(c), Lowering(l) ) when l = c -> cmerge_lowering t2_merge t2_move t1_merge t1_move
| _ -> raise (InvalidDerivation "merge")
;;
(* val get_movable_subexp : subtree -> subtree list -> subtree = <fun> *)
let get_movable_subexp t_merge t_move =
let f_merge = List.hd t_merge.features in
let match_feature f =
match ( f_merge, (get_first_feature f) ) with
( Licensor(o), Licensee(e) )
| ( Raising(o), Categorial'(e) )
| ( Lowering(o), Categorial'(e) )
| ( Selection(o), Categorial'(e) ) when e = o -> true
| _ -> false
in
try
List.find match_feature t_move
with
Not_found -> raise (InvalidDerivation "get_movable_subexp")
;;
(* val symmetric_check : subtree -> subtree list -> subtree * subtree list = <fun> *)
let symmetric_check checkor checkee =
let ee_h = get_movable_subexp checkor checkee in
let ee_t = List.filter ((!=) ee_h) checkee in
let f_or = List.tl checkor.features in
let f_ee = List.tl ee_h.features in
match f_ee with
[] ->(*print_endline "no more licensing features";*)
(
(Derivation.make_subtree ( ee_h.spec @ ee_h.head @ ee_h.comp ) checkor.head checkor.comp f_or),
ee_t
)
| _::_ ->(*print_endline "more licensing features";*)
(
(Derivation.make_subtree checkor.spec checkor.head checkor.comp f_or),
(Derivation.make_subtree ee_h.spec ee_h.head ee_h.comp f_ee)::ee_t (* XXX: This changes the order of the list. Does that matter? *)
)
;;
(* val asymmetric_check : subtree -> subtree list -> subtree * subtree list = <fun> *)
let asymmetric_check checkor checkee =
let ee_h = get_movable_subexp checkor checkee in
let ee_t = List.filter ((!=) ee_h) checkee in
let f_or = List.tl checkor.features in
let f_ee = ee_h.features in
match f_ee with
[] ->(*print_endline "no more licensing features";*)
(
(Derivation.make_subtree ( ee_h.spec @ ee_h.head @ ee_h.comp ) checkor.head checkor.comp f_or),
ee_t
)
| _::_ ->(*print_endline "more licensing features";*)
(
(Derivation.make_subtree checkor.spec checkor.head checkor.comp f_or),
(Derivation.make_subtree ee_h.spec ee_h.head ee_h.comp f_ee)::ee_t (* XXX: This changes the order of the list. Does that matter? *)
)
;;
(* val move : subtree * subtree list -> subtree * subtree list = <fun> *)
let move tree =
let t_merge = fst tree in
let t_move = snd tree in
let f_merge = List.hd t_merge.features in
let f_move = List.hd (get_movable_subexp t_merge t_move).features in
match ( f_merge, f_move ) with
( Licensor( o ), Licensee( e ) ) when e = o -> symmetric_check t_merge t_move
| _ -> raise (InvalidDerivation "move")
;;
(* val cmove1 : subtree * subtree list -> subtree * subtree list = <fun> *)
let cmove1 tree =
let t_merge = fst tree in
let t_move = snd tree in
let f_merge = List.hd t_merge.features in
let f_move = List.hd (get_movable_subexp t_merge t_move).features in
match ( f_merge, f_move ) with
( Raising( s ), Categorial'( c ) )
| ( Lowering( s ), Categorial'( c ) )
| ( Selection( s ), Categorial'( c ) ) when c = s -> symmetric_check t_merge t_move
| _ -> raise (InvalidDerivation "cmove1")
;;
(* val cmove2 : subtree * subtree list -> subtree * subtree list = <fun> *)
let cmove2 tree =
let t_merge = fst tree in
let t_move = snd tree in
let f_merge = List.hd t_merge.features in
let f_move = List.hd (get_movable_subexp t_merge t_move).features in
match ( f_merge, f_move ) with
( Raising( s ), Categorial'( c ) )
| ( Lowering( s ), Categorial'( c ) )
| ( Selection( s ), Categorial'( c ) ) when c = s -> asymmetric_check t_merge t_move
| _ -> raise (InvalidDerivation "cmove2")
;;
(* val get_entries_that_match : Lexicon.t -> (Lexicon.elt -> bool) -> Lexicon.elt list = <fun> *)
let get_entries_that_match lexicon condition =
Lexicon.elements (Lexicon.filter condition lexicon)
;;
(* val get_entries_for : Lexicon.t -> string -> Lexicon.elt list = <fun> *)
let get_entries_for lexicon lexeme =
let match_lexeme entry =
let get_lexeme entry =
List.hd (fst entry).head
in
( (get_lexeme entry) = M( lexeme ) )
in
get_entries_that_match lexicon match_lexeme
;;
Jump to Line
Something went wrong with that request. Please try again.