00001 # Copyright (C) 1997-2004 The CDG Team <cdg@nats.informatik.uni-hamburg.de> 00002 # 00003 # This file is free software; as a special exception the author gives 00004 # unlimited permission to copy and/or distribute it, with or without 00005 # modifications, as long as this notice is preserved. 00006 # 00007 # This program is distributed in the hope that it will be useful, but 00008 # WITHOUT ANY WARRANTY, to the extent permitted by law; without even the 00009 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00010 00011 ## ---------------------------------------------------------------------------- 00012 ## ParseTree - visualization of one parse. 00013 ## 00014 ## ParseTree objects are the central means to give you a nice 00015 ## dependency tree drawing. They are only thought to be used as 00016 ## components of a VisParses object being the GUI surrounding a set of 00017 ## visualized ParseTree objects. Taking the embedded Parse object into 00018 ## account, these tree classes implement the tree editor in XCDG. 00019 ## 00020 ## \author Michael Daum, Kilian A. Foth, Dietmar Fünning 00021 ## (see also AUTHORS and THANKS for more) 00022 ## 00023 ## $Id: parsetree.tcl,v 1.135 2004/10/18 08:09:32 foth Exp $ 00024 ## ---------------------------------------------------------------------------- 00025 00026 class ParseTree { 00027 inherit ::itk::Widget 00028 00029 # new options 00030 00031 ## itk_option: color of a node of the dependency tree 00032 itk_option define -nodecolor nodeColor Color "black" 00033 00034 ## itk_option: color of edges up to the parents 00035 itk_option define -edgecolor edgeColor Color "black" 00036 00037 ## itk_option: color of vertical lines 00038 itk_option define -vlinecolor vlineColor Color "gray" 00039 00040 ## itk_option: font-property for the words in the sentence 00041 itk_option define -wordfont wordFont Font "" 00042 00043 ## itk_option: font-property of the dependency labels 00044 itk_option define -labelfont labelFont Font "" 00045 00046 ## itk_option: color of the words in the sentence 00047 itk_option define -wordcolor wordColor Color "black" 00048 00049 ## itk_option: color of the dependency labels 00050 itk_option define -labelcolor labelColor Color "black" 00051 00052 ## itk_option: color of highlighted structures 00053 itk_option define -highlightcolor highlightColor Color "red" 00054 00055 ## itk_option: color of erroneous structures 00056 itk_option define -errorcolor errorColor Color "red" 00057 00058 ## itk_option: decoration of a level component 00059 itk_option define -levelrelief levelRelief Relief "flat" 00060 00061 ## itk_option: decoration of a level component 00062 itk_option define -levelborderwidth levelBorderwidth Borderwidth 1 00063 00064 ## the embedded Parse object 00065 private variable _parse "" ;## \type ParseTree 00066 00067 ## who is my daddy 00068 private variable _visparses ""; ## \type VisParses 00069 00070 ## array holding the middle points of the words. 00071 ## initialized by drawText; indexed by timepoints, e.g. 0 00072 private variable _textMidPos; ## \type TclArray 00073 00074 ## holds all items on a canvas belonging to one timepoint. 00075 ## Example: _itemsOfTimepoint(SYN,3) == 4 27 26 24 25 00076 private variable _itemsOfTimepoint; ## \type TclArray 00077 00078 ## array holding the timepoint which a specified id belongs to. 00079 ## Example: _timepointOfId(SYN,3) = 0 00080 private variable _timepointOfId; ## \type TclArray 00081 00082 ## array storing arcs by level and timepoint. 00083 ## Example: _arcOfTimepoint(3,OBL1) = 47 48 00084 private variable _arcOfTimepoint; ## \type TclArray 00085 00086 ## array holding the level that an arc belongs to. 00087 ## Example: _levelOfItem(89) = DOM 00088 private variable _levelOfItem; ## \type TclArray 00089 00090 ## holds ids of canvas items to be highlighted when touching a violation. 00091 ## Example: _itemsOfViolation(1) == 23 SYN 22 SYN 00092 private variable _itemsOfViolation; ## \type TclArray 00093 00094 ## array storing the canvas of a level. 00095 private variable _levelOfCanvas; ## \type TclArray 00096 00097 ## array indicating whether a level is already drawn. 00098 private variable _isDrawn; ## \type TclArray 00099 00100 private variable _dragItem "" 00101 private variable _mouseItem "" 00102 private variable _mouseBinding "" 00103 private variable _dragStartX 0 00104 private variable _dragStartY 0 00105 private variable _zoomstep 0 00106 private variable _oldColor "" 00107 00108 private variable _lastxmark 0 00109 private variable _lastymark 0 00110 00111 ## Command-History-Object for undo-implementation 00112 private variable _commandHistory "" 00113 00114 ## Variables holding state of the keyboard highlighting 00115 private variable _kb_word 0 00116 private variable _kb_regent -2 00117 private variable _kb_labels 00118 private variable _kb_label -1 00119 private variable _kb_lexemes 00120 private variable _kb_lexeme 00121 00122 ## Flags for inter-handler communication 00123 private variable _computing 0 00124 private variable _released 0 00125 00126 public method drawAll {} 00127 public method writeToFile {fileName}; ## \type TclString 00128 public method mirror {} 00129 public method verify {} 00130 public method showcycles {} 00131 public method breakcycles {} 00132 public method zoom {direction}; ## \type TclNumber 00133 public method setOrientation {orient}; ## \type TclString 00134 public method getOrientation {} 00135 public method parse {args}; ## \type TclList 00136 public method mainlevelname {}; 00137 public method highlight {which}; ## \type TclString 00138 public method backwardLevel {} 00139 public method forwardLevel {} 00140 00141 ## Methods used to implement undo-functionality (called from VisParses) 00142 public method undo {} 00143 public method redo {} 00144 public method addUndoListener {listener}; ## \type TclString 00145 public method canUndo {} 00146 public method canRedo {} 00147 00148 00149 constructor {p vp args} {}; ## \type Parse, VisParses, TclList 00150 destructor {} 00151 00152 ## Methods used to implement undo-functionality (Internal methods) 00153 private method undoEdge {modifier modifiee level} ; ## \type TclNumber, TclNumber, TclString 00154 private method undoLabel {modifier label level}; ## \type TclNumber, TclString, TclString 00155 private method undoLexeme {from description}; ## \type TclNumber, TclString 00156 00157 private method _zoom {step}; ## \type TclNumber 00158 private method allEnter {w}; ## \type Canvas 00159 private method allLeave {w}; ## \type Canvas 00160 private method labelOfEdge {w edge}; ## \type Canvas, TclString 00161 private method wordOfTimepoint {w t}; ## \type Canvas, TclNumber 00162 private method edgeOfTimepoint {w t}; ## \type Canvas, TclNumber 00163 private method nodeOfTimepoint {w e t}; ## \type Canvas, TclNumber, TclNumber 00164 private method edgeEnter {w}; ## \type Canvas 00165 private method edgeLeave {w}; ## \type Canvas 00166 private method allSybillings {id1 id2 level}; ## \type TclNumber, TclNumber, TclString 00167 private method canvasToScreen {canvas x y}; ## \type Canvas, TclNumber, TclNumber 00168 private method createArc {canvas x1 y1 x2 y2 text bindNo}; ## \type Canvas, TclNumber, TclNumber, TclNumber, TclNumber, TclNumber, TclNumber 00169 private method drawArcs {} 00170 private method drawLevel {level}; ## \type TclString 00171 private method drawText {canvas x y}; ## \type Widget, TclNumber, TclNumber 00172 private method drawViolas {} 00173 private method canvasClick {w x y}; ## \type Canvas, TclNumber, TclNumber 00174 private method edgeClick {w x y}; ## \type Canvas, TclNumber, TclNumber 00175 private method edgeRightClick {w}; ## \type Canvas 00176 private method arcRightClick {w}; ## \type Canvas 00177 private method edgeDrop {w x y}; ## \type Canvas, TclNumber, TclNumber 00178 private method edgeDrag {w x y}; ## \type Canvas, TclNumber, TclNumber 00179 private method edgeDragPan {w x y}; ## \type Canvas, TclNumber, TclNumber 00180 private method edgeMoveCancel {w}; ## \type Canvas 00181 private method fixCoords {w x y}; ## \type Canvas, TclNumber, TclNumber 00182 private method labelClick {w}; ## \type Canvas 00183 private method labelRightClick {w}; ## \type Canvas 00184 private method labelSelect {l i label}; ## \type TclString, TclNumber, TclString 00185 private method makeUserInterface {w}; ## \type Canvas 00186 private method moveEdge {canvas x1 y1 x2 y2}; ## \type Canvas, TclNumber, TclNumber, TclNumber, TclNumber 00187 private method moveLabel {canvas label_id x1 y1 x2 y2}; ## \type Canvas, TclString, TclNumber, TclNumber, TclNumber, TclNumber 00188 private method multiCanvas {args}; ## \type TclList 00189 private method multiMark {x y}; ## \type TclNumber, TclNumber 00190 private method multiDragto {x y}; ## \type TclNumber, TclNumber 00191 private method noCrossing {id bindings}; ## \type TclString, TclList 00192 private method paintTabs {} 00193 private method reDrawLevel {level}; ## \type TclString 00194 private method registerItems {level}; ## \type TclString 00195 private method rgValue {score}; ## \type TclNumber 00196 private method showPopMenu {w x y items}; ## \type Canvas, TclNumber, TclNumber, TclList 00197 private method violaBrowse {mode xcoord ycoord}; ## \type TclString, TclNumber, TclNumber 00198 private method pop_constraint {x y X Y}; ## \type TclNumber, TclNumber, TclNumber, TclNumber 00199 private method getAlternativeLexemes {w i} ; ## \type Canvas, TclNumber 00200 private method wordClick {w}; ## \type Canvas 00201 private method wordMiddleClick {w}; ## \type Canvas 00202 private method wordRightClick {w}; ## \type Canvas 00203 private method wordEnter {w}; ## \type Canvas 00204 private method wordLeave {w}; ## \type Canvas 00205 private method wordSelect {w from lexeme}; ## \type Canvas, TclNumber, LexemNode 00206 private method optimizeWord {t}; ## \type TclNumber 00207 private method compareLexeme {a b}; ## \type LexiconItem, LexiconItem 00208 private method closestNode {w x y}; ## \type Canvas, TclNumber, TclNumber 00209 private method itemVisible {w i}; ##\type Canvas, TclNumber 00210 private method centerOnItem {w i}; ##\type Canvas, TclNumber 00211 private method mouseScrollUp {w}; ## \type Canvas 00212 private method mouseScrollDown {w}; ## \type Canvas 00213 00214 00215 private method kb_select_word {w k a}; ## \type Canvas, TclWidget, TclKeyBinding 00216 00217 private method kb_select_edge {w k a}; ## \type Canvas, TclWidget, TclKeyBinding 00218 private method kb_change_edge {w k a}; ## \type Canvas, TclWidget, TclKeyBinding 00219 private method kb_select_label {w k a}; ## \type Canvas, TclWidget, TclKeyBinding 00220 private method kb_change_label {w k a}; ## \type Canvas, TclWidget, TclKeyBinding 00221 private method kb_select_lexeme {w k a}; ## \type Canvas, TclWidget, TclKeyBinding 00222 private method kb_change_lexeme {w k a}; ## \type Canvas, TclWidget, TclKeyBinding 00223 00224 }; 00225 00226 ## ---------------------------------------------------------------------------- 00227 ## constructor 00228 ## ---------------------------------------------------------------------------- 00229 body ParseTree::constructor {p vp args} { 00230 00231 set _parse $p 00232 set _visparses $vp 00233 00234 ## instantiating command-history-object 00235 set _commandHistory [CommandHistory $this.commandHistory] 00236 00237 00238 set levels [$_parse getLevels] 00239 foreach level $levels { 00240 set _isDrawn($level) 0 00241 } 00242 00243 # split pane 00244 itk_component add pane { 00245 iwidgets::panedwindow $itk_interior.pane \ 00246 -height 10c -width 10c -orient horizontal 00247 } {} 00248 set pane $itk_component(pane) 00249 $pane add "Parse" 00250 set pane1 [$pane childsite "Parse"] 00251 $pane reset 00252 00253 if {![$_parse isAbstract]} { 00254 $pane add "Conflicts" 00255 set pane2 [$pane childsite "Conflicts"] 00256 } 00257 00258 # tabular containing the levels 00259 itk_component add tbn { 00260 iwidgets::Tabnotebook $pane1.tbn 00261 } {} 00262 00263 if {![$_parse isAbstract]} { 00264 00265 # conflicts 00266 itk_component add conflicts { 00267 MyTable $pane2.conflicts \ 00268 -exportselection 0 \ 00269 -cols 6 \ 00270 -state disabled \ 00271 -colstretchmode unset \ 00272 -selecttype row \ 00273 -font {Helvetica -12 bold} \ 00274 -background gray90 \ 00275 -titlerows 0 \ 00276 -outerborderwidth 1 00277 } {} 00278 bind [$itk_component(conflicts) component table] <ButtonPress-1> \ 00279 [code $this violaBrowse 1 %x %y] 00280 bind [$itk_component(conflicts) component table] <ButtonPress-2> \ 00281 [code "$this pop_constraint %x %y %X %Y; break"] 00282 bind [$itk_component(conflicts) component table] <ButtonPress-3> \ 00283 [code $this violaBrowse 2 %x %y] 00284 } 00285 00286 # popup menu 00287 itk_component add popmenu { 00288 menu $itk_interior.popmenu 00289 } { 00290 keep -background -cursor 00291 rename -borderwidth -menuborderwidth menuBorderwidth Borderwidth 00292 } 00293 00294 # build a scrolled canvas for each level 00295 set tbn $itk_component(tbn) 00296 foreach level $levels { 00297 00298 # add page 00299 set page [$tbn add \ 00300 -label $level \ 00301 -command [code $this drawLevel $level]] 00302 00303 # add canvases 00304 itk_component add $level { 00305 iwidgets::scrolledcanvas $page.cs 00306 } { 00307 keep -cursor -background 00308 rename -relief -levelrelief levelRelief Relief 00309 rename -borderwidth -levelborderwidth levelBorderwidth Borderwidth 00310 } 00311 00312 # advise the horizontal scrolling commands 00313 # so that each scrollbar scrolls all levels. 00314 set hbar [$itk_component($level) component horizsb] 00315 $hbar configure -command [code $this multiCanvas xview] 00316 00317 # fast scanning 00318 bind [$itk_component($level) childsite] <ButtonPress-2> [code $this multiMark %x %y] 00319 bind [$itk_component($level) childsite] <B2-Motion> [code $this multiDragto %x %y] 00320 00321 pack $itk_component($level) -fill both -side top -expand 1 00322 set _levelOfCanvas([$itk_component($level) childsite]) $level 00323 00324 } 00325 00326 # packing 00327 if {[$_parse isAbstract]} { 00328 pack $pane $pane1 $tbn -expand 1 -fill both 00329 } else { 00330 pack $pane $pane1 $pane2 $tbn -expand 1 -fill both 00331 } 00332 if {! [$p isAbstract]} { 00333 pack $itk_component(conflicts) -expand 1 -fill both 00334 } 00335 00336 # initialize 00337 eval itk_initialize $args 00338 00339 drawViolas 00340 paintTabs 00341 00342 # view main level initially 00343 set mainlevel [mainlevelname] 00344 set index [lsearch [$_parse getLevels] $mainlevel] 00345 if {$index == -1} { 00346 $tbn view 0 00347 } else { 00348 $tbn view $index 00349 } 00350 if {![$_parse isAbstract]} { 00351 $pane fraction 80 20 00352 } 00353 } 00354 00355 00356 ## ---------------------------------------------------------------------- 00357 ## destructor 00358 ## ---------------------------------------------------------------------- 00359 body ParseTree::destructor {} { 00360 delete object $_commandHistory 00361 } 00362 00363 00364 00365 ## ---------------------------------------------------------------------------- 00366 ## part of the initialization process. 00367 ## ---------------------------------------------------------------------------- 00368 body ParseTree::makeUserInterface {w} { 00369 00370 # touching a word pops up a tooltip giving its description 00371 $w bind word <Any-Enter> [code $this wordEnter %W ] 00372 $w bind word <Any-Leave> [code $this wordLeave %W ] 00373 00374 # clicking on a word shows its menu of alternatives 00375 $w bind word <ButtonPress-1> [code $this wordClick %W] 00376 $w bind word <ButtonPress-2> [code $this wordMiddleClick %W] 00377 $w bind word <ButtonPress-3> [code $this wordRightClick %W] 00378 00379 # touching a label highlights it 00380 $w bind label <Any-Enter> [code $this allEnter %W ] 00381 $w bind label <Any-Leave> [code $this allLeave %W ] 00382 00383 # clicking on a label shows its menu of alternatives 00384 $w bind label <ButtonPress-1> [code $this labelClick %W] 00385 $w bind label <ButtonPress-3> [code $this labelRightClick %W] 00386 00387 # touching an edge highlights it 00388 $w bind edge <Any-Enter> [code $this edgeEnter %W ] 00389 $w bind edge <Any-Leave> [code $this edgeLeave %W ] 00390 00391 # middle clicking on an edge shows its label menu 00392 $w bind edge <ButtonPress-2> [code $this labelClick %W] 00393 00394 # dragging an edge moves it around 00395 $w bind edge <ButtonPress-1> [code $this edgeClick %W %x %y] 00396 $w bind edge <B1-Motion> [code $this edgeDrag %W %x %y] 00397 $w bind edge <ButtonRelease-1> [code $this edgeDrop %W %x %y] 00398 00399 # right clicking an edge redirects it automatically 00400 $w bind edge <ButtonPress-3> [code $this edgeRightClick %W] 00401 $w bind arc <ButtonPress-3> [code $this arcRightClick %W] 00402 00403 # clicking on the canvas pretends the nearest edge was clicked 00404 bind $w <ButtonPress-1> [code $this canvasClick %W %x %y] 00405 bind $w <B1-Motion> [code $this edgeDrag %W %x %y] 00406 bind $w <B1-B2-Motion> [code $this edgeDragPan %W %x %y] 00407 bind $w <ButtonRelease-1> [code $this edgeDrop %W %x %y] 00408 00409 # typing ESC cancels an edge move action 00410 bind $w <Escape> [code $this edgeMoveCancel %W] 00411 00412 # movement keys select a word to manipulate 00413 bind $w <Left> [code $this kb_select_word %W %A %K] 00414 bind $w <Right> [code $this kb_select_word %W %A %K] 00415 bind $w <Up> [code $this kb_select_word %W %A %K] 00416 bind $w <Down> [code $this kb_select_word %W %A %K] 00417 00418 # Shift combinations change subordinations 00419 bind $w <Shift-Left> [code $this kb_select_edge %W %A %K] 00420 bind $w <Shift-Right> [code $this kb_select_edge %W %A %K] 00421 bind $w <Shift-Up> [code $this kb_select_edge %W %A %K] 00422 bind $w <Shift-Down> [code $this kb_select_edge %W %A %K] 00423 bind $w <Shift-Return> [code $this kb_select_edge %W %A %K] 00424 bind $w <KeyPress-Shift_L> [code $this kb_select_edge %W %A %K] 00425 bind $w <KeyPress-Shift_R> [code $this kb_select_edge %W %A %K] 00426 bind $w <KeyRelease-Shift_L> [code $this kb_change_edge %W %A %K] 00427 bind $w <KeyRelease-Shift_R> [code $this kb_change_edge %W %A %K] 00428 00429 # Control combinations change labels 00430 bind $w <Control-Up> [code $this kb_select_label %W %A %K] 00431 bind $w <Control-Down> [code $this kb_select_label %W %A %K] 00432 bind $w <Control-Home> [code $this kb_select_label %W %A %K] 00433 bind $w <Control-End> [code $this kb_select_label %W %A %K] 00434 bind $w <Control-Return> [code $this kb_select_label %W %A %K] 00435 bind $w <KeyPress-Control_L> [code $this kb_select_label %W %A %K] 00436 bind $w <KeyPress-Control_R> [code $this kb_select_label %W %A %K] 00437 bind $w <KeyRelease-Control_L> [code $this kb_change_label %W %A %K] 00438 bind $w <KeyRelease-Control_R> [code $this kb_change_label %W %A %K] 00439 00440 # Alt combinations change lexemes 00441 bind $w <Alt-Up> [code $this kb_select_lexeme %W %A %K] 00442 bind $w <Alt-Down> [code $this kb_select_lexeme %W %A %K] 00443 bind $w <Alt-Home> [code $this kb_select_lexeme %W %A %K] 00444 bind $w <Alt-End> [code $this kb_select_lexeme %W %A %K] 00445 bind $w <Alt-Return> [code $this kb_select_lexeme %W %A %K] 00446 bind $w <KeyPress-Alt_L> [code $this kb_select_lexeme %W %A %K] 00447 bind $w <KeyPress-Alt_R> [code $this kb_select_lexeme %W %A %K] 00448 bind $w <KeyRelease-Alt_L> [code $this kb_change_lexeme %W %A %K] 00449 bind $w <KeyRelease-Alt_R> [code $this kb_change_lexeme %W %A %K] 00450 00451 bind $w <ButtonPress-4> [code $this mouseScrollDown %W] 00452 bind $w <ButtonPress-5> [code $this mouseScrollUp %W] 00453 00454 } 00455 00456 00457 ## ---------------------------------------------------------------------------- 00458 ## command bound to word middle click. 00459 ## ---------------------------------------------------------------------------- 00460 body ParseTree::wordMiddleClick {w } { 00461 set level $_levelOfCanvas($w) 00462 set _mouseItem [$w find withtag current] 00463 set timepointId $_timepointOfId($level,$_mouseItem) 00464 scan $timepointId "%i%c%i" wordposition useless1 useless2 00465 set item [$_parse getValue $wordposition] 00466 00467 # Format the item for better display in a balloon. 00468 regsub -all {,} $item ",\n" item 00469 00470 set level 0 00471 set lines [split $item "\n"] 00472 set max 0 00473 foreach line $lines { 00474 regsub -all "^ *" $line "" line 00475 set l [string length $line] 00476 if {$l > $max} { set max $l } 00477 } 00478 set text "" 00479 set nrlines 0 00480 foreach line $lines { 00481 regsub -all "^ *" $line "" line 00482 if {"" == $line} continue 00483 00484 if {[regexp {\]} $line]} { incr level -1 } 00485 set indent [string repeat " " $level] 00486 set line "$indent$line" 00487 set l [string length $line] 00488 if {"" != $text} { append text "\n" } 00489 append text "$line" 00490 incr nrlines 00491 if {[regexp {\[} $line]} { incr level } 00492 } 00493 00494 scan [$w bbox current] "%f %f %f %f" x1 y1 x2 y2 00495 set wordheight [expr $y2 - $y1] 00496 00497 scan [$w coords current] "%f %f %f %f" x1 y1 x2 y2 00498 scan [canvasToScreen $w $x1 $y1] "%d %d" x y 00499 .cdgmain balloon on $x [expr 5+ int($y + $wordheight)] $text 00500 00501 } 00502 00503 ## ---------------------------------------------------------------------------- 00504 ## command bound to Enter-event. 00505 ## ---------------------------------------------------------------------------- 00506 body ParseTree::wordEnter {w } { 00507 00508 allEnter $w 00509 set level $_levelOfCanvas($w) 00510 set _mouseItem [$w find withtag current] 00511 set timepointId $_timepointOfId($level,$_mouseItem) 00512 scan $timepointId "%i%c%i" wordposition useless1 useless2 00513 set item [$_parse getLexiconItem $wordposition] 00514 if {"NULL" != $item} { 00515 set text [LexiconItemStruct_description_get $item] 00516 scan [$w bbox current] "%f %f %f %f" x1 y1 x2 y2 00517 set wordheight [expr $y2 - $y1] 00518 scan [$w coords current] "%f %f %f %f" x1 y1 x2 y2 00519 scan [canvasToScreen $w $x1 $y1] "%d %d" x y 00520 .cdgmain balloon on $x [expr 5+ int($y + $wordheight)] $text 00521 } 00522 } 00523 00524 ## ---------------------------------------------------------------------------- 00525 ## command bound to Leave-event. 00526 ## ---------------------------------------------------------------------------- 00527 body ParseTree::wordLeave {w} { 00528 allLeave $w 00529 .cdgmain balloon off 00530 } 00531 00532 ## ---------------------------------------------------------------------------- 00533 ## command bound to Enter-event 00534 ## ---------------------------------------------------------------------------- 00535 body ParseTree::allEnter {w} { 00536 00537 # undo all previous highlightings, no matter how they arose 00538 $w itemconfigure edge -fill $itk_option(-edgecolor) 00539 $w itemconfigure node -fill $itk_option(-nodecolor) 00540 $w itemconfigure word -fill $itk_option(-wordcolor) 00541 00542 # highlight the item touched by the mouse 00543 $w itemconfigure current -fill $itk_option(-highlightcolor) 00544 } 00545 00546 ## ---------------------------------------------------------------------------- 00547 ## command bound to Leave-event 00548 ## ---------------------------------------------------------------------------- 00549 body ParseTree::allLeave {w} { 00550 if {$_oldColor == ""} { 00551 set _oldColor black 00552 } 00553 $w itemconfigure current -fill $_oldColor 00554 set _oldColor "" 00555 } 00556 00557 ## ---------------------------------------------------------------------- 00558 ## Return the label that goes with $edge. 00559 ## ---------------------------------------------------------------------- 00560 body ParseTree::labelOfEdge {w edge} { 00561 00562 set level $_levelOfCanvas($w) 00563 set t $_timepointOfId($level,$edge) 00564 foreach i $_itemsOfTimepoint($level,$t) { 00565 if {[lsearch -exact [$w gettags $i] "label"]>=0} { 00566 return $i 00567 } 00568 } 00569 return "" 00570 } 00571 00572 ## ---------------------------------------------------------------------- 00573 ## Return the word widget at timepoint $t on canvas $w. 00574 ## ---------------------------------------------------------------------- 00575 body ParseTree::wordOfTimepoint {w t} { 00576 set level $_levelOfCanvas($w) 00577 foreach word $_itemsOfTimepoint($level,$t) { 00578 set tags [$w gettags $word] 00579 if {[regexp "word" $tags]} { 00580 return $word 00581 } 00582 } 00583 } 00584 00585 ## ---------------------------------------------------------------------- 00586 ## Return the edge widget at timepoint $t on canvas $w. 00587 ## ---------------------------------------------------------------------- 00588 body ParseTree::edgeOfTimepoint {w t} { 00589 00590 set level $_levelOfCanvas($w) 00591 foreach edge $_itemsOfTimepoint($level,$t) { 00592 set tags [$w gettags $edge] 00593 if {[regexp "edge" $tags]} { 00594 return $edge 00595 } 00596 } 00597 } 00598 00599 ## ---------------------------------------------------------------------- 00600 ## Return the node widget at timepoint $t on canvas $w. 00601 ## 00602 ## Note that for t == -1, there can be several candidates on the canvas, 00603 ## and we select the one that is closest to the end of edge $e 00604 ## to avoid hectic scrolling. 00605 ## ---------------------------------------------------------------------- 00606 body ParseTree::nodeOfTimepoint {w e t} { 00607 00608 set level $_levelOfCanvas($w) 00609 if {-1 != $t} { 00610 foreach node $_itemsOfTimepoint($level,$t) { 00611 set tags [$w gettags $node] 00612 if {[regexp "node" $tags]} { 00613 return $node 00614 } 00615 } 00616 } else { 00617 scan [$w coords $e] "%f %f %f %f" ex ey foo bar 00618 set record 99999 00619 set result "" 00620 foreach item $_itemsOfTimepoint($level,$t) { 00621 set tags [$w gettags $item] 00622 if {[regexp "node" $tags]} { 00623 scan [$w coords $item] "%f %f" x y 00624 set distance \ 00625 [expr sqrt(($x - $ex) * ($x - $ex) + ($y - $ey) * ($y - $ey))] 00626 if {$distance < $record} { 00627 set record $distance 00628 set result $item 00629 } 00630 } 00631 } 00632 return $result 00633 } 00634 } 00635 00636 ## ---------------------------------------------------------------------------- 00637 ## Executed when an edge is touched. 00638 ## 00639 ## This is different from allEnter because touching an edge should 00640 ## also highlight its label. 00641 ## ---------------------------------------------------------------------------- 00642 body ParseTree::edgeEnter {w} { 00643 00644 # paint edge 00645 allEnter $w 00646 00647 # paint label 00648 set edge [$w find withtag current] 00649 set label [labelOfEdge $w $edge] 00650 $w itemconfigure $label -fill $itk_option(-highlightcolor) 00651 00652 } 00653 00654 ## ---------------------------------------------------------------------------- 00655 ## Executed when an edge is left by the mouse pointer. 00656 ## ---------------------------------------------------------------------------- 00657 body ParseTree::edgeLeave {w} { 00658 00659 # paint edge 00660 allLeave $w 00661 00662 # paint label 00663 set level $_levelOfCanvas($w) 00664 set edge [$w find withtag current] 00665 set t $_timepointOfId($level,$edge) 00666 set label [labelOfEdge $w $edge] 00667 $w itemconfigure $label -fill $itk_option(-labelcolor) 00668 00669 } 00670 00671 00672 ## ---------------------------------------------------------------------------- 00673 ## Command bound to conflict middle click. 00674 ## ---------------------------------------------------------------------------- 00675 body ParseTree::pop_constraint {x y X Y} { 00676 00677 set index [$itk_component(conflicts) index @$x,$y] 00678 scan $index "%d,%d" no col 00679 if {$no < 0} return 00680 set conflict [lindex [$_parse getViolations] $no] 00681 set id [lindex $conflict 0] 00682 set c [findConstraint $id] 00683 if {$c != "NULL"} { 00684 set s [formatConstraint $c] 00685 scan [$_visparses geometry] \ 00686 "%dx%d+%d+%d" width height xoff yoff 00687 set mx [expr int($xoff + 0.5 * $height)] 00688 set my [expr int($yoff + 0.5 * $width)] 00689 .cdgmain balloon on $mx $my $s now 00690 } 00691 } 00692 00693 ## ---------------------------------------------------------------------------- 00694 ## command bound to violation browsing. 00695 ## ---------------------------------------------------------------------------- 00696 body ParseTree::violaBrowse {mode xcoord ycoord} { 00697 00698 # get the violation 00699 set index [$itk_component(conflicts) index @$xcoord,$ycoord] 00700 00701 scan $index "%d,%d" viola_no col 00702 if {$viola_no < 0} { 00703 return 00704 } 00705 set viola [lindex [$_parse getViolations] $viola_no] 00706 set score [lindex $viola 3] 00707 set color [rgValue $score] 00708 set bId [lindex $viola $mode] 00709 if {$bId < 0} { 00710 return 00711 } 00712 set binding [$_parse getBindingById $bId] 00713 00714 # highlight 00715 foreach level [$_parse getLevels] { 00716 set canvas [$itk_component($level) childsite] 00717 $canvas itemconfigure arc -fill $itk_option(-edgecolor) 00718 $canvas itemconfigure edge -fill $itk_option(-edgecolor) 00719 $canvas itemconfigure word -fill $itk_option(-wordcolor) 00720 $canvas itemconfigure label -fill $itk_option(-labelcolor) 00721 } 00722 00723 foreach {no level} $_itemsOfViolation($viola_no) { 00724 drawLevel $level 00725 set canvas [$itk_component($level) childsite] 00726 $canvas itemconfigure $no -fill $color 00727 } 00728 00729 # set the selection on right click 00730 $itk_component(conflicts) selection clear all 00731 $itk_component(conflicts) selection set $viola_no,0 00732 00733 # focus the violation 00734 scan $binding "%s %s %s %s %s" modifier_id modifiee_id label bindNo level 00735 $itk_component(tbn) view [lsearch [$_parse getLevels] $level] 00736 set canvas $itk_component($level) 00737 00738 if {$mode == 1} { 00739 set ids [lrange $_itemsOfViolation($viola_no) 0 7] 00740 } else { 00741 set ids [lrange $_itemsOfViolation($viola_no) 8 end] 00742 } 00743 00744 set bbox [eval $canvas bbox $ids] 00745 set minx [lindex $bbox 0] 00746 set miny [lindex $bbox 1] 00747 if {$minx == ""} { 00748 set minx 0 00749 set miny 0 00750 } 00751 00752 set bbox [$canvas bbox all] 00753 set maxx [lindex $bbox 2] 00754 set maxy [lindex $bbox 3] 00755 set fraqx [expr $minx / ( 0.0 + $maxx ) - 0.01] 00756 set fraqy [expr $miny / ( 0.0 + $maxy ) - 0.1] 00757 00758 # don't scroll if there is nothing to scroll 00759 if {"[$canvas xview]" != "0 1"} { 00760 multiCanvas xview moveto $fraqx 00761 } 00762 if {"[$canvas yview]" != "0 1"} { 00763 multiCanvas yview moveto $fraqy 00764 } 00765 } 00766 00767 ## ---------------------------------------------------------------------------- 00768 ## compare two pointers to LexemeNode by their description. 00769 ## ---------------------------------------------------------------------------- 00770 body ParseTree::compareLexeme {a b} { 00771 set x [LexiconItemStruct_description_get [LexemNodeStruct_lexem_get $a]] 00772 set y [LexiconItemStruct_description_get [LexemNodeStruct_lexem_get $b]] 00773 return [string compare $x $y] 00774 00775 } 00776 00777 ## ---------------------------------------------------------------------- 00778 ## Find lexemes that can be exchanged for $item. 00779 ## 00780 ## The return value is a list of lists that each contain a descriptive 00781 ## string and the fitting wordSelect callback. 00782 ## ---------------------------------------------------------------------- 00783 body ParseTree::getAlternativeLexemes {w item} { 00784 00785 # collect needed data 00786 set lexemes [$_parse getLexemes] 00787 if {"" == $lexemes} return "" 00788 00789 set level $_levelOfCanvas($w) 00790 set timepoint $_timepointOfId($level,$item) 00791 set word [$_parse getWord $timepoint] 00792 set from [WordStruct_from_get $word] 00793 set to [WordStruct_to_get $word] 00794 00795 set items "" 00796 foreach l [lsort -command compareLexeme $lexemes] { 00797 set le [LexemNodeStruct_lexem_get $l] 00798 set d [LexiconItemStruct_description_get $le] 00799 00800 # require exactly the same timespan 00801 set a [LexemNodeStruct_arc_get $l] 00802 set f [ArcStruct_from_get $a] 00803 set t [ArcStruct_to_get $a] 00804 if {$f != $from} continue 00805 if {$t != $to} continue 00806 lappend items [list $d [code $this wordSelect $w $timepoint $l]] 00807 } 00808 00809 return $items 00810 00811 } 00812 00813 ## ---------------------------------------------------------------------------- 00814 ## show menu of available lexicon-entries when clicking on a word. 00815 ## ---------------------------------------------------------------------------- 00816 body ParseTree::wordClick {w} { 00817 00818 .cdgmain balloon off 00819 00820 # calculate position of the menu 00821 scan [$w bbox current] "%d %d %d %d" x1 y1 x2 y2 00822 00823 set _mouseItem [$w find withtag current] 00824 set items [getAlternativeLexemes $w $_mouseItem] 00825 if {"" == $items} return 00826 00827 showPopMenu $w $x1 $y2 $items 00828 } 00829 00830 ## ---------------------------------------------------------------------------- 00831 ## action taking place when a lexeme is chosen from a wordlist. 00832 ## ---------------------------------------------------------------------------- 00833 body ParseTree::wordSelect {w from lexeme} { 00834 00835 set oldDescription [$_parse getCurrentReading $from] 00836 00837 set le [LexemNodeStruct_lexem_get $lexeme] 00838 set description [LexiconItemStruct_description_get $le] 00839 set reading [LexiconItemStruct_word_get $le] 00840 $_parse swapWord $from $description 00841 00842 ## Saving action to history 00843 if { $description != $oldDescription} { 00844 $_commandHistory add [code $this undoLexeme $from $description]\ 00845 [code $this undoLexeme $from $oldDescription] 00846 } 00847 00848 drawViolas 00849 paintTabs 00850 00851 # changing a different lexeme may change the reading, 00852 # therefore we must redraw the word on the canvas 00853 set word [wordOfTimepoint $w $from] 00854 $w itemconfigure $word -text $reading 00855 00856 } 00857 00858 00859 ## ---------------------------------------------------------------------------- 00860 ## show menu of available level-labels when clicking on a label. 00861 ## ---------------------------------------------------------------------------- 00862 body ParseTree::labelClick {w} { 00863 scan [$w bbox current] "%d %d %d %d" x1 y1 x2 y2 00864 set level $_levelOfCanvas($w) 00865 set _mouseItem [$w find withtag current] 00866 set timepoint $_timepointOfId($level,$_mouseItem) 00867 00868 # The current item may not actually be the label in question, 00869 # but its corresponding edge if it received a middle click. 00870 # Pretend that the event occurred at the label. 00871 if {[regexp "edge" [$w gettags $_mouseItem]]} { 00872 set _mouseItem [labelOfEdge $w $timepoint] 00873 } 00874 00875 set _mouseBinding [$_parse getBindingAt $level $timepoint] 00876 set labels [.cdgmain levels getLabels $level] 00877 if {$labels == ""} { 00878 set labels [$_parse getLabels] 00879 } 00880 00881 set items "" 00882 foreach label [lsort $labels] { 00883 lappend items [list $label [code $this labelSelect $level $timepoint $label]] 00884 } 00885 showPopMenu $w $x1 $y2 $items 00886 00887 } 00888 00889 ## ---------------------------------------------------------------------------- 00890 ## Auto-correct the current label 00891 ## ---------------------------------------------------------------------------- 00892 body ParseTree::labelRightClick {w} { 00893 00894 set level $_levelOfCanvas($w) 00895 set canvas [$itk_component($level) childsite] 00896 set _mouseItem [$w find withtag current] 00897 set timepoint $_timepointOfId($level,$_mouseItem) 00898 set label [$_parse optimizeLabel $level $timepoint] 00899 set _mouseBinding [$_parse getBindingAt $level $timepoint] 00900 00901 if {"NULL" == "$label"} return; 00902 labelSelect $level $timepoint $label 00903 00904 } 00905 00906 ## ---------------------------------------------------------------------------- 00907 ## Auto-correct the current subordination 00908 ## ---------------------------------------------------------------------------- 00909 body ParseTree::edgeRightClick {w} { 00910 00911 set level $_levelOfCanvas($w) 00912 set canvas [$itk_component($level) childsite] 00913 set _mouseItem [$w find withtag current] 00914 set modifier $_timepointOfId($level,$_mouseItem) 00915 set oldregent [$_parse getModifiee $level $modifier] 00916 set regent [$_parse optimizeStructure $level $modifier] 00917 00918 if {$regent != $oldregent} { 00919 00920 $_parse shiftEdge $level $modifier $regent 00921 reDrawLevel $level 00922 drawArcs 00923 drawViolas 00924 paintTabs 00925 00926 $_commandHistory add \ 00927 [code "$this undoEdge $modifier $regent $level"] \ 00928 [code "$this undoEdge $modifier $oldregent $level"] 00929 } 00930 00931 } 00932 00933 00934 ## ---------------------------------------------------------------------------- 00935 ## Auto-correct the current word 00936 ## ---------------------------------------------------------------------------- 00937 body ParseTree::wordRightClick {w} { 00938 00939 # remove tooltip about to be obsoleted 00940 .cdgmain balloon off 00941 00942 # collect params 00943 scan [$w bbox current] "%d %d %d %d" x1 y1 x2 y2 00944 set level $_levelOfCanvas($w) 00945 set canvas [$itk_component($level) childsite] 00946 set _mouseItem [$w find withtag current] 00947 set timepoint $_timepointOfId($level,$_mouseItem) 00948 00949 set l [optimizeWord $timepoint] 00950 00951 wordSelect $w $timepoint $l 00952 00953 set wordheight [expr $y2 - $y1] 00954 scan [canvasToScreen $w $x1 $y1] "%d %d" x y 00955 set li [LexemNodeStruct_lexem_get $l] 00956 set d [LexiconItemStruct_description_get $li] 00957 .cdgmain balloon on $x [expr 5+ int($y + $wordheight)] $d 00958 00959 } 00960 00961 ## ---------------------------------------------------------------------- 00962 ## Wrapper for Parse::optimizeWord. 00963 ## ---------------------------------------------------------------------- 00964 body ParseTree::optimizeWord {t} { 00965 00966 # find description of best word 00967 set result [$_parse optimizeWord $t] 00968 if {"NULL" != "$result"} { 00969 00970 # find corresponding LexemNode 00971 set word [$_parse getWord $t] 00972 set from [WordStruct_from_get $word] 00973 set to [WordStruct_to_get $word] 00974 set lexemes [$_parse getLexemes] 00975 foreach ln [lsort -command compareLexeme $lexemes] { 00976 set li [LexemNodeStruct_lexem_get $ln] 00977 set d [LexiconItemStruct_description_get $li] 00978 set a [LexemNodeStruct_arc_get $ln] 00979 set f [ArcStruct_from_get $a] 00980 set t [ArcStruct_to_get $a] 00981 if {$f != $from} continue 00982 if {$t != $to} continue 00983 if {![string compare $d $result]} { 00984 return $ln 00985 } 00986 } 00987 } 00988 } 00989 00990 ## ---------------------------------------------------------------------------- 00991 ## Auto-correct a non-mainlevel subordination 00992 ## ---------------------------------------------------------------------------- 00993 body ParseTree::arcRightClick {w} { 00994 00995 set arc [$w find withtag current] 00996 set level $_levelOfItem($arc) 00997 set canvas [$itk_component($level) childsite] 00998 set modifier $_timepointOfId($level,$arc) 00999 set oldregent [$_parse getModifiee $level $modifier] 01000 set regent [$_parse optimizeStructure $level $modifier] 01001 01002 if {$regent != $oldregent} { 01003 $_parse shiftEdge $level $modifier $regent 01004 reDrawLevel $level 01005 drawArcs 01006 drawViolas 01007 paintTabs 01008 01009 $_commandHistory add \ 01010 [code "$this undoEdge $modifier $regent $level"] \ 01011 [code "$this undoEdge $modifier $oldregent $level"] 01012 } 01013 } 01014 01015 01016 ## ---------------------------------------------------------------------------- 01017 ## Set the label of the edge at $timepoint on $level. 01018 ## ---------------------------------------------------------------------------- 01019 body ParseTree::labelSelect {level timepoint label} { 01020 01021 set binding [$_parse getBindingAt $level $timepoint] 01022 scan $binding "%s %s %s %s %s" \ 01023 modifier modifiee oldlabel binding_id level 01024 01025 if {$label == $oldlabel} { 01026 return 01027 } 01028 01029 $_commandHistory add [code $this undoLabel $modifier $label $level]\ 01030 [code $this undoLabel $modifier $oldlabel $level] 01031 01032 01033 set canvas [$itk_component($level) childsite] 01034 set edge [edgeOfTimepoint $canvas $timepoint] 01035 set item [labelOfEdge $canvas $edge] 01036 $canvas itemconfigure $item -text $label 01037 $_parse swapLabel $level $modifier $label 01038 01039 drawViolas 01040 paintTabs 01041 01042 } 01043 01044 01045 ## ---------------------------------------------------------------------------- 01046 ## command bound to B1-event on the canvas background. 01047 ## ---------------------------------------------------------------------------- 01048 body ParseTree::canvasClick {w x y} { 01049 01050 set cur [$w find withtag current] 01051 if {"" != $cur} return 01052 01053 scan [fixCoords $w $x $y] "%d %d" x y 01054 01055 # fond closest edge to the click 01056 set record 999999 01057 foreach e [$w find withtag edge] { 01058 scan [$w coords $e] "%f %f %f %f" cx1 cy1 cx2 cy2 01059 01060 # compute distance of edge to click 01061 set d [point_segment_distance $x $y $cx1 $cy1 $cx2 $cy2] 01062 if {$d < $record} { 01063 set record $d 01064 set theedge $e 01065 } 01066 } 01067 01068 scan [$w coords $theedge] "%f %f %f %f" x1 y1 x2 y2 01069 set _dragItem $theedge 01070 set _dragStartX $x2 01071 set _dragStartY $y2 01072 moveEdge $w $x1 $y1 $x $y 01073 set label [labelOfEdge $w $theedge] 01074 $w itemconfigure $label -fill $itk_option(-highlightcolor) 01075 } 01076 01077 ## ---------------------------------------------------------------------------- 01078 ## command bound to B1-event on an edge. 01079 ## ---------------------------------------------------------------------------- 01080 body ParseTree::edgeClick {w x y} { 01081 scan [$w coords current] "%f %f %f %f" x1 y1 x2 y2 01082 set _dragItem [$w find withtag current] 01083 set _dragStartX $x2 01084 set _dragStartY $y2 01085 01086 $w addtag undo withtag current 01087 01088 scan [fixCoords $w $x $y] "%d %d" new_x new_y 01089 01090 moveEdge $w $x1 $y1 $new_x $new_y 01091 set label [labelOfEdge $w $_dragItem] 01092 $w itemconfigure $label -fill $itk_option(-highlightcolor) 01093 } 01094 01095 01096 ## ---------------------------------------------------------------------------- 01097 ## Find closest circle on the canvas. 01098 ## 01099 ## One should think that this should be possible with a normal 01100 ## `canvas find' command, but it isn't; you can only search for the 01101 ## closest item, OR for all circles. 01102 ## ---------------------------------------------------------------------------- 01103 body ParseTree::closestNode {w x y} { 01104 01105 set result "" 01106 set items [$w find withtag node] 01107 set record 99999 01108 01109 # find coordinates of the lower end of the moving edge; 01110 # selecting this node would create a direct cycle, which look ugly 01111 # and is very likely wrong anyway. 01112 set level $_levelOfCanvas($w) 01113 set self $_timepointOfId($level,$_dragItem) 01114 foreach item $items { 01115 if { $self == $_timepointOfId($level,$item)} continue 01116 scan [$w coords $item] "%f %f" x1 y1 01117 set distance [expr sqrt(($x1 - $x) * ($x1 - $x) + ($y1 - $y) * ($y1 - $y))] 01118 if {$distance < $record} { 01119 set record $distance 01120 set result $item 01121 } 01122 } 01123 01124 return $result 01125 01126 } 01127 01128 ## ---------------------------------------------------------------------------- 01129 ## Command bound to B1-Motion-event on a edge. 01130 ## 01131 ## Moving edges around on the canvas is implemented by setting the 01132 ## private variable _dragItem to the edge that is clicked on, moving 01133 ## this edge when the mouse is dragged, and resetting the variable 01134 ## when the mouse is released. 01135 ## 01136 ## Ordinarily one would use Tcl's automatically managed canvas tag 01137 ## `current' for this; but an edge may be selected not by clicking on 01138 ## it, but by clicking on the canvas background in its vicinity, and 01139 ## Tcl is not smart enough to assign the `current' tag to an item that 01140 ## was moved under the mouse pointer after the click occurred. It also 01141 ## doesn't allow setting the `current' tag manually, so we have to 01142 ## duplicate its functionality. 01143 ## ---------------------------------------------------------------------------- 01144 body ParseTree::edgeDrag {w x y} { 01145 if {$_dragItem == ""} { 01146 return 01147 } 01148 01149 # actually move the edge 01150 scan [$w coords $_dragItem] "%f %f %f %f" x1 y1 x2 y2 01151 scan [fixCoords $w $x $y] "%d %d" new_x new_y 01152 moveEdge $w $x1 $y1 $new_x $new_y 01153 01154 # highlight the node that the edge would now snap to 01155 set releaseItem [closestNode $w $new_x $new_y] 01156 $w itemconfigure node -fill $itk_option(-nodecolor) 01157 $w itemconfigure $releaseItem -fill $itk_option(-highlightcolor) 01158 01159 set level $_levelOfCanvas($w) 01160 set t $_timepointOfId($level,$releaseItem) 01161 01162 # highlight the new regent as well 01163 set found 0 01164 $w itemconfigure word -fill $itk_option(-wordcolor) 01165 set word [wordOfTimepoint $w $t] 01166 $w itemconfigure $word -fill $itk_option(-highlightcolor) 01167 01168 } 01169 01170 01171 ## ---------------------------------------------------------------------- 01172 ## Handler for the unusual event that the user wants to pan while 01173 ## holding an edge; this is actually useful if an edge must be moved 01174 ## between two attachment points that do not fit on the canvas 01175 ## simultaneously. 01176 ## ---------------------------------------------------------------------- 01177 body ParseTree::edgeDragPan {w x y} { 01178 edgeDrag $w $x $y 01179 multiDragto $x $y 01180 } 01181 01182 01183 ## ---------------------------------------------------------------------- 01184 ## Cancel an ongoing move operation, i.e. return the edge to where it 01185 ## was before it was picked up. Completed moves are not undone, for 01186 ## that you need undo/redo. 01187 ## ---------------------------------------------------------------------- 01188 body ParseTree::edgeMoveCancel {w} { 01189 if {"" == $_dragItem} return 01190 scan [$w coords $_dragItem] "%f %f %f %f" x1 y1 x2 y2 01191 moveEdge $w $x1 $y1 $_dragStartX $_dragStartY 01192 $w itemconfigure node -fill $itk_option(-nodecolor) 01193 $w itemconfigure $_dragItem -fill $itk_option(-edgecolor) 01194 set label [labelOfEdge $w $_dragItem] 01195 $w itemconfigure $label -fill $itk_option(-labelcolor) 01196 set _dragItem "" 01197 } 01198 01199 01200 ## ---------------------------------------------------------------------------- 01201 ## command bound to B1-Release-event on a edge. 01202 ## ---------------------------------------------------------------------------- 01203 body ParseTree::edgeDrop {w x y} { 01204 if {$_dragItem == "" } return 01205 01206 set label [labelOfEdge $w $_dragItem] 01207 01208 scan [fixCoords $w $x $y] "%d %d" new_x new_y 01209 set releaseItem [closestNode $w $new_x $new_y] 01210 scan [$w coords $_dragItem] "%f %f %f %f" x1 y1 x2 y2 01211 scan [$w coords $releaseItem] "%f %f" x2 y2 01212 if {$releaseItem != "" && !($x2 == $_dragStartX && $y2 == $_dragStartY)} { 01213 01214 # this is a correct manipulation 01215 moveEdge $w $x1 $y1 [expr $x2 + 2] [expr $y2 + 2] 01216 set level $_levelOfCanvas($w) 01217 set modifier $_timepointOfId($level,$_dragItem) 01218 set modifiee $_timepointOfId($level,$releaseItem) 01219 set binding [$_parse getBindingAt $level $modifier] 01220 scan $binding "%s %s %s %s %s" modifier oldmodifiee label where level 01221 01222 set oldBinding [$_parse getBindings $level] 01223 01224 $_parse shiftEdge $level $modifier $modifiee 01225 reDrawLevel $level 01226 01227 ## if bindings changed, save commands to history 01228 if { $oldBinding != [$_parse getBindings $level]} { 01229 $_commandHistory add\ 01230 [code "$this undoEdge $modifier $modifiee $level"]\ 01231 [code "$this undoEdge $modifier $oldmodifiee $level"] 01232 } 01233 01234 # update arcs on main level if necessary 01235 drawArcs 01236 drawViolas 01237 paintTabs 01238 01239 } else { 01240 01241 moveEdge $w $x1 $y1 $_dragStartX $_dragStartY 01242 $w itemconfigure $_dragItem -fill $itk_option(-edgecolor) 01243 $w itemconfigure $label -fill $itk_option(-labelcolor) 01244 } 01245 set _dragItem "" 01246 } 01247 01248 ## ---------------------------------------------------------------------------- 01249 ## draw violations in the list. 01250 ## --------------------------------------------------------------------------- 01251 body ParseTree::drawViolas {} { 01252 01253 if {[$_parse isAbstract]} return 01254 01255 set table $itk_component(conflicts) 01256 $table configure -state normal 01257 $table clear all 01258 $table delete rows 0 [$table cget -rows] 01259 $table tag config sel -fg "" -bg "" -relief raised -bd 1 01260 $table tag config justRight -anchor e 01261 $table tag config title -anchor w -background gray90 -foreground black -relief flat 01262 $table tag col justRight 2 4 01263 $table width 0 25 1 15 2 10 4 10 01264 01265 # write the violation rows 01266 set no 0 01267 set violas [$_parse getViolations] 01268 $table configure -rows [expr [llength $violas] +1] 01269 foreach viola $violas { 01270 # build viola_text 01271 set rowString [list [lindex $viola 0]] ;# name 01272 lappend rowString [format "%4.3e" [lindex $viola 3]] ;# score 01273 set b1Id [lindex $viola 1] 01274 set b2Id [lindex $viola 2] 01275 01276 # find the corresponding binding's id: 01277 set binding [$_parse getBindingById $b1Id] 01278 scan $binding "%s %s %s %s %s" modifier_id1 modifiee_id1 label bindNo1 level1 01279 01280 set wordstruct [$_parse getWord $modifier_id1] 01281 set word1 [WordStruct_word_get $wordstruct] 01282 if {$modifiee_id1 == -1} { 01283 set word2 NIL 01284 } else { 01285 set wordstruct [$_parse getWord $modifiee_id1] 01286 set word2 [WordStruct_word_get $wordstruct] 01287 } 01288 lappend rowString "$level1:" "$word1-$word2" 01289 01290 # more work for binary violations 01291 set bindNo2 "" 01292 if {$b2Id != -1} { 01293 01294 # find the corresponding binding's id: 01295 set binding [$_parse getBindingById $b2Id] 01296 scan $binding "%s %s %s %s %s" modifier_id2 modifiee_id2 \ 01297 label bindNo2 level2 01298 set wordstruct [$_parse getWord $modifier_id2] 01299 set word1 [WordStruct_word_get $wordstruct] 01300 if {$modifiee_id2 == -1} { 01301 set word2 NIL 01302 } else { 01303 set wordstruct [$_parse getWord $modifiee_id2] 01304 set word2 [WordStruct_word_get $wordstruct] 01305 } 01306 lappend rowString "$level2:" "$word1-$word2" 01307 } 01308 01309 # draw violation into the list 01310 $table setCell row $no,0 $rowString 01311 01312 set _itemsOfViolation($no) "" 01313 incr no 01314 } 01315 01316 set levels [$_parse getLevels] 01317 foreach level $levels { 01318 registerItems $level 01319 } 01320 01321 $table configure -state disabled 01322 01323 # notify daddy 01324 $_visparses getBadness 01325 } 01326 01327 ## ---------------------------------------------------------------------------- 01328 ## draw the sentence to the canvas. 01329 ## ---------------------------------------------------------------------------- 01330 body ParseTree::drawText {canvas x y} { 01331 01332 set xx $x 01333 set level $_levelOfCanvas($canvas) 01334 01335 set vector [$_parse getWords] 01336 for {set i 0} {$i < [vectorSize $vector]} {incr i} { 01337 set wordstruct [vectorElement $vector $i] 01338 set word [WordStruct_word_get $wordstruct] 01339 set word_id [$canvas create text $xx $y \ 01340 -text $word \ 01341 -anchor nw \ 01342 -font $itk_option(-wordfont) \ 01343 -fill $itk_option(-wordcolor) \ 01344 -tags {word text}] 01345 01346 scan [$canvas bbox $word_id] "%d %d %d %d" x1 y1 x2 y2 01347 set width [expr $x2 - $x1] 01348 set _textMidPos($i) [expr $width / 2.0 + $xx] 01349 set xx [expr $xx + $width + 20] 01350 01351 # register all ids into _timepointOfId and _itemsOfTimepoint 01352 set _timepointOfId($level,$word_id) $i 01353 lappend _itemsOfTimepoint($level,$i) $word_id 01354 } 01355 } 01356 01357 ## ---------------------------------------------------------------------------- 01358 ## move an existing edge and its label to a new position. 01359 ## ---------------------------------------------------------------------------- 01360 body ParseTree::moveLabel {w label_id x1 y1 x2 y2} { 01361 set dx [expr ($x2 - $x1) / 2.0] 01362 set dy [expr ($y2 - $y1) / 2.0] 01363 01364 set best_cross 4 01365 #how bad is our best solution 01366 01367 if {$dx == 0.0 && $dy == 0.0} { 01368 $w coords $label_id $x1 $x2 01369 } else { 01370 #the search starting point - a little down the road 01371 set mx [expr $x1 + ($dx * 0.9)] 01372 set my [expr $y1 + ($dy * 0.9)] 01373 01374 if {[expr abs($dx)] > [expr abs($dy)]} { 01375 #seek along the x dimension 01376 set delta [expr $dy/$dx] 01377 if {$delta < 0.0} { 01378 set anchor1 se 01379 set anchor2 nw 01380 } else { 01381 set anchor1 sw 01382 set anchor2 ne 01383 } 01384 #preferences in worst case 01385 set best_anchor $anchor1 01386 set best_ix [expr -($dx * 0.7)] 01387 01388 $w itemconfigure $label_id -anchor $anchor1 01389 for {set ix 0} {$ix < [expr abs($dx)]} {incr ix} { 01390 #up 01391 $w coords $label_id [expr $mx + $ix] [expr $my + ($ix * $delta)] 01392 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01393 if { $cross < $best_cross} { 01394 set best_anchor $anchor1 01395 set best_ix $ix 01396 if {$cross < 3} { 01397 break 01398 } 01399 set best_cross $cross 01400 } 01401 #another anchor 01402 $w itemconfigure $label_id -anchor $anchor2 01403 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01404 if { $cross < $best_cross} { 01405 set best_anchor $anchor2 01406 set best_ix $ix 01407 if {$cross < 3} { 01408 break 01409 } 01410 set best_cross $cross 01411 } 01412 #down 01413 $w coords $label_id [expr $mx - $ix] [expr $my - ($ix * $delta)] 01414 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01415 if { $cross < $best_cross} { 01416 set best_anchor $anchor2 01417 set best_ix [expr -$ix] 01418 if {$cross < 3} { 01419 break 01420 } 01421 set best_cross $cross 01422 } 01423 #another anchor 01424 $w itemconfigure $label_id -anchor $anchor1 01425 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01426 if { $cross < $best_cross} { 01427 set best_anchor $anchor1 01428 set best_ix [expr -$ix] 01429 if {$cross < 3} { 01430 break 01431 } 01432 set best_cross $cross 01433 } 01434 } 01435 $w coords $label_id [expr $mx + $best_ix] [expr $my + ($best_ix * $delta)] 01436 $w itemconfigure $label_id -anchor $best_anchor 01437 } else { 01438 #seek allong the y dimension 01439 01440 set delta [expr $dx/$dy] 01441 if {$delta < 0} { 01442 set anchor1 se 01443 set anchor2 nw 01444 } else { 01445 set anchor1 sw 01446 set anchor2 ne 01447 } 01448 01449 set best_anchor $anchor1 01450 set best_iy [expr -($dy * 0.7)] 01451 01452 $w itemconfigure $label_id -anchor $anchor1 01453 for {set iy 0} {$iy < [expr abs($dy)]} {incr iy} { 01454 #up 01455 $w coords $label_id [expr $mx + ($iy * $delta)] [expr $my + $iy] 01456 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01457 if { $cross < $best_cross} { 01458 set best_anchor $anchor1 01459 set best_iy $iy 01460 if {$cross < 3} { 01461 break 01462 } 01463 set best_cross $cross 01464 } 01465 $w itemconfigure $label_id -anchor $anchor2 01466 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01467 if { $cross < $best_cross} { 01468 set best_anchor $anchor2 01469 set best_iy $iy 01470 if {$cross < 3} { 01471 break 01472 } 01473 set best_cross $cross 01474 } 01475 #down 01476 $w coords $label_id [expr $mx - ($iy * $delta)] [expr $my - $iy] 01477 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01478 if { $cross < $best_cross} { 01479 set best_anchor $anchor2 01480 set best_iy [expr -$iy] 01481 if {$cross < 3} { 01482 break 01483 } 01484 set best_cross $cross 01485 } 01486 $w itemconfigure $label_id -anchor $anchor1 01487 set cross [llength [eval $w find overlap [$w bbox $label_id]]] 01488 if { $cross < $best_cross} { 01489 set best_anchor $anchor1 01490 set best_iy [expr -$iy] 01491 if {$cross < 3} { 01492 break 01493 } 01494 set best_cross $cross 01495 } 01496 } 01497 #set the best solution 01498 $w coords $label_id [expr $mx + ($best_iy * $delta)] [expr $my + $best_iy] 01499 $w itemconfigure $label_id -anchor $best_anchor 01500 } 01501 } 01502 } 01503 01504 01505 ## ---------------------------------------------------------------------------- 01506 ## move an existing edge and its label to a new position. 01507 ## ---------------------------------------------------------------------------- 01508 body ParseTree::moveEdge {w x1 y1 x2 y2} { 01509 $w coords $_dragItem $x1 $y1 $x2 $y2 01510 $w itemconfigure $_dragItem -fill $itk_option(-highlightcolor) 01511 set label [labelOfEdge $w $_dragItem] 01512 moveLabel $w $label $x1 $y1 $x2 $y2 01513 } 01514 01515 ## ---------------------------------------------------------------------------- 01516 ## checks if all nodes between id1 and id2 are modifier of id2. 01517 ## ---------------------------------------------------------------------------- 01518 body ParseTree::allSybillings {id1 id2 level} { 01519 set children [$_parse getModifiers $level $id2] 01520 01521 if {$id2 < $id1} { 01522 set tmp $id1 01523 set id1 $id2 01524 set id2 $tmp 01525 } 01526 01527 for {set i [expr $id1 + 1]} {$i < $id2} {incr i} { 01528 if {[lsearch -exact $children $i] < 0} { 01529 return 0 01530 } 01531 } 01532 01533 return 1 01534 } 01535 01536 ## ---------------------------------------------------------------------------- 01537 ## seeks an edge crossing with this id. 01538 ## ---------------------------------------------------------------------------- 01539 body ParseTree::noCrossing {id bindings} { 01540 foreach binding $bindings { 01541 set modifiee_id [lindex $binding 1] 01542 if {$modifiee_id == -1} continue 01543 set modifier_id [lindex $binding 0] 01544 if {$modifiee_id > $id && $modifier_id < $id} { 01545 return 0 } 01546 if {$modifier_id > $id && $modifiee_id < $id} { 01547 return 0 } 01548 } 01549 return 1 01550 } 01551 01552 01553 ## ---------------------------------------------------------------------------- 01554 ## force draw a specified level on its page. 01555 ## ---------------------------------------------------------------------------- 01556 body ParseTree::reDrawLevel {level} { 01557 set _isDrawn($level) 0 01558 drawLevel $level 01559 } 01560 01561 ## ---------------------------------------------------------------------------- 01562 ## draw a specified level on its page. 01563 ## ---------------------------------------------------------------------------- 01564 body ParseTree::drawLevel {level} { 01565 01566 # skip already drawn levels 01567 if { $_isDrawn($level) } { 01568 return 01569 } else { 01570 set _isDrawn($level) 1 01571 } 01572 01573 # delete old drawing 01574 set canvas [$itk_component($level) childsite] 01575 01576 $canvas delete all 01577 makeUserInterface $canvas 01578 set lapsTime [clock clicks -milliseconds] 01579 set heightInLinks [$_parse getHeight $level] 01580 set heightInPixels [expr $heightInLinks * 40.0 + 40] 01581 set lowerrow 0 01582 set middlerow -20 01583 set upperrow -60 01584 01585 # ensure that _itemsOfTimepoint($level,-1) is defined 01586 # so that nodeOfTimepoint will not choke on cyclical trees. 01587 # (Isn't there a way of testing whether $a($s) is defined 01588 # before accessing it??) 01589 set _itemsOfTimepoint($level,-1) "" 01590 01591 # draw the words 01592 drawText $canvas 10 [expr $heightInPixels + 5.0] 01593 01594 # draw bindings of level 01595 set bindings [$_parse getBindings $level] 01596 01597 foreach binding $bindings { 01598 scan $binding "%s %s %s %s %s" \ 01599 modifier_id modifiee_id label dummy dummy 01600 set label [join $label] 01601 01602 if {$heightInLinks == -1} { 01603 # draw cyclical structures as bipartite graph 01604 01605 set modifier_x $_textMidPos($modifier_id) 01606 set modifier_y $lowerrow 01607 01608 # draw lower node 01609 set node_id [$canvas create oval \ 01610 [expr $modifier_x-2] [expr $modifier_y-2] \ 01611 [expr $modifier_x+2] [expr $modifier_y+2] \ 01612 -fill $itk_option(-nodecolor) \ 01613 -tags node] 01614 $canvas raise $node_id 01615 set _timepointOfId($level,$node_id) $modifier_id 01616 lappend _itemsOfTimepoint($level,$modifier_id) $node_id 01617 01618 if {$modifiee_id == -1 } { 01619 01620 # draw NIL node 01621 set nil_x $modifier_x 01622 set nil_y $middlerow 01623 set node_id [$canvas create oval \ 01624 [expr $nil_x-2] [expr $nil_y-2] \ 01625 [expr $nil_x+2] [expr $nil_y+2] \ 01626 -fill $itk_option(-nodecolor) \ 01627 -tags node ] 01628 $canvas raise $node_id 01629 set _timepointOfId($level,$node_id) -1 01630 lappend _itemsOfTimepoint($level,-1) $node_id 01631 set modifiee_x $nil_x 01632 set modifiee_y $nil_y 01633 } else { 01634 01635 # draw upper node 01636 set modifiee_y $upperrow 01637 set modifiee_x $_textMidPos($modifiee_id) 01638 set node_id [$canvas create oval \ 01639 [expr $modifiee_x-2] [expr $modifiee_y-2] \ 01640 [expr $modifiee_x+2] [expr $modifiee_y+2] \ 01641 -fill $itk_option(-nodecolor) \ 01642 -tags node ] 01643 $canvas raise $node_id 01644 set _timepointOfId($level,$node_id) $modifiee_id 01645 lappend _itemsOfTimepoint($level,$modifiee_id) $node_id 01646 } 01647 # Herein lurks a subtle bug. If none of the bindings of this level 01648 # are NIL bindings, then no NIL node is ever drawn, and no mouse 01649 # gesture can create a NIL binding. But this can only happen if 01650 # *all* of the bindings are part of cycles. Unlikely. 01651 01652 # draw edge 01653 set edge_id [$canvas create line 0 0 0 0 \ 01654 -fill $itk_option(-edgecolor) \ 01655 -tags edge ] 01656 01657 $canvas lower $edge_id 01658 set label_id [$canvas create text 0 0 \ 01659 -text "$label" \ 01660 -anchor sw \ 01661 -font $itk_option(-labelfont) \ 01662 -fill $itk_option(-labelcolor) \ 01663 -tags {label text}] 01664 $canvas lower $label_id 01665 set _timepointOfId($level,$label_id) $modifier_id 01666 lappend _itemsOfTimepoint($level,$modifier_id) $label_id 01667 set edges($label_id) $edge_id 01668 01669 # register items and ids in _itemsOfTimepoint and _timepointOfId 01670 set _timepointOfId($level,$edge_id) $modifier_id 01671 lappend _itemsOfTimepoint($level,$modifier_id) $edge_id 01672 01673 set _dragItem $edge_id 01674 moveEdge $canvas $modifier_x $modifier_y $modifiee_x $modifiee_y 01675 $canvas itemconfigure $_dragItem -fill $itk_option(-edgecolor) 01676 set _dragItem "" 01677 01678 } else { 01679 # draw non-cyclical structure 01680 01681 set modifier_height [$_parse getWordHeight $level $modifier_id] 01682 set modifier_x $_textMidPos($modifier_id) 01683 set modifier_y [expr $modifier_height * 40.0 + 40.0] 01684 01685 if {$modifiee_id != -1 } { 01686 # non root arc 01687 if {[$_parse isLeafNode $level $modifier_id] && 01688 [allSybillings $modifier_id $modifiee_id $level] } { 01689 #set the node on the bottom 01690 set modifier_y $heightInPixels 01691 } 01692 01693 set modifiee_height [$_parse getWordHeight $level $modifiee_id] 01694 set modifiee_x $_textMidPos($modifiee_id) 01695 set modifiee_y [expr $modifiee_height * 40.0 + 40.0] 01696 01697 } else { 01698 # root arc 01699 set modifiee_x $modifier_x 01700 if {[$_parse isLeafNode $level $modifier_id]} { 01701 #set the nil node on the bottom 01702 set modifier_y $heightInPixels 01703 } 01704 set modifiee_y [expr $modifier_y - 20.0] 01705 01706 # draw nil-node 01707 set node_id [$canvas create oval \ 01708 [expr $modifiee_x-2] [expr $modifiee_y-2] \ 01709 [expr $modifiee_x+2] [expr $modifiee_y+2] \ 01710 -fill $itk_option(-nodecolor) \ 01711 -tags node ] 01712 $canvas raise $node_id 01713 01714 # register all ids into _timepointOfId and _itemsOfTimepoint 01715 set _timepointOfId($level,$node_id) $modifiee_id 01716 lappend _itemsOfTimepoint($level,$modifiee_id) $node_id 01717 } 01718 01719 # draw edge between node and word 01720 set vline_id [$canvas create line \ 01721 $modifier_x $modifier_y \ 01722 $modifier_x $heightInPixels\ 01723 -fill $itk_option(-vlinecolor) \ 01724 -tags vline] 01725 01726 $canvas lower $vline_id 01727 01728 # draw node 01729 set node_id [$canvas create oval \ 01730 [expr $modifier_x-2] [expr $modifier_y-2] \ 01731 [expr $modifier_x+2] [expr $modifier_y+2] \ 01732 -fill $itk_option(-nodecolor) \ 01733 -tags node] 01734 $canvas raise $node_id 01735 01736 # draw edge between modifier and modifiee 01737 set edge_id [$canvas create line 0 0 0 0 \ 01738 -fill $itk_option(-edgecolor) \ 01739 -tags edge ] 01740 01741 01742 $canvas lower $edge_id 01743 set label_id [$canvas create text 0 0 \ 01744 -text "$label" \ 01745 -anchor sw \ 01746 -font $itk_option(-labelfont) \ 01747 -fill $itk_option(-labelcolor) \ 01748 -tags {label text}] 01749 $canvas lower $label_id 01750 set _timepointOfId($level,$label_id) $modifier_id 01751 lappend _itemsOfTimepoint($level,$modifier_id) $label_id 01752 set edges($label_id) $edge_id 01753 01754 # register items and ids in _itemsOfTimepoint and _timepointOfId 01755 set _timepointOfId($level,$edge_id) $modifier_id 01756 set _timepointOfId($level,$vline_id) $modifier_id 01757 set _timepointOfId($level,$node_id) $modifier_id 01758 lappend _itemsOfTimepoint($level,$modifier_id) $edge_id 01759 lappend _itemsOfTimepoint($level,$modifier_id) $vline_id 01760 lappend _itemsOfTimepoint($level,$modifier_id) $node_id 01761 01762 01763 set _dragItem $edge_id 01764 moveEdge $canvas $modifier_x $modifier_y $modifiee_x $modifiee_y 01765 $canvas itemconfigure $_dragItem -fill $itk_option(-edgecolor) 01766 set _dragItem "" 01767 } 01768 } 01769 01770 # move the labels to the correct position 01771 foreach label_id [array names edges] { 01772 eval moveLabel $canvas $label_id [$canvas coords $edges($label_id)] 01773 } 01774 01775 if {$level == [mainlevelname]} { 01776 drawArcs 01777 } 01778 01779 $itk_component($level) configure -autoresize 1 01780 $itk_component($level) yview moveto 0 01781 01782 registerItems $level 01783 } 01784 01785 ## ---------------------------------------------------------------------------- 01786 ## Compute the array _itemsOfViolation for this level. 01787 ## ---------------------------------------------------------------------------- 01788 body ParseTree::registerItems {level} { 01789 if {!$_isDrawn($level)} { 01790 return 01791 } 01792 01793 set mainlevel [mainlevelname] 01794 set no 0 01795 set canvas [$itk_component($level) childsite] 01796 01797 foreach viola [$_parse getViolations] { 01798 set b1Id [lindex $viola 1] 01799 set b2Id [lindex $viola 2] 01800 01801 # find the corresponding binding's id: 01802 set binding [$_parse getBindingById $b1Id] 01803 scan $binding "%s %s %s %s %s" \ 01804 modifier_id1 modifiee_id1 label bindNo1 level1 01805 01806 if {$level == $level1} { 01807 # register words, edges and labels for the first LV 01808 if {$modifiee_id1 != -1} { 01809 foreach id $_itemsOfTimepoint($level,$modifiee_id1) { 01810 set id_tags [$canvas gettags $id] 01811 if {[regexp "word" $id_tags]} { 01812 lappend _itemsOfViolation($no) $id $level 01813 break 01814 } 01815 } 01816 } 01817 foreach id $_itemsOfTimepoint($level,$modifier_id1) { 01818 set id_tags [$canvas gettags $id] 01819 if {[regexp "edge|label|word" $id_tags]} { 01820 lappend _itemsOfViolation($no) $id $level 01821 } 01822 } 01823 } 01824 01825 if {$level == [mainlevelname]} { 01826 # register arcs and labels for the first LV 01827 catch { 01828 foreach id $_arcOfTimepoint($level1,$modifier_id1) { 01829 lappend _itemsOfViolation($no) $id $level 01830 } 01831 } 01832 } 01833 01834 # more work for binary violations 01835 if {$b2Id != -1} { 01836 01837 # find the corresponding binding's id: 01838 set binding [$_parse getBindingById $b2Id] 01839 scan $binding "%s %s %s %s %s" modifier_id2 modifiee_id2 \ 01840 label bindNo2 level2 01841 01842 if {$level == $level2} { 01843 # register edges and labels for the first LV 01844 if {$modifiee_id2 != -1} { 01845 foreach id $_itemsOfTimepoint($level,$modifiee_id2) { 01846 set id_tags [$canvas gettags $id] 01847 if {[regexp "word" $id_tags]} { 01848 lappend _itemsOfViolation($no) $id $level 01849 break 01850 } 01851 } 01852 } 01853 foreach id $_itemsOfTimepoint($level,$modifier_id2) { 01854 set id_tags [$canvas gettags $id] 01855 if {[regexp "edge|label|word" $id_tags]} { 01856 lappend _itemsOfViolation($no) $id $level 01857 } 01858 } 01859 } 01860 01861 if {$level == [mainlevelname]} { 01862 # register arcs and labels for the second LV 01863 catch { 01864 foreach id $_arcOfTimepoint($level2,$modifier_id2) { 01865 lappend _itemsOfViolation($no) $id $level 01866 } 01867 } 01868 } 01869 } 01870 incr no 01871 } 01872 } 01873 01874 ## ---------------------------------------------------------------------------- 01875 ## draw everything into the levels. 01876 ## ---------------------------------------------------------------------------- 01877 body ParseTree::drawAll {} { 01878 set _zoomstep 0 01879 foreach level [$_parse getLevels] { 01880 reDrawLevel $level 01881 } 01882 if {![$_parse isAbstract]} { 01883 $itk_component(conflicts) selection clear all 01884 } 01885 paintTabs 01886 } 01887 01888 ## ---------------------------------------------------------------------------- 01889 ## colorize the tabs in the tabnotebook. 01890 ## This is done according to the worst violation on that tab. 01891 ## ---------------------------------------------------------------------------- 01892 body ParseTree::paintTabs {} { 01893 01894 if {[$_parse isAbstract]} return 01895 01896 set level_index [$itk_component(tbn) index select] 01897 if {$level_index < 0} { 01898 set level_index 0 01899 } 01900 01901 set tabset [$itk_component(tbn) component tabset] 01902 $tabset configure -foreground black -selectforeground black 01903 01904 # find the worst score of a violation for each level 01905 foreach level [$_parse getLevels] { 01906 set levelPenalty($level) 1.0 01907 } 01908 01909 foreach viola [$_parse getViolations] { 01910 set b1Id [lindex $viola 1] 01911 set b2Id [lindex $viola 2] 01912 set score [lindex $viola 3] 01913 set binding [$_parse getBindingById $b1Id] 01914 scan $binding "%s %s %s %s %s" foo bar baz quux level1 01915 01916 if {$score < $levelPenalty($level1)} { 01917 set levelPenalty($level1) $score 01918 } 01919 if {$b2Id != -1} { 01920 01921 # find the corresponding binding's id: 01922 set binding [$_parse getBindingById $b2Id] 01923 scan $binding "%s %s %s %s %s" foo bar baz quux level2 01924 if {$score < $levelPenalty($level2)} { 01925 set levelPenalty($level2) $score 01926 } 01927 } 01928 } 01929 01930 # paint the tabs in the tabnotebook green or red accordingly 01931 foreach level [$_parse getLevels] { 01932 01933 # get a severity value from parse 01934 set severity $levelPenalty($level) 01935 set color [rgValue $severity] 01936 01937 $tabset tabconfigure [$tabset index $level] \ 01938 -foreground $color \ 01939 -selectforeground $color 01940 } 01941 $itk_component(tbn) view $level_index 01942 } 01943 01944 ## ---------------------------------------------------------------------------- 01945 ## take a score and return an appropriate red/green color for it. 01946 ## ---------------------------------------------------------------------------- 01947 body ParseTree::rgValue {score} { 01948 01949 # non-linear mapping to intensity values because the intensities 01950 # below 0.4 are pretty much indistinguishable 01951 # (try to find a closed form for this if you want) 01952 if {$score == 1.0} { 01953 set intensity 0.0 01954 } elseif {$score > 0.999} { 01955 set intensity 0.1 01956 } elseif {$score > 0.99} { 01957 set intensity 0.2 01958 } elseif {$score > 0.9} { 01959 set intensity 0.3 01960 } elseif {$score > 0.8} { 01961 set intensity 0.4 01962 } elseif {$score > 0.4} { 01963 set intensity 0.5 01964 } elseif {$score > 0.2} { 01965 set intensity 0.6 01966 } elseif {$score > 0.1} { 01967 set intensity 0.7 01968 } elseif {$score > 0.01} { 01969 set intensity 0.8 01970 } elseif {$score > 0.001} { 01971 set intensity 0.9 01972 } else { 01973 set intensity 1.0 01974 } 01975 01976 set redvalue [format "%.0f" [expr 4096 * $intensity]] 01977 if {$redvalue > 4095} { set redvalue 4095 } 01978 set greenvalue [format "%.0f" [expr (4095 - $redvalue) / 1.5]] 01979 set color [format "#%03x%03x%03x" $redvalue $greenvalue 0] 01980 return $color 01981 } 01982 01983 ## ---------------------------------------------------------------------------- 01984 ## saves the Parse to file as an annotation in cdgp input format 01985 ## ---------------------------------------------------------------------------- 01986 body ParseTree::writeToFile {fileName} { 01987 01988 writeAnnotation [$_parse toAnno] $fileName 01989 01990 } 01991 01992 ## ---------------------------------------------------------------------------- 01993 ## option -labelfont 01994 ## ---------------------------------------------------------------------------- 01995 configbody ParseTree::labelfont { 01996 01997 foreach level [$_parse getLevels] { 01998 if {$_isDrawn($level)} { 01999 set canvas [$itk_component($level) childsite] 02000 $canvas itemconfigure label -font $itk_option(-labelfont) 02001 } 02002 } 02003 } 02004 02005 02006 ## ---------------------------------------------------------------------------- 02007 ## option -wordfont 02008 ## ---------------------------------------------------------------------------- 02009 configbody ParseTree::wordfont { 02010 02011 foreach level [$_parse getLevels] { 02012 if {$_isDrawn($level)} { 02013 set canvas [$itk_component($level) childsite] 02014 $canvas itemconfigure word -font $itk_option(-wordfont) 02015 $canvas itemconfigure title -font $itk_option(-wordfont) 02016 $canvas itemconfigure viola -font $itk_option(-wordfont) 02017 } 02018 } 02019 } 02020 02021 ## ---------------------------------------------------------------------------- 02022 ## compute the screen x and y coords of canvas-coords x and y. 02023 ## ---------------------------------------------------------------------------- 02024 body ParseTree::canvasToScreen {canvas x y} { 02025 02026 set rootx [winfo rootx $canvas] 02027 set rooty [winfo rooty $canvas] 02028 scan [$canvas cget -scrollregion] "%d %d %d %d" min_x min_y max_x max_y 02029 set left_off [lindex [$canvas xview] 0] 02030 set up_off [lindex [$canvas yview] 0] 02031 scan [expr $rootx + $x - $min_x - ($max_x - $min_x) * $left_off] "%d" X 02032 scan [expr $rooty + $y - $min_y - ($max_y - $min_y) * $up_off] "%d" Y 02033 02034 return [list $X $Y] 02035 } 02036 02037 ## ---------------------------------------------------------------------------- 02038 ## Translate window-based into canvas-based co-ordinates. 02039 ## 02040 ## If a scrolledcanvas is scrolled to the right, away from the home 02041 ## position, and a mouse click occurs in its upper left corner, then 02042 ## the bind event will still receive the coordinates (1,1) through its 02043 ## %x and %y parameters, even though the canvas pixel the the mouse is 02044 ## touching is something like (320,1). (Actually, because of the way 02045 ## the scrolledcanvas widget is written, an offset occurs even in the 02046 ## home position.) This routine accounts for that offset. Therefore it 02047 ## must be called whenever coordinates received through `bind' are to 02048 ## be applied to things on the canvas. 02049 ## ---------------------------------------------------------------------------- 02050 body ParseTree::fixCoords {w x y} { 02051 02052 scan [$w cget -scrollregion] "%d %d %d %d" min_x min_y max_x max_y 02053 set left_off [lindex [$w xview] 0] 02054 set up_off [lindex [$w yview] 0] 02055 scan [expr $x + $min_x + ($max_x - $min_x) * $left_off] "%d" new_x 02056 scan [expr $y + $min_y + ($max_y - $min_y) * $up_off] "%d" new_y 02057 02058 return [list $new_x $new_y] 02059 } 02060 02061 ## ---------------------------------------------------------------------------- 02062 ## build a popup menu and show the provided items. 02063 ## Items is a list of pairs consisting of a label and the associated command. 02064 ## ---------------------------------------------------------------------------- 02065 body ParseTree::showPopMenu {w x y items} { 02066 02067 set popmenu $itk_component(popmenu) 02068 $popmenu delete 0 end 02069 02070 foreach item $items { 02071 $popmenu add command \ 02072 -label " [lindex $item 0] " \ 02073 -command [lindex $item 1] 02074 } 02075 update idletask 02076 02077 set screenHeight [winfo screenheight $w] 02078 set reqHeight [winfo reqheight $popmenu] 02079 scan [canvasToScreen $w $x $y] "%d %d" screenX screenY 02080 set diffHeight [expr $screenHeight - $reqHeight -$screenY] 02081 set noItems [llength $items] 02082 02083 if {$diffHeight<0} { 02084 02085 # distribute items on some cascaded menus 02086 set heightPerItem [expr $reqHeight / $noItems] 02087 set maxItems [expr ($screenHeight -$screenY) / $heightPerItem - 2] 02088 set noCascades [expr ceil($noItems / double($maxItems))] 02089 $popmenu delete $maxItems end 02090 set lastCascade $popmenu 02091 set lastItem $maxItems 02092 02093 for {set i 1} {$i < $noCascades} {incr i} { 02094 if {![winfo exists $lastCascade.$i]} { 02095 set newCascade [menu $lastCascade.$i ] 02096 } else { 02097 set newCascade $lastCascade.$i 02098 $newCascade delete 0 end 02099 } 02100 $lastCascade add separator 02101 $lastCascade add cascade \ 02102 -label " ... " \ 02103 -menu $newCascade 02104 02105 for {set j 0} \ 02106 {$j < $maxItems && [expr $lastItem + $j] < $noItems} \ 02107 {incr j} { 02108 set item [lindex $items [expr $lastItem + $j]] 02109 $newCascade add command \ 02110 -label " [lindex $item 0] " \ 02111 -command [lindex $item 1] 02112 } 02113 incr lastItem $j 02114 set lastCascade $newCascade 02115 } 02116 update idletask 02117 } 02118 eval tk_popup $popmenu $screenX $screenY 02119 } 02120 02121 02122 ## ---------------------------------------------------------------------------- 02123 ## draws all bindings not on the main level as arcs under the main tree. 02124 ## ---------------------------------------------------------------------------- 02125 body ParseTree::drawArcs {} { 02126 02127 set mainlevel [mainlevelname] 02128 set canvas [$itk_component($mainlevel) childsite] 02129 02130 # retract all arcs 02131 $canvas delete arc 02132 array unset _arcOfTimepoint 02133 02134 set heightInLinks [$_parse getHeight $mainlevel] 02135 set start [expr $heightInLinks * 40.0 + 80] 02136 set nrWords [vectorSize [$_parse getWords]] 02137 02138 # collect bindings in array arcs which are worth drawing 02139 set arcs "" 02140 foreach level [$_parse getLevels] { 02141 02142 # skip main level bindings 02143 if {$level != $mainlevel} { 02144 02145 foreach binding [$_parse getBindings $level] { 02146 scan $binding "%s %s %s %s %s" from to label bindNo foo 02147 02148 # skip NULL bindings 02149 if {$to != "-1" } { 02150 lappend arcs [list $from $to $label $bindNo $level] 02151 } 02152 } 02153 } 02154 } 02155 02156 # Now figure out where to draw the arcs so that they don't overlap. 02157 # We do it like this: the space below the sentence is segmented into 02158 # rows and columns, starting with row 0 directly under the sentence 02159 # and column 0 under the first word. Now when an arc is drawn from a 02160 # to b, it gets drawn into the first row r with unused columns a 02161 # through b and then marks cells ($r,$a) through ($r,b) as used. 02162 02163 # init cell array 02164 set noArcs [llength $arcs] 02165 for {set row 0} {$row < $noArcs} {incr row} { 02166 for {set column 0} {$column < $nrWords} {incr column} { 02167 set cell($row,$column) 0 02168 } 02169 } 02170 02171 # draw all arcs 02172 foreach arc $arcs { 02173 02174 # get the arc 02175 set from [lindex $arc 0] 02176 set to [lindex $arc 1] 02177 set label [lindex $arc 2] 02178 set bindno [lindex $arc 3] 02179 set level [lindex $arc 4] 02180 02181 # a = min(from,to), z = max(from,to) 02182 if {$from > $to} { 02183 set a $to 02184 set z $from 02185 } else { 02186 set a $from 02187 set z $to 02188 } 02189 02190 # find first partially free row 02191 for {set row 0} {$row < $noArcs} {incr row} { 02192 set rowOK 1 02193 for {set column $a} {$column < $z} {incr column} { 02194 if {$cell($row,$column) == 1} { 02195 set rowOK 0 02196 break 02197 } 02198 } 02199 if {$rowOK == 1} { 02200 break 02201 } 02202 } 02203 02204 # mark cells as used 02205 for {set column $a} {$column < $z} {incr column} { 02206 set cell($row,$column) 1 02207 } 02208 02209 set x1 $_textMidPos($from) 02210 set x2 $_textMidPos($to) 02211 set y1 [expr $start + $row * 40] 02212 set y2 [expr $start + (1 + $row) * 40] 02213 02214 # shift arrowheads so that they never overlap 02215 if {$from < $to} { 02216 set x2 [expr $x2 - 10] 02217 } else { 02218 set x2 [expr $x2 + 10] 02219 } 02220 02221 set text "$level:$label" 02222 if {$label == "{}"} { 02223 set text $level 02224 } 02225 02226 set items [createArc $canvas $x1 $y1 $x2 $y2 $text $bindno] 02227 02228 # register items 02229 foreach item $items { 02230 set _levelOfItem($item) $level 02231 set _timepointOfId($level,$item) $from 02232 lappend _arcOfTimepoint($level,$from) $item 02233 } 02234 02235 } 02236 } 02237 02238 ## ---------------------------------------------------------------------------- 02239 ## creates a new arc with the specified parameters. 02240 ## ---------------------------------------------------------------------------- 02241 body ParseTree::createArc {canvas x1 y1 x2 y2 text bindNo} { 02242 02243 # arc 02244 set xmid [expr ($x2 + $x1) / 2] 02245 set arc [$canvas create line $x1 $y1 $xmid $y2 $x2 $y1 \ 02246 -arrow last \ 02247 -smooth 1 \ 02248 -tags [list arc binding$bindNo]] 02249 02250 #-arrowshape "10 10 6"\ 02251 02252 # label 02253 set textx [expr $x1 + ($x2 - $x1) / 2] 02254 set texty [expr $y2 - 5] 02255 set label [$canvas create text $textx $texty\ 02256 -text $text\ 02257 -font $itk_option(-wordfont)\ 02258 -tags [list text arc binding$bindNo]] 02259 02260 return "$arc $label" 02261 02262 } 02263 02264 ## ---------------------------------------------------------------------------- 02265 ## scan all levels of the tree horizontally. 02266 ## \param x the x position of the pointer 02267 ## \param y the x position of the pointer 02268 ## ---------------------------------------------------------------------------- 02269 body ParseTree::multiMark {x y} { 02270 set _lastxmark $x 02271 set _lastymark $y 02272 foreach level [$_parse getLevels] { 02273 $itk_component($level) scan mark $x $y 02274 } 02275 } 02276 02277 ## ---------------------------------------------------------------------------- 02278 ## scan all levels of the tree horizontally. 02279 ## \param x the x position of the pointer 02280 ## \param y the x position of the pointer 02281 ## ---------------------------------------------------------------------------- 02282 body ParseTree::multiDragto {x y} { 02283 02284 set mainlevel [mainlevelname] 02285 set canvas [$itk_component($mainlevel) childsite] 02286 if {"[$canvas xview]" == "0 1"} { 02287 set x $_lastxmark 02288 } 02289 if {"[$canvas yview]" == "0 1"} { 02290 set y $_lastymark 02291 } 02292 02293 # Restrict the actual Y coordinate used for scrolling. 02294 # 02295 # Since all levels of analysis model the same word sequence (the 02296 # path criterion), all canvases in a ParseTree must be the same 02297 # width. But the tree structures created by them can differ; usually 02298 # the main level with its glorious syntax tree is much higher than 02299 # any auxiliary levels, where only isolated edges appear. Therefore 02300 # we cannot use the Y coordinate extracted from the click event 02301 # uncritically for vertical panning on all canvases. Instead, we 02302 # check whether each canvas is already completely visible, and if it 02303 # is, we do not pan vertically at all. 02304 foreach level [$_parse getLevels] { 02305 set c $itk_component($level) 02306 set eff_y $y 02307 if {"[$c yview]" == "0 1"} { 02308 set eff_y 0 02309 } 02310 $c scan dragto $x $eff_y 02311 } 02312 } 02313 02314 ## ---------------------------------------------------------------------------- 02315 ## call all level canvases of the tree. 02316 ## ---------------------------------------------------------------------------- 02317 body ParseTree::multiCanvas {args} { 02318 02319 foreach level [$_parse getLevels] { 02320 drawLevel $level 02321 if {"$args" != ""} { 02322 eval $itk_component($level) $args 02323 } 02324 } 02325 } 02326 02327 ## ---------------------------------------------------------------------------- 02328 ## apply parseMirror. 02329 ## ---------------------------------------------------------------------------- 02330 body ParseTree::mirror {} { 02331 $_parse mirror 02332 02333 drawViolas 02334 02335 foreach level [$_parse getLevels] { 02336 reDrawLevel $level 02337 } 02338 paintTabs 02339 02340 } 02341 02342 ## ---------------------------------------------------------------------------- 02343 ## highlight differences to annotation 02344 ## ---------------------------------------------------------------------------- 02345 body ParseTree::verify {} { 02346 02347 # downlight everything 02348 foreach level [$_parse getLevels] { 02349 set canvas [$itk_component($level) childsite] 02350 $canvas itemconfigure arc -fill $itk_option(-edgecolor) 02351 $canvas itemconfigure edge -fill $itk_option(-edgecolor) 02352 $canvas itemconfigure word -fill $itk_option(-wordcolor) 02353 $canvas itemconfigure label -fill $itk_option(-labelcolor) 02354 } 02355 02356 set pv [$_parse verify] 02357 if {$pv == ""} return 02358 02359 set wrongwords [ParseVerificationStruct_lexErrors_get $pv] 02360 set wronglabels [ParseVerificationStruct_labelErrors_get $pv] 02361 set wrongedges [ParseVerificationStruct_structErrors_get $pv] 02362 02363 set mainlevel [mainlevelname] 02364 set canvas [$itk_component($mainlevel) childsite] 02365 02366 # highlight wrong words 02367 foreach id [$canvas find withtag word] { 02368 set wordno $_timepointOfId($mainlevel,$id) 02369 if {[vectorElement $wrongwords $wordno] != "NULL"} { 02370 $canvas itemconfigure $id -fill $itk_option(-errorcolor) 02371 } 02372 } 02373 02374 # highlight wrong labels 02375 foreach id [$canvas find withtag label] { 02376 set t $_timepointOfId($mainlevel,$id) 02377 set i [$_parse indexOf $mainlevel $t] 02378 if {[vectorElement $wronglabels $i] != "NULL"} { 02379 $canvas itemconfigure $id -fill $itk_option(-errorcolor) 02380 } 02381 } 02382 02383 # highlight wrong edges 02384 foreach id [$canvas find withtag edge] { 02385 set t $_timepointOfId($mainlevel,$id) 02386 set i [$_parse indexOf $mainlevel $t] 02387 if {[vectorElement $wrongedges $i] != "NULL"} { 02388 $canvas itemconfigure $id -fill $itk_option(-errorcolor) 02389 } 02390 } 02391 02392 parseVerificationDelete $pv 02393 } 02394 02395 ## ---------------------------------------------------------------------------- 02396 ## highlight all edges participating in cycles on the current level. 02397 ## ---------------------------------------------------------------------------- 02398 body ParseTree::showcycles {} { 02399 02400 # process currently shown level 02401 set level [lindex [$_parse getLevels] [$itk_component(tbn) view]] 02402 02403 # search bindings for structure 02404 set bindings [$_parse getBindings $level] 02405 foreach binding $bindings { 02406 set down [lindex $binding 0] 02407 set up [lindex $binding 1] 02408 set parent($down) $up 02409 } 02410 02411 # search structure for cycles 02412 set max [array size parent] 02413 for {set i 0} {$i < [array size parent]} {incr i} { 02414 set cyclic($i) 0 02415 } 02416 02417 for {set i 0} {$i < [array size parent]} {incr i} { 02418 02419 # already got this? 02420 if { 1 == $cyclic($i) } continue 02421 02422 set counter 0 02423 set j $i 02424 while {$j != -1} { 02425 incr counter 02426 # found cycle that doesn't involve i? 02427 # let him live, we'll get to him later 02428 if {$counter > $max} break 02429 02430 set j $parent($j) 02431 # found cycle that involves i? 02432 if {$j == $i} { 02433 set cyclic($i) 1 02434 break 02435 } 02436 } 02437 } 02438 02439 set canvas [$itk_component($level) childsite] 02440 set items "" 02441 foreach id [$canvas find withtag edge] { 02442 if {1 == $cyclic($_timepointOfId($level,$id))} { 02443 $canvas itemconfigure $id -fill $itk_option(-highlightcolor) 02444 } else { 02445 $canvas itemconfigure $id -fill $itk_option(-edgecolor) 02446 } 02447 } 02448 } 02449 02450 ## ---------------------------------------------------------------------------- 02451 ## Break cycles in the tree on the current level. 02452 ## 02453 ## This may be necessary because a cycle can't be broken 02454 ## by drag & drop if there isn't already a root binding. 02455 ## ---------------------------------------------------------------------------- 02456 body ParseTree::breakcycles {} { 02457 02458 # process currently shown level 02459 set level [lindex [$_parse getLevels] [$itk_component(tbn) view]] 02460 02461 # search bindings for structure 02462 set bindings [$_parse getBindings $level] 02463 foreach binding $bindings { 02464 set down [lindex $binding 0] 02465 set up [lindex $binding 1] 02466 set parent($down) $up 02467 } 02468 02469 # search structure for cycles 02470 set max [array size parent] 02471 for {set i 0} {$i < [array size parent]} {incr i} { 02472 set cyclic($i) 0 02473 } 02474 02475 for {set i 0} {$i < [array size parent]} {incr i} { 02476 02477 set counter 0 02478 set j $i 02479 while {$j != -1} { 02480 set j $parent($j) 02481 if {$j != -1} { 02482 set old $parent($j) 02483 } 02484 incr counter 02485 if {$counter > $max || $j == $i} { 02486 02487 # found cycle? 02488 $_parse shiftEdge $level $j -1 02489 02490 $_commandHistory add\ 02491 [code "$this undoEdge $j -1 $level"]\ 02492 [code "$this undoEdge $j $old $level"] 02493 02494 reDrawLevel $level 02495 drawViolas 02496 paintTabs 02497 breakcycles 02498 return 02499 02500 } 02501 } 02502 } 02503 02504 } 02505 02506 02507 ## ---------------------------------------------------------------------------- 02508 ## increase or decrease zoom level of all canvases. 02509 ## ---------------------------------------------------------------------------- 02510 body ParseTree::zoom {direction} { 02511 02512 # Only five zoom levels are allowed: -2/-1/0/1/2 02513 set newzoom [expr $_zoomstep + $direction] 02514 if {$newzoom > 2} { 02515 set newzoom 2 02516 } 02517 if {$newzoom < -2} { 02518 set newzoom -2 02519 } 02520 02521 _zoom $newzoom 02522 02523 } 02524 02525 02526 ## ---------------------------------------------------------------------------- 02527 ## set zoom level for one canvas. 02528 ## ---------------------------------------------------------------------------- 02529 body ParseTree::_zoom {step} { 02530 02531 set old_zoomstep $_zoomstep 02532 set _zoomstep $step 02533 02534 if {$old_zoomstep == $_zoomstep} { 02535 return 02536 } 02537 02538 # If we got here, each level actually needs to be redrawn. 02539 # It would be nicer just to rescale the canvases and leave 02540 # them drawn, but drawLevel{} uses the actual size of the 02541 # text items to group them implicitly, and that calculation 02542 # becomes invalid when the font size changes, so it looks better 02543 # to force a redraw here. 02544 # This also breaks the time-saving delayed drawing of levels. 02545 foreach level [$_parse getLevels] { 02546 02547 reDrawLevel $level 02548 02549 # scale canvas 02550 set canvas [$itk_component($level) childsite] 02551 array set factors {-2 0.5 -1 0.75 0 1 1 1.33 2 1.75} 02552 set factor $factors($_zoomstep) 02553 $canvas scale all 0 0 $factor $factor 02554 02555 # scale text items 02556 array set fontsizes {-2 5 -1 9 0 10 1 14 2 16} 02557 set size $fontsizes($_zoomstep) 02558 $canvas itemconfigure text -font [list Helvetica $size bold] 02559 $canvas configure -scrollregion [$canvas bbox all] 02560 02561 } 02562 } 02563 02564 ## ---------------------------------------------------------------------------- 02565 ## delegate to the _parse. 02566 ## ---------------------------------------------------------------------------- 02567 body ParseTree::parse {args} { 02568 eval $_parse $args 02569 } 02570 02571 ## ---------------------------------------------------------------------------- 02572 ## set the orientation of the panedwindow and reset to default fraction. 02573 ## ---------------------------------------------------------------------------- 02574 body ParseTree::setOrientation {orient} { 02575 if {[$_parse isAbstract]} return 02576 $itk_component(pane) configure -orient $orient 02577 $itk_component(pane) fraction 80 20 02578 } 02579 02580 ## ---------------------------------------------------------------------------- 02581 ## get the orientation of the panedwindow. 02582 ## ---------------------------------------------------------------------------- 02583 body ParseTree::getOrientation {} { 02584 return [$itk_component(pane) cget -orient] 02585 } 02586 02587 ## ---------------------------------------------------------------------------- 02588 ## Return he name of the main level. 02589 ## 02590 ## The main level is the one that gets all other edges drawn under it 02591 ## as little arcs. If the grammar does not define one, return the name 02592 ## of the first level in the parse. 02593 ## ---------------------------------------------------------------------------- 02594 body ParseTree::mainlevelname {} { 02595 02596 set result [.cdgmain levels getMainlevelId] 02597 if {$result != ""} { return $result } 02598 02599 return [lindex [$_parse getLevels] 0] 02600 02601 } 02602 02603 ## ---------------------------------------------------------------------------- 02604 ## Highlight specified edges in color. 02605 ## ---------------------------------------------------------------------------- 02606 body ParseTree::highlight {which} { 02607 02608 if { ! [regexp {(^[0-9]+(,[0-9]+)*$)?} $which] } { 02609 ::cmd::Puts "ERROR: Bad parse edge specification `$which'" 02610 ::cmd::Puts "ERROR: Highlighting failed." 02611 return 02612 } 02613 02614 set levels [$_parse getLevels] 02615 set nolevels [llength $levels] 02616 set nowords [$_parse getWidth] 02617 02618 02619 regsub -all "," $which " " which 02620 foreach w [split $which] { 02621 set l [expr $w % $nolevels] 02622 set t [expr $w / $nolevels] 02623 02624 # catch improper index 02625 if {$t > $nowords} continue 02626 02627 # to be highlighted, the edge must first be drawn 02628 set level [lindex $levels $l] 02629 drawLevel $level 02630 set canvas [$itk_component($level) childsite] 02631 set edge [edgeOfTimepoint $canvas $t] 02632 $canvas itemconfigure $edge -fill $itk_option(-highlightcolor) 02633 } 02634 } 02635 02636 02637 ## ---------------------------------------------------------------------- 02638 ## Change reading for given vertice to description 02639 ## @param from vertice to change 02640 ## @param description new reading 02641 ## ---------------------------------------------------------------------- 02642 body ParseTree::undoLexeme {from description} { 02643 $_parse swapWord $from $description 02644 drawAll 02645 drawViolas 02646 } 02647 02648 02649 ## ---------------------------------------------------------------------- 02650 ## Change modifier's label at given level 02651 ## ---------------------------------------------------------------------- 02652 body ParseTree::undoLabel {modifier label level} { 02653 $_parse swapLabel $level $modifier $label 02654 drawAll 02655 drawViolas 02656 } 02657 02658 02659 02660 ## ---------------------------------------------------------------------- 02661 ## Shift edge (modifier) to modifiee on given level 02662 ## Used to undo edge-moving actions 02663 ## ---------------------------------------------------------------------- 02664 body ParseTree::undoEdge {modifier modifiee level} { 02665 $_parse shiftEdge $level $modifier $modifiee 02666 # update arcs on main level if necessary 02667 drawAll 02668 drawViolas 02669 } 02670 02671 02672 ## ---------------------------------------------------------------------- 02673 ## Add a listener to be informed of changes to the command-history 02674 ## @param listener Object-ID implementing method update {} 02675 ## ---------------------------------------------------------------------- 02676 body ParseTree::addUndoListener {listener} { 02677 if { $_commandHistory != "" } { 02678 $_commandHistory addListener $listener 02679 } 02680 } 02681 02682 02683 ## ---------------------------------------------------------------------- 02684 ## Calls undo on command history 02685 ## ---------------------------------------------------------------------- 02686 body ParseTree::undo {} { 02687 if {[$_commandHistory canUndo] == 1} { 02688 $_commandHistory undo 02689 } 02690 02691 # undo commands can be called via Ctrl-Press events on the enclosing 02692 # VisParses widget, but ParseTrees believe that releasing Ctrl means 02693 # "apply the change to the current label previously chosen via keyboard". 02694 # 02695 # The effect is that undoing a label change via Ctrl-Z first undoes 02696 # the change, then triggers the Control-Release event, which 02697 # promptly sets the label back to what it was before. To stop it 02698 # from doing this, we reset _kb_label. 02699 02700 # Not a very nice solution; it will break immediately when VisParses 02701 # receives any other Ctrl binding. Please change this to a brilliant 02702 # nice clean implementation when you have the time. 02703 set _kb_label -1 02704 02705 } 02706 02707 ## ---------------------------------------------------------------------- 02708 ## Calls redo on command history 02709 ## ---------------------------------------------------------------------- 02710 body ParseTree::redo {} { 02711 if {[$_commandHistory canRedo] == 1} { 02712 $_commandHistory redo 02713 } 02714 02715 # See comment to `undo'. 02716 set _kb_label -1 02717 02718 } 02719 02720 02721 ## ---------------------------------------------------------------------- 02722 ## Predicate-method rooted to command history 02723 ## @return 1 => undo can be executed, 0 => undo can not be executed 02724 ## ---------------------------------------------------------------------- 02725 body ParseTree::canUndo {} { 02726 return [$_commandHistory canUndo] 02727 } 02728 02729 ## ---------------------------------------------------------------------- 02730 ## Predicate-method rooted to command history 02731 ## @return 1 => undo can be executed, 0 => undo can not be executed 02732 ## ---------------------------------------------------------------------- 02733 body ParseTree::canRedo {} { 02734 return [$_commandHistory canRedo] 02735 } 02736 02737 ## ---------------------------------------------------------------------- 02738 ## Check if $i is actually visible on $w. 02739 ## 02740 ## Returns 0 only if $i is actually scrolled offscreen. $i might also 02741 ## be invisible because the entire X window is partially obscured, but 02742 ## Tcl cannot detect this. 02743 ## ---------------------------------------------------------------------- 02744 body ParseTree::itemVisible {w i} { 02745 02746 scan [$w xview] "%f %f" from to 02747 scan [$w coords $i] "%f %f" x y 02748 scan [$w bbox all] "%f %f %f %f" xmin ymin xmax ymax 02749 02750 set xfrom [expr $xmax * $from] 02751 set xto [expr $xmax * $to] 02752 02753 if {$x >= $xfrom & $x <= $xto} { 02754 return 1 02755 } 02756 02757 return 0 02758 } 02759 02760 ## ---------------------------------------------------------------------- 02761 ## Scroll $w horizontally so that $i is visible. 02762 ## ---------------------------------------------------------------------- 02763 body ParseTree::centerOnItem {w i} { 02764 02765 scan [$w bbox all] "%f %f %f %f" xmin ymin xmax ymax 02766 02767 scan [$w xview] "%f %f" from to 02768 set xfrom [expr $xmax * $from] 02769 set xto [expr $xmax * $to] 02770 set width [expr $xto - $xfrom] 02771 02772 # Which point do we definitely want to see? 02773 scan [$w coords $i] "%f %f" x y 02774 02775 # What does the mean in window fractions? 02776 set xfraction [expr ($x - ($width/2)) / $xmax] 02777 $w xview moveto $xfraction 02778 02779 } 02780 02781 ## ---------------------------------------------------------------------- 02782 ## Handle keyboard editing events: select the word that the next change 02783 ## will apply to. 02784 ## ---------------------------------------------------------------------- 02785 body ParseTree::kb_select_word {w a k} { 02786 02787 set min 0 02788 set max [$_parse getWidth] 02789 set level $_levelOfCanvas($w) 02790 02791 if {"Left" == $k} { 02792 incr _kb_word -1 02793 if {$_kb_word < $min} { 02794 set _kb_word [expr $max - 1] 02795 } 02796 } elseif {"Right" == $k} { 02797 incr _kb_word 02798 if {$_kb_word >= $max} { 02799 set _kb_word $min 02800 } 02801 } elseif {"Up" == $k} { 02802 set r [$_parse getModifiee $level $_kb_word] 02803 if {-1 != $r} { 02804 set _kb_word $r 02805 } 02806 } elseif {"Down" == $k} { 02807 set rs [$_parse getModifiers $level $_kb_word] 02808 if {1 == [llength $rs]} { 02809 set _kb_word $rs 02810 } 02811 } 02812 02813 set word [wordOfTimepoint $w $_kb_word] 02814 $w itemconfigure word -fill $itk_option(-wordcolor) 02815 $w itemconfigure edge -fill $itk_option(-edgecolor) 02816 $w itemconfigure node -fill $itk_option(-nodecolor) 02817 $w itemconfigure $word -fill $itk_option(-highlightcolor) 02818 02819 # Maybe scroll the canvas so that the word is actually visible. 02820 $w yview moveto 1 02821 if {! [itemVisible $w $word]} { 02822 centerOnItem $w $word 02823 } 02824 02825 } 02826 02827 ## ---------------------------------------------------------------------- 02828 ## Handle Shift-ed keyboard editing events. 02829 ## ---------------------------------------------------------------------- 02830 body ParseTree::kb_select_edge {w a k} { 02831 02832 set _computing 1 02833 02834 set min -1 02835 set max [$_parse getWidth] 02836 set level $_levelOfCanvas($w) 02837 set oldregent [$_parse getModifiee $level $_kb_word] 02838 set edge [edgeOfTimepoint $w $_kb_word] 02839 02840 # if no keyboard editing is in progress, start from the current regent 02841 if {$_kb_regent == -2} { 02842 set binding [$_parse getBindingAt $level $_kb_word] 02843 scan $binding "%s %s %s %s %s" a b c d e 02844 set _kb_regent $b 02845 } 02846 02847 # shift hypothetical regent 02848 02849 # Left and right are pretty unambiguous; the new regent should be 02850 # increased or decreased. NIL is considered to be regent -1 (that 02851 # is, to the left of the first word). The only question is whether 02852 # the first `right' command should change the regent to the word 02853 # after the old regent or the word after the old dependent. We use 02854 # the latter since that results in the smaller change to the tree. 02855 if {"Left" == $k} { 02856 incr _kb_regent -1 02857 if {$_kb_regent == $_kb_word} { 02858 incr _kb_regent -1 02859 } 02860 if {$_kb_regent < $min} { 02861 set _kb_regent [expr $max - 1] 02862 if {$_kb_regent == $_kb_word} { 02863 set _kb_regent [expr $max - 2] 02864 } 02865 } 02866 02867 } elseif {"Right" == $k} { 02868 incr _kb_regent 02869 if {$_kb_regent == $_kb_word} { 02870 incr _kb_regent 02871 } 02872 if {$_kb_regent >= $max} { 02873 set _kb_regent -1 02874 } 02875 02876 } elseif {"Up" == $k} { 02877 02878 # Shifting the edge up means attaching it to the regent of its 02879 # regent. The regent of NIL is supposed to be NIL. 02880 if {$_kb_regent == -1} { 02881 set r -1 02882 } else { 02883 set r [$_parse getModifiee $level $_kb_regent] 02884 } 02885 if {$r == $_kb_word} { 02886 set r $_kb_regent 02887 } 02888 set _kb_regent $r 02889 02890 } elseif {"Down" == $k} { 02891 02892 # Shifting an edge down is ambiguous. Since there are already Left 02893 # and Right commands, we take it to mean that the word should be 02894 # attached to the nearest sibling that does not cause projectivity 02895 # errors. 02896 set xs [$_parse getModifiers $level $_kb_regent] 02897 set new_regent -1 02898 02899 # find nearest dependent on the same side 02900 set record $max 02901 foreach x $xs { 02902 if {$x == $_kb_word} continue 02903 if {$_kb_word > $oldregent && $x < $oldregent} continue 02904 if {$_kb_word < $oldregent && $x > $oldregent} continue 02905 set dist [expr abs($x - $_kb_word)] 02906 if {$dist < $record} { 02907 set record $dist 02908 set new_regent $x 02909 } 02910 } 02911 02912 if {-1 == $new_regent} return 02913 set _kb_regent $new_regent 02914 02915 } elseif {"Return" == $k} { 02916 02917 # Return emulates the right mouse button: optimize this subordination 02918 set _kb_regent [$_parse optimizeStructure $level $_kb_word] 02919 02920 } 02921 02922 # Highlight both the edge and the regent's node 02923 set word [wordOfTimepoint $w $_kb_word] 02924 set node1 [nodeOfTimepoint $w $edge $_kb_word] 02925 set node2 [nodeOfTimepoint $w $edge $_kb_regent] 02926 02927 $w itemconfigure node -fill $itk_option(-nodecolor) 02928 $w itemconfigure edge -fill $itk_option(-edgecolor) 02929 02930 # It is possible that nodeOfTimepoint fails, if NIL was requested 02931 # and the canvas contains no NIL binding. The editing move is still 02932 # possible, but we cannot preview it, so we don't try. 02933 if {"" != $node2} { 02934 $w itemconfigure $node2 -fill $itk_option(-highlightcolor) 02935 $w itemconfigure $edge -fill $itk_option(-highlightcolor) 02936 set _dragItem $edge 02937 scan [$w coords $node1] "%f %f" x1 y1 02938 scan [$w coords $node2] "%f %f" x2 y2 02939 moveEdge $w $x1 $y1 $x2 $y2 02940 set _dragItem "" 02941 02942 if {! [itemVisible $w $node2]} { 02943 centerOnItem $w $node2 02944 } 02945 } 02946 02947 set _computing 0 02948 02949 # maybe call back release handler 02950 if {1 == $_released} { 02951 kb_change_edge $w $a $k 02952 } 02953 } 02954 02955 ## ---------------------------------------------------------------------- 02956 ## Handle Shift-ed keyboard editing events: 02957 ## actually change the subordination 02958 ## ---------------------------------------------------------------------- 02959 body ParseTree::kb_change_edge {w a k} { 02960 02961 # maybe defer action until later 02962 if {1 == $_computing} { 02963 set _released 1 02964 return 02965 } 02966 02967 set level $_levelOfCanvas($w) 02968 set oldregent [$_parse getModifiee $level $_kb_word] 02969 02970 # actually edit 02971 if {$oldregent != $_kb_regent} { 02972 02973 $_parse shiftEdge $level $_kb_word $_kb_regent 02974 02975 # supply history 02976 $_commandHistory add\ 02977 [code "$this undoEdge $_kb_word $_kb_regent $level"]\ 02978 [code "$this undoEdge $_kb_word $oldregent $level"] 02979 02980 # redraw 02981 reDrawLevel $level 02982 drawArcs 02983 drawViolas 02984 paintTabs 02985 } 02986 02987 # close keyboard editing action 02988 $w itemconfigure node -fill $itk_option(-nodecolor) 02989 $w itemconfigure edge -fill $itk_option(-edgecolor) 02990 set _kb_regent -2 02991 02992 set _released 0 02993 02994 } 02995 02996 ## ---------------------------------------------------------------------- 02997 ## Handle Control-ed keyboard events: 02998 ## select the hypothetical new label 02999 ## ---------------------------------------------------------------------- 03000 body ParseTree::kb_select_label {w a k} { 03001 03002 set _computing 1 03003 03004 set level $_levelOfCanvas($w) 03005 set edge [edgeOfTimepoint $w $_kb_word] 03006 set item [labelOfEdge $w $edge] 03007 set binding [$_parse getBindingAt $level $_kb_word] 03008 scan $binding "%s %s %s %s %s" a b c d e 03009 set current $c 03010 03011 # When Control is pressed, nothing happens, but the list of 03012 # possible alternative labels is built because we might be needing 03013 # it soon. 03014 if {[regexp {^Control_[LR]$} $k]} { 03015 set _kb_labels [lsort [.cdgmain levels getLabels $level]] 03016 if {$_kb_labels == ""} { 03017 set _kb_labels [lsort [$_parse getLabels]] 03018 } 03019 set _kb_label [lsearch $_kb_labels $current] 03020 03021 if { -1 == $_kb_label} { 03022 puts "WARNING: _kb_label is -1!" 03023 } 03024 03025 $w itemconfigure label -fill $itk_option(-wordcolor) 03026 $w itemconfigure $item -fill $itk_option(-highlightcolor) 03027 03028 } elseif {$k == "Up"} { 03029 03030 # When Up and Down are pressed, the hypothetical new label is 03031 # changed, and the change is reflected in the string widget of that 03032 # label, but neither the Tcl parse nor the C Parse are actually 03033 # changed yet, because that takes appreciable time. 03034 if {$_kb_label > 0} { 03035 incr _kb_label -1 03036 } 03037 03038 } elseif {$k == "Down"} { 03039 if {$_kb_label < [llength $_kb_labels]} { 03040 incr _kb_label 03041 } 03042 03043 } elseif {$k == "Home"} { 03044 set _kb_label 0 03045 03046 } elseif {$k == "End"} { 03047 set _kb_label [expr [llength $_kb_labels] - 1] 03048 03049 } elseif {$k == "Return"} { 03050 03051 # Return emulates the right mouse button: optimize the current label. 03052 set label [$_parse optimizeLabel $level $_kb_word] 03053 if {"NULL" != $label} { 03054 set _kb_label [lsearch $_kb_labels $label] 03055 } 03056 } 03057 set text [lindex $_kb_labels $_kb_label] 03058 $w itemconfigure $item -text $text 03059 03060 set _computing 0 03061 03062 # Maybe call the key-release handler back 03063 # if it was called too early to do its work 03064 if {1 == $_released} { 03065 kb_change_label $w $a $k 03066 } 03067 } 03068 03069 ## ---------------------------------------------------------------------- 03070 ## Handle Control-ed keyboard editing events: 03071 ## actually change the label 03072 ## ---------------------------------------------------------------------- 03073 body ParseTree::kb_change_label {w a k} { 03074 03075 # detect spurious Control-Release events, i.e. those that 03076 # result from other Control-ed actions. 03077 if {-1 == $_kb_label} return 03078 03079 # If this handler triggers while another handler is running, 03080 # we do not yet know which label to use. This can happen when 03081 # parseOptimizeLabel() has been called. 03082 # 03083 # We would like to just `vwait _computing' and then use the result, 03084 # but Tcl doesn't work like that; the computation cannot continue 03085 # until we ourselves exit. So we exit, but set a flag that will let 03086 # kb_select_label know to call us back when it is ready. 03087 if {1 == $_computing} { 03088 set _released 1 03089 return 03090 } 03091 03092 set level $_levelOfCanvas($w) 03093 set label [lindex $_kb_labels $_kb_label] 03094 labelSelect $level $_kb_word $label 03095 $w itemconfigure label -fill $itk_option(-labelcolor) 03096 03097 set _kb_label -1 03098 03099 set _released 0 03100 } 03101 03102 03103 ## ---------------------------------------------------------------------- 03104 ## Handle Alt keyboard events: 03105 ## select the hypothetical new lexeme 03106 ## ---------------------------------------------------------------------- 03107 body ParseTree::kb_select_lexeme {w a k} { 03108 03109 set _computing 1 03110 03111 set level $_levelOfCanvas($w) 03112 set item [wordOfTimepoint $w $_kb_word] 03113 03114 # When Alt is pressed, nothing happens, but the list of 03115 # possible alternative lexemes is built because we might be needing 03116 # it soon. 03117 if {[regexp {^Alt_[LR]$} $k]} { 03118 set li [$_parse getLexiconItem $_kb_word] 03119 if {"NULL" != $li} { 03120 set desc [LexiconItemStruct_description_get $li] 03121 } 03122 03123 set _kb_lexemes [getAlternativeLexemes $w $item] 03124 set i 0 03125 foreach pair $_kb_lexemes { 03126 if {[lindex $pair 0] == $desc} { 03127 break 03128 } 03129 incr i 03130 } 03131 set _kb_lexeme $i 03132 03133 } elseif {$k == "Up"} { 03134 03135 # When Up and Down are pressed, the hypothetical new lexeme is 03136 # changed, and the change is reflected in the string widget of that 03137 # lexeme, but neither the Tcl parse nor the C Parse are actually 03138 # changed yet, because that takes appreciable time. 03139 if {$_kb_lexeme > 0} { 03140 incr _kb_lexeme -1 03141 } 03142 03143 } elseif {$k == "Down"} { 03144 03145 if {$_kb_lexeme < [llength $_kb_lexemes]} { 03146 incr _kb_lexeme 03147 } 03148 03149 } elseif {$k == "Home"} { 03150 set _kb_lexeme 0 03151 03152 } elseif {$k == "End"} { 03153 set _kb_lexeme [expr [llength $_kb_lexemes] - 1] 03154 03155 } elseif {$k == "Return"} { 03156 03157 # Enter emulates the right mouse click: optimize current word. 03158 set ln [optimizeWord $_kb_word] 03159 set li [LexemNodeStruct_lexem_get $ln] 03160 set d [LexiconItemStruct_description_get $li] 03161 set i 0 03162 03163 foreach pair $_kb_lexemes { 03164 if {[lindex $pair 0] == $d} { 03165 break 03166 } 03167 incr i 03168 } 03169 set _kb_lexeme $i 03170 } 03171 03172 # show tooltip 03173 set pair [lindex $_kb_lexemes $_kb_lexeme] 03174 set text [lindex $pair 0] 03175 03176 scan [$w bbox $item] "%f %f %f %f" x1 y1 x2 y2 03177 set wordheight [expr $y2 - $y1] 03178 scan [$w coords $item] "%f %f %f %f" x1 y1 x2 y2 03179 scan [canvasToScreen $w $x1 $y1] "%d %d" x y 03180 .cdgmain balloon on $x [expr 5+ int($y + $wordheight)] $text now 03181 set _computing 0 03182 03183 # maybe call back release handler 03184 if {1 == $_released} { 03185 kb_change_lexeme $w $a $k 03186 } 03187 03188 03189 } 03190 03191 ## ---------------------------------------------------------------------- 03192 ## Handle Alt keyboard editing events: 03193 ## actually change the lexeme 03194 ## ---------------------------------------------------------------------- 03195 body ParseTree::kb_change_lexeme {w a k} { 03196 03197 # maybe defer action until later 03198 if {1 == $_computing} { 03199 set _released 1 03200 return 03201 } 03202 03203 # actually change the parse 03204 set command [lindex [lindex $_kb_lexemes $_kb_lexeme] 1] 03205 eval $command 03206 03207 # remove tooltip 03208 .cdgmain balloon off 03209 03210 set _released 0 03211 } 03212 03213 03214 ## ---------------------------------------------------------------------- 03215 ## Switch to the previous level of description. 03216 ## ---------------------------------------------------------------------- 03217 body ParseTree::backwardLevel {} { 03218 set tbn $itk_component(tbn) 03219 $tbn prev 03220 } 03221 03222 ## ---------------------------------------------------------------------- 03223 ## Switch to the next level of description. 03224 ## ---------------------------------------------------------------------- 03225 body ParseTree::forwardLevel {} { 03226 set tbn $itk_component(tbn) 03227 $tbn next 03228 } 03229 03230 ## ---------------------------------------------------------------------- 03231 ## Scroll canvas up a step. 03232 ## ---------------------------------------------------------------------- 03233 body ParseTree::mouseScrollUp {w} { 03234 $w yview scroll 1 units 03235 } 03236 03237 ## ---------------------------------------------------------------------- 03238 ## Scroll canvas down a step. 03239 ## ---------------------------------------------------------------------- 03240 body ParseTree::mouseScrollDown {w} { 03241 $w yview scroll -1 units 03242 }