abx.tcl

#!/bin/sh
# Bare-bones Tk GUI for ABX testing.
# klg, Nov 2017; next line executed by sh \
exec wish "$0" ${1+"$@"}
package require Tk
package require msgcat
namespace import msgcat::mc

# Require k of n trials to pass
lassign {13 16} abx_k abx_n

#set play_command {play $s 2> /dev/null}
set play_command {ffmpeg -v 0 -i $s -vn -sn -f alsa default}

wm title . ABX
wm protocol . WM_DELETE_WINDOW exit

grid anchor . c

grid [label .header] -row 0 -column 0 -columnspan 4 -sticky nswe
grid [label .status] -row 3 -column 0 -columnspan 4 -sticky nswe

grid [button .playA -text [mc {Play A}]] -row 1 -column 0 -sticky nswe
grid [button .playX -text [mc {Play X}]] -row 1 -column 1 -columnspan 2 -sticky nswe
grid [button .playB -text [mc {Play B}]] -row 1 -column 3 -sticky nswe

grid [button .ansA -text [mc {X = A}]] -column 0 -row 2 -sticky nswe -columnspan 2
grid [button .ansB -text [mc {X = B}]] -column 2 -row 2 -sticky nswe -columnspan 2

.header configure -text [mc {ABX test}]
.status configure -text [mc {Setting up...}] -anchor nw

.playA configure -command {play A}
.playB configure -command {play B}
.playX configure -command {play X}

.ansA configure -command {answer A}
.ansB configure -command {answer B}

while {[llength $argv] < 2} {
  set f [tk_getOpenFile -multiple 1 -title [mc {Select samples to compare}]]
  if {$f == {}} exit
  lset argv [concat $argv $f]
}

proc shuffle {lst} {
  set L [llength $lst]
  for {set i 0} {$i < $L - 1} {incr i} {
    set j [expr {int(($L - $i) * rand()) + $i}]
    set x [lindex $lst $i]
    lset lst $i [lindex $lst $j]
    lset lst $j $x
  }
  return $lst
}

lset argv [lrange [shuffle $argv] 0 1]

set fileA [lindex $argv 0]
set fileB [lindex $argv 1]
set fileX {}

puts "A $fileA"
puts "B $fileB"

proc play {which} {
  global file$which play_command
  set fn [expr "\$file$which"]
  set fd [open [apply [list s [concat list | $play_command]] $fn] RDWR]
  fileevent $fd readable [list play_end $which $fd]
  .status configure -text [mc Playing...]
  .play$which configure -command [list play_stop $which $fd]
}

proc play_stop {which fd} {
  catch {puts $fd q}
  .status configure -text [mc Stop.]
  play_end $which $fd
}

proc play_end {which fd} {
  if [catch {close $fd} err] {
    .status configure -text "[mc Error:] $err"
  }
  .play$which configure -command [list play $which]
}

set trialno 0
set trialok 0

proc answer {which} {
  global trialno trialok abx_n abx_k
  if {$trialno >= $abx_n} {
    if {$trialok >= $abx_k} {
      .header configure -text [mc {Significantly different.}]
    } else {
      .header configure -text [mc {No significant difference found.}]
    }
    .status configure -text [mc {Done: %u/%u matched.} $trialok $trialno]
    puts "$trialok $trialno"
    foreach x {A B} { .ans$x configure -state disabled }
  } else {
    global fileA fileB fileX
    catch {
      if {[expr "\$file$which"] eq $fileX} {
        incr trialok
      }
    }
    incr trialno
    set fileX [lindex [shuffle [list $fileA $fileB]] 0]
    .playX flash
    .header configure -text [mc {ABX trial %u/%u} $trialno $abx_n]
    .status configure -text [mc Ready.]
  }
}

answer X