#!/usr/bin/tclsh # splitsent - sentence splitter for multi-rooted corpus files # Copyright (C) 2005-2007 Richard Moot (Richard.Moot@labri.fr) # Copyright (C) 2005-2007 CNRS (http://www.cnrs.fr) # Copyright (C) 2005-2007 INRIA (http://www.inria.fr) # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # Tcl script to split a multi-rooted sentence into one sentence per root node # The algorithm employed is the following: # We find the different root nodes for a sentence, as done for the cgntoform # script, then descend from there to the leaves, adding all encountered nodes # to the current sentence. # # TODO: Renumber the non-terminal nodes to start at 500 and increase by one. # TODO: Remove secondary edges between components. # Note that sentence numbers will not be kept, since they will typically # increase. set debug 0 # skipcat is a list of categories which will be split into one tree # for each of their daughters. set skipcat {DU LIST} proc loadcgn {file} { global sentence sn s_tot sentno set rn [file rootname $file] set lf "$rn.rtd" set f [open $file r] set of [open $lf w] set ll {} set ln 0 set sn 1 while {[gets $f line] >= 0} { # discard leading comments if {[regexp {^(%+)(.*)$} $line]} { } elseif {[regexp {^#BOS ([0-9]+)(.*)$} $line x sentno]} { array unset sentence set ln 0 incr s_tot } elseif {[regexp {^#EOS ([0-9]+)(.*)$} $line x line y]} { splitsentence $ln $of } elseif {[regexp {^#FORMAT ([0-9]+)(.*)$} $line x format y]} { } else { regsub -all (\t+) $line \t line set list [split $line \t] set sentence($ln) $list incr ln } } close $of close $f } proc splitsentence {lines of} { global sentence sentno s_inc empty skipcat # find the top nodes set tops {} set alltops 0 for {set i [expr $lines -1]} {$i >= 0} {incr i -1} { if {[lsearch $alltops [getparent $sentence($i)]] != -1} { putsdebug "$sentence($i)" set sentence($i) [concat [lrange $sentence($i) 0 2] -- 0] putsdebug "$sentence($i)" set newtop [getitemno [getword $sentence($i)] $i] putsdebug "New top: $newtop" if {[lsearch $skipcat [gettag $sentence($i)]] != -1} { lappend alltops $newtop } else { lappend tops $i incr s_inc } } } if {[llength $tops] == 0} { incr empty if {$lines > 0} { puts stderr "$sentno has no top nodes!" } else { putsdebug "Empty phrase $sentno removed." } } else { incr s_inc -1 } putsdebug "Tops: $tops" foreach t $tops { set linenos [descendants $lines $t] putsdebug "Linenos: $linenos" printsent $of $linenos } } proc descendants {lines top} { global sentence set topno [getitemno [getword $sentence($top)] $top] if {$topno < 500} { return $topno } else { set desc {} set alllines $top for {set i [expr $lines - 1]} {$i >= 0} {incr i -1} { set p [getparent $sentence($i)] set item [getitemno [getword $sentence($i)] $i] if {[lsearch $topno $p] != -1} { lappend topno $item lappend alllines $i } } } return $alllines } proc printsent {of list} { global sentence sn puts $of "#BOS $sn" for {set i [expr [llength $list] -1]} {$i >= 0} {incr i -1} { puts $of [tabby $sentence([lindex $list $i])] } puts $of "#EOS $sn" incr sn } # add some tabs to make things look a bit prettier proc tabby {list} { set list [linsert $list 3 ""] set strlen [string length [lindex $list 0]] set tabs [expr 3-ceil(double($strlen+1)/double(8))] if {$tabs <= 0} { } elseif {$tabs == 1} { set list [linsert $list 1 ""] } elseif {$tabs == 2} { set list [linsert $list 1 "" ""] } return [join $list \t] } proc getitemno {word n} { if {[regexp {^#([0-9]+)$} $word x parent]} { return $parent } else { return $n } } proc getword {s} { lindex $s 0 } proc gettag {s} { lindex $s 1 } proc getparent {s} { lindex $s 4 } proc getsecedges {s} { lrange $s 5 end } proc iso8859 {string} { regsub -all \ë\; $string ë string regsub -all \ï\; $string ï string regsub -all \ö\; $string ö string regsub -all \ü\; $string ü string regsub -all \ç\; $string ç string regsub -all \é\; $string é string regsub -all \è\; $string è string regsub -all \à\; $string à string regsub -all \É\; $string É string regsub -all \È\; $string È string return $string } # putsdebug # # prints a string to standard out only if the value of the global # variable `debug' is set to 1 proc putsdebug {string} { global debug if {$debug == 1} { puts stderr $string } } proc parseargs {list} { global argv for {set i 0} {$i < [llength $argv]} {incr i} { set item [lindex $list $i] if {[string equal "--" $item]} { return [lrange $list [expr $i+1] end] } elseif {[regexp -- {-(.*)} $item all option]} { treatoption $option } else { return [lrange $list $i end] } } } proc treatoption {option} { if {[string equal "help" $option]} { helpmessage } else { for {set i 0} {$i < [string length $option]} {incr i} { treatabbrev [string range $option $i $i] } } } proc treatabbrev {abr} { if {[string equal "h" $abr]} { helpmessage } elseif {[string equal "d" $abr]} { setdebug } else { puts stderr "Unknown option: $abr" } } proc helpmessage {} { puts "Usage: splitsent -hd" } proc setdebug {} { global debug set debug 1 } set s_tot 0 set s_inc 0 set empty 0 foreach f [parseargs $argv] { if {[file readable $f]} { puts stderr "File: $f" loadcgn $f } else { puts stderr "File $f does not exist or is unreadable" exit 1 } } puts stderr "$s_tot total sentences." puts stderr "$s_inc sentences added." puts stderr "$empty empty sentences removed." puts stderr "[expr $s_tot+$s_inc-$empty] new total."