#!/usr/bin/tclsh # subparentedges - corpus search script # Copyright (C) 2004-2007 Richard Moot (Richard.Moot@labri.fr) # Copyright (C) 2004-2007 CNRS (http://www.cnrs.fr) # Copyright (C) 2004-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 # Lists all occurrences of an specified edge label linking a # daughter to the given parent node. For example # # subparentedges tag du filenames # # will list all TAG constituents occurring as daughter of a # discourse unit. set debug 0 # modified loadcgn to no longer keep an array of sentences and comments. # this should keep the memory usage down a bit. proc loadcgn {file} { global sentno filename set filename $file set f [open $file r] set sentno 0 # read the cgn output file and convert it to an array while {[gets $f line] >= 0} { # discard leading comments if {[regexp {^(%+)(.*)$} $line]} { putsdebug $line } elseif {[regexp {^#BOS ([0-9]+)(.*)$} $line x sentno]} { set cursent {} # if sentence has a comment, put the comment in a # separate array if {[regexp {^(.*)(%+)(.*)$} $x y z v c]} { } } elseif {[regexp {^#FORMAT ([0-9]+)(.*)$} $line x format y]} { putsdebug "Format: $format" } elseif {[regexp {^#EOS ([0-9]+)(.*)$} $line x line y]} { if [catch {set cursent}] { putsdebug "Ignored: $line" } else { senttosubs $cursent putsdebug "Processed: $line" } } else { if {[catch {set cursent}]!= 1} { regsub -all (\t+) $line \t line regsub -all {(\*).} $line "" line set line [iso8859 $line] set list [split $line \t] lappend cursent $list } } } close $f } # proc senttosubs {list} { set top [findtop $list] foreach i $top { toptosubs $list $i [getitemvertex $list $i] [getitemedge $list $i] } } proc toptosubs {list item vertex edge} { global sentno itemselect target chlist filename if {[string compare $edge $itemselect]==0} { set chlist(0) 0 unset chlist collectchildren $list $item $vertex set desc [lsort -integer [array names chlist]] set parent [getitemparent $list $item] set parentvertex [getitemvertex $list $parent] if {$parent == 0} { set pp "" } else { set pp "[string toupper $parentvertex]\($parent\)-" } if {[string compare $edge "--"]== 0} { set ppe "" } else { set ppe "$edge-" } if {[string equal $parentvertex $target]} { puts "# $filename $sentno $pp$ppe[string toupper $vertex]\($item\) \[$desc\]" foreach n $desc { puts -nonewline " $chlist($n)" } puts "" } } else { set children [findchildren $list $item] foreach i $children { toptosubs $list $i [getitemvertex $list $i] [getitemedge $list $i] } } } proc collectchildren {list item vertex} { global chlist set children [findchildren $list $item] if {$children =={}} { set chlist($item) [getitemword $list $item] } else { foreach i $children { collectchildren $list $i [getitemedge $list $i] } } } # findtop # # returns a list containing all top-level nodes, ie. those nodes without # parent proc findtop {list} { set top {} for {set n 0} {$n < [llength $list]} {incr n} { set itemn [lindex $list $n] set itemword [getword $itemn] if {[getparent $itemn] == 0} { lappend top [getitemno $itemword $n] } } return $top } # findchildren # # returns a list with the item numbers of all children of the specified # parent. Returns the empty list if parent == 0. proc findchildren {list parent} { if {$parent == 0} { return {} } set children {} for {set n 0} {$n < [llength $list]} {incr n} { set itemn [lindex $list $n] set itemword [getword $itemn] set itemedge [string tolower [getedge $itemn]] set itemparent [getparent $itemn] set itemsecedges [getsecedges $itemn] if {$itemparent == $parent} { lappend children [getitemno $itemword $n] } else { for {set m 1} {$m < [llength $itemsecedges]} {set m [expr $m+2]} { if {[lindex $itemsecedges $m] == $parent} { lappend children [getitemno $itemword $n] break } } } } putsdebug "Parent : $parent" putsdebug "Children: $children" return $children } proc filtersec {list children parent} { set primary {} foreach c $children { set itemn [lindex $c 0] set item [selectitem $list $itemn] if {[getparent $item] == $parent} { lappend primary $c } } return $primary } 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 } proc putsdebug {string} { global debug if {$debug == 1} { puts $string } } proc getword {s} { lindex $s 0 } proc gettag {s} { lindex $s 1 } proc getmorph {s} { lindex $s 2 } proc getedge {s} { lindex $s 3 } proc getparent {s} { lindex $s 4 } proc getsecedges {s} { lrange $s 5 end } proc getitemvertex {list i} { string tolower [gettag [selectitem $list $i]] } proc getitemedge {list i} { string tolower [getedge [selectitem $list $i]] } proc getitemparent {list i} { getparent [selectitem $list $i] } proc getitemedges {ilist} { set edges {} foreach i $ilist { lappend edges [lindex $i 1] } return $edges } proc getitemword {list i} { getword [selectitem $list $i] } # returns the POS tag of the current item, or 0 if it is unavailable proc getpos {s} { set tag [lindex $s 1] if {[regexp {^#([0-9]+)$} $tag]} { return 0 } else { return $tag } } proc trigram {list n} { if {$n == 0} { return "0, 0, [getpos [lindex $list $n]]" } elseif {$n == 1} { return "0, [getpos [lindex $list [expr $n-1]]], [getpos [lindex $list $n]]" } else { return "[getpos [lindex $list [expr $n-2]]], [getpos [lindex $list [expr $n-1]]], [getpos [lindex $list $n]]" } } # getitemno # # returns the item number of a specific list item, which is a number # greater than 500 for a parent node proc getitemno {word n} { if {[regexp {^#([0-9]+)$} $word x parent]} { return $parent } else { return $n } } # selectitem # # returns the specified list item n. Also works if n is a parent node # with n>=500 # Modified to allow `skips' as in, eg. fv400016.syn, sentence 1, where # discontinuous #600 and #700 appear proc selectitem {list n} { if {$n < 500} { return [lindex $list $n] } else { for {set i 0} {$i < [llength $list]} {incr i} { set word [getword [lindex $list $i]] if {[string compare $word "#$n"] == 0} { return [lindex $list $i] } } } } proc pplist {list} { foreach i $list { putsdebug $i } } if {[llength $argv] < 3} { puts "Usage: subparentedges EDGELABEL PARENTVERTEX FILENAMES" exit 1 } set itemselect [lindex $argv 0] set target [lindex $argv 1] set files [lrange $argv 2 end] foreach f $files { if {[file readable $f]} { puts stderr "File: $f" loadcgn $f } else { puts stderr "File $f does not exist or is unreadable" exit 1 } }