##
## Paul Nash
## webscool <webscool@ihug.co.nz>
## http://homepages.ihug.co.nz/~webscool/chucalc.html
##

# plugin and 8.0 compatability
if {[catch {string repeat a 5}]} {
    proc string_repeat { a b } {
	set res {}
	for {set i $b} {$i > 0} {incr i -1} {
	    append res $a
	}
	return $res
    }
} else {
    interp alias {} string_repeat {} string repeat
}
# note that this version of string_replace is not a general version 
# it does not handle "end-n" indexes or odd boundary conditions
if {[catch {string_replace a 0 0 {b {}} }]} {
    proc string_replace { a  s f b } {
        return [string range $a 0 [expr {$s-1}]]$b[string range $a [expr {$f+1}] end]
    }
} else {
    interp alias {} string_replace {} string replace
}

#now for chu proper
#
# layout the chu calculator window
#
pack [frame .s] [frame .b] [frame .e]

# status entry , unique and k button
set w .s
set k 2
set unique 1
set limit 600
pack [label $w.l -text Status] [entry $w.entry -width 50] \
        [button $w.cancel -text CANCEL -bg bisque3 -command "cancel"] \
        [label $w.l1 -width 6] \
        [button $w.unique -text Unique -bg bisque3 -command "unique \$unique" ] \
        [label $w.l2 -width 6] \
        [label $w.l3 -text K] [entry $w.k -width 3 ]  -side left
$w.k insert 0 $k
bind $w.k <Return> "setk \[$w.k get]"
proc setk {ik} {
    global wt k
    set k $ik
    $wt insert end "$k , "
    .e.edit.w1.r.g1.k delete 0 end
    .e.edit.w1.r.g1.k insert end $k
}
# unique - toggle unique status
# param 0 means currently Multi and request Unique(1)
proc unique {u} {
    global unique wt
    set unique [expr ! $u ]
    set unival [expr $unique?"Unique":"Multi"]   
    $wt insert end "$unival , "
    .s.unique configure -text $unival
}
# cancel - cancel a current operation
set cancel 0
proc cancel {} {
    global cancel
    set cancel 1
}

# operators and matrix boxes
set w .b
pack [ frame $w.unary] [frame $w.m1] [frame $w.binary] [frame $w.m2] [frame $w.m3] -side left

#operators

set w .b.unary
pack [button $w.id -text ID -bg bisque3 -command "chuunary ID \[.b.m1.g1.space cget -text]" ] \
        [button $w.trans -text _|_ -bg bisque3 -command "chuunary _|_ \[.b.m1.g1.space cget -text]" ] \
        [button $w.exp1 -text ! -bg bisque3 -command "chuunary ! \[.b.m1.g1.space cget -text]" ] \
        [button $w.exp2 -text ? -bg bisque3 -command "chuunary ? \[.b.m1.g1.space cget -text]" ]

set w .b.binary
pack [button $w.sum -text + -bg bisque3 \
                -command "binop \[.b.m1.g1.space cget -text]  + \[.b.m2.g1.space cget -text]"] \
        [button $w.prod -text * -bg bisque3  \
                -command "binop \[.b.m1.g1.space cget -text]  * \[.b.m2.g1.space cget -text]"] \
        [label $w.l1 -text " "] \
        [button $w.concat -text {;} -bg bisque3 \
                -command "binop \[.b.m1.g1.space cget -text] {;} \[.b.m2.g1.space cget -text]"] \
        [button $w.choice -text U -bg bisque3 \
                -command "binop \[.b.m1.g1.space cget -text]  U \[.b.m2.g1.space cget -text]"] \
        [label $w.l2 -text " "] \
        [button $w.with -text & -bg bisque3 \
                -command "binop \[.b.m1.g1.space cget -text]  & \[.b.m2.g1.space cget -text]"] \
        [button $w.par -text # -bg bisque3  \
                -command "binop \[.b.m1.g1.space cget -text]  # \[.b.m2.g1.space cget -text]"] \
        [button $w.imply -text "-o" -bg bisque3 -command "binop  \[.b.m1.g1.space cget -text]  -o \[.b.m2.g1.space cget -text]"] \
        [button $w.imply2 -text => -bg bisque3 \
                -command "binop \[.b.m1.g1.space cget -text]  => \[.b.m2.g1.space cget -text]"] 
#
# matrix windows m1 m2 m3
#

set constants "T 0 1 _|_ Sp2 Pt2 GF2^2"
set chu(T) "{set k} {set null 1} {set null 0} {set null {}} "
set chu(0) "{set k} {set null 0} {set null 1} { set null {}} "
set chu(1) "{set k} {set null 1} {set k} {set jj {}; for { set ii 0} { \$ii < \$k } { incr ii } {append jj \$ii}; set jj}"
set chu(_|_) "{set k} {set k} {set null 1} {set jj {}; for {set ii 0} { \$ii < \$k } { incr ii } {lappend jj \$ii}; set jj}"
set chu(Sp2) "{set null 2} {set null 2} {set null 2} {set null {01 10}}"
set chu(Pt2) "{set null 2} {set null 2} {set null 2} {set null {00 01}}"
set chu(GF2^2) "{set null 2} {set null 4} {set null 4} {set null {0000 0101 0011 0110}}"
#set chu(test) "{set null 2} {set null 4} {set null 4} {set null {0011 0101 1010 0110}}"

set undefined "p q u v"
set chu(undefined) "{} {} {} {set null Undefined}"
foreach i $undefined {
    set chu($i) $chu(undefined)
}

foreach i { m1 m2 m3 } {
    set w .b.$i
    pack [frame $w.e] [frame $w.g1] [frame $w.g2]
}
foreach i { m1 m2} {
    set w .b.$i.e
    pack [ listbox $w.lb -height 5 -width 10 -selectmode single -yscrollcommand "$w.s set"] -side right
    pack [scrollbar $w.s -command "$w.lb yview"] -side right -fill y
    foreach j $constants { $w.lb insert end $j }
}
set w .b.m3.e
pack [frame $w.f ] -side right
pack [label $w.f.l -text NEW] [entry $w.f.e -width 10] -side top
pack [ listbox $w.lb -height 5 -width 10 -selectmode single -yscrollcommand "$w.s set"] -side right
pack [scrollbar $w.s -command "$w.lb yview"] -side right -fill y
foreach j $undefined { $w.lb insert end $j }
bind $w.f.e <Return> newEntry

proc newEntry {} {
    global undefined chu
# enter the name in the undefined list and append to m3.lb and w2.lb listboxes
   set new [.b.m3.e.f.e get]
   if { [ info exists chu($new)]} { 
       .b.m3.g2.text delete 1.0 end
       .b.m3.g2.text insert end "Identifier $new is in use"
       return
   }
    lappend undefined $new
    .b.m3.e.lb insert end $new
    .e.edit.w2.l.lb.vars insert end $new
    set chu($new) [list {} {} {} {set null Undefined}]
    mview m3 $new
}

foreach i { m1 m2 m3} {
    set w .b.$i.g1
    grid [label $w.l0 -text Space] [label $w.l1 -text Points ] [label $w.l2 -text States ] [label $w.l3 -text k ]
    grid [label $w.space -width 10 -bg bisque2] [entry $w.points -width 5] \
             [entry $w.states -width 5] [entry $w.k -width 3 ]
}
foreach i {m1 m2 m3} {
    set w .b.$i.g2
    grid [text $w.text -width 24 -height 10 -yscrollcommand "$w.ys set" -xscrollcommand "$w.xs set "] \
        [ scrollbar $w.ys -command "$w.text yview"] -sticky ns
    grid [scrollbar $w.xs -orient horizontal -command "$w.text xview"] -sticky ew
}
#
# the script/edit window
#
set w .e
pack [frame $w.f1] [frame .e.script] -side left

set w .e.f1
pack [ radiobutton $w.script -text Script -variable script -value script -command setScript] \
        [radiobutton $w.edit -text Edit -variable script -value edit -command setEdit] 

proc setScript {} {
    catch { pack forget .e.edit }
    catch { pack .e.script -side left }
}

proc setEdit {} {
    catch { pack forget .e.script }
    catch { pack .e.edit  -side left }
}

#
# the script window
#

set w .e.script
pack [frame $w.t] [button $w.exec -text "Execute selected text" -bg bisque3 \
        -command execScript ]
pack [text $w.t.text -height 10 -width 60 -exportselection 1 -yscrollcommand "$w.t.scroll set"] -side left
pack [scrollbar $w.t.scroll -command "$w.t.text yview"] -fill y -side left
set wt $w.t.text

#
# the edit window
#

frame .e.edit
foreach i {w1 w2} {
    set w .e.edit.$i
    pack [frame $w] [ frame $w.l ] [frame $w.r ] -side left
    if { $i == "w1" } {
        pack [label $w.l.lab -width 4 ]
    } else {
        pack [button $w.l.parse -text Parse>> -command parse] 
    }
    pack [frame $w.l.lb] [label $w.l.msg ]
    pack [listbox $w.l.lb.vars -width 10 -height 4 -yscrollcommand "$w.l.lb.scroll set" ] -side left
    pack [ scrollbar $w.l.lb.scroll -command "$w.l.lb.vars yview" ] -fill y -side left
    bind $w.l.lb.vars <Button-1> \
            "mview $i \[ $w.l.lb.vars get \[ $w.l.lb.vars index @%x,%y]]"
    pack [frame $w.r.g1] [ frame $w.r.g2]
    grid [label $w.r.g1.l0 -text Space ] [label $w.r.g1.l1 -text Points ] [label $w.r.g1.l2 -text States ]   \
            [label $w.r.g1.l3 -text k ]
    if { $i == "w1" } { set it 1 } else { set it p }
    grid [label $w.r.g1.space -width 10 -bg bisque2 -text $it ] [entry $w.r.g1.points -width 5] \
            [entry $w.r.g1.states -width 5] [entry $w.r.g1.k -width 3 ]
    
    grid [text $w.r.g2.text -width 24 -height 10 -yscrollcommand "$w.r.g2.ys set" -xscrollcommand "$w.r.g2.xs set "] \
            [ scrollbar $w.r.g2.ys -command "$w.r.g2.text yview"] -sticky ns
    grid [scrollbar $w.r.g2.xs -orient horizontal -command "$w.r.g2.text xview"] -sticky ew
}
# populate the vars listboxes
set w .e.edit.w1.l.lb.vars
foreach i $constants {
    $w insert end $i
}
bind $w <Button-1> "mview w1 \[ $w get \[ $w index @%x,%y]]"
    
foreach i $undefined {
    .e.edit.w2.l.lb.vars insert end $i
}

# parse - parse the content of the first edit window (w1)
# and put result in the second edit window (w2).
# Report any errors in the second edit window
proc parse {} {
    global k chu m
    set w1 .e.edit.w1.r.g2.text
    set w2 .e.edit.w2.r.g2.text
    set m {}
    scan [$w1 index end] %d points
    for {set i 1} {$i < $points} {incr i} {
        set line [$w1 get $i.0 "$i.0 lineend"]
        regsub -all {[ \t]} $line "" line
        if { [lindex $line 0] != {} } {
            lappend m $line
        }
    }
    set points [llength $m]
    # check that all list elements have same length, and that they all consist of digits [0-9]
    $w2 delete 1.0 end
    set states [ string length [ lindex $m 0]]
    set mtest  ^[string_repeat \[0-9\] $states]$
    set notok 0
    for { set i 0 } { $i < $points } {incr i } {
        if { ![regexp $mtest [lindex $m $i]] } {
            set notok 1
            if { [string length [lindex $m $i]] != $states } {
                $w2 insert end "Error Line $i - length does not match\n"
            } else {
                $w2 insert end "Error Line $i - invalid character in line\n"
            }
        }
    }
    if { $notok } return
    # now cut m down according to the points and states in .e.edit.w1.g1
    set newpoints [.e.edit.w1.r.g1.points get]
    if { ![regexp {^[0-9]+$} $newpoints] || $newpoints > $points} { 
        .e.edit.w1.r.g1.points delete 0 end
        .e.edit.w1.r.g1.points insert end $points
    } elseif { $newpoints < $points } {
        set m [ lreplace $m $newpoints end  ]
        set points $newpoints
    }
    set newstates [.e.edit.w1.r.g1.states get]
    if { ![regexp {^[0-9]+$} $newstates] || $newstates > $states} { 
        .e.edit.w1.r.g1.states delete 0 end
        .e.edit.w1.r.g1.states insert end $states
    } elseif { $newstates < $states } {
        set mk {}
        foreach i $m {
            lappend mk [string range $i 0 [expr {$newstates-1}]]
        }
        set m $mk
        set states $newstates
    }
    set ik 0
    for { set i 0 } { $i < [string length $m] } { incr i } {
        if { [string compare [string index $m $i] $ik] == 1 } {
            set ik [string index $m $i]
        }
    }
    incr ik
    set newk [.e.edit.w1.r.g1.k get]
    if { ![regexp {^(10|[1-9])$} $newstates] || $newk < $ik }  { 
        .e.edit.w1.r.g1.k delete 0 end
        .e.edit.w1.r.g1.k insert end $ik
    } elseif { $newk > $ik } {
        set ik $newk
    }
    foreach i $m {
        $w2 insert end "$i\n"
    }
    set name [.e.edit.w2.r.g1.space cget -text]
    set chu($name) [list "set null $ik" \
            "set null $points" "set null $states" "set null \"$m\""]
    define $name
    set chu($name) [chuunique $name]
    mview w2 $name
    foreach i {m1 m2 m3 } {
        if { [.b.$i.g1.space cget -text] == $name } {
             mview $i $name
        }
    }
}

proc varset {} {}
# Initialisation - k=2 already
# m1 = 1 m2 = 1 m3 = p

foreach i { m1 m2 m3} {
    set w .b.$i.e.lb
    bind $w <Button-1> "mview $i \[ $w get \[ $w index @%x,%y]]"
}


proc mview {mi space} {
    global chu k
    # check that chu(space) has a k = $k
    if { [string index $mi 0] == "m"} {
        set w .b.$mi
    } else  {
        set w .e.edit.$mi.r
    }
    $w.g1.space config -text $space
    $w.g1.points delete 0 end
    $w.g1.points insert end [eval [lindex $chu($space) 1]]
    $w.g1.states delete 0 end
    $w.g1.states insert end [eval [lindex $chu($space) 2]]
    $w.g1.k delete 0 end
    $w.g1.k insert end  [eval [lindex $chu($space) 0]]
    $w.g2.text delete 1.0 end
    foreach i [eval [lindex $chu($space) 3]] {
        $w.g2.text insert end "$i\n"
    }
}
mview m1 1
mview m2 1
mview m3 p

######################################################
# Operators
#
# Unary Operators
#

# unique operator
proc chuunique {source} {
    global unique k chu
    if { ! $unique } { return $chu($source) }
    set m [eval [lindex $chu($source) 3]]
    set p [matrixUnique $m]
    if { [string length $m] == [string length $p] } {
        return $chu($source)
    }
    return [list [lindex $chu($source) 0] "set null [llength $p]" "set null [string length [lindex $p 0]]" \
            "set null \"$p\" "]
}


#unary operators 
proc chuunary {op source} {
    global chu k wt cancel
    set target [.b.m3.g1.space cget -text]
    .s.entry delete 0 end
    .s.entry insert end "Executing $target = $op $source"
    update
    switch -exact -- $op {
         ID { set chu($target) $chu($source)
              }
        _|_ { set chu($target) [chutrans $source]
              }
        ? { set chu($target) [chuquery $source]
            }
        !   {     
            set "chu(_|_ $source)" [chutrans $source]
            set "chu(? _|_ $source)" [chuquery "_|_ $source"]
            set chu($target) [chutrans "? _|_ $source"]
            }
     } 
    set chu($target) [chuunique $target]
    mview m3 $target
    define $target
    # if result is not undefined
    if { [lindex $chu($target) 0 ] != {} } {
        .s.entry delete 0 end
        .s.entry insert end "Done" 
        $wt insert end "$target = $op $source , "
    }
    if { $cancel } {
         .s.entry delete 0 end
         .s.entry insert end "Operation cancelled."
         set cancel 0
    }
    update
}

proc chutrans {source} {
    global chu k
    set space [eval [lindex $chu($source) 3]]
    set m [matrixTrans $space]
    return [list [lindex $chu($source) 0] [lindex $chu($source) 2] [lindex $chu($source) 1] "set null \"$m\"" ]
}

##########################################################
# query  forms a superset of rows of source
# source first has added all constant rows for k
# Then has added the diagonal of every matrix generated by MG on (_|_source,source)
proc chuquery {source} {
    global k q rowQNodes chu wt cancel

    # special case for k=2
    if { $k == 2 } { return [chuquery2 $source]}

    # space is row uniqued to save computation time, but mainly to keep a strict count
    # of the number of different rows.
    set space " [matrixRowUnique [eval [lindex $chu($source) 3]]]"
    set ncols [eval [lindex $chu($source) 2]]
    for { set i 0 } { $i < $k} { incr i } {
        set konstant " [string_repeat $i $ncols]"
        if { ![regexp $konstant $space] } {
            append space $konstant
        }
    }

    # apply the matrix generator to (_|_source,source)
    # this returns a lot of matrices, collect the diagonals, 
    # but dont add to space until the end of this round
    # if a round produces no new unique rows we are finished
    while 1 {
        # if all possible rows are already generated we dont have to confirm it
        if { [llength $space] == pow($k,$ncols) } break

        qInit $space
        while { [qNext] } {
            set newrow ""
            for { set i 0 } { $i < $ncols } { incr i } {
                append newrow [string index $rowQNodes($i) $i]
            }
            set newrows($newrow) 1
            # check the cancel button
            update
            if { $cancel } {
                return $chu(undefined)
            }
        }
        if { [array names newrows] == {} } break
        set space [concat $space [array names newrows]]
        unset newrows
    }
    return [list [lindex $chu($source) 0] "set null [llength $space]" [lindex $chu($source) 2] "set null \"$space\"" ]
}

# Matrix Generator routines tailored for Query
# qInit and qNext are the matrix generating routine
# qInit sets up the work matrix/arrays rowQNodes and rowCols which are transpose twins
#           sets pointers curRow and curCol to the first cell in the work matrix
#           determines the work matrix bounds
#           transposes the first argument for easier reference by row
#           inserts a space in front of each space to aid regular expression matching

# Copyright Paul Nash April 2000
# This pair of matrix generator routines (qInit and qNext) are the intellectual property of Paul Nash

proc qInit { a } {
    global wt Q
    global k q rowQNodes colQNodes  
    set Q " $a"
    set q(ncols) [string length [lindex $a 0]]
    set q(curCol) 0
    set q(nrows) $q(ncols)
    set q(curRow) 0
    # rowQNodes and colQNodes are maintained as the transpose of each other for
    # convenience of searching 
    #  [ string index $rowQNodes($i) $j] == [ string index $colQNodes($j) $i]
    # initialise row search arrays with . which matches any single character in a regular expression
    catch {unset rowQNodes}
    catch {unset colQNodes}
    for { set r 0 } { $r < $q(nrows) } { incr r } { 
        set rowQNodes($r)  [string_repeat . $q(ncols)]
        set colQNodes($r) [string_repeat . $q(nrows)]
    }    
}


# The cell path traverses the matrix in the following diagonal order:
#   1    6   11  16  21
# 22    2     7  12  17
# 18  23     3    8  13
# 14  19   24    4    9
# 10  15   20   25   5
#this path is easily calculated and determines the diagonal first
#If this diagonal is already known then we move on to the next possible diagonal

proc qNext {} {
    global k q rowQNodes colQNodes wt Q 

    while {1} {      
        # increment from the current position
        set symbol [string index $rowQNodes($q(curRow)) $q(curCol)]
        if { $symbol =="." } {
            set symbol 0
        } else { 
            incr symbol
            if { $symbol == $k } {
                set symbol .
            }
        }
        set rowQNodes($q(curRow)) \
                    [string_replace $rowQNodes($q(curRow)) $q(curCol) $q(curCol) $symbol ]
        set colQNodes($q(curCol)) \
                    [string_replace $colQNodes($q(curCol)) $q(curRow) $q(curRow) $symbol ]
        # if this cell ran over to k and got changed back to . we step backwards
         if { $symbol == "." } {
             if { $q(curRow) == 0 && $q(curCol) == 0 } {
                  return 0
             }

             set q(curCol) [expr { (   $q(curCol) -1 + (($q(curRow)-1)/$q(nrows))   )     %$q(ncols) }]
             set q(curRow) [expr { ($q(curRow)-1)%$q(nrows)} ]
             continue
         }
         # we now have a new entry to be tested
         if { ([ regexp " $rowQNodes($q(curRow))" $Q ] ==0 ) ||
                  ([ regexp " $colQNodes($q(curCol))" $Q ] == 0 ) } {
             continue
         } else {
             # That was OK 
             # if this is the diagonal and it is already known then continue
             if { ($q(curRow) + 1 == $q(nrows)) && ($q(curCol) + 1 == $q(ncols)) } {
                set diag " "
                for {set i 0} { $i < $q(nrows) } { incr i } {
                    append diag [string index $rowQNodes($i) $i ]
                }
                if { [regexp $diag $Q] } continue
             }
             # If this is the last cell then return the completed function
             if { ($q(curRow) + 1 == $q(nrows)) && ($q(curCol) + 2 == $q(ncols)) } {

                 # but first rewind the matrix back to the diagonal, 
                 # since we dont need to search this diagonal any more
                 for  {set r 0 } { $r < $q(nrows) } { incr r} {
                     set d [string index $rowQNodes($r) $r ]
                     set rowQNodes($r) [string_repeat . $q(nrows) ]
                     set colQNodes($r) [string_repeat . $q(nrows) ]
                     set rowQNodes($r) [string_replace $rowQNodes($r) $r $r $d]
                     set colQNodes($r) [string_replace $colQNodes($r) $r $r $d]
                 }
                 set q(curRow) [expr $q(nrows) -1]
                 set q(curCol) [expr $q(nrows) -1]

                 return 1
             }
         }

        # step curRow, curCol forward to fill in the next cell for this function
        set q(curCol) [ expr { ( $q(curCol) +1 + (($q(curRow) +1)/$q(nrows)))%$q(ncols) } ]
        set q(curRow) [ expr { ( $q(curRow) +1)%$q(nrows) } ]
    }
}

# end of query
#
################################



#define - check if variable is undefined - if it is move it to defined list, undate listboxes 
#             and mviews if it is currently visible in m1 or m2
proc define space {
    global chu undefined
    if { [set ind [lsearch -exact $undefined $space]] >= 0  } {
        set undefined [lreplace $undefined $ind $ind ]
        .b.m1.e.lb insert end $space
        .b.m2.e.lb insert end $space
        .e.edit.w1.l.lb.vars insert end $space
    }
   if { [.b.m1.g1.space cget -text] == $space } { mview m1 $space }
   if { [.b.m2.g1.space cget -text] == $space } { mview m2 $space }
}

# binary operators
# sum + - the transpose of this is for some reason called product by Larry Yogman
# prod is the simplest to program because it is row oriented. sum = _|_ prod ( _|_A, _|_B)
# every column of source1 is followed by every column of source2
proc binop { source1 op source2 } {
    global chu k wt cancel
    
    set k1 [eval [lindex $chu($source1) 0]]
    set k2 [eval [lindex $chu($source2) 0]]
    if { $k1 != $k2 } {
        .s.entry delete 0 end
        .s.entry insert end "Operation ignored - $source1 and $source2 have nonmatching k, $k1 and $k2"
        return
    }
    set target [.b.m3.g1.space cget -text]
    .s.entry delete 0 end
    .s.entry insert end "Executing $target = $source1 $op $source2"
    update

    set "chu(_|_ $source1)" [chutrans $source1]
    set "chu(_|_ $source2)" [chutrans $source2]
    switch -exact -- $op {
        U {
            set chu($target) [chuchoice $source1 $source2]
            }
        {;}  {
            set chu($target) [chusequence $source1 $source2]
           }
        & {
           set chu($target) [chuprod $source1 $source2]
           }
        + { 
            set "chu(_|_ $source1)" [chutrans $source1]
            set "chu(_|_ $source2)" [chutrans $source2]
            set "chu(_|_ $target)" [chuprod "_|_ $source1" "_|_ $source2"]
            set chu($target) [chutrans "_|_ $target"]
            }
        * {
            set "chu(_|_ $source2)" [chutrans $source2]
            set "chu(_|_ $target)" [chuimply $source1 "_|_ $source2"]
            set chu($target) [chutrans "_|_ $target"]
           }
        -o {
             set chu($target) [chuimply $source1 $source2]
            }
        \# {
             set "chu(_|_ $source1)" [chutrans $source1]
             set  chu($target) [chuimply "_|_ $source1" $source2]
            }
        => {
              set "chu(_|_ $source1)" [chutrans $source1]
              set "chu(? _|_ $source1)" [chuquery "_|_ $source1"]
              set "chu(_|_ ? _|_ $source1)" [chutrans "? _|_ $source1"]
              set chu($target) [chuimply "_|_ ? _|_ $source1" $source2]
             }
    }
    set chu($target) [chuunique $target]
    mview m3 $target
    define $target
    # if target is not undefined
    if { [lindex $chu($target) 0 ] != {} } {
        .s.entry delete 0 end
        .s.entry insert end "Done" 
        $wt insert end "$target = $source1 $op $source2 , "
        update
    }
    if { $cancel } {
         .s.entry delete 0 end
         .s.entry insert end "Operation cancelled."
         set cancel 0
    }
}

proc chuprod {source1 source2} {
    global chu k limit
    if {  [eval [lindex $chu($source1) 1]]* [ eval [lindex $chu($source2) 1]] > $limit } {
        .s.entry delete 0 end
        .s.entry insert end "Operation cancelled - exceeds row bounds"
        update
        return $chu(undefined)
    }
    if {  [eval [lindex $chu($source1) 2]]+ [ eval [lindex $chu($source2) 2]] > $limit } {
        .s.entry delete 0 end
        .s.entry insert end "Operation cancelled - exceeds column bounds"
        update
        return $chu(undefined)
    }
    set space1 [eval [lindex $chu($source1) 3]]
    set space2 [eval [lindex $chu($source2) 3]]
    set m {}
    foreach i $space1 {
        foreach j $space2 {
            lappend m ${i}$j
        }
    }
    set m [matrixUnique $m]
    return [list "set null $k" "set null [llength $m]" "set null [string length [lindex $m 0]]" "set null \"$m\" "]
}

# choice  - place source1 in the nw quadrant, source2 in the se quadrant, 
#                 zeros in the ne and sw quadrants
proc chuchoice { source1 source2 } {
    global chu k limit

    set space1 [eval [lindex $chu($source1) 3]]
    set states1 [eval [lindex $chu($source1) 2]]
    set space2 [eval [lindex $chu($source2) 3]]
    set states2 [eval [lindex $chu($source2) 2]]
    if {  [eval [lindex $chu($source1) 1]] + [ eval [lindex $chu($source2) 1]] > $limit } {
        .s.entry delete 0 end
        .s.entry insert end "Operation cancelled - exceeds row bounds"
        update
        return $chu(undefined)
    }
    if {  $states1 + $states2 > $limit } {
        .s.entry delete 0 end
        .s.entry insert end "Operation cancelled - exceeds column bounds"
        update
        return $chu(undefined)
    }

    set m {}
    foreach i $space1 {
        lappend m $i[string_repeat 0 $states2]
    }
    foreach i $space2 {
        lappend m [string_repeat 0 $states1]$i
    }
    set points [expr [eval [lindex $chu($source1) 1]] + [eval [lindex $chu($source2) 1]]]
    set m [matrixUnique $m]
    return [list "set null $k"  "set null $points" "set null [expr $states1 + $states2]" "set null \"$m\" "]
}

# sequence(=concat) combines the columns of two spaces, but not in all possible ways. 
#    columns are partially ordered by componentwise comparison
#    a cloumn is initial if it is "larger" than no other columns, ie no column is less than it.
#    a column is final if it is " smaller" than no other columns.
#    columns of the new matrix are any columns of the first space 
#           followed by an initial column of the second space
#           or a final column of the first space followed by any column of the second space
proc chusequence {source1 source2} {
    global chu k limit

    set space1 [eval [lindex $chu($source1) 3]]
    set space2 [eval [lindex $chu($source2) 3]]
    # get initial columns of source2
    set t2 [matrixTrans $space2]
    set initial2 [ matrixOrder > $t2 ]
    # get final columns of space1
    set t1 [matrixTrans $space1]
    set final1 [matrixOrder < $t1 ]
    if {  [eval [lindex $chu($source1) 1]]* [ eval [lindex $chu($source2) 1]] > $limit } {
        .s.entry delete o end
        .s.entry insert end "Operation cancelled - exceeds row bounds"
        update
        return $chu(undefined)
    }
    if { ([eval [lindex $chu($source1) 2]] * [llength $initial2] )+ \
         ([eval [lindex $chu($source2) 2]] * [llength $final1]) -
         ( [llength $initial2] * [llength $final1]) > $limit } {
        .s.entry delete o end
        .s.entry insert end "Operation cancelled - exceeds column bounds"
        update
        return $chu(undefined)
    }
    # now assemble the output matrix in transverse form
    set t3 {}
    foreach i $t1 {
    foreach j $initial2 {
        lappend t3 ${i}[lindex $t2 $j]
    }}
    foreach i $final1 {
    for { set j 0 } { $j < [llength $t2] } { incr j } {
        if { [lsearch $initial2 $j ] < 0 } {
            lappend t3  [lindex $t1 $i][lindex $t2 $j] 
        }
    }}
    set t3 [matrixTrans [matrixUnique $t3]]
    return [list [lindex $chu($source1) 0] "set null [llength $t3]" "set null [string length [lindex $t3 0]]" " set null \"$t3\" "]
}
#
# matrix operators - these are the lowest level operators on fully expanded matrixes
#
# they accept one or two matrices and return a matrix
#
proc matrixTrans {m} {
    set q {}
    set states [string length [lindex $m 0]]
    for {set j 0} { $j < $states } { incr j } {
        set w {}
        foreach i $m {
            append w [string index $i $j ]
        }
        lappend q $w
   }
   return $q
}

# unique the rows, transpose, unique new rows (old columns) and transpose back
proc matrixUnique {m} {
    global unique
    if { ! $unique } { return $m }
    return [matrixTrans [matrixRowUnique [matrixTrans [matrixRowUnique $m]]]]
}
proc matrixRowUnique {m} {
    set n [lsort $m]
    set j ""
    set p {}
    foreach i $n {
        if { $i != $j } { 
            lappend p $i
            set j $i
        }
    }
    if { [llength $p] == [llength $m] } {
        return $m
    } else {
        return $p
    }
}

# initial and final - returns index to the initial or final rows of the matrix
# use op= ">" for initial and op= "<" for final
proc matrixOrder { op m } {
    set l {}
    set slength [ string length [lindex $m 0] ]
    for {set i 0} {$i < [llength $m]} { incr i } {
        set ii [lindex $m $i ]
        set done 0
        foreach j $m {
             if { [string compare $ii $j] != 0 } {
                 for { set c 0 } { $c < $slength } { incr c } {
                      set test [expr "[string index $j $c ]" $op "[string index $ii $c]" ]
                      if { $test } break
                 } 
                 if { $c >= $slength } { 
                     set done 1
                     break
                 }
            }
        }
        if { ! $done } { lappend l $i }
    }
    return $l
}


#########################################
# Implication
#

proc chuimplyold {source1 source2} {
    global chu k cancel limit
    global mg rowNodes

    set space1 [eval [lindex $chu($source1) 3]]
    set space2 [eval [lindex $chu($source2) 3]]
    if { [llength $space1] * [string length [lindex $space2 0]] > $limit } {
           .s.entry delete 0 end
            .s.entry insert end "Operation cancelled - exceeds space bounds"
            return $chu(undefined)
        }    
    mgInit  $space1 $space2
    set t {}
    set trows 0
    while {[mgNext]} {
        set r ""
        for {set i 0 } { $i < $mg(nrows) } {incr i} {
            append r $rowNodes($i)
        }
        lappend t $r
        if { [incr trows] > $limit } {
            .s.entry delete 0 end
            .s.entry insert end "Operation cancelled - exceeds space bounds"
            return $chu(undefined)
        }    
        # check the cancel button
#        update
        if { $cancel } {
             return $chu(undefined)
        }
    }
    return [list [lindex $chu($source1) 0] "set null [llength $t]" \
            "set null [string length [lindex $t 0]]" " set null \"$t\" "]
}

proc printArray {a} {
    upvar $a arr
    set r ""
    foreach i [lsort -integer [array names arr]] {
        lappend r $arr($i)
    }
    return $r
}

# Matrix Generator routines
# mgInit and mgNext are the matrix generating routine
# mgInit sets up the work matrix/arrays rowNodes and rowCols which are transpose twins
#           sets pointers curRow and curCol to the first cell in the work matrix
#           determines the work matrix bounds
#           transposes the first argument for easier reference by row
#           inserts a space in front of each space to aid regular expression matching

# Copyright Paul Nash April 2000
# This pair of matrix generator routines (mgInit and mgNext) are the intellectual property of Paul Nash
proc mgInit { a b } {
    global wt B tA
    global k mg rowNodes colNodes  
    set B " $b"
    set tA " [matrixTrans $a]"
    set mg(ncols) [string length [lindex $b 0]]
    set mg(curCol) 0
    set mg(nrows) [string length [lindex $tA 0]]
    set mg(curRow) 0
    # rowNodes and colNodes are maintained as the transpose of each other for
    # convenience of searching 
    #  [ string index $rowNodes($i) $j] == [ string index $colNodes($j) $i]
    # initialise row search arrays with . which matches any single character in a regular expression
    catch {unset rowNodes}
    for { set r 0 } { $r < $mg(nrows) } { incr r } { 
        set rowNodes($r)  [string_repeat . $mg(ncols)]
    }
    #initialise column search arrays - similarly
    catch {unset colNodes}
    for { set c 0 } { $c < $mg(ncols) } { incr c } {
         set colNodes($c) [string_repeat . $mg(nrows)]
    }    
}


# The cell path traverses the matrix in the following herringbone order:
# 1    2   3   4
# 5    9 10 11
# 6  12 15 16
# 7  13 17 19
# 8  14 18 20

proc mgNext {} {
    global k mg rowNodes colNodes wt B tA

    while {1} {
        set symbol [string index $rowNodes($mg(curRow)) $mg(curCol)]
        if { $symbol =="." } {
            set symbol 0
        } else { 
            incr symbol
            if { $symbol == $k } {
                set symbol .
            }
        }
        set rowNodes($mg(curRow)) \
                    [string_replace $rowNodes($mg(curRow)) $mg(curCol) $mg(curCol) $symbol ]
        set colNodes($mg(curCol)) \
                    [string_replace $colNodes($mg(curCol)) $mg(curRow) $mg(curRow) $symbol ]
        # if this cell ran over to k and got changed back to . we step backwards
         if { $symbol == "." } {
             if { $mg(curRow) == 0 && $mg(curCol) == 0 } {
                  return 0
             }

             if { $mg(curRow) <= $mg(curCol) } {
                incr mg(curCol) -1
                if { $mg(curCol) < $mg(curRow) } {
                    set mg(curRow) [expr {$mg(nrows)-1}]
                }
            } else {
                incr mg(curRow) -1
                if { $mg(curRow) == $mg(curCol) } {
                    set mg(curCol) [ expr { $mg(ncols)-1} ]
                }   
            }
            continue
         }
         # we now have a new entry to be tested
         if { ([ regexp " $rowNodes($mg(curRow))" $B ] ==0 ) ||
                  ([ regexp " $colNodes($mg(curCol))" $tA ] == 0 ) } {
             continue
         } else {
             # That was OK 
             # If this is the last cell then return the completed morphism
             if { ($mg(curRow) + 1 == $mg(nrows)) && ($mg(curCol) + 1 == $mg(ncols)) } {
                 return 1
             }
         }

        # step curRow, curCol forward to fill in the next cell for this morphism
        if { $mg(curRow) <= $mg(curCol) } {
            incr mg(curCol)
            if {$mg(curCol) == $mg(ncols) } {
               set mg(curCol) $mg(curRow)
               set mg(curRow) [expr {$mg(curCol)+1}]
            }
        } else {
            incr mg(curRow)
            if { $mg(curRow) == $mg(nrows) } {
                set mg(curRow) [expr {$mg(curCol)+1}]
                set mg(curCol) $mg(curRow)
            }
        }
    }
}

# end of implication
#
############################

# execute script
# 
proc execScript {} {
    global wt k chu unique
    set indices [$wt tag ranges sel]
    set cmd [$wt get [lindex $indices 0] [lindex $indices 1]]

   # There are 4 command types - assign K, Unique/Multi, unary op and binary op
    while {$cmd != {} } {
        set cmd0 [lindex $cmd 0]
        if { [regexp {^([2-9]|10)$} $cmd0 match] &&
            ([lindex $cmd 1] == "," ) } {
                set k $match
                setk $k
                .s.k delete 0 end
                .s.k insert end $k
                set cmd [lreplace $cmd 0 1 ]
                continue
        }
        if { [regexp {^(Unique|Multi)$} $cmd0 match ] &&
                ([lindex $cmd 1] == ",")} {
                if {$match == "Unique" } {
                    unique 0
                } else {
                    unique 1
                }
                set cmd [lreplace $cmd 0 1 ]
                continue    
        }
        if { [lindex $cmd 1]  == "="} {
            if { ![info exists chu($cmd0) ] } {
                .b.m3.e.f.e delete 0 end
                .b.m3.e.f.e insert end $cmd0
                newEntry
            }
            if { [regexp {^(ID|~|!|\?)$} [lindex $cmd 2] op] &&
                   [info exists chu([lindex $cmd 3]) ] && ( "," == [lindex $cmd 4]) } {
               set target $cmd0
               set source [lindex $cmd 3]
               mview m3 $target
               mview m1 $source
               chuunary $op $source
               set cmd [lreplace $cmd 0 4]
               continue
           } 
           if { [info exists chu([lindex $cmd 2]) ] && [regexp {^([+*&#;U]|-o|=>)$} [lindex $cmd 3] op ] &&
                  [info exists chu([lindex $cmd 4]) ] && ( "," == [lindex $cmd 5]) } {
                set target $cmd0
                mview m3 $target
                set source1 [lindex $cmd 2]
                set source2 [lindex $cmd 4]
                mview m1 $source1
                mview m2 $source2
                binop $source1 $op $source2
                set cmd [lreplace $cmd 0 5]
                continue
           }
        }
       .s.entry delete 0 end
       .s.entry insert end "Error in script - execution stopped."   
    }
    .s.entry delete 0 end
    .s.entry insert end " Execution of script completed."
}

proc chuquery2 {source} {
    global k chu limit

    set cols [eval [lindex $chu($source) 2]]
    if { $cols < 32 } {  return [chuquery2bin $source]}
    # space is row uniqued to save computation time, but mainly to keep a strict count
    # of the number of different rows.
    set space " [matrixRowUnique [eval [lindex $chu($source) 3]]]"
    set rows [eval [lindex $chu($source) 1]]
    for { set i 0 } { $i < $k} { incr i } {
        set konstant " [string_repeat $i $cols]"
        if { ![regexp $konstant $space] } {
            append space $konstant
        }
    }

    set start 1
    set new 1
    while {$new} {
        set new 0
        for {set i $start} { $i < $rows } { incr i } {
             for { set j 0} { $j < $i } { incr j } {
                set Urow " "
                set Irow " "
                for { set ic 0 } { $ic < $cols } { incr ic } {
#puts "i=$i; j=$j; ic=$ic; ichar=[string index [list index $space $i] $ic]; jchar=[string index [list index $space $j] $ic];"
                   append Urow [ expr { [string index [lindex $space $i] $ic] | [string index [lindex $space $j] $ic]}]
                   append Irow [ expr { [string index [lindex $space $i] $ic] & [string index [lindex $space $j] $ic]}]
                }
                if { ![regexp $Urow $space match] } {
                    append space $Urow
                    set new 1
                }
                if { ![regexp $Irow $space match] } {
                    append space $Irow
                    set new 1
                }
                if { [llength $space] > $limit } {
                    .s.entry delete 0 end
                    .s.entry insert end "Operation cancelled - exceeds row bounds"
                    update
                    return $chu(undefined)
                }
         }}
         set start $rows
         set rows [llength $space]
    }
    return [list [lindex $chu($source) 0] "set null [llength $space]" [lindex $chu($source) 2] "set null \"$space\"" ]

}

proc chuquery2bin {source} {
    global k chu limit

    # k=2 and there are less than 32 cols
        set cols [eval [lindex $chu($source) 2]]
    # space is row uniqued to save computation time, but mainly to keep a strict count
    # of the number of different rows.
    set space " [matrixRowUnique [eval [lindex $chu($source) 3]]]"
    foreach i $space {
         set ival 0
         
    }
    set rows [eval [lindex $chu($source) 1]]
    for { set i 0 } { $i < $k} { incr i } {
        set konstant " [string_repeat $i $cols]"
        if { ![regexp $konstant $space] } {
            append space $konstant
        }
    }
    #covert space from string to integer format
    set ispace " "
    foreach i $space {
        append ispace " [binStringToInt $i]"
    }
    set start 1
    set new 1
    while {$new} {
        set new 0
        for {set i $start} { $i < $rows } { incr i } {
             for { set j 0} { $j < $i } { incr j } {
                set Urow " [ expr { [lindex $ispace $i] | [lindex $ispace $j] }]"
                set Irow " [ expr { [lindex $ispace $i] & [lindex $ispace $j] }]"
                if { ![regexp $Urow $ispace match] } {
                    append ispace $Urow
                    set new 1
                }
                if { ![regexp $Irow $ispace match] } {
                    append ispace $Irow
                    set new 1
                }
                if { [llength $ispace] > $limit } {
                    .s.entry delete 0 end
                    .s.entry insert end "Operation cancelled - exceeds row bounds"
                    update
                    return $chu(undefined)
                }
         }}
         set start $rows
         set rows [llength $ispace]
    }
    # convert ispace from integer back to binary string form
    set space {}
    foreach i $ispace {
        set istring [intToBinString $i]
        lappend space [string_repeat 0 [expr {$cols - [string length $istring]}]]$istring
    }
    return [list [lindex $chu($source) 0] "set null [llength $space]" [lindex $chu($source) 2] "set null \"$space\"" ]

}

proc binStringToInt { str } {
   set strlen [string length $str]
   if {$strlen > 31 } { 
        error "binary string of length $strlen is too long for conversion to integer"
   }
   if { $strlen == 0} {
       error "binary string of zero length"
   }
   set res [string index $str 0]
   for { set i 1} { $i < [string length $str]} { incr i} {
       set res [expr {(int($res)*2)+int([string index $str $i])}]
   }
   return $res
}
proc intToBinString { int } {
    set res ""
    while {$int != 0 } {
        set res [expr {$int%2} ]$res
        set int [expr {$int/2} ]
    }
    return $res
}




#############################
#  New row/column version

proc chuimply {source1 source2} {
    global chu k cancel limit
    global mg rowNodes  B tA colindex

    set space1 [eval [lindex $chu($source1) 3]]
    set space2 [eval [lindex $chu($source2) 3]]
    if { [llength $space1] * [string length [lindex $space2 0]] > $limit } {
           .s.entry delete 0 end
            .s.entry insert end "Operation cancelled - exceeds space bounds"
            return $chu(undefined)
    }    
    set B " $space2"
    set tA " [matrixTrans $space1]"
    set mg(ncols) [string length [lindex $space2 0]]
    set mg(curCol) 0
    set mg(nrows) [string length [lindex $tA 0]]
    
    # rowNodes and colNodes are maintained as the transpose of each other for
    # convenience of searching 
    #  [ string index $rowNodes($i) $j] == [ string index $colNodes($j) $i]
    # initialise row search arrays with . which matches any single character in a regular expression
    # initialise colindex
    catch {unset colindex}
    for { set c 0} { $c < $mg(ncols) } { incr c} {
        set colindex($c) .
    }
    # initialise row search arrays
    catch {unset rowNodes}
    for { set r 0 } { $r < $mg(nrows) } { incr r } {
         set rowNodes($r) [string_repeat . $mg(ncols)]
    }    

    set t {}
    set trows 0
    while {[mgNext3]} {
        set r ""
        for {set i 0 } { $i < $mg(nrows) } {incr i} {
            append r $rowNodes($i)
        }
        lappend t $r
        if { [incr trows] > $limit } {
            .s.entry delete 0 end
            .s.entry insert end "Operation cancelled - exceeds space bounds"
            return $chu(undefined)
        }    
        # check the cancel button
#        update
        if { $cancel } {
             return $chu(undefined)
        }
    }
    return [list [lindex $chu($source1) 0] "set null [llength $t]" \
            "set null [string length [lindex $t 0]]" " set null \"$t\" "]
}

proc mgNext3 {} {
    global k mg rowNodes colindex wt B tA
    while {1} {
        if { $colindex($mg(curCol)) =="." } {
            set colindex($mg(curCol)) 0
        } else { 
            incr colindex($mg(curCol))
            if { $colindex($mg(curCol)) == [llength $tA] } {
                set colindex($mg(curCol))  .
            }
        }

        # if this cell ran over to k and got changed back to . we step backwards
        if { $colindex($mg(curCol)) == "." } {
            for { set r 0 } { $r < $mg(nrows) } { incr r } {
                set rowNodes($r) [string_replace $rowNodes($r) $mg(curCol) $mg(curCol) . ]
            }
             if { $mg(curCol) == 0 } {
                  return 0
             }
             incr mg(curCol) -1 
             continue
         }

#puts "colindex=[printArray colindex]; rowNodes=[printArray rowNodes];"
         # we now have a new entry to be tested
         for { set r 0} { $r < $mg(nrows) } { incr r } {
                set rowNodes($r) [string_replace $rowNodes($r) $mg(curCol) $mg(curCol) \
                        [string index  [lindex $tA $colindex($mg(curCol))] $r] ]
                if { [ regexp " $rowNodes($r)" $B ] ==0 } break
         }
         if { $r >= $mg(nrows) } {
             # That was OK 
             # If this is the last cell then return the completed morphism
             if { ($mg(curCol)  +1 )== $mg(ncols) } {
                 return 1
             }
         } else {
             continue
         }

        # step curRow, curCol forward to fill in the next cell for this function
        incr mg(curCol) 

    }
}