#!/usr/bin/tclsh # cgntoform - lexcion extration 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 # Parametric conversion of corpus files into lexicon files which # have a Prolog-like notation. # The most important parameters are: # 1) indexes used for discontinuous modes # no difference between discontinuous and continuous modes # set laindex 0 # set raindex 0 # set rmindex 0 # set lmindex 0 # modes for left and right arguments and modifiers when we do # want to make these distinctions. set laindex 1 set raindex 2 set rmindex 3 set lmindex 4 # 2) the arrays "functor" and "modifier" specifying the functors and # arguments of the different constituents. The functors for a # parent vertex are specified in order of preference, for example # # set functor(smain) {hd svp vc predc su sup obj1 pc dp ld mod} # # note that the extraction algorithm *requires* every constituent # to have a functor and that common categories like SMAIN therefore # need a long listing like shown above to be able to handle all # different incomplete sentences in the corpus. # # The modifier array specifies the different edge labels of the # modifiers of a constituent. # # set modifier(smain) {mod predm dp} # # Unlike the functor array *all* daughters which have the required # edge label are treated as a modifier here. # 20051108 changed vp modifier to s modifier (reversal of previous # strategy, but permits unique type for V1 and subject-less # phrases). # 20051107 change WHQ, WHSUB and WHREL to s # 20051006 added distinction between arguments and modifiers which are # directly to the right/left (mode 0) and those which are not # mode 1/2. Need to test the effects: it leads to a bigger # lexicon, but it will help the parser. # 20050202 reprogrammed the calculation of the directionality of the # implications; `findchildren' now generates the children in # left-to-right order and they are kept in order # afterwards. This fixes some inconsistencies in the order # of the arguments. # 20050113 stores lexical differences, as generated by diff in a .dif # file. # 20041225 modified to take directionality into account, still need # to model arguments `at a distance' appropriately # 20041225 also modified to remove outermost DU items # 20040130 the current version sends the output of file.syn to file.lex # for all arguments on the command line RM set debug 0 set formcount 0 # loadcgn filename # # load and process CGN files. # # | after filename means "skipped, because .lex is current" # . after filename means "computed new .lex but found no difference" # - after filename means "computed new, different .lex" proc loadcgn {file} { global positions comment sentence sentno of # get rid of position info from previous files array unset positions set rn [file rootname $file] set lf "$rn.lex" # if .lex file exists and is newer and this script hasn't been # modified, do nothing. # commented out - Makefile should take care of this. # if {[file exists $lf] && [file mtime $lf] > [file mtime $file] && [file mtime "/Users/moot/Corpus/bin/cgntoform"] < [file mtime $lf]} { # puts stderr "|" # return {} # } set f [open $file r] set bf "$rn.old" if {[file exists $lf]} { file copy -force $lf $bf } set of [open $lf w] set sentno 0 set values {} # 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 sentence($sentno) {} lappend values $sentno puts $of "" puts $of "%= sentence $sentno =" puts $of "" # if sentence has a comment, put the comment in a # separate array if {[regexp {^(.*)(%+)(.*)$} $x y z v c]} { regsub -all \" $c \' c set comment($sentno) $c } else { set comment($sentno) {} } } elseif {[regexp {^#FORMAT ([0-9]+)(.*)$} $line x format y]} { putsdebug "Format: $format" } elseif {[regexp {^#EOS ([0-9]+)(.*)$} $line x line y]} { if [catch {set sentence($sentno)}] { putsdebug "Ignored: $line" } else { putsdebug "" putsdebug "Starting sentence $sentno" putsdebug "" get_positions $sentence($sentno) senttolex $sentence($sentno) $file putsdebug "Processed: $line" } } else { if {[catch {set sentence($sentno)}]!= 1} { regsub -all (\t+) $line \t line regsub -all {(\*).} $line "" line set line [iso8859 $line] set list [split $line \t] set current $sentence($sentno) set l [llength $current] set sentence($sentno) [linsert $current $l $list] } } } close $f close $of if {[file exists $bf]} { set df "$rn.dif" if {[catch {exec diff $lf $bf > $df}]} { puts stderr "-" } else { puts stderr "." file delete $df } file delete $bf } else { puts stderr "." } return $values } # proc get_positions {list} { global positions sentno for {set n 0} {$n < [llength $list]} {incr n} { set item [selectitem $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($sentno,$num) } else { set positions($sentno,$n) $n set nums $n } if {[catch {set positions($sentno,$parent)}]} { set positions($sentno,$parent) $nums } else { set current $positions($sentno,$parent) foreach i $nums { if {[lsearch $current $i] == -1} { set current [lsort -integer [lappend current $i]] } } set positions($sentno,$parent) $current } } } proc senttolex {list file} { global sentno argv currentword of set simplefile [file tail [file rootname $file]] array unset currentword set top [findtop $list] set topf {} foreach i $top { set form [getitemform $list $i 0 "--"] set topf [concat $topf [toptolex $list $i $form [getitemvertex $list $i]]] } # print the collected word information set anyitems 0 set prev -1 foreach i [lsort -integer [array names currentword]] { set item $currentword($i) set w [lindex $item 0] set form [translateform [lindex $item 1]] set tri [lindex $item 2] incr prev # print error information if a word seems to be missing if {$prev != $i} { puts stderr "" puts -nonewline stderr "Missing word! $sentno $prev-$i (before $w)" set prev $i } puts $of "lex(\"$w\", $form, \"$w\", \"$simplefile\", $sentno, $i, $tri)." set anyitems 1 } # print goal formula if {$anyitems != 0} { set form [lindex $topf end] set rest [lrange $topf 0 end-1] puts $of "" puts $of "goal(\"$simplefile\", $sentno, [complexprod $rest 1 $form])." } } # translateform # # sneaky last-minute modifications # utilizes: p(4,A,B) -> p(0,A,B) # p(3,A,B) -> p(4,B,A) proc translateform {form} { global trans # regsub -all {dl\(0\,s\,s\)} $form "dl(4,s,s)" form # regsub -all {dr\(3\,s\,s\)} $form "dl(4,s,s)" form # regsub -all {dr\(0\,s\,s\)} $form "dl(4,s,s)" form if {[catch {set trans($form)}] == 0} { return $trans($form) } else { return $form } } proc readtrans {file} { global trans if {[file readable $file]} { puts -nonewline stderr "Trns: $file" set fh [open $file r] set i 0 while {[gets $fh line] >= 0} { regexp {^reduce\((.*)\-(.*)\)\.$} $line all f r regsub -all " " $f "" f regsub -all " " $r "" r set trans($f) $r incr i } close $fh } } # toptolex # # covert a root node to lexical entries for all the leaves reachable # from it. proc toptolex {list item form vertex} { set forms {} if {[string equal $vertex "du"]||[string equal $vertex "list"]} { foreach t [findchildren $list $item] { set ct [lindex $t 0] set cv [getitemvertex $list $ct] set cf [getitemform $list $ct 0 "--"] set forms [concat $forms [toptolex $list $ct $cf $cv]] } } else { toptolex1 $list $item $form $vertex set forms [list $form] } return $forms } proc toptolex1 {list item form vertex} { global currentword sentno positions laindex raindex lmindex rmindex set children [findchildren $list $item] set length [llength $children] if {$length == 0} { # terminal node, add entry to the lexicon set w [getitemword $list $item] if {[catch {set currentword($item)}]} { set currentword($item) [list $w $form [itemdata $list $item]] } else { set prevf [lindex $currentword($item) 1] set form [complexprod $form 0 $prevf] set currentword($item) [list $w $form [itemdata $list $item]] } } elseif {$length == 1} { # unique child, descend recursively with the current formula set functor [lindex $children 0] set funnum [lindex $functor 0] putsdebug "F:$functor" putsdebug "R:$children" toptolex1 $list $funnum $form [getitemvertex $list $funnum] } else { # multiple children, separate them into functor, modifiers # and arguments set lmform [leftmodifierform 0 $form] set lmform1 [leftmodifierform $lmindex $form] set rmform [rightmodifierform 0 $form] set rmform1 [rightmodifierform $rmindex $form] if {[string equal $vertex "mwu"]} { # special treatment for merged-word units set mwu [analyse_mwu $list $children $vertex $item $form] if {[llength $mwu] == 0} { # everything has been treated already return } else { set functor [lindex $mwu 0] set left [lindex $mwu 1] set right [lindex $mwu 2] set mleft [lindex $mwu 3] set mright [reverse [lindex $mwu 4]] } } elseif {[string equal $vertex "advp"]||[string equal $vertex "list"]} { # analyse ADVP and LIST as multiple modifiers (if possible) set advp [rebracket4 $list $children $form] if {[llength $advp] == 0} { return } else { set functor [lindex $advp 0] set left [lindex $advp 1] set right [lindex $advp 2] set mleft [lindex $advp 3] set mright [reverse [lindex $advp 4]] } } else { # generic treatment for other categories set funres [selectfunctor $list $children $vertex $item] putsdebug $funres set functor [lindex $funres 0] set left [lindex $funres 1] set right [lindex $funres 2] # compute all modifiers set lmres [selectmodifiers $list $left $vertex] set mleft [lindex $lmres 0] set left [lindex $lmres 1] set rmres [selectmodifiers $list $right $vertex] set mright [lindex $rmres 0] set right [lindex $rmres 1] } set funnum [lindex $functor 0] putsdebug "FU: $functor" putsdebug "ML: $mleft" putsdebug "MR: $mright" putsdebug "AL: $left" putsdebug "AR: $right" set currentall $positions($sentno,$item) set leftall [lindex $currentall 0] set rightall [lindex $currentall end] set currentfun $positions($sentno,$funnum) set leftfun [expr [lindex $currentfun 0] -1] set rightfun [expr [lindex $currentfun end] +1] # left modifiers foreach m $mleft { set mno [lindex $m 0] set mvertex [getitemvertex $list $mno] set modpos $positions($sentno,$mno) set cl [lindex $modpos 0] set cr [lindex $modpos end] putsdebug "LM $cl.$cr - $leftfun.$rightfun" putsdebug "$mno $lmform $mvertex" # are we at the current left value and does adding the # next modifier mean we'll still be left of the functor? if {$cl == $leftall && $cr <= $leftfun} { toptolex1 $list $mno $lmform $mvertex set leftall [expr $cr + 1] } else { toptolex1 $list $mno $lmform1 $mvertex } } # right modifiers foreach m $mright { set mno [lindex $m 0] set mvertex [getitemvertex $list $mno] set modpos $positions($sentno,$mno) set cl [lindex $modpos 0] set cr [lindex $modpos end] putsdebug "RM $cl.$cr - $leftfun.$rightfun" if {$cr == $rightall && $cl >= $rightfun} { toptolex1 $list $mno $rmform $mvertex set rightall [expr $cl - 1] } else { toptolex1 $list $mno $rmform1 $mvertex } } set leftform {} set rightform {} # left argments foreach i $left { set num [lindex $i 0] set edge [lindex $i 1] set iform [getitemform $list $num $vertex $edge] set ivertex [getitemvertex $list $num] toptolex1 $list $num $iform $ivertex set argpos $positions($sentno,$num) if {[lindex $argpos end] == $leftfun} { set index 0 } else { set index $laindex } putsdebug "L($index) $leftfun - $argpos" set leftform [concat $index $iform $leftform] set leftfun [expr [lindex $argpos 0] -1] } # right arguments foreach i $right { set num [lindex $i 0] set edge [lindex $i 1] set iform [getitemform $list $num $vertex $edge] set ivertex [getitemvertex $list $num] toptolex1 $list $num $iform $ivertex set argpos $positions($sentno,$num) putsdebug $argpos if {[lindex $argpos 0] == $rightfun} { set index 0 } else { set index $raindex } putsdebug "R($index) $rightfun - $argpos" lappend rightform $index $iform set rightfun [expr [lindex $argpos end] +1] } set cpxform [complexform $leftform $rightform $form] toptolex1 $list $funnum $cpxform [getitemvertex $list $funnum] } } # findtop # # returns a list containing all top-level nodes, ie. those nodes without # parent # Modified to return the tops in left-to-right order just like # findchildren 20051005 RM proc findtop {list} { global positions sentno for {set n 0} {$n < [llength $list]} {incr n} { set itemn [lindex $list $n] set itemword [getword $itemn] set itemparent [getparent $itemn] set i [getitemno $itemword $n] set pos $positions($sentno,$i) set pair [list [lindex $pos end] [lindex $pos 0]] if {$itemparent == 0} { set children($pair) $i } } set top {} set left 0 foreach p [lsort -command compare_pairs [array names children]] { lappend top $children($p) } putsdebug "Tops : $top" return $top } # findchildren # # returns a list with the item numbers of all children of the specified # parent. Returns the empty list if parent == 0. # # Modified to return the children in left-to-right order based on # their positions. 20050202 RM proc findchildren {list parent} { global positions sentno lp if {$parent == 0} { return {} } putsdebug "" putsdebug "findchildren" putsdebug "" 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] set i [getitemno $itemword $n] set pos $positions($sentno,$i) set pair [list [lindex $pos end] [lindex $pos 0]] if {$itemparent == $parent} { set children($pair) [list $i $itemedge] } for {set m 1} {$m < [llength $itemsecedges]} {set m [expr $m+2]} { if {[lindex $itemsecedges $m] == $parent} { set children($pair) [list $i [string tolower [lindex $itemsecedges [expr $m-1]]]] break } } } set clist {} foreach p [lsort -command compare_pairs [array names children]] { lappend clist $children($p) } putsdebug "Parent : $parent" putsdebug "Children: $clist" return $clist } # 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 analyse_conj {list children vertex item form} { global sentno set f $form set m 0 set ci -1 foreach c $children { set i [lindex $c 0] set e [lindex $c 1] if {[string equal $e "crd"]} { incr m if {$m > 1} { toptolex1 $list $ci $f [getitemvertex $list $ci] set f "dl(0,$form,$form)" } set ci $i } elseif {[string equal $e "cnj"]} { set f1 [getitemform $list $i "conj" $e] toptolex1 $list $i $f1 [getitemvertex $list $i] if {$m == 0} { set f "dl(0,$f1,$f)" } else { set f "dr(0,$f,$f1)" } } elseif {[string equal $e "mod"]} { if {$m > 0} { toptolex1 $list $i "dr(0,$form,$form)" [getitemvertex $list $i] } else { toptolex1 $list $i "dl(0,$form,$form)" [getitemvertex $list $i] } } else { puts stderr "($sentno) Conj: $e $children" set f1 [getitemform $list $i "conj" $e] toptolex1 $list $i $f1 [getitemvertex $list $i] if {$m == 0} { set f "dl(0,$f1,$f)" } else { set f "dr(0,$f,$f1)" } } } if {$ci >= 0} { toptolex1 $list $ci $f [getitemvertex $list $ci] } } proc adjacent {i j} { global positions sentno set ip $positions($sentno,$i) set jp $positions($sentno,$j) set ir [expr [lindex $ip end]+1] set jl [lindex $jp 0] return $ir==$jl } # analyse_mwu # lists the structure (functor, arguments and modifiers) of merged-word # units. # reanalyses # een np of # (en dan) [crd] -> (en) [crd] (dan) [mod] # op de hoogte van -> op [hd] (de np/np hoogte np) van # ook al -> ook [mod] al [mod] # dat/een soort van -> een np/np soort np van (np\np)/np # wat voor soort van -> wat np voor (np\np)/np soort np van (np\np)/np # maar goed -> maar [mod] goed [mod] # of dat -> ??? Vlaams # van alles en nog wat -> pp/np np (pp\np)/np np/np np # ADVP # dan ook [prt prt] # ook nog [prt prt] # TODO # np/np ((np/np)\(np/np))/np np/np np # twee TW1 en VG1 een LID kwart N1 # kwart N1 voor/over VZ1 (tien) TW1 proc analyse_mwu {list children vertex item form} { set cw [getchildwords $children $list] set cl [split $cw] putsdebug "MWU: $cw $form" if {[string equal $cw "of vg1 zo bw"]|| \ [string equal $cw "of vg1 zoiets vnw22"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "maar vg1 ook bw"]|| [string equal $cw "maar vg1 toch bw"]|| [string equal $cw "maar vg1 ja tsw"]|| [string equal $cw "maar vg1 goed adj9"]|| [string equal $cw "maar vg1 goed adj4"]|| [string equal $cw "maar bw goed adj4"]|| [string equal $cw "wat vnw14 een lid"]|| [string equal $cw "maar vg1 dan bw"]|| [string equal $cw "ook bw al bw"]|| [string equal $cw "nou bw ja tsw"]|| [string equal $cw "ja tsw maar vg1"]|| [string equal $cw "nee tsw maar vg1"]|| [string equal $cw "nee tsw hoor tsw"]|| [string equal $cw "oh tsw jee tsw"]|| [string equal $cw "ah tsw ja tsw"]|| [string equal $cw "het lid liefst bw"]|| [string equal $cw "het lid meest vnw26"]|| [string equal $cw "niet bw alleen bw"]|| [string equal $cw "niet bw eens bw"]|| [string equal $cw "en vg1 ook bw"]|| [string equal $cw "en vg1 dan bw"]} { return [rebracket3 $list $children $form] } elseif {[string equal $cw "en vg1 zo bw"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "iets vnw22 van vz1"]} { return [rebracket0 $list $children $form] } elseif {[string equal $cw "er vnw20 aan vz2 toe vz2 np"]} { return [list [lindex $children 1] [lrange $children 0 0] [lrange $children 2 2] {} {}] } elseif {[string equal $cw "onder vz1 andere adj1"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "zeg ww1 maar bw"]|| [string equal $cw "zeg ww1 maar vg1"]} { return [list [lindex $children 0] {} {} {} [lrange $children 1 1]] } elseif {[string equal $cw "wat vnw14 voor vz1"]} { return [list [lindex $children 1] [lrange $children 0 0] {} {} {}] } elseif {[string equal $cw "af vz2 en vg1 toe vz2"]} { return [list [lindex $children 1] [lrange $children 0 0] [lrange $children 2 2] {} {}] } elseif {[string equal $cw "tot vz1 en vg1 met vz1"]} { return [list [lindex $children 1] [lrange $children 0 0] [lrange $children 2 2] {} {}] } elseif {[string equal $cw "dit vnw19 en vg1 dat vnw19"]|| [string equal $cw "die vnw19 en vg1 die vnw19"]} { return [list [lindex $children 1] [lrange $children 0 0] [lrange $children 2 2] {} {}] } elseif {[string equal $cw "één vnw24 of vg1 andere adj1"]|| [string equal $cw "één vnw24 of vg1 ander adj1"]|| [string equal $cw "één vnw24 of vg1 ander adj2"]|| [string equal $cw "één vnw24 en vg1 ander adj1"]|| [string equal $cw "één vnw25 en vg1 ander adj2"]|| [string equal $cw "één vnw24 en vg1 ander adj2"]|| [string equal $cw "zus bw en vg1 zo bw"]|| [string equal $cw "heen vz2 en vg1 weer bw"]|| [string equal $cw "op vz2 en vg1 neer bw"]|| [string equal $cw "min bw of vg1 meer vnw26"]|| [string equal $cw "hier vnw20 en vg1 daar vnw20"]|| [string equal $cw "vast adj9 en vg1 zeker adj9"]|| [string equal $cw "minste vnw24 of vg1 geringste adj3"]|| [string equal $cw "minste adj3 of vg1 geringste adj3"]|| [string equal $cw "Rembo n5 en vg1 Rembo n5"]|| [string equal $cw "Samson n5 en vg1 Gert n5"]|| [string equal $cw "een vnw24 of vg1 andere adj1"]|| [string first "mond- spec2 en vg1 klauw" $cw] != -1} { # conjunction-like elements # TODO # Piet Pienter en Bert Bibber return [list [lindex $children 1] [lrange $children 0 0] [lrange $children 2 2] {} {}] } elseif {[string equal $cw "aan vz1 het lid"]|| [string equal $cw "aan vz1 't vnw3"]|| [string equal $cw "aan vz1 't lid"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "wat vnw14 dan bw ook bw"]} { return [list [lindex $children 0] {} {} {} [lrange $children 1 2]] } elseif {[string equal $cw "in vz1 feite n1"]|| [string equal $cw "op vz1 zoek n1"]|| [string equal $cw "op vz1 weg n1"]|| [string equal $cw "onder vz1 meer vnw26"]|| [string equal $cw "van vz1 alles vnw22"]|| [string equal $cw "in vz1 staat n1"]|| [string equal $cw "in vz1 principe n1"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "het lid beste adj6"]|| [string equal $cw "het lid best adj11"]|| [string equal $cw "het lid eerst adj11"]|| [string equal $cw "het lid eerste adj6"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "dat vnw21 soort n1 van vz1"]|| [string equal $cw "een lid soort n1 van vz1"]} { return [rebracket1 $list $children $form] } elseif {[string equal $cw "in vz1 verband n1 met vz1"]} { return [rebracket2 $list $children $form "np" "np"] } elseif {[string equal $cw "in vz1 plaats n1 van vz1"] || [string equal $cw "in vz1 dienst n1 van vz1"] || [string equal $cw "in vz1 vergelijking n1 met vz1"] || [string equal $cw "in vz1 handen n3 van vz1"] || [string equal $cw "in vz1 termen n3 van vz1"] || [string equal $cw "in vz1 tegenstelling n1 tot vz1"]|| [string equal $cw "in vz1 relatie n1 tot vz1"]|| [string equal $cw "naar vz1 aanleiding n1 van vz1"] || [string equal $cw "onder vz1 leiding n1 van vz1"] || [string equal $cw "op vz1 basis n1 van vz1"] || [string equal $cw "op vz1 weg n1 naar vz1"] || [string equal $cw "op vz1 grond n1 van vz1"] || [string equal $cw "op vz1 gebied n1 van vz1"] || [string equal $cw "op vz1 vlak n1 van vz1"] || [string equal $cw "met vz1 betrekking n1 tot vz1"] || [string equal $cw "ten vz3 opzichte n1 van vz1"] || [string equal $cw "ter vz3 beschikking n1 van vz1"] || [string equal $cw "ter vz3 hoogte n1 van vz1"] || [string equal $cw "ten vz3 behoeve n1 van vz1"] || [string equal $cw "ten vz3 noorden n1 van vz1"] || [string equal $cw "ten vz3 tijde n1 van vz1"] || [string equal $cw "ten vz3 aanzien n1 van vz1"] || [string equal $cw "ten vz3 koste n1 van vz1"] || [string equal $cw "bij vz1 wijze n1 van vz1"]} { return [rebracket2 $list $children $form "np" "np"] } elseif {[string equal $cw "op vz1 de lid hoogte n1 van vz1"] || [string equal $cw "op vz1 het lid vlak n1 van vz1"] || [string equal $cw "op vz1 het lid gebied n1 van vz1"] || [string equal $cw "aan vz1 de lid hand n1 van vz1"] || [string equal $cw "in vz1 de lid loop n1 van vz1"] || [string equal $cw "van vz1 de lid kant n1 van vz1"] || [string equal $cw "in vz1 het lid kader n1 van vz1"]} { return [rebracket2 $list $children $form [list dr(0,np,np) "np"] "np"] } elseif {[string equal $cw "met vz1 name n1"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "wie vnw14 weet ww1"]} { return [list [lindex $children 1] [lrange $children 0 0] {} {} {}] } elseif {[string equal $cw "of vg1 niet bw"]|| [string equal $cw "of vg1 wel bw"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } elseif {[string equal $cw "van vz1 die vnw21"]} { # als DETP [mod] [hd] return [list [lindex $children 1] {} {} [lrange $children 0 0] {}] } elseif {[string equal $cw "vierkante adj1 meter n1"]} { return [list [lindex $children 1] {} {} [lrange $children 0 0] {}] } elseif {[string equal $cw "weet ww1 ik vnw1 veel vnw26"]|| [string equal $cw "wist ww1 ik vnw1 vee@l vnw26"]|| [string equal $cw "weet ww1 ik vnw1 veel vnw26 wat vnw14"]} { return [list [lindex $children 0] {} [lrange $children 1 end] {} {}] } elseif {[string equal $cw "weet ww1 je vnw1 wel bw"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} [lrange $children 2 2]] } elseif {[string equal $cw "dank ww1 u vnw6 wel bw"]|| [string equal $cw "dank ww1 u vnw6"]|| [string equal $cw "dank ww1 je vnw6"]|| [string equal $cw "dank ww1 je vnw1"]|| [string equal $cw "dank ww1 je vnw6 wel bw"]|| [string equal $cw "dank ww1 je vnw1 wel bw"]} { return [list [lindex $children 0] {} [lrange $children 1 1] {} [lrange $children 2 2]] } elseif {[set u [lsearch $cl "uur"]] > 0 && \ [string equal [lindex $cl [expr $u-1]] "tw1"]} { # X uur Y set u [expr $u/2] return [list [lindex $children $u] {} {} [lrange $children 0 [expr $u-1]] [lrange $children [expr $u+1] end]] } elseif {[ohja $cl] != -1} { return [rebracket4 $list $children $form] } elseif {[set c [complextw $cl]] != -1} { return [list [lindex $children $c] [lrange $children 0 [expr $c-1]] [lrange $children [expr $c+1] end] {} {}] } else { #default to the all modifier case putsdebug "MWUDEFAULT: $cw $form" return [list [lindex $children end] {} {} [lrange $children 0 end-1] {}] } } # iets van # np (np\A)/B |- A/B proc rebracket0 {list children form} { set fs [parseform $form] set c [lindex $fs 0] set i [lindex $fs 1] set a1 [lindex $fs 2] set a2 [lindex $fs 3] if {[string equal $c "dr"]} { set rf "dr($i,dl(0,np,[portrayform $a1]),[portrayform $a2])" analyse_children $list $children [list np $rf] putsdebug "np $rf" return {} } else { return [list [lindex $children 1] {} {} [lrange $children 0 0] [lrange $children 2 2]] } } # een soort van # np/np np (np\A)/B |- A/B proc rebracket1 {list children form} { set fs [parseform $form] set c [lindex $fs 0] set i [lindex $fs 1] set a1 [lindex $fs 2] set a2 [lindex $fs 3] if {[string equal $c "dr"]} { set rf "dr($i,dl(0,np,[portrayform $a1]),[portrayform $a2])" analyse_children $list $children [list "dr(0,np,np)" np $rf] putsdebug "dr(0,np,np) np $rf" return {} } else { return [list [lindex $children 1] {} {} [lrange $children 0 0] [lrange $children 2 2]] } } # in plaats van # bij wijze van # naar aanl. van # ten opz. van # A/C ...C... (C\C)/B |- A/B # B\C ...C... (C\C)/A |- B\A # op de_hoogte van TODO: word order! "op de hoogte is van" proc rebracket2 {list children form mcfs cr} { set fs [parseform $form] putsdebug $fs set c [lindex $fs 0] set i [lindex $fs 1] set a1 [lindex $fs 2] set a2 [lindex $fs 3] if {[string equal $c "dr"]} { set f1 "dr(0,[portrayform $a1],$cr)" set f2 "dr($i,dl(0,$cr,$cr),[portrayform $a2])" analyse_children $list $children [concat $f1 $mcfs $f2] return {} } else { return [list [lindex $children 1] {} {} [lrange $children 0 0] [lrange $children 2 end]] } } # maar ook # en dan # ook al (sometimes ADVP) # nou ja # het liefst # A/B B/B |- A/B # # A\A A\B |- A\B proc rebracket3 {list children form} { set fs [parseform $form] set c [lindex $fs 0] set i [lindex $fs 1] set a1 [lindex $fs 2] set a2 [lindex $fs 3] if {[string equal $c "dr"]} { set f1 "dr($i,[portrayform $a1],[portrayform $a2])" set f2 "dr($i,[portrayform $a2],[portrayform $a2])" analyse_children $list $children [list $f1 $f2] putsdebug "$f1 $f2" return {} } elseif {[string equal $c "dl"]} { set f1 "dl($i,[portrayform $a1],[portrayform $a1])" set f2 "dl($i,[portrayform $a1],[portrayform $a2])" analyse_children $list $children [list $f1 $f2] putsdebug "$f1 $f2" return {} } else { return [list [lindex $children 0] {} [lrange $children 1 1] {} {}] } } # ja ja+ # oh ja+ # nee nee+ # oh nee+ proc rebracket4 {list children form} { set fs [parseform $form] set c [lindex $fs 0] set i [lindex $fs 1] set a1 [lindex $fs 2] set a2 [lindex $fs 3] if {[string equal $c "dr"]} { set f1 "dr($i,[portrayform $a1],[portrayform $a2])" set flist $f1 set f2 "dr($i,[portrayform $a2],[portrayform $a2])" for {set n 1} {$n < [llength $children]} {incr n} { lappend flist $f2 } analyse_children $list $children $flist putsdebug "$flist" return {} } elseif {[string equal $c "dl"]} { set f1 "dl($i,[portrayform $a1],[portrayform $a1])" set flist $f1 set f2 "dl($i,[portrayform $a1],[portrayform $a2])" for {set n 1} {$n < [llength $children]} {incr n} { lappend flist $f2 } analyse_children $list $children $flist putsdebug "$flist" return {} } else { return [list [lindex $children end] {} {} [lrange $children 0 end-1] {}] } } # een (stuk) of # B (B\A)/B |- A/B # TODO proc rebracket5 {list children form} { set fs [parseform $form] set c [lindex $fs 0] set i [lindex $fs 1] set a1 [lindex $fs 2] set a2 [lindex $fs 3] if {[string equal $c "dr"]} { set rf "dr($i,dl(0,np,[portrayform $a1]),[portrayform $a2])" analyse_children $list $children [list "dr(0,np,np)" np $rf] putsdebug "dr(0,np,np) np $rf" return {} } else { return [list [lindex $children 1] {} {} [lrange $children 0 0] [lrange $children 2 2]] } } # wat betreft # (A/B)*C C\D |- A/B # (np/s)*np (np\s)/np |- np/ proc ohja {children} { for {set i 0} {$i < [llength $children]} {incr i +2} { if {[string equal [lindex $children $i] "oh"]|| [string equal [lindex $children $i] "o"]|| [string equal [lindex $children $i] "ja"]|| [string equal [lindex $children $i] "nee"]} { } else { return -1 } } return 1 } proc s_return {posl} { for {set i 1} {$i < [llength $posl]} {incr i +2} { set x [lindex $posl $i] if {[string equal $x "bw"]|| [string equal $x "tsw"]|| [string equal $x "vg1"]|| [string equal $x "adj9"]} { continue } else { return -1 } } return 0 } proc complextw {children} { # TODO een half -> np set index -1 for {set i 0} {$i < [llength $children]} {incr i +2} { if {[string equal [lindex $children [expr $i+1]] "tw1"]|| [string equal [lindex $children [expr $i+1]] "tw2"]} { continue } elseif {[string equal [lindex $children $i] "komma"]|| [string equal [lindex $children $i] "en"]} { set index [expr $i/2] continue } else { return -1 } } return $index } proc analyse_children {list children cforms} { set i 0 foreach c $children { set num [lindex $c 0] set f [lindex $cforms $i] toptolex1 $list $num $f [getitemvertex $list $num] incr i } } proc getchildwords {children list} { set result "" foreach c $children { set item [selectitem $list [lindex $c 0]] set pos [getpos $item] set word [getword $item] set result "$result $word $pos" } return [string trim $result] } proc getchildpos {children list} { set result {} foreach c $children { set item [selectitem $list [lindex $c 0]] set pos [getpos $item] lappend result $pos } return $result } proc ismodifier {list} { set conn [lindex $list 0] return ([string equal $conn "dr"] || [string equal $conn 0] "dl"]) && [string equal [portrayform [lindex $list 2]] [portrayform [lindex $list 3]]] } # portrayform # # transform a formula in list notation to one in string notation proc portrayform {list} { set l [llength $list] if {$l == 1} { return $list } elseif {$l == 4} { return "[lindex $list 0]([lindex $list 1],[portrayform [lindex $list 2]],[portrayform [lindex $list 3]])" } } # parseform # # transform a string containing a formula into a list proc parseform {string} { global res set string [string trim $string] set i [parseform1 $string 0] if {$i != [string length $string]} { puts stderr "$i [string length $string]" puts stderr "Trailing material deleted! .[string range $string $i end].$res." } return $res } proc parseform1 {string begin} { global arg1 arg2 index res set i $begin if {[string equal [string range $string $i [expr $i+2]] "dl("]} { set i [parserest $string [expr $i+3]] set res [list dl $index $arg1 $arg2] } elseif {[string equal [string range $string $i [expr $i+2]] "dr("]} { set i [parserest $string [expr $i+3]] set res [list dr $index $arg1 $arg2] } elseif {[string equal [string range $string $i [expr $i+1]] "p("]} { set i [parserest $string [expr $i+2]] set res [list p $index $arg1 $arg2] } else { # atomic formula set j [string first "," $string $i] set k [string first ")" $string $i] if {$j < $k && $j != -1} { set res [string range $string $begin [expr $j-1]] set i $j } elseif {$k != -1} { set res [string range $string $begin [expr $k-1]] set i $k } else { set res [string range $string $begin end] set i [string length $string] } } return $i } proc parserest {string i} { global res arg1 arg2 index set i [parseindex $string $i] set thisindex $index set i [parsecomma $string $i] set i [parseform1 $string $i] set thisarg1 $res set i [parsecomma $string $i] set i [parseform1 $string $i] set thisarg2 $res set i [parseparnc $string $i] set index $thisindex set arg1 $thisarg1 set arg2 $thisarg2 return $i } proc parsecomma {string i} { if {[string equal [string range $string $i $i] ","]} { return [expr $i+1] } else { puts stderr "Missing comma: $string" exit 1 } } proc parseparnc {string i} { if {[string equal [string range $string $i $i] ")"]} { return [expr $i+1] } else { puts stderr "Missing close parenthesis: $string" exit 1 } } proc parseindex {string i} { global index if {[set j [string first "," $string $i]] != -1} { set index [string range $string $i [expr $j-1]] return $j } else { puts stderr "Missing comma: $string" exit 1 } } 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 $string } } proc getword {s} { lindex $s 0 } # changed to distinguish the different SPEC types 20050104 RM # conflated ADJ types, only distinguishing between prenominal (ADJ1), # nominal (ADJ2), postnominal (ADJ3), free (ADJ4) and dialectic (ADJ5). proc gettag {s} { set tag [lindex $s 1] set morph [lindex $s 2] if {[string equal $tag "SPEC"]&&[regexp {T00([2-6,8,9])} $morph all n]} { return "$tag$n" } elseif {[regexp {ADJ([0-9]+)} $tag all n]} { if {$n < 4} { return "ADJ1" } elseif {$n < 7} { return "ADJ2" } elseif {$n < 9} { return "ADJ3" } elseif {$n < 12} { return "ADJ4" } else { return "ADJ5" } } else { return $tag } } 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 getitemedge {list i} { string tolower [getedge [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 [gettag $s] if {[regexp {^#([0-9]+)$} $tag]} { return 0 } else { return [string tolower $tag] } } # itemdata # # outputs a string containing additional data for item n, currently # only edge, morphology and POS. proc itemdata {list n} { return [string tolower "[getedge [lindex $list $n]], [getmorph [lindex $list $n]], [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 } } # comments # ssub: vc is necessary because of fn000178 #10 # obj1 is necessary because of fn000252 #32 # many entries added, especially for the sentence types, because the # `all modifier' possibility has been ruled out set functor(smain) {hd svp vc predc su sup obj1 pc dp ld mod} set functor(sv1) {hd svp vc predc su sup obj1 pc dp ld mod} set functor(ssub) {hd svp vc predc su sup obj1 pc dp ld mod} set functor(inf) {hd svp vc predc su sup obj1 pc dp ld mod} set functor(ppart) {hd svp vc predc su sup obj1 pc dp ld mod} set functor(ppres) {hd svp vc predc su sup obj1 pc dp ld mod} set functor(cp) {cmp} set functor(mwu) {hd mwp} set functor(ti) {hd cmp} set functor(oti) {hd cmp} set functor(ahi) {cmp hd} set functor(advp) {hd prt mod} set functor(detp) {obcomp hd det mod} set functor(ap) {obcomp hd prt pc mod} set functor(pp) {hd hdf det obj1} set functor(np) {hd nucl mod part appos predm} set functor(svan) {hd cmp} set functor(rel) {rhd hd body} set functor(whrel) {whd hd rhd cmp} set functor(whq) {whd cmp} set functor(whsub) {whd} set functor(conj) {crd cnj} set functor(du) {hd nucl dp tag sat dlink} set functor(list) {hd lp} set functor(compp) {hd cmp} # svp removed for SMAIN # ld removed as modifier # mwp added as modifier for MWU (should reduce complexity and is # comparable to the way LIST/lp are now treated) # crd added for CONJ (should help with repeated `en') 20030128 set modifier(smain) {mod predm dp} set modifier(sv1) {mod predm dp} set modifier(ssub) {mod predm dp} set modifier(inf) {mod predm dp} set modifier(ppart) {mod predm ld} set modifier(ppres) {mod predm ld} set modifier(cp) {mod} set modifier(mwu) {mod mwp} set modifier(ti) {mod predm} set modifier(oti) {mod predm} set modifier(ahi) {mod predm} set modifier(advp) {mod prt} set modifier(detp) {mod} set modifier(ap) {mod prt} set modifier(pp) {mod} set modifier(np) {det mod tag appos pc vc ld dp lp obj1 obj2 svp obcomp predm} # set modifier(np) {det mod tag appos predm} set modifier(svan) {mod} set modifier(rel) {mod} set modifier(whrel) {mod} set modifier(whq) {mod} set modifier(whsub) {mod} set modifier(conj) {crd} set modifier(du) {mod sat tag nucl} set modifier(list) {mod} set modifier(compp) {mod} set modifier(n3) {mod} set modifier(n1) {mod} # selectfunctor # # selects the functor of a list of items proc selectfunctor {list children parent itemno} { global functor sentno of foreach e $functor($parent) { set left {} set n 1 foreach i $children { set edge [lindex $i 1] if {[string equal $edge $e]} { return [list $i $left [lrange $children $n end]] } else { incr n set left [linsert $left 0 $i] } } } puts $of "%! ($sentno) No functor found for $parent-$itemno: [getitemedges $children]" pplist $list puts stderr "!\n($sentno) No functor found for $parent-$itemno: [getitemedges $children]" exit 1 } proc selectmodifiers {list children parent} { global modifier of sentno set mods {} set newc {} if {[catch {set modifier($parent)} errmsg]} { puts $of "No modifiers specified for $parent\n$errmsg" exit 1 } foreach i $children { set num [lindex $i 0] set edge [lindex $i 1] if {[lsearch $modifier($parent) $edge] > -1} { set mods [linsert $mods 0 $i] } else { lappend newc $i } } return [list $mods $newc] } # 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 getitemvertex {list i} { string tolower [gettag [selectitem $list $i]] } # moved SVAN to np # changed TSW to s, expect this to work better, since the Flemish # annotation consistently annotates single-TSW sentences as DU # 20041225 RM # removed mistake where the indexes were swappend for the CONJ and # LIST cases, causing everything to fall back to the np base case # 20030129 RM # notes: CP -> np ? CP occurs often as object, but usually is a # type of sentential complement. `s' is probably better. # REL -> np ? # AP -> np ? # BW -> ? (many different uses) # changed {ap|lid|detp|rel} to np; result are less lexical trees, but # slightly worse performance. reverting to old 20050112 RM # changed rel to dl(0,np,np) # added let -> np rule # changed to have an extra `edge' argument # changed again to have an extra vertex argument, which contains the label # of the parent node proc getitemform {list i vertex edge} { global of set pp "pp" set item [selectitem $list $i] set tag [string tolower [gettag $item]] if {[regexp {vnw([0-9]+)} $tag all n]} { if {$n == 11 || $n == 17 || $n == 18 || $n == 21 || $n == 24 || $n > 25} { # determiner, except nominal (VNW25) return dr(0,np,np) } else { return np } } elseif {[regexp {adj([0-9]+)} $tag all n]} { if {$n == 3} { # postnominal return dl(0,np,np) } elseif {$n == 2} { # nominal return np } else { # prenominal return dr(0,np,np) } } elseif {[regexp {n([0-9]+)} $tag all n]} { if {$n == 6} { return dr(0,np,np) } else { return np } } elseif {[regexp {spec([0-9])|compp} $tag]} { return np } elseif {[regexp {ww([0-9]+)} $tag all n]} { if {$n == 6 || $n == 9 || $n == 12} { return np } elseif {$n == 5 || $n == 8 || $n == 11} { return dr(0,np,np) } else { return dl(0,np,s) } } elseif {[regexp {ssub|smain|sv1|svan} $tag]} { return s } elseif {[regexp {whq|whrel|whsub} $tag]} { return s } elseif {[regexp {ppres|ppart|ti|oti|ahi|inf} $tag]} { return dl(0,np,s) } elseif {[string equal "advp" $tag]} { return [rightmodifierform 4 "s"] } elseif {[string equal "bw" $tag]} { if {[string first "obj" $edge]!= -1 || [string equal "su" $edge]} { return np } elseif {[string equal "predc" $edge]} { # treated like adjective, which is a bit strange but # corresponds to other `predc' arguments # eg. `liever', `zover', `weg' return dr(0,np,np) } elseif {[string equal "det" $edge]} { # determiners, like `al die/dat', `allemaal', `zo' return dr(0,np,np) } elseif {[string equal "pc" $edge]} { # prepositional complement, like `daarover', `eraan' return $pp } elseif {[string equal "svp" $edge]} { # weg/terug (nemen), neer (leggen) return dl(0,np,$pp) } else { # default is sentence modifier return [rightmodifierform 4 "s"] } } elseif {[regexp {ap|lid|detp} $tag]} { return dr(0,np,np) } elseif {[string equal "rel" $tag]} { return dl(0,np,np) } elseif {[regexp {vz([0-9]+)} $tag all n]} { if {$n == 2} { # postposition return dl(0,np,$pp) } else { # preposition return dr(0,$pp,np) } } elseif {[regexp {vg([0-9]+)|tsw} $tag]} { return [leftmodifierform 0 "s"] } elseif {[regexp {tw([0-9]+)} $tag]} { return dr(0,np,np) } elseif {[string equal "cp" $tag]} { return s } elseif {[string equal "mwu" $tag]} { set children [findchildren $list $i] set posl [getchildwords $children $list] set fst [lindex $posl 0] putsdebug "MWUS: $posl" if {[lsearch $posl "ww1"] != -1} { return s } elseif {[s_return $posl] != -1} { return s } elseif {[string equal [lindex $posl 1] "vz1"]|| [string equal [lindex $posl end] "vz2"]|| [string equal [lindex $posl 1] "vz3"]} { putsdebug "MWUPP: $posl" return $pp } else { return np } } elseif {[string equal "du" $tag]} { # discourse unit has the type of its `nucl' daugther set children [findchildren $list $i] foreach c $children { set chedge [lindex $c 1] if {[string equal "nucl" $chedge]} { set newi [lindex $c 0] set newresult [getitemform $list $newi "du" $edge] return $newresult } } # discourse unit with only `dp' daugthers has the type of its # first `dp' daugther set fc [lindex $children 0] set newi [lindex $fc 0] return [getitemform $list $newi "du" $edge] } elseif {[string equal "conj" $tag]} { set children [findchildren $list $i] foreach c $children { set chedge [lindex $c 1] if {[string equal "cnj" $chedge]} { set newi [lindex $c 0] set newresult [getitemform $list $newi "conj" $edge] return $newresult } } return np } elseif {[string equal "list" $tag]} { set children [findchildren $list $i] foreach c $children { set chedge [lindex $c 1] if {[string equal "lp" $chedge]} { set newi [lindex $c 0] return [getitemform $list $newi "list" $edge] } } return np } elseif {[string equal "np" $tag]} { return np } elseif {[string equal "let" $tag]} { if {[string equal "body" $edge]} { if {[string equal "svan" $vertex]} { return s } else { return dl(0,np,s) } } else { return np } } elseif {[string equal "pp" $tag]} { # changed from "pp" to reduce errors return $pp } else { puts stderr $tag return $tag } } proc pplist {list} { foreach i $list { putsdebug $i } } proc complexform {left right form} { set result $form for {set i 0} {$i < [llength $left]} {incr i +2} { set result "dl([lindex $left $i],[lindex $left [expr $i+1]],$result)" } for {set i [expr [llength $right] -1]} {$i > -1} {incr i -2} { set result "dr([lindex $right [expr $i-1]],$result,[lindex $right $i])" } return $result } proc leftmodifierform {mode form} { set f [modifierform $form] return dr($mode,$f,$f) } proc rightmodifierform {mode form} { set f [modifierform $form] return dl($mode,$f,$f) } proc modifierform {form} { # vp modifiers now modifier sentence instead, this avoids problems # with V1 sentences and subject-less phrases 20051108 RM if {[string equal $form "dl(0,np,s)"]} { set form "s" } return $form } proc complexprod {list mode form} { set result $form for {set i [expr [llength $list] -1]} {$i > -1} {incr i -1} { set result "p($mode,[lindex $list $i],$result)" } return $result } proc reverse {list} { set result {} for {set i [expr [llength $list] -1]} {$i >= 0} {incr i -1} { lappend result [lindex $list $i] } return $result } # main loop # call `loadcgn' for each of the argument files which exist. readtrans reduced_form.pl foreach f $argv { if {[file readable $f]} { puts -nonewline stderr "File: $f" loadcgn $f } else { puts stderr "File $f does not exist or is unreadable" exit 1 } }