Annotation of capa/capa51/GUITools/gradesubjective.tcl, revision 1.11

1.11    ! albertel    1: # grade subjective responses
        !             2: #  Copyright (C) 1992-2000 Michigan State University
        !             3: #
        !             4: #  The CAPA system is free software; you can redistribute it and/or
        !             5: #  modify it under the terms of the GNU Library General Public License as
        !             6: #  published by the Free Software Foundation; either version 2 of the
        !             7: #  License, or (at your option) any later version.
        !             8: #
        !             9: #  The CAPA system is distributed in the hope that it will be useful,
        !            10: #  but WITHOUT ANY WARRANTY; without even the implied warranty of
        !            11: #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
        !            12: #  Library General Public License for more details.
        !            13: #
        !            14: #  You should have received a copy of the GNU Library General Public
        !            15: #  License along with the CAPA system; see the file COPYING.  If not,
        !            16: #  write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
        !            17: #  Boston, MA 02111-1307, USA.
        !            18: #
        !            19: #  As a special exception, you have permission to link this program
        !            20: #  with the TtH/TtM library and distribute executables, as long as you
        !            21: #  follow the requirements of the GNU GPL in regard to all of the
        !            22: #  software in the executable aside from TtH/TtM.
        !            23: 
1.1       albertel   24: set gMaxSet 99
                     25: 
                     26: proc gradeSubjective {} {
                     27:     global gSubj
                     28: 
                     29:     if { [winfo exists .gradeSubjective] } { return }
                     30:     set var [tk_getOpenFile -title "Please select a capa.config file" -filetypes \
                     31: 		 { { {Capa Config} {capa.config} } }]
                     32:     
                     33:     if { $var != "" } {
                     34: 	set gSubj(dir) [file dirname $var]
                     35: 	cd $gSubj(dir)
                     36:     } else {
                     37: 	return
                     38:     }
                     39:     parseCapaConfig
                     40:     if { "" == [set gSubj(set) [getOneSet {} $gSubj(dir)]] } return
                     41:     if { "" == [set gSubj(quest) [getString {} "Which question?"]] } return
                     42:     set fileid [open "records/set$gSubj(set).db" r]
                     43:     gets $fileid aline
                     44:     gets $fileid aline
                     45:     set gSubj(max) [lindex [split $aline {}] [expr $gSubj(quest) - 1]]
1.9       albertel   46:     set gSubj(keywords) ""
1.1       albertel   47:     createGradeSubjWindow
                     48: }
                     49: 
                     50: proc createGradeSubjWindow {} {
                     51:     global gSubj
                     52: 
                     53:     set gradSubj [toplevel .gradesubjective]
                     54:     wm protocol $gradSubj WM_DELETE_WINDOW "subjDone"
                     55: 
                     56:     set info [frame $gradSubj.info]
                     57:     set grade [frame $gradSubj.grade]
1.7       albertel   58:     set keyword [frame $gradSubj.keyword]
1.1       albertel   59:     set gSubj(pictFrame) [set picts [frame $gradSubj.picts -borderwidth 4 -relief groove]]
1.7       albertel   60:     pack $info $grade $keyword -side top
1.1       albertel   61: 
                     62:     set msg [frame $info.msg]
                     63:     set id [frame $info.id]
                     64:     pack $msg $id -side left
                     65:     
                     66: #    set gSubj(msg) [text $msg.text -width 40 -height 8 -yscrollcommand "$msg.scroll set"]
                     67: #    scrollbar $msg.scroll -command "$msg.text yview"
                     68: #    pack $gSubj(msg) $msg.scroll -side left
                     69: #    pack configure $msg.scroll -fill y
                     70: #    $gSubj(msg) tag configure error -foreground red
                     71: #    $gSubj(msg) tag configure info -foreground #006c00
                     72: 
                     73:     set msglist [frame $msg.msglist]
                     74:     set msgbutton [frame $msg.msgbutton]
                     75:     pack $msglist $msgbutton -side top
                     76:     pack configure $msgbutton -anchor w
                     77: 
1.2       albertel   78:     set gSubj(responseList) [listbox $msglist.list -width 40 -height 5 \
                     79: 				 -yscrollcommand "$msglist.scroll set"]
1.4       albertel   80:     scrollbar $msglist.scroll -command "$msglist.list yview"
1.2       albertel   81:     pack $gSubj(responseList) $msglist.scroll -side left
1.1       albertel   82:     pack configure $msglist.scroll -fill y
                     83:     
                     84:     set gSubj(numresponse) 0
                     85: 
                     86:     button $msgbutton.send -text Send -command subjSendResponse
                     87:     button $msgbutton.new -text New -command subjNewResponse
                     88:     button $msgbutton.delete -text Delete -command subjDeleteResponse
                     89:     button $msgbutton.view -text View -command subjViewResponse
                     90:     button $msgbutton.edit -text Edit -command subjEditResponse
                     91:     pack $msgbutton.send $msgbutton.new $msgbutton.delete $msgbutton.view \
                     92: 	$msgbutton.edit -side left
                     93: 
                     94:     set idlist [frame $id.idlist]
                     95:     set idbutton [frame $id.idbutton]
                     96:     pack $idlist $idbutton -side top
                     97:     pack configure $idbutton -anchor w
                     98: 
                     99:     set gSubj(idlist) [listbox $idlist.list -width 34 -height 5 \
                    100: 			   -yscrollcommand "$idlist.scroll set"]
                    101:     scrollbar $idlist.scroll -command "$idlist.list yview"
                    102:     pack $idlist.list $idlist.scroll -side left
                    103:     pack configure $idlist.scroll -fill y
                    104: 
                    105:     button $idbutton.delete -text Delete -command subjDeleteId
1.3       albertel  106:     frame $idbutton.spacer -width 30
                    107:     label $idbutton.l1 -text "\# Words:"
                    108:     label $idbutton.words -textvariable gSubj(numwords)
                    109:     pack $idbutton.delete $idbutton.spacer $idbutton.l1 $idbutton.words -side left 
1.1       albertel  110:     
                    111:     set response [frame $grade.response]
                    112:     pack $response 
                    113: 
                    114:     set scoreandcom [toplevel $gradSubj.scoreandcom]
                    115:     wm title $scoreandcom "Control Panel"  
1.5       albertel  116:     wm protocol $scoreandcom WM_DELETE_WINDOW "subjDone"
1.1       albertel  117: 
                    118:     set score [frame $scoreandcom.score]
                    119:     set command [frame $scoreandcom.command]
                    120:     set morebut [frame $scoreandcom.morebut]
                    121:     set stat [frame $scoreandcom.stat]
                    122:     pack $score $command $morebut $stat -side top
                    123: 
                    124:     set command1 [frame $command.command1]
                    125:     set command2 [frame $command.command2]
                    126:     pack $command1 $command2 -side left
                    127: 
                    128:     set top [frame $response.top]
                    129:     set bot [frame $response.bot]
                    130:     pack $top $bot -side top
                    131:     pack configure $bot -expand 0 -fill x
                    132: 
                    133:     set gSubj(response) [text $top.response -width 80 -height 21 \
                    134: 			     -yscrollcommand "$top.scroll set" \
                    135: 			     -xscrollcommand "$bot.scroll set"]
                    136:     scrollbar $top.scroll -command "$top.response yview"
                    137:     pack $gSubj(response) $top.scroll -side left
                    138:     pack configure $top.scroll -fill y
                    139: 
                    140:     scrollbar $bot.scroll -orient h -command "$top.response xview"
                    141:     pack $bot.scroll 
                    142:     pack configure $bot.scroll -expand 0 -fill x
                    143: 
1.7       albertel  144:     set left [frame $keyword.left]
                    145:     set left2 [frame $keyword.left2]
                    146:     set right [frame $keyword.right]
                    147:     pack $left $left2 $right -side left
                    148: 
                    149:     set gSubj(keyword) [text $right.keyword -width 60 -height 5 \
                    150: 			    -yscrollcommand "$right.scroll set" ]
                    151:     scrollbar $right.scroll -command "$right.response yview"
                    152:     pack $gSubj(keyword) $right.scroll -side left
                    153:     pack configure $right.scroll -fill y
                    154: 
1.9       albertel  155:     bindtags $gSubj(keyword) "$gSubj(keyword) all"
                    156:     bind $gSubj(keyword) <1> "[bind Text <1>][bind Text <Double-1>]"
                    157: 
1.7       albertel  158:     button $left.add -command "subjAddKeyword" -text "Add"
                    159:     button $left2.addsp -command "subjAddKeywordSpelling" -text "Add Sp"
                    160:     button $left.delete -command "subjDeleteKeyword" -text "Delete"
                    161:     button $left2.see -command "subjSeeKeyword" -text "See Sp"
                    162:     pack $left.add $left2.addsp $left.delete $left2.see -side top
                    163: 
1.1       albertel  164:     wm geometry $gradSubj "-10+0"
                    165: 
                    166:     set score0 [frame $score.score0]
                    167:     set score1 [frame $score.score1]
                    168:     pack $score0 $score1 -side top
                    169: 
                    170:     for {set i 0} {$i < 10 } { incr i } {
                    171: 	set parent [eval set "score[expr $i/5]"]
                    172: 	set a [frame $parent.score$i -relief sunken -borderwidth 1]
                    173: 	if { $gSubj(max) < $i} {
                    174: 	    radiobutton $a.score$i -text $i -variable gSubj(score) \
                    175: 		-value $i -state disabled
                    176: 	} else {
                    177: 	    radiobutton $a.score$i -text $i -variable gSubj(score) -value $i
                    178: 	}
                    179: 	pack $parent.score$i $a.score$i -side left
                    180:     }
                    181: 
                    182:     set buttonwidth 8
                    183:     set gSubj(wrap) 1;set gSubj(pict) 0
                    184:     button $command1.setnext -text "Grade&Next" -command "subjSet;subjNext" \
                    185: 	-width $buttonwidth
                    186:     button $command2.set -text "Grade" -command subjSet -width $buttonwidth
                    187:     frame  $command1.space1 -height 30
                    188:     frame  $command2.space2 -height 30
                    189:     frame  $command2.space22 -height 5
                    190:     button $command1.next -text "Next" -command subjNext -width $buttonwidth
1.7       albertel  191:     button $command1.prev -text "Prev" -command subjPrev -width $buttonwidth
                    192:     button $command1.goto -text "GoTo" -command subjGoto -width $buttonwidth
                    193:     button $command1.exit -text "Exit" -command subjDone -width $buttonwidth
                    194:     button $command2.findid -text "Find ID" -command subjFindId -width $buttonwidth
1.1       albertel  195:     button $command2.addid -text "Add ID" -command subjAddId -width $buttonwidth
1.7       albertel  196:     button $command2.findname -text "Find Name" -command subjFindName -width $buttonwidth
1.1       albertel  197:     checkbutton $command2.wrap -text wrap -command subjWrap -variable gSubj(wrap)
                    198:     checkbutton $command2.pict -text pict -command subjPict -variable gSubj(pict)
                    199:     checkbutton $command1.done -text graded -variable gSubj(donestat) -state disabled
                    200:     pack $command1.setnext $command2.set $command1.space1 $command2.space2 \
1.7       albertel  201: 	$command1.next $command1.prev $command2.findid \
                    202: 	$command2.addid $command2.findname $command1.goto $command1.exit \
1.1       albertel  203:         $command2.wrap $command2.pict $command1.done $command2.space22
                    204: 
                    205:     button $morebut.print -text "Print Response" -command subjPrint \
                    206: 	-width [expr $buttonwidth*2]
                    207:     pack $morebut.print
                    208: 
                    209:     set gSubj(done) 0
                    210:     set gSubj(togo) 0
                    211:     set gSubj(secAvg) 0.0
                    212:     set gSubj(sec) 0
                    213:     set gSubj(pause) 0
                    214:     label $stat.done -text Done:
                    215:     label $stat.donenum -textvariable gSubj(done) -width 4
                    216:     label $stat.togo -text "To Go:"
                    217:     label $stat.togonum -textvariable gSubj(togo) -width 4
                    218:     label $stat.sec -text Sec:
                    219:     label $stat.secnum -textvariable gSubj(sec) -width 4
                    220:     label $stat.avgsec -text AvgSec:
                    221:     label $stat.avgsecnum -textvariable gSubj(avgsec) -width 4
                    222:     checkbutton $stat.pause -variable gSubj(pause) -text "Pause" -command subjPause
                    223:     pack $stat.done $stat.donenum $stat.togo $stat.togonum -side left 
                    224:     #not packed
                    225:     #$stat.sec $stat.secnum $stat.avgsec $stat.avgsecnum $stat.pause
                    226: 
                    227:     set gSubj(canvas) [canvas $picts.canvas -height 220 \
                    228: 			   -xscrollcommand "$picts.scroll set"]
                    229:     scrollbar $picts.scroll -orient h -command "$picts.canvas xview"
                    230:     pack  $picts.scroll $gSubj(canvas) -fill x
                    231:     subjInit
                    232: }
                    233: 
                    234: proc subjWrap {} {
                    235:     global gSubj 
                    236:     if { $gSubj(wrap) } {
                    237: 	$gSubj(response) configure -wrap char
                    238:     } else {
                    239: 	$gSubj(response) configure -wrap none
                    240:     }
                    241: }
                    242: 
                    243: proc updateSecCount {} {
                    244:     global gSubj
                    245:     
                    246:     if { [catch {set gSubj(pause)}] } { return }
                    247:     if { !$gSubj(pause) } {set gSubj(sec) [expr {[clock seconds] - $gSubj(seconds)}]}
                    248:     after 300 updateSecCount
                    249: }
                    250: 
                    251: proc subjCheckForNew {} {
                    252:     global gSubj
1.10      albertel  253:  
                    254:     foreach file [glob ?????????] {
                    255: 	if { [lsearch $gSubj(stunums) $file] == -1 } { lappend gSubj(stunums) $file }
                    256:     }
                    257:     set gSubj(togo) [expr [llength $gSubj(stunums)]-$gSubj(done)]
1.1       albertel  258: }
                    259: 
1.5       albertel  260: proc checkGSubj {} {
                    261:     global gSubj
                    262:     if {[catch {set gSubj(stunums)}]} {
                    263: 	cd [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest)]
                    264: 	set gSubj(stunums) [lsort -dictionary [glob *]]
                    265: 	if { [set num [lsearch $gSubj(stunums) gradingstatus]] != -1} {
                    266: 	    set gSubj(stunums) [lreplace $gSubj(stunums) $num $num]
                    267: 	}
                    268: 	cd $gSubj(dir)
                    269:     }
                    270:     if {[catch {set gSubj(current)}]} {set gSubj(current) -1}
                    271:     if {[catch {set gSubj(totalsec)}]} {set gSubj(totalsec) 0}
                    272:     if {[catch {set gSubj(seconds)}]} {set gSubj(seconds) [clock seconds]}
                    273:     if {[catch {set gSubj(togo)}]} {set gSubj(togo) [llength $gSubj(stunums)]}
                    274:     if {[catch {set gSubj(allstunum)}] || 
                    275: 	[catch {set gSubj(allname)}] || 
                    276: 	[catch {set gSubj(allemail)}] } {
                    277: 	subjInitAllLists
                    278:     }
                    279: }
                    280: 
1.1       albertel  281: proc subjRestore {} {
                    282:     global gSubj
                    283:     source gradingstatus
                    284:     subjCheckForNew
                    285:     set gSubj(seconds) [expr {[clock seconds] - $gSubj(sec)}]
                    286:     cd $gSubj(dir)
1.5       albertel  287:     if { [catch {incr gSubj(current) -1}]} { set gSubj(current) -1 }
1.4       albertel  288:     if { $gSubj(redoalllists) } { subjInitAllLists; set gSubj(redoalllists) 0 }
1.5       albertel  289:     checkGSubj
1.4       albertel  290:     subjIndexResponse
1.1       albertel  291:     subjNext
                    292: }
                    293: 
                    294: proc subjSave {} {
                    295:     global gSubj
                    296:     set file [file join $gSubj(dir) records set$gSubj(set) \
                    297: 		  problem$gSubj(quest) gradingstatus]
                    298:     set fileId [open $file w]
1.4       albertel  299:     puts $fileId "array set gSubj \{[array get gSubj]\}"
1.1       albertel  300:     close $fileId
                    301: }
                    302: 
                    303: proc subjDone {} {
                    304:     global gSubj
1.5       albertel  305:     if { [catch {subjSave}] } {
                    306: 	displayMessage "Unable to save."
                    307:     }
1.1       albertel  308:     unset gSubj
                    309:     destroy .gradesubjective
                    310: }
                    311: 
1.4       albertel  312: proc subjInitAllLists {} {
                    313:     global gSubj
                    314:     set i 0
                    315:     catch {unset gSubj(allstunum)}
                    316:     catch {unset gSubj(allname)}
                    317:     catch {unset gSubj(allemail)}
                    318:     set fileId [open classl r]
                    319:     while { 1 } {
                    320: 	incr i
                    321: 	set aline [gets $fileId]
                    322: 	if { [eof $fileId]} {break}
1.10      albertel  323: 	# skip blank lines
                    324: 	if { [string trim $aline] == "" } { continue }
1.4       albertel  325: 	lappend gSubj(allstunum) [string toupper [string range $aline 14 22]]
                    326: 	#lappend gSubj(allname) [string toupper [string range $aline 24 59]]
                    327: 	lappend gSubj(allname) [string range $aline 24 59]
                    328: 	lappend gSubj(allemail) [string range $aline 60 99]
                    329:     }
                    330: }
                    331: 
1.1       albertel  332: proc subjInit {} {
                    333:     global gSubj
                    334:     
                    335:     set dir [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest)]
                    336:     cd $dir
1.4       albertel  337:     set gSubj(redoalllists) 0
1.1       albertel  338:     if { [file exists gradingstatus] } { subjRestore } else {
                    339: 	set gSubj(stunums) [lsort -dictionary [glob *]]
                    340: 	cd $gSubj(dir)
                    341: 	set gSubj(current) -1
                    342: 	set gSubj(totalsec) 0
                    343: 	set gSubj(seconds) [clock seconds]
1.4       albertel  344: 	subjInitAllLists
1.1       albertel  345: 	set gSubj(togo) [llength $gSubj(stunums)]
                    346: 	subjNext
                    347:     }
1.9       albertel  348:     subjUpdateKeywords
1.1       albertel  349:     after 300 updateSecCount
                    350: }
                    351: 
                    352: #FIXME check Ids when adding them to the list of ids
                    353: proc checkId { id } {
                    354:     global gSubj
                    355:     set score [getScore $gSubj(set) $gSubj(quest) $id]
                    356:     if { $score == "-" || $score == "0" } { return 1 }
                    357:     return 0
                    358: }
                    359: 
                    360: proc subjPause {} {
                    361:     global gSubj
                    362:     if { !$gSubj(pause) } { set gSubj(seconds) [expr {[clock seconds] - $gSubj(sec)}] }
                    363: }
                    364: 
                    365: proc subjStatusUpdate {} {
                    366:     global gSubj
                    367:     
                    368:     set gSubj(done) [llength [array names gSubj "done.*.score"]]
                    369:     set total [llength $gSubj(stunums)]
                    370:     set gSubj(togo) [expr $total-$gSubj(done)]
                    371:     incr gSubj(totalsec) [expr {[clock seconds] - $gSubj(seconds)}]
                    372:     set gSubj(avgsec) [format %4.1f [expr $gSubj(totalsec)/double($gSubj(done))]]
                    373: #    puts $gSubj(avgsec)
                    374:     set gSubj(seconds) [clock seconds]
                    375: }
                    376: 
                    377: proc subjSet {} {
                    378:     global gSubj
                    379: 
                    380: #    if {$gSubj(togo) == 0} { return }
                    381:     if {$gSubj(score) == "" } { subjMessage "Please select a score." error; return }
                    382:     set idlist [subjGetIdList]
                    383:     foreach id $idlist {
                    384: 	setScore $gSubj(set) $gSubj(quest) $id $gSubj(score)
                    385:     }
                    386:     set id [lindex $gSubj(stunums) $gSubj(current)]
                    387:     set gSubj(done.$id.idlist) $idlist
                    388:     set gSubj(done.$id.score) $gSubj(score)
                    389:     set gSubj(donestat) 1
                    390:     subjStatusUpdate
                    391:     subjSave
                    392: }
                    393: 
                    394: proc subjNext {} {
                    395:     global gSubj
                    396: 
                    397:     set gSubj(score) ""
                    398:     set gSubj(pict) 0
                    399:     subjPict
                    400:     incr gSubj(current)
                    401:     if { [llength $gSubj(stunums)] < $gSubj(current) } { incr gSubj(current) -1 }
                    402:     set id [lindex $gSubj(stunums) $gSubj(current)]
                    403: 
                    404:     $gSubj(response) delete 0.0 end
                    405:     $gSubj(idlist) delete 0 end
                    406: 
                    407:     if { $id != "" } { 
                    408: 	set file [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest) $id]
                    409: 	set fileId [open $file "r"]
                    410: 	$gSubj(response) insert 0.0 [read $fileId [file size $file]]
                    411: 	close $fileId
                    412: 	subjInsertIds $id
                    413:     }
                    414: 
1.3       albertel  415:     append words [string trim [$gSubj(response) get 0.0 end-1c]] " "
                    416:     set ws [format " \t\n"]
                    417:     set gSubj(numwords) [regsub -all -- \[$ws\]+  $words {} b]
1.1       albertel  418:     wm title .gradesubjective "Grading Subjective, Set $gSubj(set), Prob $gSubj(quest), $id"
                    419:     if { [catch {set gSubj(score) $gSubj(done.$id.score)}] } {
                    420: 	set gSubj(score) ""
                    421: 	set gSubj(donestat) 0
                    422: 	update idletasks
                    423: 	subjFindIds
                    424:     } else {
                    425: 	set gSubj(donestat) 1
                    426: 	subjInsertIds $gSubj(done.$id.idlist)
                    427: 	update idletasks
                    428:     }
1.9       albertel  429:     subjUpdateResponse
1.1       albertel  430:     subjPicts
                    431: }
                    432: 
                    433: proc subjFindIds1 {} {
                    434:     global gSubj
                    435: 
                    436:     set text [$gSubj(response) get 0.0 end]
                    437:     set result ""
                    438:     foreach id $gSubj(allstunum) {
                    439: 	if { [regexp -nocase -- $id $text] } {
                    440: 	    lappend result $id
                    441: 	}
                    442:     }
                    443:     return $result
                    444: }
                    445: 
                    446: proc subjFindIds2 {} {
                    447:     global gSubj
                    448: 
                    449:     set text [string toupper [$gSubj(response) get 0.0 end]]
                    450:     set result ""
                    451:     if { [catch {lsearch $text a}] } { 
1.10      albertel  452: 	#puts badlist
                    453: 	return subjFindIds1 
1.1       albertel  454:     } else {
                    455: 	foreach id $gSubj(allstunum) {
                    456: 	    if { [lsearch -glob $text *$id*] != -1 } {
                    457: 		lappend result $id
                    458: 	    }
                    459: 	}
                    460:     }
                    461:     return $result
                    462: }
                    463: 
                    464: proc subjFindIds3 {} {
                    465:     global gSubj
                    466: 
                    467:     set text [string toupper [$gSubj(response) get 0.0 end]]
                    468:     set text [split $text "{}!@\#\$%^&*()_-+=|\\,.<>/?'\";:`~ \n\t"]
                    469:     set result ""
                    470:     foreach word $text {
                    471: 	if { [lsearch -exact $gSubj(allstunum) $word] != -1 } {
                    472: 	    lappend result $word
                    473: 	}
                    474:     }
                    475:     return $result
                    476: }
                    477: 
                    478: proc subjFindIds4 {} {
                    479:     global gSubj
                    480: 
                    481:     set text [string toupper [$gSubj(response) get 0.0 end]]
                    482:     set text [split $text "{}!@\#\$%^&*()_-+=|\\,.<>/?'\";:`~ \n\t"]
                    483:     set result ""
                    484:     foreach id $gSubj(allstunum) {
                    485: 	if { [lsearch -exact $text $id] != -1 } {
                    486: 	    lappend result $id
                    487: 	}
                    488:     }
                    489:     return $result
                    490: }
                    491: 
                    492: proc subjFindId {} {
                    493:     global gSubj
                    494:     puts "4:[time {subjInsertIds [set ids [subjFindIds4]]} ]\t:[llength $ids]"
                    495:     subjPicts
                    496: }
                    497: 
                    498: proc subjFindIds {} {
                    499:     global gSubj
                    500: #    puts "4:[time {subjInsertIds [set ids [subjFindIds4]]} ]\t:[llength $ids]"
                    501:     subjInsertIds [set ids [subjFindIds4]]
                    502: #    puts "3:[time {set ids [subjFindIds3]} 2]\t:[llength $ids]"
                    503: #    puts "2:[time {set ids [subjFindIds2]} 2]\t:[llength $ids]"
                    504: #    puts "1:[time {set ids [subjFindIds1]} 2]\t:[llength $ids]"
                    505: 
                    506: }
                    507: 
                    508: proc subjFindName {} {
                    509:     global gSubj
                    510:     
                    511:     if {[catch {set text [string toupper [$gSubj(response) get sel.first sel.last]]}]} {
                    512: 	set text [string toupper [$gSubj(response) get 0.0 end]]
                    513:     }
                    514:     set text [split $text "{}!@\#\$%^&*()_-+=|\\,.<>/?'\";:`~ \n\t"]
                    515:     set result ""
                    516:     set length [llength $gSubj(allname)]
                    517:     foreach word $text {
                    518: 	if { [string length $word] == 0 } { continue }
                    519: 	for { set i 0 } { $i < $length } { incr i } {
                    520: 	    set name [string toupper [lindex $gSubj(allname) $i]]
                    521: 	    if { [set find [lsearch -glob $name *$word*]] != -1 } {
                    522: 		lappend result $i
                    523: 	    }
                    524: 	}
                    525:     }
                    526:     set result [lunique $result]
                    527:     foreach index $result {
                    528: 	lappend temp [list [lindex $gSubj(allstunum) $index] \
                    529: 			  [lindex $gSubj(allname) $index]]
                    530:     }
                    531:     if {[catch {set temp [lsort $temp]}]} {
                    532: 	displayMessage "No Student found."
                    533: 	return
                    534:     }
                    535:     set selected [multipleChoice {} "Select which student you want." $temp 1]
                    536:     if {$selected == ""} { return }
                    537:     set done 0
                    538:     if { [llength $selected] == 2 } { 
                    539: 	if { [lindex [lindex $selected 0] 0] == "" } { 
                    540: 	    set selected [lindex $selected 0]
                    541: 	    set done 1
                    542: 	}
                    543:     }
                    544:     if { !$done } { foreach person $selected { lappend idlist [lindex $selected 0] } }
                    545:     subjInsertIds $idlist
                    546:     subjPicts
                    547: }
                    548: 
                    549: proc subjGetNameFromId { id } {
                    550:     global gSubj
                    551:     return [lindex $gSubj(allname) [lsearch $gSubj(allstunum) $id]]
                    552: }
                    553: 
                    554: proc subjGetIdList {} {
                    555:     global gSubj
                    556:     set list [$gSubj(idlist) get 0 end]
                    557:     set id ""
                    558:     foreach element $list {
                    559: 	append id "[lindex $element 0] "
                    560:     }
                    561:     return $id
                    562: }
                    563: 
                    564: proc subjInsertIds { selected } {
                    565:     global gSubj
                    566:     set current [subjGetIdList]
                    567:     foreach person $selected {lappend current [lindex $person 0]}
                    568:     set current [lsort [lunique $current]]
                    569:     $gSubj(idlist) delete 0 end
                    570:     foreach id $current {
                    571: 	$gSubj(idlist) insert end "$id [subjGetNameFromId $id]"
                    572:     }
                    573: }
                    574: 
                    575: proc subjDeleteId {} {
                    576:     global gSubj
                    577:     $gSubj(idlist) delete [$gSubj(idlist) curselection]
                    578:     subjPicts
                    579: }
                    580: 
                    581: proc subjAddId {} {
                    582:     global gSubj
                    583:     getOneStudent {} $gSubj(dir) id name
                    584:     if { $id == "" } { return }
                    585:     subjInsertIds $id
                    586: }
                    587: 
                    588: proc subjPrev {} {
                    589:     global gSubj
                    590:     if  { $gSubj(current) > 0 } {
                    591: 	incr gSubj(current) -2
                    592: 	subjNext
                    593:     }
                    594: }
                    595: 
                    596: proc subjMessage { mesg {tag normal} } {
                    597:     global gSubj
1.5       albertel  598:     displayMessage $mesg
1.1       albertel  599: #    $gSubj(msg) insert end "[clock format [clock seconds] -format {%I:%M:%S}] - $mesg\n" $tag
                    600: #    $gSubj(msg) see end
                    601: }
                    602: 
                    603: proc subjAddPict { id } {
                    604:     global gSubj
                    605:     set gif [file join $gSubj(dir) photo gif $id.gif]
                    606:     if { ![file exists $gif] } { return }
                    607:     lappend gSubj(imagelist) [set image [image create photo]]
                    608:     $image read $gif
                    609:     set a [llength $gSubj(imagelist)]
                    610:     $gSubj(canvas) create image [expr ($a-1)*200] 20 -image $image -anchor nw
                    611:     $gSubj(canvas) create text [expr ($a-1)*200] 10 -text $id -anchor nw
                    612:     $gSubj(canvas) create text [expr ($a-1)*200] 0 -text [subjGetNameFromId $id] \
                    613: 	-anchor nw
                    614:     $gSubj(canvas) configure -scrollregion "1 1 [expr ($a)*200] 200"
                    615:     update idletasks
                    616:     return $a
                    617: }
                    618: 
                    619: proc subjConvertPict { id } {
                    620:     global gSubj
                    621:     set gif [file join $gSubj(dir) photo gif $id.gif]
                    622:     set jpg [file join $gSubj(dir) photo jpg $id.jpg]
                    623:     if { ![file exists $gif] } {
                    624: 	if { [file exists $jpg] } {
                    625: 	    exec djpeg -outfile $gif $jpg
                    626: 	}
                    627:     }
                    628: }
                    629: 
                    630: proc subjPicts {} {
                    631:     global gSubj 
                    632: 
                    633:     $gSubj(canvas) delete all
                    634:     catch { foreach image $gSubj(imagelist) { catch {image delete $image} } }
                    635:     set gSubj(imagelist) ""
                    636:     set idlist [subjGetIdList]
                    637:     foreach id $idlist {
                    638: 	subjConvertPict $id
                    639: 	set num [subjAddPict $id]
                    640:     } 
                    641: }
                    642: 
                    643: proc subjPict {} {
                    644:     global gSubj
                    645:     if { $gSubj(pict) } {
                    646: 	pack $gSubj(pictFrame)
                    647: 	pack configure $gSubj(pictFrame) -fill x
                    648:     } else {
                    649: 	pack forget $gSubj(pictFrame)
                    650:     }
                    651: }
                    652: 
                    653: proc subjPrint {} {
                    654:     global gSubj
                    655:     set lprCommand [getLprCommand quiztemp.txt]
                    656:     if {$lprCommand == "Cancel"} { return }
                    657:   
                    658:     set fileId [open "quiztemp.txt" w] 
                    659:     set subid [lindex $gSubj(stunums) $gSubj(current)]
                    660:     if { $subid != "" } {
                    661: 	set file [file join $gSubj(dir) records set$gSubj(set) \
                    662: 		      problem$gSubj(quest) $subid]
                    663: 	puts $fileId "Submitted at [clock format [file mtime $file ]]"
                    664: 	puts $fileId "By Student:\n [string trimright [subjGetNameFromId $subid]] ($subid)"
                    665:     }
                    666:     if { [llength [subjGetIdList]] > 1 } {
                    667: 	puts $fileId "Additional Authors:"
                    668: 	foreach id [subjGetIdList] {
                    669: 	    if { $id == $subid } { continue }
                    670: 	    puts $fileId " [string trimright [subjGetNameFromId $id]] ($id)"
                    671: 	}
                    672:     }
                    673:     puts $fileId ""
                    674:     puts -nonewline $fileId "[ $gSubj(response) get 0.0 end-1c ]"
                    675:     close $fileId
                    676: 
                    677:     set errorMsg ""
                    678:     set error [catch {set output [ eval "exec $lprCommand" ] } errorMsg ]
                    679:     
                    680:     if { $error == 1 } {
                    681:         displayError "An error occurred while printing: $errorMsg"
                    682:     } else {
                    683: 	displayMessage "Print job sent to the printer.\n $output"
                    684:     }
                    685:     exec rm -f quiztemp.txt
                    686: }
                    687: 
                    688: proc subjGoto {} {
                    689:     global gSubj
                    690:     subjGetOneStudent {} $gSubj(dir) id name
                    691:     if { $id == "" } { return }
                    692:     if { [file exists [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest) $id] ] } {
                    693: 	set gSubj(current) [expr [lsearch $gSubj(stunums) $id] - 1]
                    694: 	subjNext
                    695:     } else {
                    696: 	displayMessage "Student $id did not submit an answer."
                    697:     }
                    698: }
                    699: 
                    700: proc subjGetUngraded {} {
                    701:     global gSubj
                    702: 
                    703:     set idlist ""
                    704:     foreach stunum $gSubj(stunums) {
                    705: 	if {[catch {set gSubj(done.$stunum.score)}]} {
                    706: 	    lappend idlist $stunum
                    707: 	}
                    708:     }
                    709:     return [multipleChoice {} "Select which student you want to grade." $idlist 1]
                    710: }
                    711: 
                    712: proc subjGetOneStudent { window path idVar nameVar {message "" } } {
                    713:     upvar $idVar id
                    714:     upvar $nameVar name
                    715:     
                    716:     set select [tk_dialog $window.dialog "$message Student select method" \
                    717: 		    "Select student by:" "" "" "Student Number" \
                    718: 		    "Student Name" "Not Yet Graded" "Cancel"]
                    719:     if { $select == 3 } { 
                    720: 	set id ""
                    721: 	set name ""
                    722: 	return 
                    723:     }
                    724:     if { $select == 2 } {
                    725: 	set id [subjGetUngraded]
                    726: 	set name [subjGetNameFromId $id]
                    727: 	return
                    728:     }
                    729:     set done 0
                    730:     while { ! $done } {
                    731: 	if { $select } { set search "name" } { set search "number" }
                    732: 	set pattern [ getString $window "$message Please enter a student $search." ]
                    733: 	if {$pattern == "" } {
                    734: 	    set done 1
                    735: 	    set id ""
                    736: 	    set name ""
                    737: 	    continue
                    738: 	}
                    739: 	if { $select } {
                    740: 	    set matched_entries [findByStudentName $pattern $path]
                    741: 	} else {
                    742: 	    set matched_entries [findByStudentNumber $pattern $path]
                    743: 	}
                    744: 	if { [llength $matched_entries] == 0 } {
                    745: 	    displayMessage "No student found. Please re-enter student $search."
                    746: 	} elseif { [llength $matched_entries] == 1 } {
                    747: 	    set id [lindex [lindex $matched_entries 0] 0]
                    748: 	    set name [lindex [lindex $matched_entries 0] 1]
                    749: 	    set done 1
                    750: 	} elseif { [llength $matched_entries] < 30 } {
                    751: 	    set select [ multipleChoice $window \
                    752: 			     "Matched Student Records, Select one" \
                    753: 			     $matched_entries ]
                    754: 	    if { $select == "" } { 
                    755: 		set id ""; set name ""
                    756: 		return 
                    757: 	    }
                    758: 	    set id [lindex $select 0]
                    759: 	    set name [lindex $select 1]
                    760: 	    set done 1
                    761: 	} else {
                    762: 	    displayMessage "There were [llength $matched_entries], please enter more data to narrow the search."
                    763: 	}
                    764:     }
                    765: }
                    766: 
                    767: ###########################################################
                    768: # subjSendResponse
                    769: ###########################################################
                    770: ###########################################################
                    771: ###########################################################
                    772: proc subjSendResponse {} {
1.10      albertel  773:     global gSubj gCapaConfig
1.4       albertel  774: 
                    775:     if { "" == [set which [$gSubj(responseList) curselection]]} {
                    776: 	displayMessage "Please select a message to send."
                    777: 	return
                    778:     }
                    779:     incr which
1.5       albertel  780: 
                    781:     set message ""
1.4       albertel  782: 
                    783:     set stuList [$gSubj(idlist) get 0 end]
                    784:     foreach stu $stuList {
                    785: 	set stu [lindex $stu 0]
                    786: 	set index [lsearch $gSubj(allstunum) $stu]
                    787: 	set name [lindex $gSubj(allname) $index]
                    788: 	set email [lindex $gSubj(allemail) $index]
1.10      albertel  789: 	#puts "$name:[split $name ,]:[lindex [split $name ,] 1]:[lindex [lindex [split $name ,] 1] 0]:$index:$stu"
                    790: 	#puts [lsearch $gSubj(allemail) albertel@pilot.msu.edu]
1.4       albertel  791: 	set first_name [lindex [lindex [split $name ,] 1] 0]
                    792: 	set last_name [lindex [split $name , ] 0]
                    793: 	set score $gSubj(score)
                    794: 	regsub -all -- \\\$last_name $gSubj(response.$which) $last_name message
                    795: 	regsub -all -- \\\$first_name $message $first_name message
                    796: 	regsub -all -- \\\$score $message $score message
                    797: #	set message [subst -nobackslashes -nocommands $gSubj(response.$which)]
                    798: 	if { [regexp -- (^Subject:\[^\n\]*)(\n)(.*) $message matchvar subjline newline messagebody] } {
1.10      albertel  799: 	    set subject "$subjline Class [file tail $gSubj(dir)], Set $gSubj(set), Question $gSubj(quest)"
                    800: 	    set message $messagebody
1.4       albertel  801: 	} else {
1.10      albertel  802: 	    set subject "Subject: Class [file tail $gSubj(dir)], Set $gSubj(set), Question $gSubj(quest)"
1.4       albertel  803: 	}
                    804: 	displayMessage "$message sent to $email"
1.10      albertel  805: 	exec echo $message | $gCapaConfig(mail_command) -s $subject $email
1.4       albertel  806:     }
1.1       albertel  807: }
                    808: 
1.2       albertel  809: ###########################################################
                    810: # subjIndexResponse
                    811: ###########################################################
                    812: ###########################################################
                    813: ###########################################################
1.1       albertel  814: proc subjIndexResponse {} {
                    815:     global gSubj
                    816:     
1.2       albertel  817:     $gSubj(responseList) delete 0 end
1.1       albertel  818: 
                    819:     set i 0
                    820:     foreach element [lsort -dictionary [array names gSubj "response.*"]] {
1.4       albertel  821: 	regsub -all -- "\[\n\r\t\]+" [string range $gSubj($element) 0 37] " " head
                    822: 	$gSubj(responseList) insert end "[incr i].$head"
1.1       albertel  823:     }
                    824: }
                    825: 
                    826: ###########################################################
                    827: # subjSaveResponse
                    828: ###########################################################
                    829: ###########################################################
                    830: ###########################################################
                    831: proc subjSaveResponse {} {
                    832:     global gSubj
                    833:     
                    834:     set num [incr gSubj(numresponse)]
1.4       albertel  835:     set gSubj(response.$num) [$gSubj(responseNew) get 0.0 end-1c]
                    836:     destroy [winfo toplevel $gSubj(responseNew)]
1.1       albertel  837:     subjIndexResponse
1.4       albertel  838:     $gSubj(responseList) selection set end
                    839:     $gSubj(responseList) see end
1.1       albertel  840: }
                    841: 
                    842: ###########################################################
                    843: # subjNewResponse
                    844: ###########################################################
                    845: ###########################################################
                    846: ###########################################################
                    847: proc subjNewResponse {} {
                    848:     global gSubj gWindowMenu
                    849:    
                    850:     if { [winfo exists .addresponse] } { 
                    851: 	capaRaise .addresponse
                    852: 	return 
                    853:     }
                    854:     set response [toplevel .addresponse]
                    855:     $gWindowMenu add command -label "AddingResponse" -command "capaRaise $response"
                    856:     wm title $response "Adding a New Response"  
                    857: 
                    858:     set textFrame [frame $response.text]
                    859:     set buttonFrame [frame $response.button]
1.2       albertel  860:     pack $textFrame $buttonFrame
1.1       albertel  861: 
1.4       albertel  862:     set gSubj(responseNew) [text $textFrame.text -yscrollcommand \
1.1       albertel  863: 	    "$textFrame.scroll set" -wrap char -height 15]
                    864:     scrollbar $textFrame.scroll -command "$textFrame.text yview"
1.2       albertel  865:     pack $textFrame.text $textFrame.scroll -side left -expand 1
                    866:     pack configure $textFrame.scroll -fill y
1.1       albertel  867: 
                    868:     button $buttonFrame.save -text Save -command "subjSaveResponse"
                    869:     button $buttonFrame.forget -text Cancel -command "destroy $response"
                    870:     pack $buttonFrame.save $buttonFrame.forget -side left
                    871: }
                    872: 
                    873: ###########################################################
                    874: # subjDeleteResponse
                    875: ###########################################################
                    876: ###########################################################
                    877: ###########################################################
                    878: proc subjDeleteResponse {} {
                    879:     global gSubj
1.4       albertel  880:     if { [winfo exists .editresponse] } { 
                    881: 	displayMessage "Please finish with editing the response, before deleting responses."
                    882: 	return
                    883:     }
                    884:     if { "" == [set which [$gSubj(responseList) curselection]]} { return }
                    885:     incr which
                    886:     if { [catch {unset gSubj(response.$which)}] } {
1.10      albertel  887: 	#puts [array names gSubj response.*]
1.4       albertel  888: 	return
                    889:     }
                    890:     for {set i [expr $which + 1]} { [info exists gSubj(response.$i)] } {incr i} {
                    891: 	set j [expr $i - 1]
                    892: 	set gSubj(response.$j) $gSubj(response.$i)
                    893: 	unset gSubj(response.$i)
                    894:     }
                    895:     set gSubj(numresponse) [expr $i - 2]
                    896:     subjIndexResponse
                    897:     $gSubj(responseList) see [incr which -2]
1.1       albertel  898: }
                    899: 
                    900: ###########################################################
                    901: # subjEditResponse
                    902: ###########################################################
                    903: ###########################################################
                    904: ###########################################################
                    905: proc subjEditResponse {} {
1.4       albertel  906:     global gSubj gWindowMenu
                    907: 
                    908:     if { [winfo exists .editresponse] } { capaRaise .editresponse ; return }
                    909:     if { "" == [set which [$gSubj(responseList) curselection]]} { return }
                    910:     incr which
                    911: 
                    912:     set response [toplevel .editresponse ]
                    913:     $gWindowMenu add command -label "EditingResponse" -command "capaRaise $response"
                    914:     wm title $response "Editing a Response"  
                    915: 
                    916:     set textFrame [frame $response.text]
                    917:     set buttonFrame [frame $response.button]
                    918:     pack $textFrame $buttonFrame
                    919: 
                    920:     set gSubj(responseEdit) [text $textFrame.text -yscrollcommand \
                    921: 	    "$textFrame.scroll set" -wrap char -height 15]
                    922:     scrollbar $textFrame.scroll -command "$textFrame.text yview"
                    923:     pack $textFrame.text $textFrame.scroll -side left -expand 1
                    924:     pack configure $textFrame.scroll -fill y
                    925:     $gSubj(responseEdit) insert 0.0 $gSubj(response.$which)
                    926: 
                    927:     set gSubj(editresponsedone) 0
                    928:     button $buttonFrame.save -text Save -command "set gSubj(editresponsedone) 1"
                    929:     button $buttonFrame.forget -text Cancel -command "set gSubj(editresponsedone) 0"
                    930:     pack $buttonFrame.save $buttonFrame.forget -side left
                    931:     vwait gSubj(editresponsedone)
                    932:     if { $gSubj(editresponsedone) } {
                    933: 	set gSubj(response.$which) [$gSubj(responseEdit) get 0.0 end-1c]	
                    934: 	subjIndexResponse
                    935: 	$gSubj(responseList) selection set $which
                    936: 	$gSubj(responseList) see $which
                    937:     } 
                    938:     destroy $response
1.1       albertel  939: }
                    940: 
                    941: ###########################################################
                    942: # subjViewResponse
                    943: ###########################################################
                    944: ###########################################################
                    945: ###########################################################
                    946: proc subjViewResponse {} {
1.4       albertel  947:     global gSubj gUniqueNumber gWindowMenu
                    948: 
                    949:     if { "" == [set which [$gSubj(responseList) curselection]]} { return }
                    950:     incr which
                    951:     set num [incr gUniqueNumber]
                    952: 
                    953:     set response [toplevel .viewresponse$num ]
                    954:     $gWindowMenu add command -label "ViewingResponse $which" \
                    955: 	-command "capaRaise $response"
                    956:     wm title $response "Viewing Response $which"  
                    957: 
                    958:     set textFrame [frame $response.text]
                    959:     set buttonFrame [frame $response.button]
                    960:     pack $textFrame $buttonFrame
                    961: 
                    962:     text $textFrame.text -yscrollcommand "$textFrame.scroll set" -wrap char -height 15
                    963:     scrollbar $textFrame.scroll -command "$textFrame.text yview"
                    964:     pack $textFrame.text $textFrame.scroll -side left -expand 1
                    965:     pack configure $textFrame.scroll -fill y
                    966:     $textFrame.text insert 0.0 $gSubj(response.$which)
                    967:     $textFrame.text configure -state disabled
                    968: 
                    969:     button $buttonFrame.forget -text Dismiss -command "destroy $response"
                    970:     pack $buttonFrame.forget -side left
1.1       albertel  971: }
1.6       albertel  972: 
                    973: ###########################################################
1.8       albertel  974: # subjUpdateResponse
                    975: ###########################################################
                    976: ###########################################################
                    977: ###########################################################
                    978: proc subjUpdateResponse {} {
1.9       albertel  979:     global gSubj
                    980: 
                    981:     $gSubj(response) tag delete keyword
                    982:     $gSubj(response) tag configure keyword -background green
                    983:     set startindex 0.0
                    984:     set lastindex [$gSubj(response) index end]
                    985:     while { 1 } {
                    986: 	set endindex [$gSubj(response) index "$startindex wordend"]
                    987: #	puts "$startindex -> $endindex"
                    988: 	set word [string trim [string toupper [$gSubj(response) get $startindex $endindex]]]
                    989: 	if { $word != "" } {
                    990: 	    #	puts "Word :$word:"
                    991: 	    foreach keyword $gSubj(keywords) {
                    992: 		set keyword [string toupper [lindex $keyword 1]]
                    993: 		if { [lsearch -exact $keyword $word] != -1 } {
                    994: 		    $gSubj(response) tag add keyword $startindex $endindex
                    995: 		}
                    996: 	    }
                    997: 	    #	puts [$gSubj(response) index "$endindex+1c"]
                    998: 	    #	puts [$gSubj(response) index "$endindex wordstart"]
                    999: 	    #	puts [$gSubj(response) index "$endindex+1c wordstart"]
                   1000: 	    
                   1001: 	    #	set startindex [$gSubj(response) index "$endindex + 1c"]
                   1002: 	}
                   1003: 	set startindex $endindex
                   1004: 	if { $startindex == $lastindex } { break }
                   1005:     }
1.8       albertel 1006: }
                   1007: 
                   1008: ###########################################################
                   1009: # subjUpdateKeywords
                   1010: ###########################################################
                   1011: ###########################################################
                   1012: ###########################################################
                   1013: proc subjUpdateKeywords {} {
                   1014:     global gSubj
                   1015:     $gSubj(keyword) delete 0.0 end
1.9       albertel 1016:     set lokeyword ""
                   1017: #    puts $gSubj(keywords)
1.8       albertel 1018:     foreach keyword $gSubj(keywords) { lappend lokeyword [lindex $keyword 0] }
1.9       albertel 1019:     if { $lokeyword == "" } { return }
1.8       albertel 1020:     set lokeyword [lsort $lokeyword]
                   1021:     set max 0
                   1022:     foreach key $lokeyword {
                   1023: 	if { [string length $key] > $max } { set max [string length $key] }
                   1024:     }
                   1025:     incr max
                   1026:     set numcol [expr 60/$max]
                   1027:     set end [llength $lokeyword]
                   1028:     set lastline 0
                   1029:     for { set i 0 } { $i < $end } { incr i } {
                   1030: 	set line [expr $i/$numcol]
                   1031: 	set col [expr $i%$numcol*$max]
1.9       albertel 1032: #	puts $line.$col
1.8       albertel 1033: 	$gSubj(keyword) insert end [format "%-[set max]s" [lindex $lokeyword $i]]
                   1034: 	if {($col + (2*$max)) > 60} {
1.9       albertel 1035: #	    puts "Putting in newlne"
1.8       albertel 1036: 	    $gSubj(keyword) insert end "\n"
                   1037: 	    set lastline $line
                   1038: 	}
                   1039:     }
                   1040:     subjUpdateResponse
                   1041: }
                   1042: 
                   1043: ###########################################################
1.6       albertel 1044: # subjAddKeyword
                   1045: ###########################################################
                   1046: ###########################################################
                   1047: ###########################################################
                   1048: proc subjAddKeyword {} {
1.9       albertel 1049:     global gSubj 
1.8       albertel 1050: 
1.9       albertel 1051:     if { "" == [set newword [getString [winfo toplevel $gSubj(keyword)] "Enter a new keyword" nospace ]]} {
1.8       albertel 1052: 	return
                   1053:     }
1.9       albertel 1054:     set i 0
                   1055:     foreach keyword $gSubj(keywords) {
                   1056: 	if {-1 != [lsearch $keyword $newword]} { break }
                   1057: 	incr i
                   1058:     }
                   1059:     if { $i >= [llength $gSubj(keywords)] } {
                   1060:         lappend gSubj(keywords) [list $newword [list $newword]]
                   1061: 	subjUpdateKeywords
                   1062:     }
                   1063: }
                   1064: 
                   1065: ###########################################################
                   1066: # subjAddKeywordSpelling
                   1067: ###########################################################
                   1068: ###########################################################
                   1069: ###########################################################
                   1070: proc subjAddKeywordSpelling {} {
                   1071:     global gSubj
                   1072: 
                   1073:     if { [catch {set word [$gSubj(keyword) get sel.first sel.last]}]} { return }
                   1074:     if { "" == [set newspell [getString [winfo toplevel $gSubj(keyword)] "Enter a new spelling for $word" nospace ]]} {
                   1075: 	return
                   1076:     }
                   1077:     set i 0
                   1078:     foreach keyword $gSubj(keywords) {
                   1079: 	if {-1 != [lsearch $keyword $word]} { break }
                   1080: 	incr i
                   1081:     }
                   1082: 
                   1083:     set gSubj(keywords) [lreplace $gSubj(keywords) $i $i \
                   1084: 			     [list $word [concat [lindex $keyword 1] $newspell]]]
                   1085:     subjUpdateKeywords
                   1086: }
                   1087: 
                   1088: ###########################################################
                   1089: # subjSeeKeyword
                   1090: ###########################################################
                   1091: ###########################################################
                   1092: ###########################################################
                   1093: proc subjSeeKeyword {} {
                   1094:     global gSubj gPromptMC
                   1095:     
                   1096:     if { [catch {set word [$gSubj(keyword) get sel.first sel.last]}]} { return }
                   1097:     set i 0
                   1098:     foreach keyword $gSubj(keywords) {
                   1099: 	if {-1 != [lsearch $keyword $word]} { break }
                   1100: 	incr i
                   1101:     }
                   1102: 
                   1103:     set which $i
                   1104:     set setWin [toplevel $gSubj(keyword).keyword]
                   1105:     
                   1106:     set msgFrame [frame $setWin.msgFrame]
                   1107:     set valFrame [frame $setWin.valFrame]
                   1108:     set buttonFrame [frame $setWin.buttonFrame]
                   1109:     pack $msgFrame $valFrame $buttonFrame
                   1110:     pack configure $valFrame -expand 1 -fill both
                   1111: 
                   1112:     message $msgFrame.msg -text "Alternate spellings for [lindex $keyword 0]" \
                   1113: 	-aspect 3000
                   1114:     pack $msgFrame.msg
                   1115:     
                   1116:     set maxWidth 1
                   1117:     foreach choice [lindex $keyword 1] {
                   1118: 	if {[string length $choice] > $maxWidth} {set maxWidth [string length $choice]}
                   1119:     }
                   1120:     listbox $valFrame.val -width [expr $maxWidth + 2] \
                   1121: 	-yscrollcommand "$valFrame.scroll set" -selectmode single
                   1122:     scrollbar $valFrame.scroll -command "$valFrame.val yview"
                   1123:     pack $valFrame.val $valFrame.scroll -side left
                   1124:     pack configure $valFrame.val -expand 1 -fill both 
                   1125:     pack configure $valFrame.scroll -expand 0 -fill y
                   1126:     foreach choice [lsort [lrange [lindex $keyword 1] 1 end]] { 
                   1127: 	$valFrame.val insert end $choice 
                   1128:     }
                   1129: 
                   1130:     button $buttonFrame.select -text "Delete" -command { set gPromptMC(ok) 1 }
                   1131:     frame $buttonFrame.spacer -width 10
                   1132:     button $buttonFrame.cancel -text "Dismiss" -command { set gPromptMC(ok) 0 }
                   1133:     pack $buttonFrame.select $buttonFrame.cancel -side left
                   1134: 
                   1135:     bind $setWin <Return> "set gPromptMC(ok) 0"
                   1136:     Centre_Dialog $setWin default
                   1137:     update idletasks
                   1138:     focus $setWin
                   1139:     capaRaise $setWin
                   1140:     capaGrab $setWin
                   1141:     while { 1 } {
                   1142: 	update idletasks
                   1143: 	vwait gPromptMC(ok)
                   1144: 	if { $gPromptMC(ok) == 0 } { break }
                   1145: 	set select [$valFrame.val curselection]
                   1146: 	if { $select != "" } { 
                   1147: 	    $valFrame.val delete $select
                   1148: 	} 
                   1149:     }
                   1150:     set spellings [lindex $keyword 0]
                   1151:     for {set i 0} {$i < [$valFrame.val index end]} { incr i } { 
                   1152: 	lappend spellings [$valFrame.val get $i]
                   1153:     }
                   1154:     capaGrab release $setWin
                   1155:     destroy $setWin
                   1156: 
                   1157:     set gSubj(keywords) [lreplace $gSubj(keywords) $which $which \
                   1158: 			     [list [lindex $keyword 0] $spellings ]]
                   1159: 
1.8       albertel 1160:     subjUpdateKeywords
1.6       albertel 1161: }
1.9       albertel 1162: 
                   1163: ###########################################################
                   1164: # subjDeleteKeyword
                   1165: ###########################################################
                   1166: ###########################################################
                   1167: ###########################################################
                   1168: proc subjDeleteKeyword {} {
                   1169:     global gSubj
                   1170:     
                   1171:     if { [catch {set word [$gSubj(keyword) get sel.first sel.last]}]} { return }
                   1172:     set newkeyword ""
                   1173:     foreach keyword $gSubj(keywords) {
                   1174: 	if {-1 == [lsearch $keyword $word]} { lappend newkeyword $keyword }
                   1175:     }
                   1176:     set gSubj(keywords) $newkeyword
                   1177:     subjUpdateKeywords
1.11    ! albertel 1178: }

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>