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