[LON-CAPA-cvs] cvs: modules /albertel scanner.tcl

[albertel]

albertel		Sun Feb  8 00:04:37 2004 EDT

  Added files:                 
    /modules/albertel	scanner.tcl 
  Log:
  - program to chat with the Scantron 1212 "Classroom Wizard"
     Does
       - Escrow mode reject/accepts
       - Validation of all fields on example form
       - Can be used to send commands to the scanner to change options
     
     Doesn't
       - allow configuration of which fields are required, which are optional which should be ignored.
       - do anything with the data once it has it
  
  
  

Index: modules/albertel/scanner.tcl
+++ modules/albertel/scanner.tcl

proc parseline { line imagear } {
    upvar $imagear image
    #puts "length is [string length $line]"
    if { "\n" == [string index $line 0] } {
	#puts "First is LF"
	if { "\r" == [string index $line end] } {
	    #puts "Last is CR"
	    set line [string range $line 1 end-1]
	}
    }
    #puts "length is [string length $line]"
    for { set i [expr [string length $line]-1] } { $i >= 1 } { incr i -2} {
	set linenumber [expr (([string length $line]-$i-1)/2)+1]
	set char1 [scan [string index $line [expr $i-1]] "%c" ]
	for { set j 0 } { $j < 6} {incr j } {
	    set char [expr ($char1 >> $j ) & 1]
#	    puts -nonewline $char
	    lappend image($linenumber) $char
	}
	set char2 [scan [string index $line [expr $i]] "%c" ]
	for { set j 0 } { $j < 6} {incr j } {
	    set char [expr ($char2 >> $j ) & 1]
#	    puts -nonewline $char
	    lappend image($linenumber) $char
	}
#	puts " $linenumber"
#	puts " [expr $i] [expr $i-1]"
    }
}

proc getdata { imagear dataar } {
    upvar $imagear image $dataar data

    set alphabet [list A B C D E F G H I J K L M N O P Q R S T U V W X Y Z]
    set reject ""

    #parse student id
    for {set i 1} {$i <= 10 } {incr i} {
	set found 0
	for { set j 6 } { $j <= 15 } { incr j } {
	    if { [lindex $image($j) $i] } {
		incr found 
		append data(studentid) "[expr $j-6]"
	    }
	}
	if {$found != 1} {
	    append reject "Student ID character $i invalid \n"
	}
    }
    #parse quiz vers
    set found 0
    for { set j 6 } { $j <= 15 } { incr j } {
	if { [lindex $image($j) $i] } {
	    incr found
	    append data(quizversion) [lindex $alphabet [expr $j-6]]
	}
    }
    if {$found > 1} {
	append reject "Quiz Version invalid \n"
    }
    if {$found < 1} {
	set data(quizversion) ""
    }

    #parse Quiz I.D.
    for {set i 17} {$i <= 19 } {incr i} {
	set found 0
	for { set j 2 } { $j <= 11 } { incr j } {
	    if { [lindex $image($i) $j] } {
		incr found
		append data(quizid) "[expr $j-2]"
	    }
	}
	if {$found != 1} {
	    append reject "Quiz ID character [expr $i-16] invalid \n"
	}
    }

    #parse subjective score
    set totalfound 0
    set data(subjectivescore) 0
    for {set i 21} {$i <= 22 } {incr i} {
	set found 0
	for { set j 7 } { $j <= 11 } { incr j } {
	    if { [lindex $image($i) $j] } {
		incr found
		incr totalfound
		incr data(subjectivescore) [expr ((12-$j)+((22-$i)*5))*10]
	    }
	}
	if {$found > 1} {
	    append reject "Subjective score invalid \n"
	}
    }
    for {set i 23} {$i <= 24 } {incr i} {
	set found 0
	for { set j 7 } { $j <= 11 } { incr j } {
	    if { [lindex $image($i) $j] } {
		incr found
		incr totalfound
		incr data(subjectivescore) [expr ((11-$j)+((24-$i)*5))]
	    }
	}
	if {$found > 1} {
	    append reject "Subjective score invalid \n"
	}
    }
    if { $data(subjectivescore) > 100 } {
	append reject "Subjective Score greater than 100\n"
    }
    if { $totalfound > 2 } {
	append reject "Subjective Score invalid, too many items bubbled in ($totalfound)\n"
    }
    if { $totalfound == 0 } { set data(subjectivescore) "" }
    
    #parse answers
    for {set i 21} {$i <= 45 } {incr i} {
	set found 0
	for { set j 1 } { $j <= 5 } { incr j } {
	    if { [lindex $image($i) $j] } {
		incr found
		append data(answer) [lindex $alphabet [expr $j-1]]
	    }
	}
	if {$found > 1} {
	    append reject "Answer on line [expr $i-20] has multiple bubbles filled in \n"
	}
	if {$found == 0} { append data(answer) " " }
    }    
    return $reject
}

proc readdata {} {
    global scanner
    while { 1 } {
	append line [read $scanner]
	set lastchar [string index $line end]
	if { $lastchar == "\r" } { break }
	after 10
    }
    parseline $line image
    set reject [getdata image data]
    if { $reject != "" } {
	puts "Reject Form: \n$reject"
	sendcommand "3"
    } else {
	puts "Accept Form"
	sendcommand "4"
    }
    parray data
}

proc sendcommand { command } {
    global scanner
    puts -nonewline $scanner $command
    flush $scanner
}

proc readcommand {} {
    global scanner
    set line [gets stdin]
    switch -glob $line {
	q {
	    exit
	}
	s* {
	    set command [string range $line 1 end]
	    puts "sending command to scanner $command"
	    sendcommand $command
	    puts "sent"
	}
    }
}

proc main {} {
    global scanner
    set scanner [open "/dev/ttyS1" "r+"]
    fconfigure $scanner -blocking 0 -translation binary
    fileevent $scanner readable readdata
    fconfigure stdin -blocking 0 
    fileevent stdin readable readcommand
    vwait c
}
main