Return to seating.tcl CVS log

Up to [LON-CAPA] / capa / capa51 / GUITools

- fixed license notices the reference the GNU GPL rather than the GNU LGPL

    1: # randomiz a seating chart file
    2: #  Copyright (C) 1992-2000 Michigan State University
    3: #
    4: #  The CAPA system is free software; you can redistribute it and/or
    5: #  modify it under the terms of the GNU General Public License as
    6: #  published by the Free Software Foundation; either version 2 of the
    7: #  License, or (at your option) any later version.
    8: #
    9: #  The CAPA system is distributed in the hope that it will be useful,
   10: #  but WITHOUT ANY WARRANTY; without even the implied warranty of
   11: #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12: #  General Public License for more details.
   13: #
   14: #  You should have received a copy of the GNU General Public
   15: #  License along with the CAPA system; see the file COPYING.  If not,
   16: #  write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
   17: #  Boston, MA 02111-1307, USA.
   18: #
   19: #  As a special exception, you have permission to link this program
   20: #  with the TtH/TtM library and distribute executables, as long as you
   21: #  follow the requirements of the GNU GPL in regard to all of the
   22: #  software in the executable aside from TtH/TtM.
   23: 
   24: proc RSgetSeats { file } {
   25:     set seats ""
   26:     set fileId [open $file ]
   27:     while { 1 } {
   28: 	set line [gets $fileId]
   29: 	if { [eof $fileId] } { break }
   30: 	set location [string first " #" $line]
   31: 	incr location -1
   32: 	if { $location > 0 } { set line [string range $line 0 $location] }
   33: 	set line [string trim $line]
   34: 	lappend seats $line
   35:     }
   36:     return $seats
   37: }
   38: 
   39: proc RSprocessSeats { seats moveVar unmoveVar } {
   40:     upvar $moveVar move
   41:     upvar $unmoveVar unmove
   42:     set length [llength $seats]
   43:     for {set i 0} {$i < $length} {incr i} {
   44: 	set seat [lindex $seats $i]
   45: 	if { [set location [string first " !" $seat]] > 0 } {
   46: 	    incr location -1
   47: 	    set seat [string trim [string range $seat 0 $location] ]
   48: 	    set unmove($i) $seat
   49: 	} else {
   50: 	    lappend move $seat
   51: 	}
   52:     }
   53: }
   54: 
   55: proc RSdoAssignment { movable unmovableVar outputfile } {
   56:     upvar $unmovableVar unmovable
   57:     
   58:     set fileId [open $outputfile "w"]
   59:     set totallength [expr {[llength $movable] + [llength [array names unmovable]]}]
   60:     for { set i 0 } { $i < $totallength } { incr i } {
   61: 	if { [set which [lsearch [array names unmovable] $i]] != -1} {
   62: 	    set which [lindex [array names unmovable] $which]
   63: 	    set seat $unmovable($which)
   64: 	    unset unmovable($which)
   65: 	} else {
   66: 	    set which [expr int(rand() * [llength $movable])]
   67: 	    set seat [lindex $movable $which]
   68: 	    set movable [lreplace $movable $which $which]
   69: 	}
   70: 	puts $fileId $seat
   71:     }
   72:     close $fileId
   73: }
   74: 
   75: proc RSassign {file output seed} {
   76:     set move ""
   77:     expr srand($seed)
   78:     RSprocessSeats [RSgetSeats $file] move unmove
   79:     RSdoAssignment $move unmove $output
   80: }
   81: 
   82: proc RSopenFile { num which } {
   83:     global gRS
   84:     set gRS($num.$which) [tk_getOpenFile]
   85: }
   86: 
   87: proc RSsaveFile { num which } {
   88:     global gRS
   89:     set gRS($num.$which) [tk_getSaveFile]
   90: }
   91: 
   92: proc RSrun { num } {
   93:     global gRS
   94:     RSassign $gRS($num.file) $gRS($num.output) $gRS($num.seed)
   95:     displayMessage "Done"
   96: }
   97: 
   98: proc RSstart {num} {
   99:     global gRS
  100:     set gRS($num.file) ""
  101:     set gRS($num.output) ""
  102:     set gRS($num.seed) 100
  103: 
  104:     set window [toplevel .randomSeating$num]
  105: 
  106:     set infoFrame [frame $window.infoFrame]
  107:     set pathFrame [frame $window.pathFrame]
  108:     set seedFrame [frame $window.seedFrame]
  109:     set buttonFrame [frame $window.buttonFrame]
  110:     pack $infoFrame $pathFrame $seedFrame $buttonFrame
  111: 
  112:     set inputFrame [frame $pathFrame.inputFrame]
  113:     set outputFrame [frame $pathFrame.outputFrame]
  114:     pack $inputFrame $outputFrame
  115: 
  116:     label $inputFrame.label -text "Input File:"
  117:     set ientryFrame [frame $inputFrame.ientryFrame]
  118:     button $inputFrame.select -text "Select File" \
  119: 	-command "RSopenFile $num file"
  120:     pack $inputFrame.label $ientryFrame $inputFrame.select -side left
  121:     entry $ientryFrame.entry -textvariable gRS($num.file) \
  122: 	    -xscrollcommand "$ientryFrame.scroll set"
  123:     scrollbar $ientryFrame.scroll -orient h -command \
  124: 	    "$ientryFrame.entry xview"
  125:     pack $ientryFrame.entry $ientryFrame.scroll
  126:     pack configure $ientryFrame.scroll -fill x
  127: 
  128:     label $outputFrame.label -text "Output File:"
  129:     set oentryFrame [frame $outputFrame.oentryFrame]
  130:     button $outputFrame.select -text "Select File" \
  131: 	-command "RSsaveFile $num output"
  132:     pack $outputFrame.label $oentryFrame $outputFrame.select -side left
  133:     entry $oentryFrame.entry -textvariable gRS($num.output) \
  134: 	    -xscrollcommand "$oentryFrame.scroll set"
  135:     scrollbar $oentryFrame.scroll -orient h -command \
  136: 	    "$oentryFrame.entry xview"
  137:     pack $oentryFrame.entry $oentryFrame.scroll
  138:     pack configure $oentryFrame.scroll -fill x
  139: 
  140:     scale $seedFrame.seed -from 1 -to 30000 -variable gRS($num.seed) \
  141: 	-label "Random number seed" -orient h -length 300
  142:     pack $seedFrame.seed
  143: 
  144:     button $buttonFrame.assign -text Assign -command "RSrun $num"
  145:     button $buttonFrame.exit -text "Exit" -command \
  146: 	"unset gRS($num.file); unset gRS($num.output); unset gRS($num.seed); destroy $window"
  147:     pack $buttonFrame.assign $buttonFrame.exit -side left
  148: }