#!/usr/bin/tclsh # childedges - 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 # This program outputs a list of parent nodes together with the vertex # and edge labels of its children and the number of times this # combination was found in the files. # # Typical call: childedges filenames # Typical output: # 4 - np, adj1 mod n1, hd # 1 - inf, ww4 hd, MOD # # which indicates 4 nps have been found in the files with an # adj(jective)1 as mod(ifier) and an n(oun)1 ad h(ea)d, and # 1 infinitive with a verb as head and a mod(ifier) secondary # edge. 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 {} } 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 # puts $cursent } } } close $f } # proc senttosubs {list} { get_positions $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 argv itemselect chlist filename set allchildren [findchildren $list $item $vertex] set children [lindex $allchildren 0] set schildren [lindex $allchildren 1] # if {[llength $children] == 0} { # set cname "none" # } else { set cname [mapsnd $children] # } # if {[llength $schildren] == 0} { # set sname "none" # } else { set sname $schildren # } if {[catch {set chlist($vertex,$cname,$sname)}]} { set chlist($vertex,$cname,$sname) 1 } else { incr chlist($vertex,$cname,$sname) } foreach i $children { set item [lindex $i 0] toptosubs $list $item [getitemvertex $list $item] [lindex $i 1] } } # 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 cat} { global positions sentno if {$parent == 0} { return {} } putsdebug "" putsdebug "findchildren" putsdebug "" # get all the children of parent and store them in an array # indexed by the left-right positions of the children for {set n 0} {$n < [llength $list]} {incr n} { set itemn [lindex $list $n] set itemparent [getparent $itemn] if {$itemparent == $parent} { set itemword [getword $itemn] set itemedge [string tolower [getedge $itemn]] set i [getitemno $itemword $n] set pos $positions($i) set pair [list [lindex $pos end] [lindex $pos 0]] set children($pair) [list $i $itemedge] } } # retrieve all the children in order of their positions from left # to right set clist {} foreach p [lsort -command compare_pairs [array names children]] { lappend clist $children($p) } # get all secondary edge children of parent and put them in a # separate list set slist {} for {set n 0} {$n < [llength $list]} {incr n} { set itemn [lindex $list $n] set itemtag [gettag $itemn] set itemsecedges [getsecedges $itemn] for {set m 1} {$m < [llength $itemsecedges]} {incr m +2} { if {[lindex $itemsecedges $m] == $parent} { set itemword [getword $itemn] set i [getitemno $itemword $n] lappend slist [lindex $itemsecedges [expr $m-1]] break } } } putsdebug "Parent : $parent" putsdebug "Children: $clist" return [list $clist [lsort $slist]] } # compare_pairs pair1 pair2 # # compare two lists with two elements, first using the first element, # then - if the first elements are equal - using the second proc compare_pairs {x y} { set xl [lindex $x 0] set yl [lindex $y 0] if {$xl == $yl} { return [expr [lindex $x 1] > [lindex $y 1]] } else { return [expr $xl > $yl] } } proc mapsnd {list} { set snd {} foreach i $list { lappend snd [lindex $i 1] } return $snd } proc get_positions {list} { global positions sentno for {set n 0} {$n < [llength $list]} {incr n} { set item [lindex $list $n] set word [getword $item] set parent [getparent $item] if {$parent == 0} { set parent 999 } if {[regexp {^#([0-9]+)$} $word all num]} { set nums $positions($num) } else { set positions($n) $n set nums $n } if {[catch {set positions($parent)}]} { set positions($parent) $nums } else { set current $positions($parent) foreach i $nums { if {[lsearch $current $i] == -1} { set current [lsort -integer [lappend current $i]] } } set positions($parent) $current } } } 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 } } # 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 {$argc < 1} { puts "Usage: subvertices FILENAMES" exit 1 } foreach f $argv { if {[file readable $f]} { puts stderr "File: $f" loadcgn $f } else { puts stderr "File $f does not exist or is unreadable" exit 1 } } foreach i [array names chlist] { puts "$chlist($i) - $i" }