File:
[LON-CAPA] /
capa /
capa51 /
GUITools /
gradesubjective.tcl
Revision
1.12:
download - view:
text,
annotated -
select for diffs
Mon Aug 7 20:47:29 2000 UTC (24 years, 2 months ago) by
albertel
Branches:
MAIN
CVS tags:
version_2_9_X,
version_2_9_99_0,
version_2_9_1,
version_2_9_0,
version_2_8_X,
version_2_8_99_1,
version_2_8_99_0,
version_2_8_2,
version_2_8_1,
version_2_8_0,
version_2_7_X,
version_2_7_99_1,
version_2_7_99_0,
version_2_7_1,
version_2_7_0,
version_2_6_X,
version_2_6_99_1,
version_2_6_99_0,
version_2_6_3,
version_2_6_2,
version_2_6_1,
version_2_6_0,
version_2_5_X,
version_2_5_99_1,
version_2_5_99_0,
version_2_5_2,
version_2_5_1,
version_2_5_0,
version_2_4_X,
version_2_4_99_0,
version_2_4_2,
version_2_4_1,
version_2_4_0,
version_2_3_X,
version_2_3_99_0,
version_2_3_2,
version_2_3_1,
version_2_3_0,
version_2_2_X,
version_2_2_99_1,
version_2_2_99_0,
version_2_2_2,
version_2_2_1,
version_2_2_0,
version_2_1_X,
version_2_1_99_3,
version_2_1_99_2,
version_2_1_99_1,
version_2_1_99_0,
version_2_1_3,
version_2_1_2,
version_2_1_1,
version_2_1_0,
version_2_12_X,
version_2_11_X,
version_2_11_5_msu,
version_2_11_5,
version_2_11_4_uiuc,
version_2_11_4_msu,
version_2_11_4,
version_2_11_3_uiuc,
version_2_11_3_msu,
version_2_11_3,
version_2_11_2_uiuc,
version_2_11_2_msu,
version_2_11_2_educog,
version_2_11_2,
version_2_11_1,
version_2_11_0_RC3,
version_2_11_0_RC2,
version_2_11_0_RC1,
version_2_11_0,
version_2_10_X,
version_2_10_1,
version_2_10_0_RC2,
version_2_10_0_RC1,
version_2_10_0,
version_2_0_X,
version_2_0_99_1,
version_2_0_2,
version_2_0_1,
version_2_0_0,
version_1_99_3,
version_1_99_2,
version_1_99_1_tmcc,
version_1_99_1,
version_1_99_0_tmcc,
version_1_99_0,
version_1_3_X,
version_1_3_3,
version_1_3_2,
version_1_3_1,
version_1_3_0,
version_1_2_X,
version_1_2_99_1,
version_1_2_99_0,
version_1_2_1,
version_1_2_0,
version_1_1_X,
version_1_1_99_5,
version_1_1_99_4,
version_1_1_99_3,
version_1_1_99_2,
version_1_1_99_1,
version_1_1_99_0,
version_1_1_3,
version_1_1_2,
version_1_1_1,
version_1_1_0,
version_1_0_99_3,
version_1_0_99_2,
version_1_0_99_1,
version_1_0_99,
version_1_0_3,
version_1_0_2,
version_1_0_1,
version_1_0_0,
version_0_99_5,
version_0_99_4,
version_0_99_3,
version_0_99_2,
version_0_99_1,
version_0_99_0,
version_0_6_2,
version_0_6,
version_0_5_1,
version_0_5,
version_0_4,
stable_2002_spring,
stable_2002_july,
stable_2002_april,
stable_2001_fall,
release_5-1-3,
loncapaMITrelate_1,
language_hyphenation_merge,
language_hyphenation,
conference_2003,
bz6209-base,
bz6209,
STABLE,
HEAD,
GCI_3,
GCI_2,
GCI_1,
CAPA_5-1-6,
CAPA_5-1-5,
CAPA_5-1-4_RC1,
BZ4492-merge,
BZ4492-feature_horizontal_radioresponse,
BZ4492-feature_Support_horizontal_radioresponse,
BZ4492-Support_horizontal_radioresponse
- fixed license notices the reference the GNU GPL rather than the GNU LGPL
# grade subjective responses
# Copyright (C) 1992-2000 Michigan State University
#
# The CAPA system is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; either version 2 of the
# License, or (at your option) any later version.
#
# The CAPA system is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with the CAPA system; see the file COPYING. If not,
# write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
# As a special exception, you have permission to link this program
# with the TtH/TtM library and distribute executables, as long as you
# follow the requirements of the GNU GPL in regard to all of the
# software in the executable aside from TtH/TtM.
set gMaxSet 99
proc gradeSubjective {} {
global gSubj
if { [winfo exists .gradeSubjective] } { return }
set var [tk_getOpenFile -title "Please select a capa.config file" -filetypes \
{ { {Capa Config} {capa.config} } }]
if { $var != "" } {
set gSubj(dir) [file dirname $var]
cd $gSubj(dir)
} else {
return
}
parseCapaConfig
if { "" == [set gSubj(set) [getOneSet {} $gSubj(dir)]] } return
if { "" == [set gSubj(quest) [getString {} "Which question?"]] } return
set fileid [open "records/set$gSubj(set).db" r]
gets $fileid aline
gets $fileid aline
set gSubj(max) [lindex [split $aline {}] [expr $gSubj(quest) - 1]]
set gSubj(keywords) ""
createGradeSubjWindow
}
proc createGradeSubjWindow {} {
global gSubj
set gradSubj [toplevel .gradesubjective]
wm protocol $gradSubj WM_DELETE_WINDOW "subjDone"
set info [frame $gradSubj.info]
set grade [frame $gradSubj.grade]
set keyword [frame $gradSubj.keyword]
set gSubj(pictFrame) [set picts [frame $gradSubj.picts -borderwidth 4 -relief groove]]
pack $info $grade $keyword -side top
set msg [frame $info.msg]
set id [frame $info.id]
pack $msg $id -side left
# set gSubj(msg) [text $msg.text -width 40 -height 8 -yscrollcommand "$msg.scroll set"]
# scrollbar $msg.scroll -command "$msg.text yview"
# pack $gSubj(msg) $msg.scroll -side left
# pack configure $msg.scroll -fill y
# $gSubj(msg) tag configure error -foreground red
# $gSubj(msg) tag configure info -foreground #006c00
set msglist [frame $msg.msglist]
set msgbutton [frame $msg.msgbutton]
pack $msglist $msgbutton -side top
pack configure $msgbutton -anchor w
set gSubj(responseList) [listbox $msglist.list -width 40 -height 5 \
-yscrollcommand "$msglist.scroll set"]
scrollbar $msglist.scroll -command "$msglist.list yview"
pack $gSubj(responseList) $msglist.scroll -side left
pack configure $msglist.scroll -fill y
set gSubj(numresponse) 0
button $msgbutton.send -text Send -command subjSendResponse
button $msgbutton.new -text New -command subjNewResponse
button $msgbutton.delete -text Delete -command subjDeleteResponse
button $msgbutton.view -text View -command subjViewResponse
button $msgbutton.edit -text Edit -command subjEditResponse
pack $msgbutton.send $msgbutton.new $msgbutton.delete $msgbutton.view \
$msgbutton.edit -side left
set idlist [frame $id.idlist]
set idbutton [frame $id.idbutton]
pack $idlist $idbutton -side top
pack configure $idbutton -anchor w
set gSubj(idlist) [listbox $idlist.list -width 34 -height 5 \
-yscrollcommand "$idlist.scroll set"]
scrollbar $idlist.scroll -command "$idlist.list yview"
pack $idlist.list $idlist.scroll -side left
pack configure $idlist.scroll -fill y
button $idbutton.delete -text Delete -command subjDeleteId
frame $idbutton.spacer -width 30
label $idbutton.l1 -text "\# Words:"
label $idbutton.words -textvariable gSubj(numwords)
pack $idbutton.delete $idbutton.spacer $idbutton.l1 $idbutton.words -side left
set response [frame $grade.response]
pack $response
set scoreandcom [toplevel $gradSubj.scoreandcom]
wm title $scoreandcom "Control Panel"
wm protocol $scoreandcom WM_DELETE_WINDOW "subjDone"
set score [frame $scoreandcom.score]
set command [frame $scoreandcom.command]
set morebut [frame $scoreandcom.morebut]
set stat [frame $scoreandcom.stat]
pack $score $command $morebut $stat -side top
set command1 [frame $command.command1]
set command2 [frame $command.command2]
pack $command1 $command2 -side left
set top [frame $response.top]
set bot [frame $response.bot]
pack $top $bot -side top
pack configure $bot -expand 0 -fill x
set gSubj(response) [text $top.response -width 80 -height 21 \
-yscrollcommand "$top.scroll set" \
-xscrollcommand "$bot.scroll set"]
scrollbar $top.scroll -command "$top.response yview"
pack $gSubj(response) $top.scroll -side left
pack configure $top.scroll -fill y
scrollbar $bot.scroll -orient h -command "$top.response xview"
pack $bot.scroll
pack configure $bot.scroll -expand 0 -fill x
set left [frame $keyword.left]
set left2 [frame $keyword.left2]
set right [frame $keyword.right]
pack $left $left2 $right -side left
set gSubj(keyword) [text $right.keyword -width 60 -height 5 \
-yscrollcommand "$right.scroll set" ]
scrollbar $right.scroll -command "$right.response yview"
pack $gSubj(keyword) $right.scroll -side left
pack configure $right.scroll -fill y
bindtags $gSubj(keyword) "$gSubj(keyword) all"
bind $gSubj(keyword) <1> "[bind Text <1>][bind Text <Double-1>]"
button $left.add -command "subjAddKeyword" -text "Add"
button $left2.addsp -command "subjAddKeywordSpelling" -text "Add Sp"
button $left.delete -command "subjDeleteKeyword" -text "Delete"
button $left2.see -command "subjSeeKeyword" -text "See Sp"
pack $left.add $left2.addsp $left.delete $left2.see -side top
wm geometry $gradSubj "-10+0"
set score0 [frame $score.score0]
set score1 [frame $score.score1]
pack $score0 $score1 -side top
for {set i 0} {$i < 10 } { incr i } {
set parent [eval set "score[expr $i/5]"]
set a [frame $parent.score$i -relief sunken -borderwidth 1]
if { $gSubj(max) < $i} {
radiobutton $a.score$i -text $i -variable gSubj(score) \
-value $i -state disabled
} else {
radiobutton $a.score$i -text $i -variable gSubj(score) -value $i
}
pack $parent.score$i $a.score$i -side left
}
set buttonwidth 8
set gSubj(wrap) 1;set gSubj(pict) 0
button $command1.setnext -text "Grade&Next" -command "subjSet;subjNext" \
-width $buttonwidth
button $command2.set -text "Grade" -command subjSet -width $buttonwidth
frame $command1.space1 -height 30
frame $command2.space2 -height 30
frame $command2.space22 -height 5
button $command1.next -text "Next" -command subjNext -width $buttonwidth
button $command1.prev -text "Prev" -command subjPrev -width $buttonwidth
button $command1.goto -text "GoTo" -command subjGoto -width $buttonwidth
button $command1.exit -text "Exit" -command subjDone -width $buttonwidth
button $command2.findid -text "Find ID" -command subjFindId -width $buttonwidth
button $command2.addid -text "Add ID" -command subjAddId -width $buttonwidth
button $command2.findname -text "Find Name" -command subjFindName -width $buttonwidth
checkbutton $command2.wrap -text wrap -command subjWrap -variable gSubj(wrap)
checkbutton $command2.pict -text pict -command subjPict -variable gSubj(pict)
checkbutton $command1.done -text graded -variable gSubj(donestat) -state disabled
pack $command1.setnext $command2.set $command1.space1 $command2.space2 \
$command1.next $command1.prev $command2.findid \
$command2.addid $command2.findname $command1.goto $command1.exit \
$command2.wrap $command2.pict $command1.done $command2.space22
button $morebut.print -text "Print Response" -command subjPrint \
-width [expr $buttonwidth*2]
pack $morebut.print
set gSubj(done) 0
set gSubj(togo) 0
set gSubj(secAvg) 0.0
set gSubj(sec) 0
set gSubj(pause) 0
label $stat.done -text Done:
label $stat.donenum -textvariable gSubj(done) -width 4
label $stat.togo -text "To Go:"
label $stat.togonum -textvariable gSubj(togo) -width 4
label $stat.sec -text Sec:
label $stat.secnum -textvariable gSubj(sec) -width 4
label $stat.avgsec -text AvgSec:
label $stat.avgsecnum -textvariable gSubj(avgsec) -width 4
checkbutton $stat.pause -variable gSubj(pause) -text "Pause" -command subjPause
pack $stat.done $stat.donenum $stat.togo $stat.togonum -side left
#not packed
#$stat.sec $stat.secnum $stat.avgsec $stat.avgsecnum $stat.pause
set gSubj(canvas) [canvas $picts.canvas -height 220 \
-xscrollcommand "$picts.scroll set"]
scrollbar $picts.scroll -orient h -command "$picts.canvas xview"
pack $picts.scroll $gSubj(canvas) -fill x
subjInit
}
proc subjWrap {} {
global gSubj
if { $gSubj(wrap) } {
$gSubj(response) configure -wrap char
} else {
$gSubj(response) configure -wrap none
}
}
proc updateSecCount {} {
global gSubj
if { [catch {set gSubj(pause)}] } { return }
if { !$gSubj(pause) } {set gSubj(sec) [expr {[clock seconds] - $gSubj(seconds)}]}
after 300 updateSecCount
}
proc subjCheckForNew {} {
global gSubj
foreach file [glob ?????????] {
if { [lsearch $gSubj(stunums) $file] == -1 } { lappend gSubj(stunums) $file }
}
set gSubj(togo) [expr [llength $gSubj(stunums)]-$gSubj(done)]
}
proc checkGSubj {} {
global gSubj
if {[catch {set gSubj(stunums)}]} {
cd [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest)]
set gSubj(stunums) [lsort -dictionary [glob *]]
if { [set num [lsearch $gSubj(stunums) gradingstatus]] != -1} {
set gSubj(stunums) [lreplace $gSubj(stunums) $num $num]
}
cd $gSubj(dir)
}
if {[catch {set gSubj(current)}]} {set gSubj(current) -1}
if {[catch {set gSubj(totalsec)}]} {set gSubj(totalsec) 0}
if {[catch {set gSubj(seconds)}]} {set gSubj(seconds) [clock seconds]}
if {[catch {set gSubj(togo)}]} {set gSubj(togo) [llength $gSubj(stunums)]}
if {[catch {set gSubj(allstunum)}] ||
[catch {set gSubj(allname)}] ||
[catch {set gSubj(allemail)}] } {
subjInitAllLists
}
}
proc subjRestore {} {
global gSubj
source gradingstatus
subjCheckForNew
set gSubj(seconds) [expr {[clock seconds] - $gSubj(sec)}]
cd $gSubj(dir)
if { [catch {incr gSubj(current) -1}]} { set gSubj(current) -1 }
if { $gSubj(redoalllists) } { subjInitAllLists; set gSubj(redoalllists) 0 }
checkGSubj
subjIndexResponse
subjNext
}
proc subjSave {} {
global gSubj
set file [file join $gSubj(dir) records set$gSubj(set) \
problem$gSubj(quest) gradingstatus]
set fileId [open $file w]
puts $fileId "array set gSubj \{[array get gSubj]\}"
close $fileId
}
proc subjDone {} {
global gSubj
if { [catch {subjSave}] } {
displayMessage "Unable to save."
}
unset gSubj
destroy .gradesubjective
}
proc subjInitAllLists {} {
global gSubj
set i 0
catch {unset gSubj(allstunum)}
catch {unset gSubj(allname)}
catch {unset gSubj(allemail)}
set fileId [open classl r]
while { 1 } {
incr i
set aline [gets $fileId]
if { [eof $fileId]} {break}
# skip blank lines
if { [string trim $aline] == "" } { continue }
lappend gSubj(allstunum) [string toupper [string range $aline 14 22]]
#lappend gSubj(allname) [string toupper [string range $aline 24 59]]
lappend gSubj(allname) [string range $aline 24 59]
lappend gSubj(allemail) [string range $aline 60 99]
}
}
proc subjInit {} {
global gSubj
set dir [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest)]
cd $dir
set gSubj(redoalllists) 0
if { [file exists gradingstatus] } { subjRestore } else {
set gSubj(stunums) [lsort -dictionary [glob *]]
cd $gSubj(dir)
set gSubj(current) -1
set gSubj(totalsec) 0
set gSubj(seconds) [clock seconds]
subjInitAllLists
set gSubj(togo) [llength $gSubj(stunums)]
subjNext
}
subjUpdateKeywords
after 300 updateSecCount
}
#FIXME check Ids when adding them to the list of ids
proc checkId { id } {
global gSubj
set score [getScore $gSubj(set) $gSubj(quest) $id]
if { $score == "-" || $score == "0" } { return 1 }
return 0
}
proc subjPause {} {
global gSubj
if { !$gSubj(pause) } { set gSubj(seconds) [expr {[clock seconds] - $gSubj(sec)}] }
}
proc subjStatusUpdate {} {
global gSubj
set gSubj(done) [llength [array names gSubj "done.*.score"]]
set total [llength $gSubj(stunums)]
set gSubj(togo) [expr $total-$gSubj(done)]
incr gSubj(totalsec) [expr {[clock seconds] - $gSubj(seconds)}]
set gSubj(avgsec) [format %4.1f [expr $gSubj(totalsec)/double($gSubj(done))]]
# puts $gSubj(avgsec)
set gSubj(seconds) [clock seconds]
}
proc subjSet {} {
global gSubj
# if {$gSubj(togo) == 0} { return }
if {$gSubj(score) == "" } { subjMessage "Please select a score." error; return }
set idlist [subjGetIdList]
foreach id $idlist {
setScore $gSubj(set) $gSubj(quest) $id $gSubj(score)
}
set id [lindex $gSubj(stunums) $gSubj(current)]
set gSubj(done.$id.idlist) $idlist
set gSubj(done.$id.score) $gSubj(score)
set gSubj(donestat) 1
subjStatusUpdate
subjSave
}
proc subjNext {} {
global gSubj
set gSubj(score) ""
set gSubj(pict) 0
subjPict
incr gSubj(current)
if { [llength $gSubj(stunums)] < $gSubj(current) } { incr gSubj(current) -1 }
set id [lindex $gSubj(stunums) $gSubj(current)]
$gSubj(response) delete 0.0 end
$gSubj(idlist) delete 0 end
if { $id != "" } {
set file [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest) $id]
set fileId [open $file "r"]
$gSubj(response) insert 0.0 [read $fileId [file size $file]]
close $fileId
subjInsertIds $id
}
append words [string trim [$gSubj(response) get 0.0 end-1c]] " "
set ws [format " \t\n"]
set gSubj(numwords) [regsub -all -- \[$ws\]+ $words {} b]
wm title .gradesubjective "Grading Subjective, Set $gSubj(set), Prob $gSubj(quest), $id"
if { [catch {set gSubj(score) $gSubj(done.$id.score)}] } {
set gSubj(score) ""
set gSubj(donestat) 0
update idletasks
subjFindIds
} else {
set gSubj(donestat) 1
subjInsertIds $gSubj(done.$id.idlist)
update idletasks
}
subjUpdateResponse
subjPicts
}
proc subjFindIds1 {} {
global gSubj
set text [$gSubj(response) get 0.0 end]
set result ""
foreach id $gSubj(allstunum) {
if { [regexp -nocase -- $id $text] } {
lappend result $id
}
}
return $result
}
proc subjFindIds2 {} {
global gSubj
set text [string toupper [$gSubj(response) get 0.0 end]]
set result ""
if { [catch {lsearch $text a}] } {
#puts badlist
return subjFindIds1
} else {
foreach id $gSubj(allstunum) {
if { [lsearch -glob $text *$id*] != -1 } {
lappend result $id
}
}
}
return $result
}
proc subjFindIds3 {} {
global gSubj
set text [string toupper [$gSubj(response) get 0.0 end]]
set text [split $text "{}!@\#\$%^&*()_-+=|\\,.<>/?'\";:`~ \n\t"]
set result ""
foreach word $text {
if { [lsearch -exact $gSubj(allstunum) $word] != -1 } {
lappend result $word
}
}
return $result
}
proc subjFindIds4 {} {
global gSubj
set text [string toupper [$gSubj(response) get 0.0 end]]
set text [split $text "{}!@\#\$%^&*()_-+=|\\,.<>/?'\";:`~ \n\t"]
set result ""
foreach id $gSubj(allstunum) {
if { [lsearch -exact $text $id] != -1 } {
lappend result $id
}
}
return $result
}
proc subjFindId {} {
global gSubj
puts "4:[time {subjInsertIds [set ids [subjFindIds4]]} ]\t:[llength $ids]"
subjPicts
}
proc subjFindIds {} {
global gSubj
# puts "4:[time {subjInsertIds [set ids [subjFindIds4]]} ]\t:[llength $ids]"
subjInsertIds [set ids [subjFindIds4]]
# puts "3:[time {set ids [subjFindIds3]} 2]\t:[llength $ids]"
# puts "2:[time {set ids [subjFindIds2]} 2]\t:[llength $ids]"
# puts "1:[time {set ids [subjFindIds1]} 2]\t:[llength $ids]"
}
proc subjFindName {} {
global gSubj
if {[catch {set text [string toupper [$gSubj(response) get sel.first sel.last]]}]} {
set text [string toupper [$gSubj(response) get 0.0 end]]
}
set text [split $text "{}!@\#\$%^&*()_-+=|\\,.<>/?'\";:`~ \n\t"]
set result ""
set length [llength $gSubj(allname)]
foreach word $text {
if { [string length $word] == 0 } { continue }
for { set i 0 } { $i < $length } { incr i } {
set name [string toupper [lindex $gSubj(allname) $i]]
if { [set find [lsearch -glob $name *$word*]] != -1 } {
lappend result $i
}
}
}
set result [lunique $result]
foreach index $result {
lappend temp [list [lindex $gSubj(allstunum) $index] \
[lindex $gSubj(allname) $index]]
}
if {[catch {set temp [lsort $temp]}]} {
displayMessage "No Student found."
return
}
set selected [multipleChoice {} "Select which student you want." $temp 1]
if {$selected == ""} { return }
set done 0
if { [llength $selected] == 2 } {
if { [lindex [lindex $selected 0] 0] == "" } {
set selected [lindex $selected 0]
set done 1
}
}
if { !$done } { foreach person $selected { lappend idlist [lindex $selected 0] } }
subjInsertIds $idlist
subjPicts
}
proc subjGetNameFromId { id } {
global gSubj
return [lindex $gSubj(allname) [lsearch $gSubj(allstunum) $id]]
}
proc subjGetIdList {} {
global gSubj
set list [$gSubj(idlist) get 0 end]
set id ""
foreach element $list {
append id "[lindex $element 0] "
}
return $id
}
proc subjInsertIds { selected } {
global gSubj
set current [subjGetIdList]
foreach person $selected {lappend current [lindex $person 0]}
set current [lsort [lunique $current]]
$gSubj(idlist) delete 0 end
foreach id $current {
$gSubj(idlist) insert end "$id [subjGetNameFromId $id]"
}
}
proc subjDeleteId {} {
global gSubj
$gSubj(idlist) delete [$gSubj(idlist) curselection]
subjPicts
}
proc subjAddId {} {
global gSubj
getOneStudent {} $gSubj(dir) id name
if { $id == "" } { return }
subjInsertIds $id
}
proc subjPrev {} {
global gSubj
if { $gSubj(current) > 0 } {
incr gSubj(current) -2
subjNext
}
}
proc subjMessage { mesg {tag normal} } {
global gSubj
displayMessage $mesg
# $gSubj(msg) insert end "[clock format [clock seconds] -format {%I:%M:%S}] - $mesg\n" $tag
# $gSubj(msg) see end
}
proc subjAddPict { id } {
global gSubj
set gif [file join $gSubj(dir) photo gif $id.gif]
if { ![file exists $gif] } { return }
lappend gSubj(imagelist) [set image [image create photo]]
$image read $gif
set a [llength $gSubj(imagelist)]
$gSubj(canvas) create image [expr ($a-1)*200] 20 -image $image -anchor nw
$gSubj(canvas) create text [expr ($a-1)*200] 10 -text $id -anchor nw
$gSubj(canvas) create text [expr ($a-1)*200] 0 -text [subjGetNameFromId $id] \
-anchor nw
$gSubj(canvas) configure -scrollregion "1 1 [expr ($a)*200] 200"
update idletasks
return $a
}
proc subjConvertPict { id } {
global gSubj
set gif [file join $gSubj(dir) photo gif $id.gif]
set jpg [file join $gSubj(dir) photo jpg $id.jpg]
if { ![file exists $gif] } {
if { [file exists $jpg] } {
exec djpeg -outfile $gif $jpg
}
}
}
proc subjPicts {} {
global gSubj
$gSubj(canvas) delete all
catch { foreach image $gSubj(imagelist) { catch {image delete $image} } }
set gSubj(imagelist) ""
set idlist [subjGetIdList]
foreach id $idlist {
subjConvertPict $id
set num [subjAddPict $id]
}
}
proc subjPict {} {
global gSubj
if { $gSubj(pict) } {
pack $gSubj(pictFrame)
pack configure $gSubj(pictFrame) -fill x
} else {
pack forget $gSubj(pictFrame)
}
}
proc subjPrint {} {
global gSubj
set lprCommand [getLprCommand quiztemp.txt]
if {$lprCommand == "Cancel"} { return }
set fileId [open "quiztemp.txt" w]
set subid [lindex $gSubj(stunums) $gSubj(current)]
if { $subid != "" } {
set file [file join $gSubj(dir) records set$gSubj(set) \
problem$gSubj(quest) $subid]
puts $fileId "Submitted at [clock format [file mtime $file ]]"
puts $fileId "By Student:\n [string trimright [subjGetNameFromId $subid]] ($subid)"
}
if { [llength [subjGetIdList]] > 1 } {
puts $fileId "Additional Authors:"
foreach id [subjGetIdList] {
if { $id == $subid } { continue }
puts $fileId " [string trimright [subjGetNameFromId $id]] ($id)"
}
}
puts $fileId ""
puts -nonewline $fileId "[ $gSubj(response) get 0.0 end-1c ]"
close $fileId
set errorMsg ""
set error [catch {set output [ eval "exec $lprCommand" ] } errorMsg ]
if { $error == 1 } {
displayError "An error occurred while printing: $errorMsg"
} else {
displayMessage "Print job sent to the printer.\n $output"
}
exec rm -f quiztemp.txt
}
proc subjGoto {} {
global gSubj
subjGetOneStudent {} $gSubj(dir) id name
if { $id == "" } { return }
if { [file exists [file join $gSubj(dir) records set$gSubj(set) problem$gSubj(quest) $id] ] } {
set gSubj(current) [expr [lsearch $gSubj(stunums) $id] - 1]
subjNext
} else {
displayMessage "Student $id did not submit an answer."
}
}
proc subjGetUngraded {} {
global gSubj
set idlist ""
foreach stunum $gSubj(stunums) {
if {[catch {set gSubj(done.$stunum.score)}]} {
lappend idlist $stunum
}
}
return [multipleChoice {} "Select which student you want to grade." $idlist 1]
}
proc subjGetOneStudent { window path idVar nameVar {message "" } } {
upvar $idVar id
upvar $nameVar name
set select [tk_dialog $window.dialog "$message Student select method" \
"Select student by:" "" "" "Student Number" \
"Student Name" "Not Yet Graded" "Cancel"]
if { $select == 3 } {
set id ""
set name ""
return
}
if { $select == 2 } {
set id [subjGetUngraded]
set name [subjGetNameFromId $id]
return
}
set done 0
while { ! $done } {
if { $select } { set search "name" } { set search "number" }
set pattern [ getString $window "$message Please enter a student $search." ]
if {$pattern == "" } {
set done 1
set id ""
set name ""
continue
}
if { $select } {
set matched_entries [findByStudentName $pattern $path]
} else {
set matched_entries [findByStudentNumber $pattern $path]
}
if { [llength $matched_entries] == 0 } {
displayMessage "No student found. Please re-enter student $search."
} elseif { [llength $matched_entries] == 1 } {
set id [lindex [lindex $matched_entries 0] 0]
set name [lindex [lindex $matched_entries 0] 1]
set done 1
} elseif { [llength $matched_entries] < 30 } {
set select [ multipleChoice $window \
"Matched Student Records, Select one" \
$matched_entries ]
if { $select == "" } {
set id ""; set name ""
return
}
set id [lindex $select 0]
set name [lindex $select 1]
set done 1
} else {
displayMessage "There were [llength $matched_entries], please enter more data to narrow the search."
}
}
}
###########################################################
# subjSendResponse
###########################################################
###########################################################
###########################################################
proc subjSendResponse {} {
global gSubj gCapaConfig
if { "" == [set which [$gSubj(responseList) curselection]]} {
displayMessage "Please select a message to send."
return
}
incr which
set message ""
set stuList [$gSubj(idlist) get 0 end]
foreach stu $stuList {
set stu [lindex $stu 0]
set index [lsearch $gSubj(allstunum) $stu]
set name [lindex $gSubj(allname) $index]
set email [lindex $gSubj(allemail) $index]
#puts "$name:[split $name ,]:[lindex [split $name ,] 1]:[lindex [lindex [split $name ,] 1] 0]:$index:$stu"
#puts [lsearch $gSubj(allemail) albertel@pilot.msu.edu]
set first_name [lindex [lindex [split $name ,] 1] 0]
set last_name [lindex [split $name , ] 0]
set score $gSubj(score)
regsub -all -- \\\$last_name $gSubj(response.$which) $last_name message
regsub -all -- \\\$first_name $message $first_name message
regsub -all -- \\\$score $message $score message
# set message [subst -nobackslashes -nocommands $gSubj(response.$which)]
if { [regexp -- (^Subject:\[^\n\]*)(\n)(.*) $message matchvar subjline newline messagebody] } {
set subject "$subjline Class [file tail $gSubj(dir)], Set $gSubj(set), Question $gSubj(quest)"
set message $messagebody
} else {
set subject "Subject: Class [file tail $gSubj(dir)], Set $gSubj(set), Question $gSubj(quest)"
}
displayMessage "$message sent to $email"
exec echo $message | $gCapaConfig(mail_command) -s $subject $email
}
}
###########################################################
# subjIndexResponse
###########################################################
###########################################################
###########################################################
proc subjIndexResponse {} {
global gSubj
$gSubj(responseList) delete 0 end
set i 0
foreach element [lsort -dictionary [array names gSubj "response.*"]] {
regsub -all -- "\[\n\r\t\]+" [string range $gSubj($element) 0 37] " " head
$gSubj(responseList) insert end "[incr i].$head"
}
}
###########################################################
# subjSaveResponse
###########################################################
###########################################################
###########################################################
proc subjSaveResponse {} {
global gSubj
set num [incr gSubj(numresponse)]
set gSubj(response.$num) [$gSubj(responseNew) get 0.0 end-1c]
destroy [winfo toplevel $gSubj(responseNew)]
subjIndexResponse
$gSubj(responseList) selection set end
$gSubj(responseList) see end
}
###########################################################
# subjNewResponse
###########################################################
###########################################################
###########################################################
proc subjNewResponse {} {
global gSubj gWindowMenu
if { [winfo exists .addresponse] } {
capaRaise .addresponse
return
}
set response [toplevel .addresponse]
$gWindowMenu add command -label "AddingResponse" -command "capaRaise $response"
wm title $response "Adding a New Response"
set textFrame [frame $response.text]
set buttonFrame [frame $response.button]
pack $textFrame $buttonFrame
set gSubj(responseNew) [text $textFrame.text -yscrollcommand \
"$textFrame.scroll set" -wrap char -height 15]
scrollbar $textFrame.scroll -command "$textFrame.text yview"
pack $textFrame.text $textFrame.scroll -side left -expand 1
pack configure $textFrame.scroll -fill y
button $buttonFrame.save -text Save -command "subjSaveResponse"
button $buttonFrame.forget -text Cancel -command "destroy $response"
pack $buttonFrame.save $buttonFrame.forget -side left
}
###########################################################
# subjDeleteResponse
###########################################################
###########################################################
###########################################################
proc subjDeleteResponse {} {
global gSubj
if { [winfo exists .editresponse] } {
displayMessage "Please finish with editing the response, before deleting responses."
return
}
if { "" == [set which [$gSubj(responseList) curselection]]} { return }
incr which
if { [catch {unset gSubj(response.$which)}] } {
#puts [array names gSubj response.*]
return
}
for {set i [expr $which + 1]} { [info exists gSubj(response.$i)] } {incr i} {
set j [expr $i - 1]
set gSubj(response.$j) $gSubj(response.$i)
unset gSubj(response.$i)
}
set gSubj(numresponse) [expr $i - 2]
subjIndexResponse
$gSubj(responseList) see [incr which -2]
}
###########################################################
# subjEditResponse
###########################################################
###########################################################
###########################################################
proc subjEditResponse {} {
global gSubj gWindowMenu
if { [winfo exists .editresponse] } { capaRaise .editresponse ; return }
if { "" == [set which [$gSubj(responseList) curselection]]} { return }
incr which
set response [toplevel .editresponse ]
$gWindowMenu add command -label "EditingResponse" -command "capaRaise $response"
wm title $response "Editing a Response"
set textFrame [frame $response.text]
set buttonFrame [frame $response.button]
pack $textFrame $buttonFrame
set gSubj(responseEdit) [text $textFrame.text -yscrollcommand \
"$textFrame.scroll set" -wrap char -height 15]
scrollbar $textFrame.scroll -command "$textFrame.text yview"
pack $textFrame.text $textFrame.scroll -side left -expand 1
pack configure $textFrame.scroll -fill y
$gSubj(responseEdit) insert 0.0 $gSubj(response.$which)
set gSubj(editresponsedone) 0
button $buttonFrame.save -text Save -command "set gSubj(editresponsedone) 1"
button $buttonFrame.forget -text Cancel -command "set gSubj(editresponsedone) 0"
pack $buttonFrame.save $buttonFrame.forget -side left
vwait gSubj(editresponsedone)
if { $gSubj(editresponsedone) } {
set gSubj(response.$which) [$gSubj(responseEdit) get 0.0 end-1c]
subjIndexResponse
$gSubj(responseList) selection set $which
$gSubj(responseList) see $which
}
destroy $response
}
###########################################################
# subjViewResponse
###########################################################
###########################################################
###########################################################
proc subjViewResponse {} {
global gSubj gUniqueNumber gWindowMenu
if { "" == [set which [$gSubj(responseList) curselection]]} { return }
incr which
set num [incr gUniqueNumber]
set response [toplevel .viewresponse$num ]
$gWindowMenu add command -label "ViewingResponse $which" \
-command "capaRaise $response"
wm title $response "Viewing Response $which"
set textFrame [frame $response.text]
set buttonFrame [frame $response.button]
pack $textFrame $buttonFrame
text $textFrame.text -yscrollcommand "$textFrame.scroll set" -wrap char -height 15
scrollbar $textFrame.scroll -command "$textFrame.text yview"
pack $textFrame.text $textFrame.scroll -side left -expand 1
pack configure $textFrame.scroll -fill y
$textFrame.text insert 0.0 $gSubj(response.$which)
$textFrame.text configure -state disabled
button $buttonFrame.forget -text Dismiss -command "destroy $response"
pack $buttonFrame.forget -side left
}
###########################################################
# subjUpdateResponse
###########################################################
###########################################################
###########################################################
proc subjUpdateResponse {} {
global gSubj
$gSubj(response) tag delete keyword
$gSubj(response) tag configure keyword -background green
set startindex 0.0
set lastindex [$gSubj(response) index end]
while { 1 } {
set endindex [$gSubj(response) index "$startindex wordend"]
# puts "$startindex -> $endindex"
set word [string trim [string toupper [$gSubj(response) get $startindex $endindex]]]
if { $word != "" } {
# puts "Word :$word:"
foreach keyword $gSubj(keywords) {
set keyword [string toupper [lindex $keyword 1]]
if { [lsearch -exact $keyword $word] != -1 } {
$gSubj(response) tag add keyword $startindex $endindex
}
}
# puts [$gSubj(response) index "$endindex+1c"]
# puts [$gSubj(response) index "$endindex wordstart"]
# puts [$gSubj(response) index "$endindex+1c wordstart"]
# set startindex [$gSubj(response) index "$endindex + 1c"]
}
set startindex $endindex
if { $startindex == $lastindex } { break }
}
}
###########################################################
# subjUpdateKeywords
###########################################################
###########################################################
###########################################################
proc subjUpdateKeywords {} {
global gSubj
$gSubj(keyword) delete 0.0 end
set lokeyword ""
# puts $gSubj(keywords)
foreach keyword $gSubj(keywords) { lappend lokeyword [lindex $keyword 0] }
if { $lokeyword == "" } { return }
set lokeyword [lsort $lokeyword]
set max 0
foreach key $lokeyword {
if { [string length $key] > $max } { set max [string length $key] }
}
incr max
set numcol [expr 60/$max]
set end [llength $lokeyword]
set lastline 0
for { set i 0 } { $i < $end } { incr i } {
set line [expr $i/$numcol]
set col [expr $i%$numcol*$max]
# puts $line.$col
$gSubj(keyword) insert end [format "%-[set max]s" [lindex $lokeyword $i]]
if {($col + (2*$max)) > 60} {
# puts "Putting in newlne"
$gSubj(keyword) insert end "\n"
set lastline $line
}
}
subjUpdateResponse
}
###########################################################
# subjAddKeyword
###########################################################
###########################################################
###########################################################
proc subjAddKeyword {} {
global gSubj
if { "" == [set newword [getString [winfo toplevel $gSubj(keyword)] "Enter a new keyword" nospace ]]} {
return
}
set i 0
foreach keyword $gSubj(keywords) {
if {-1 != [lsearch $keyword $newword]} { break }
incr i
}
if { $i >= [llength $gSubj(keywords)] } {
lappend gSubj(keywords) [list $newword [list $newword]]
subjUpdateKeywords
}
}
###########################################################
# subjAddKeywordSpelling
###########################################################
###########################################################
###########################################################
proc subjAddKeywordSpelling {} {
global gSubj
if { [catch {set word [$gSubj(keyword) get sel.first sel.last]}]} { return }
if { "" == [set newspell [getString [winfo toplevel $gSubj(keyword)] "Enter a new spelling for $word" nospace ]]} {
return
}
set i 0
foreach keyword $gSubj(keywords) {
if {-1 != [lsearch $keyword $word]} { break }
incr i
}
set gSubj(keywords) [lreplace $gSubj(keywords) $i $i \
[list $word [concat [lindex $keyword 1] $newspell]]]
subjUpdateKeywords
}
###########################################################
# subjSeeKeyword
###########################################################
###########################################################
###########################################################
proc subjSeeKeyword {} {
global gSubj gPromptMC
if { [catch {set word [$gSubj(keyword) get sel.first sel.last]}]} { return }
set i 0
foreach keyword $gSubj(keywords) {
if {-1 != [lsearch $keyword $word]} { break }
incr i
}
set which $i
set setWin [toplevel $gSubj(keyword).keyword]
set msgFrame [frame $setWin.msgFrame]
set valFrame [frame $setWin.valFrame]
set buttonFrame [frame $setWin.buttonFrame]
pack $msgFrame $valFrame $buttonFrame
pack configure $valFrame -expand 1 -fill both
message $msgFrame.msg -text "Alternate spellings for [lindex $keyword 0]" \
-aspect 3000
pack $msgFrame.msg
set maxWidth 1
foreach choice [lindex $keyword 1] {
if {[string length $choice] > $maxWidth} {set maxWidth [string length $choice]}
}
listbox $valFrame.val -width [expr $maxWidth + 2] \
-yscrollcommand "$valFrame.scroll set" -selectmode single
scrollbar $valFrame.scroll -command "$valFrame.val yview"
pack $valFrame.val $valFrame.scroll -side left
pack configure $valFrame.val -expand 1 -fill both
pack configure $valFrame.scroll -expand 0 -fill y
foreach choice [lsort [lrange [lindex $keyword 1] 1 end]] {
$valFrame.val insert end $choice
}
button $buttonFrame.select -text "Delete" -command { set gPromptMC(ok) 1 }
frame $buttonFrame.spacer -width 10
button $buttonFrame.cancel -text "Dismiss" -command { set gPromptMC(ok) 0 }
pack $buttonFrame.select $buttonFrame.cancel -side left
bind $setWin <Return> "set gPromptMC(ok) 0"
Centre_Dialog $setWin default
update idletasks
focus $setWin
capaRaise $setWin
capaGrab $setWin
while { 1 } {
update idletasks
vwait gPromptMC(ok)
if { $gPromptMC(ok) == 0 } { break }
set select [$valFrame.val curselection]
if { $select != "" } {
$valFrame.val delete $select
}
}
set spellings [lindex $keyword 0]
for {set i 0} {$i < [$valFrame.val index end]} { incr i } {
lappend spellings [$valFrame.val get $i]
}
capaGrab release $setWin
destroy $setWin
set gSubj(keywords) [lreplace $gSubj(keywords) $which $which \
[list [lindex $keyword 0] $spellings ]]
subjUpdateKeywords
}
###########################################################
# subjDeleteKeyword
###########################################################
###########################################################
###########################################################
proc subjDeleteKeyword {} {
global gSubj
if { [catch {set word [$gSubj(keyword) get sel.first sel.last]}]} { return }
set newkeyword ""
foreach keyword $gSubj(keywords) {
if {-1 == [lsearch $keyword $word]} { lappend newkeyword $keyword }
}
set gSubj(keywords) $newkeyword
subjUpdateKeywords
}
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>