[BACK]Return to common.tcl CVS log [TXT] [DIR] Up to [LON-CAPA] / capa / capa51 / GUITools

Diff for /capa/capa51/GUITools/common.tcl between versions 1.1.1.1 and 1.11

version 1.1.1.1, 1999/09/28 21:25:36 version 1.11, 2000/08/07 20:47:29
Line 1 Line 1
   # functions common to all to main CAPA programs
   #  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  set gMaxSet 99
 ###########################################################  ###########################################################
 # capaRaise  # capaRaise
Line 568  proc parseCapaConfig { {num "" } { path Line 591  proc parseCapaConfig { {num "" } { path
  "answers_command *= *" -   "answers_command *= *" -
  "dvips_command *= *" -   "dvips_command *= *" -
                 "xdvi_command *= *" -                  "xdvi_command *= *" -
    "mail_command *= *" -
  "IMP_color *= *" -   "IMP_color *= *" -
  "comment_color *= *" -   "comment_color *= *" -
  "exam_path *= *" -   "exam_path *= *" -
  "quiz_path *= *" -   "quiz_path *= *" -
  "supp_path *= *" -   "supp_path *= *" -
    "correction_path *= *" -
    "default_try_val *= *" -
    "default_prob_val *= *" -
    "default_hint_val *= *" -
    "homework_weight *= *" -
    "quiz_weight *= *" -
    "exam_weight *= *" -
    "final_weight *= *" -
    "correction_weight *= *" -
    "final_exam_set_number *= *" -
    "homework_count *= *" -
    "quiz_count *= *" -
  "others_path *= *" {    "others_path *= *" { 
     set gCapaConfig($prefix[lindex $aline 0]) [lindex $aline end]       set gCapaConfig($prefix[lindex $aline 0]) [lindex $aline end] 
  }   }
Line 1132  proc getOneStudent { window path idVar n Line 1168  proc getOneStudent { window path idVar n
 ###########################################################  ###########################################################
 ###########################################################  ###########################################################
 ###########################################################  ###########################################################
 proc getString { window message } {  proc getString { window message {type "any"}} {
     global gPrompt       global gPrompt 
     set setWin [toplevel $window.getstring]      set setWin [toplevel $window.getstring]
           
Line 1143  proc getString { window message } { Line 1179  proc getString { window message } {
   
           
     set gPrompt(val) ""      set gPrompt(val) ""
     entry $valFrame.val -textvariable gPrompt(val)       entry $valFrame.val -textvariable gPrompt(val) -validate key \
    -validatecommand "limitEntry %W -1 $type %P"
     pack $valFrame.val      pack $valFrame.val
   
     message $msgFrame.msg -text $message -aspect 3000      message $msgFrame.msg -text $message -aspect 3000
Line 1179  proc getString { window message } { Line 1216  proc getString { window message } {
 proc multipleChoice { window message choices {single 1}} {  proc multipleChoice { window message choices {single 1}} {
     global gPromptMC      global gPromptMC
           
     set setWin [toplevel $window.getstring]      set setWin [toplevel $window.choice]
           
     set msgFrame [frame $setWin.msgFrame]      set msgFrame [frame $setWin.msgFrame]
     set valFrame [frame $setWin.valFrame]      set valFrame [frame $setWin.valFrame]
Line 1217  proc multipleChoice { window message cho Line 1254  proc multipleChoice { window message cho
     }      }
   
     bind $setWin <Return> "set gPromptMC(ok) 1"      bind $setWin <Return> "set gPromptMC(ok) 1"
       bind $setWin <Double-1> "set gPromptMC(ok) 1"
     Centre_Dialog $setWin default      Centre_Dialog $setWin default
     update idletasks      update idletasks
     focus $setWin      focus $setWin
Line 1231  proc multipleChoice { window message cho Line 1269  proc multipleChoice { window message cho
     }      }
     capaGrab release $setWin      capaGrab release $setWin
     destroy $setWin      destroy $setWin
       update idletasks
     if { $gPromptMC(ok) == 1 } {      if { $gPromptMC(ok) == 1 } {
  foreach selection $select { lappend result [lindex $choices $selection] }   foreach selection $select { lappend result [lindex $choices $selection] }
  if { [llength $result] == 1 } { set result [lindex $result 0] }   if { [llength $result] == 1 } { set result [lindex $result 0] }
Line 1424  proc pickSections { sectionsToPickFrom { Line 1463  proc pickSections { sectionsToPickFrom {
 }  }
   
 ###########################################################  ###########################################################
   # pickSets
   ###########################################################
   ###########################################################
   ###########################################################
   proc pickSets { setsToPickFrom mode {title "Select Sets"} {window ""}} {
       global gPromptPSets
       
       if { $setsToPickFrom == "" } { 
    displayMessage "No available sets."
    return "Cancel" 
       }
       set dialog [toplevel $window.pickSets -borderwidth 10]
       wm title $dialog "Which Sets"
   
       set infoFrame [frame $dialog.info ]
       set setListFrame [frame $dialog.list  -relief groove -borderwidth 5]
       set buttonFrame [frame $dialog.buttons -bd 10]
       pack $infoFrame $setListFrame $buttonFrame -side top -fill x
       
       message $infoFrame.msg -text $title -aspect 5000
       pack $infoFrame.msg
   
       set headerFrame [frame $setListFrame.head ]
       set listboxFrame [frame $setListFrame.listboxframe]
       pack $headerFrame $listboxFrame -side top 
       pack configure $headerFrame -anchor w
   
       message $headerFrame.msg -text "Set #" -aspect 5000
       pack $headerFrame.msg
   
       set setList [ listbox $listboxFrame.list \
                  -yscrollcommand "$listboxFrame.scroll set" \
                  -width 30 -height 10 -selectmode $mode ]
       scrollbar $listboxFrame.scroll \
                   -command "$listboxFrame.list yview" \
                   -orient v
       pack $setList $listboxFrame.scroll -side left
       pack configure $listboxFrame.scroll -fill y      
   
       foreach set $setsToPickFrom {
    $setList insert end [format "%3d" $set]
       }
   
       button $buttonFrame.yes -text Continue -command {set gPromptPSets(yes) 1} \
       -underline 0
       frame $buttonFrame.spacer -width 10
       button $buttonFrame.selectall -text "SelectAll" -command \
    "$setList selection set 0 end"
       button $buttonFrame.cancel -text Cancel -command { set gPromptPSets(yes) 0 } \
       -underline 0
       bind $dialog <Destroy> "set gPromptPSets(yes) 0"
       bind $dialog <Double-1> "set gPromptPSets(yes) 1"
   
       if { $mode == "single" } {
    pack $buttonFrame.yes $buttonFrame.cancel -side left
       } else {
    pack $buttonFrame.yes $buttonFrame.spacer \
       $buttonFrame.selectall $buttonFrame.cancel -side left
       }
       
       bind $dialog <Alt-Key> break
       
       Centre_Dialog $dialog default
       update
       
       focus $dialog
       capaRaise $dialog
       capaGrab $dialog
       vwait gPromptPSets(yes)
       capaGrab release $dialog
       bind $dialog <Destroy> ""
       if {$gPromptPSets(yes)} {
    set selectionList [ $setList curselection ]
    set setsToDo ""
    foreach selection $selectionList {
       lappend setsToDo [string trim [lindex [$setList get $selection] 0]]
    }
    destroy $dialog
    return $setsToDo
       } else {
    destroy $dialog
    return Cancel
       }
   }
   
   ###########################################################
 # getSet  # getSet
 ###########################################################  ###########################################################
 ###########################################################  ###########################################################
Line 1434  proc getSet { pid set followupCommand {s Line 1559  proc getSet { pid set followupCommand {s
     if { $start } {       if { $start } { 
  set gGetSet($num.toprocess) $pid   set gGetSet($num.toprocess) $pid
  set gGetSet($num.command) $followupCommand   set gGetSet($num.command) $followupCommand
  foreach name [array names gGetSet {*.[alhu]*}] { unset gGetSet($name) }  
  if { [array names gGetSet exit] == "" } { set gGetSet(exit) 0 }   if { [array names gGetSet exit] == "" } { set gGetSet(exit) 0 }
     }      }
     if { [catch {set gCapaConfig(getSet.answers_command)}] } {parseCapaConfig getSet}      if { [catch {set gCapaConfig(getSet.answers_command)}] } {parseCapaConfig getSet}
     set command "$gCapaConfig(getSet.answers_command) $pid {} {} $set"      set command "$gCapaConfig(getSet.answers_command) $pid {} 1 $set"
     foreach var [array names gCapaConfig $num.*] { unset gCapaConfig($var) }      foreach var [array names gCapaConfig $num.*] { unset gCapaConfig($var) }
     set fileId [open "|$command" "r"]      set fileId [open "|$command" "r"]
   #    puts "new command $num $fileId"
     fileevent $fileId readable "getSetLine $num $fileId"      fileevent $fileId readable "getSetLine $num $fileId"
     update idletasks      update idletasks
 }  }
Line 1452  proc getSet { pid set followupCommand {s Line 1577  proc getSet { pid set followupCommand {s
 ###########################################################  ###########################################################
 proc getSetQuestion { num fileId } {  proc getSetQuestion { num fileId } {
     global gGetSet       global gGetSet 
   #    puts -nonewline "$num $fileId "
     if { $gGetSet(exit) } {       if { $gGetSet(exit) } { 
  fileevent $fileId readable ""   fileevent $fileId readable ""
  catch {close $fileId}   catch {close $fileId}
Line 1461  proc getSetQuestion { num fileId } { Line 1587  proc getSetQuestion { num fileId } {
     set aline [gets $fileId]      set aline [gets $fileId]
     if { $aline != "" } {      if { $aline != "" } {
  switch [lindex [split $aline :] 0] {   switch [lindex [split $aline :] 0] {
     EQES { fileevent $fileId readable "getSetLine $num $fileId" }      EQES { 
     default { lappend gGetSet($num.$questNum.quest) $aline }  # puts -nonewline " EQES "
    fileevent $fileId readable "getSetLine $num $fileId" 
       }
       default { 
   # puts -nonewline " QES TEXT " 
    lappend gGetSet($num.$questNum.quest) $aline 
       }
  }   }
       } else {
   # puts -nonewline " QES BLANK "
     }      }
     if { [eof $fileId] } { getSetEnd $fileId }      if { [eof $fileId] } { getSetEnd $fileId }
   #    puts ""
 }  }
   
 ###########################################################  ###########################################################
Line 1476  proc getSetQuestion { num fileId } { Line 1611  proc getSetQuestion { num fileId } {
 proc getSetLine { num fileId } {  proc getSetLine { num fileId } {
     global gGetSet       global gGetSet 
           
   #    puts -nonewline "$num $fileId "
     if { $gGetSet(exit) } {       if { $gGetSet(exit) } { 
  fileevent $fileId readable ""   fileevent $fileId readable ""
  catch {close $fileId}   catch {close $fileId}
Line 1485  proc getSetLine { num fileId } { Line 1621  proc getSetLine { num fileId } {
     if { $aline != "" } {      if { $aline != "" } {
  switch [lindex [split $aline :] 0] {   switch [lindex [split $aline :] 0] {
     ANS {       ANS { 
    set list [array name gGetSet "$num.*"]
   # puts -nonewline " ANS $aline :$list: "
  set questNum $gGetSet($num.questNum)   set questNum $gGetSet($num.questNum)
  set ans [string range $aline 4 end]   set ans [string range $aline 4 end]
  set length [llength $ans]   set length [llength $ans]
Line 1496  proc getSetLine { num fileId } { Line 1634  proc getSetLine { num fileId } {
     lappend gGetSet($num.$questNum.low) [lindex $ans 1]      lappend gGetSet($num.$questNum.low) [lindex $ans 1]
     lappend gGetSet($num.$questNum.high) [lindex $ans 2]      lappend gGetSet($num.$questNum.high) [lindex $ans 2]
  }   }
    set list [array name gGetSet "$num.*"]
   # puts -nonewline " $ans :$list: "
     }      }
     DONE { set gGetSet($num.maxprob) $gGetSet($num.questNum) }      DONE {
   # puts -nonewline " DONE "
    set gGetSet($num.maxprob) $gGetSet($num.questNum) }
     ERROR {      ERROR {
   # puts -nonewline " ERROR "
   fileevent $fileId readable ""    fileevent $fileId readable ""
  displayError "Answers returned invalid message: $aline"    displayError "Answers returned invalid message: $aline" 
  fileevent $fileId readable "getSetLine $num $fileId"   fileevent $fileId readable "getSetLine $num $fileId"
     }      }
     BQES {      BQES {
   # puts -nonewline " BQES "
   incr gGetSet($num.questNum)    incr gGetSet($num.questNum)
  fileevent $fileId readable "getSetQuestion $num $fileId"    fileevent $fileId readable "getSetQuestion $num $fileId" 
     }      }
     SET { set gGetSet($num.questNum) 0 }      SET { 
     default {}  # puts -nonewline " SET "
    set gGetSet($num.questNum) 0 
       }
       default { # puts "What's this: $aline" }
  }   }
       } else {
   # puts -nonewline "BLANK"
     }      }
     if { [eof $fileId] } { getSetEnd $num $fileId }      if { [eof $fileId] } { getSetEnd $num $fileId }
   #    puts ""
 }  }
   
 ###########################################################  ###########################################################
Line 1520  proc getSetLine { num fileId } { Line 1670  proc getSetLine { num fileId } {
 ###########################################################  ###########################################################
 ###########################################################  ###########################################################
 proc getSetEnd { num fileId } {  proc getSetEnd { num fileId } {
     global gGetSet c      global gGetSet
     if { [eof $fileId] } {      if { [eof $fileId] } {
  catch {close $fileId}    catch {close $fileId} 
  set command $gGetSet($num.command)   set command $gGetSet($num.command)
   # puts [array name gGetSet "$num.*"]
   # parray gGetSet
  foreach var [array names gGetSet "$num.*"] {    foreach var [array names gGetSet "$num.*"] { 
     set var2 [join [lrange [split $var .] 1 end] .]      set var2 [join [lrange [split $var .] 1 end] .]
     set array($var2) $gGetSet($var)       set array($var2) $gGetSet($var) 
   #    puts "unset $var"
     unset gGetSet($var)      unset gGetSet($var)
  }   }
  eval "$command array"  # parray gGetSet
    eval $command [list [array get array]]
     }      }
 }  }
   
Line 1550  proc lunique __LIST { Line 1704  proc lunique __LIST {
     }      }
 }  }
   
   ###########################################################
   # lreverse
   ###########################################################
   proc lreverse list { 
       set result ""
       foreach element $list { set result [linsert $result 0 $element] } 
       return [concat $result]
   }
   
 proc splitline { line maxLength } {  proc splitline { line maxLength } {
     set length [string length $line]      set length [string length $line]
     set lines [expr $length/$maxLength + 1]      set lines [expr $length/$maxLength + 1]
Line 1685  proc winprintText { num } { Line 1848  proc winprintText { num } {
 ###########################################################  ###########################################################
 proc limitEntry { window max type {newvalue ""}} {  proc limitEntry { window max type {newvalue ""}} {
     after idle "$window config -validate key"      after idle "$window config -validate key"
     if {[string length $newvalue] > $max } { return 0 }      if {($max != -1) && ([string length $newvalue] > $max)} { return 0 }
     switch $type {      switch $type {
  any {}   any {}
  number { if {(![regexp ^\[0-9\]+$ $newvalue])&&($newvalue!="")} { return 0 } }   number { if {(![regexp ^\[0-9\]+$ $newvalue])&&($newvalue!="")} { return 0 } }
  letter {if {(![regexp ^\[A-Za-z\]+$ $newvalue])&& ($newvalue!="")} { return 0 }}   letter { if {(![regexp ^\[A-Za-z\]+$ $newvalue])&& ($newvalue!="")} { return 0 }}
    nospace {if {(![regexp "^\[^ \]+$" $newvalue])&& ($newvalue!="")} { return 0 }}
     }      }
     return 1      return 1
 }  }
   
   ###########################################################
   # getCapaID
   ###########################################################
   ###########################################################
   ###########################################################
   proc getCapaID { setinfo stunum sectionnum {path .} } {
       global  gMaxSet
       set pwd [pwd]
       cd $path
       set result ""
       switch -regexp -- $setinfo {
    ^[0-9]+$ {
       set result [getSpecificCapaId $stunum $setinfo]
    }
    ^[0-9]+\.\.[0-9]+$ {
       set range [split $setinfo .]
       set low [lindex $range 0]
       set high [lindex $range 2]
       for { set i $low } { $i <= $high } { incr i } {
    append result "[getSpecificCapaId $stunum $i] "
       }
    }
    ^[0-9]+(,[0-9]+)+$ {
       set list [split $setinfo ,]
       foreach set $list {
    append result "[getSpecificCapaId $stunum $set] "
       }
    }
    all {
       for { set i 1 } { $i <= $gMaxSet } { incr i } {
    if { [file exists [file join records date$i.db]] } {
       if { [isSetOpen $stunum $sectionnum $i] } {
    append result "[getSpecificCapaId $stunum $i] "
       }
    } else {
       break
    }
       }
    }
    default {
       set result "UNKNOWN"
    }
       }
       cd $pwd
       set result [string trim $result]
       return $result
   }
   
   ###########################################################
   # getScores
   ###########################################################
   ###########################################################
   ###########################################################
   proc getScores { setinfo stunum sectionnum {path .} {max 99} {limitVar none}} {
       global  gMaxSet
       if { $limitVar != "none" } { upvar $limitVar limit }
       set pwd [pwd]
       cd $path
       set result "0"
       switch -regexp -- $setinfo {
    ^[0-9]+$ {
       if { $setinfo <= $max } {
    set result [format "%4d" [getScore $stunum $setinfo]]
       }
    }
    ^[0-9]+\.\.[0-9]+$ {
       set range [split $setinfo .]
       set low [lindex $range 0]
       set high [lindex $range 2]
       if { $high > $max } { set high $max }
       for { set i $low } { $i <= $high } { incr i } {
    incr result [getScore $stunum $i]
       }
       set result [format "%4d" $result]
    }
    ^[0-9]+(,[0-9]+)+$ {
       set result ""
       set list [split $setinfo ,]
       foreach set $list {
    if { $set > $max } { continue }
    append result [format "%4d " [getScore $stunum $set]]
       }
    }
    all {
       for { set i 1 } { $i <= $max } { incr i } {
    if { [file exists [file join records date$i.db]] } {
       if { [isSetOpen $stunum $sectionnum $i] } {
    incr result [getScore $stunum $i]
       }
    } else {
       set result [format "%4d" $result]
       break
    }
       }
       set limit [expr {$i-1}]
    }
    default {
       set result "UNKNOWN"
    }
       }
       cd $pwd
       set result [string trimright $result]
       return $result
   }
   
   ###########################################################
   # getScore
   ###########################################################
   ###########################################################
   ###########################################################
   proc getScore { stunum set } {
       set fileId [open [file join records set$set.db] r]
       set total_score 0
       set aline [gets $fileId]
       set weights [split [gets $fileId] {}]
       set aline [gets $fileId]
       set aline [gets $fileId]
       while {! [eof $fileId]} {
    if {[string toupper $stunum] == [string toupper [lindex [split $aline " "] 0]]} {
       set scores [lindex [split [lindex [split $aline " "] 1] ","] 0]
       set scores [split $scores {}] 
       for { set i 0 } { $i < [llength $scores] } { incr i } {
    switch -- [lindex $scores $i] {
       y - Y { incr total_score [lindex $weights $i] }
       n - N - e - E - - { }
       0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
    # catching in case weights is not as long as the record
    catch {incr total_score [lindex $scores $i]}
       }
       default { puts "Unknown character [lindex $scores $i]" }
    }
       }
       break
    }
    set aline [gets $fileId]
       }
       close $fileId
       return $total_score
   }
   
   ###########################################################
   # getTotals
   ###########################################################
   ###########################################################
   ###########################################################
   proc getTotals { setinfo stunum sectionnum {path .} {max 99} {limitVar none}} {
       global  gMaxSet
       if { $limitVar != "none" } { upvar $limitVar limit }
       set pwd [pwd]
       cd $path
       set result "0"
       switch -regexp -- $setinfo {
    ^[0-9]+$ {
       if { $setinfo <= $max } {
    set result [format "%4d" [getTotal $stunum $setinfo]]
       }
    }
    ^[0-9]+\.\.[0-9]+$ {
       set range [split $setinfo .]
       set low [lindex $range 0]
       set high [lindex $range 2]
       if { $high > $max } { set high $max }
       for { set i $low } { $i <= $high } { incr i } {
    incr result [getTotal $stunum $i]
       }
       set result [format "%4d" $result]
    }
    ^[0-9]+(,[0-9]+)+$ {
       set result ""
       set list [split $setinfo ,]
       foreach set $list {
    if { $set > $max } { continue }
    append result [format "%4d " [getTotal $stunum $set]]
       }
    }
    all {
       for { set i 1 } { $i <= $max } { incr i } {
    if { [file exists [file join records date$i.db]] } {
       if { [isSetOpen $stunum $sectionnum $i] } {
    incr result [getTotal $stunum $i]
       }
    } else {
       set result [format "%4d" $result]
       break
    }
       }
       set limit [expr {$i-1}]
    }
    default {
       set result "UNKNOWN"
    }
       }
       cd $pwd
       set result [string trimright $result]
       return $result
   }
   
   ###########################################################
   # getTotal
   ###########################################################
   ###########################################################
   ###########################################################
   proc getTotal { stunum set } {
       set fileId [open [file join records set$set.db] r]
       set total_total 0
       set aline [gets $fileId]
       set weights [split [gets $fileId] {}]
       set aline [gets $fileId]
       set aline [gets $fileId]
       while {! [eof $fileId]} {
    if {[string toupper $stunum] == [string toupper [lindex [split $aline " "] 0]]} {
       set scores [lindex [split [lindex [split $aline " "] 1] ","] 0]
       set scores [split $scores {}] 
       for { set i 0 } { $i < [llength $scores] } { incr i } {
    switch -- [lindex $scores $i] {
       e - E { }
       0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 - y - Y - n - N - - { 
    catch { incr total_total [lindex $weights $i] }
       }
       default { 
    catch { incr total_total [lindex $weights $i] }
    puts "Unknown character [lindex $scores $i]" 
       }
    }
       }
       break
    }
    set aline [gets $fileId]
       }
       close $fileId
       return $total_total
   }
Removed from v.1.1.1.1  
changed lines
  Added in v.1.11

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