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>
![[BACK]](/icons/back.gif){kind=icon}
Return to gradesubjective.tcl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / capa / capa51 / GUITools