ascend4/TK/MtxProc.tcl

#  MtxProc.tcl: Mtxview procedures
#  by Benjamin A. Allan and Kirk A. Abbott
#  Created: January 1994
#  Part of ASCEND
#  Revision: $Revision: 1.15 $
#  Last modified on: $Date: 1998/06/18 15:54:50 $
#  Last modified by: $Author: mthomas $
#  Revision control file: $RCSfile: MtxProc.tcl,v $
#
#  This file is part of the ASCEND Tcl/Tk Interface.
#
#  Copyright (C) 1994-1998 Carnegie Mellon University
#
#  The ASCEND Tcl/Tk Interface 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 ASCEND Tcl/Tk Interface is distributed in 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 program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA.  Check the
#  file named COPYING.  COPYING is found in ../compiler.

 # File structure:
 # default set procedure
 # menu button direct callbacks
 # menu button internals
 # utility routines
 # routines that should be in other files
 #
#
# proc set_Mtx_Defaults {}
#---------------------------------------------------------------------------
# set startup vars
#---------------------------------------------------------------------------
proc set_Mtx_Defaults {} {
  global ascMtxVect
  set ascMtxVect(blknumber) " "
  set ascMtxVect(blkboxid) ""
  set ascMtxVect(blkboxcorners) ""
 # blkboxcorners is valid only when blkboxid != ""
 # both are managed in the bindings
  set ascMtxVect(oldvpart) " "
  set ascMtxVect(oldrpart) " "
  set ascMtxVect(sf) 9
  set ascMtxVect(canvas) .mtx.can_mtx.canvas2
  set ascMtxVect(windowname) .mtx
}

#
# proc Mtx_do_Redraw {}
#----------------------------------------------------------------------------
# Redraw button. Checks scale for map size and updates the plot.            #
#----------------------------------------------------------------------------
proc Mtx_do_Redraw {} {
  global ascSolvStatVect ascMtxVect ascSolvVect
  if {$ascSolvVect(mtxup)} {
    set ascMtxVect(sf) [.mtx.zoom get]
    Mtx_Plot_FIncidence $ascSolvStatVect(vars) \
                       $ascSolvStatVect(rels) $ascMtxVect(sf)
  }
}
 # old version
 #proc Mtx_do_Redraw {} {
 #  global ascSolvStatVect ascMtxVect ascSolvVect
 #  if {$ascSolvVect(mtxup)} {
 #    set ascMtxVect(sf) [.mtx.zoom get]
 #    Mtx_Plot_CIncidence $ascSolvStatVect(vars) \
 #                       $ascSolvStatVect(rels) $ascMtxVect(sf) \
 #                        [dbg_get_order r] \
 #                        [dbg_get_order c] 1
 #  }
 #}

#
# proc Mtx_do_Grill {}
#----------------------------------------------------------------------------
# Mtx attributes set command                                                #
#----------------------------------------------------------------------------
proc Mtx_do_Grill {} {
  puts stderr "There will be options when someone tells me what they want"
  Mtx_do_Help
}

#
# proc Mtx_do_PrintBlock {}
#----------------------------------------------------------------------------
# the print block button internals.                                         #
#----------------------------------------------------------------------------
proc Mtx_do_PrintBlock {} {
  global ascMtxVect
  if {"$ascMtxVect(blkboxid)" != ""} {
    Print_configure $ascMtxVect(windowname) Printer
    if {[Print_cancelcheck]} {
      return
    }
    DispPrint [DispWriteCanvasRegion  \
      $ascMtxVect(canvas) $ascMtxVect(blkboxcorners)]
    HUB_Message_to_HUB WINDOWPRINTED MTX
  } else {
    puts  stderr "Can't print 1x1 or nonexistent blocks"
  }
}

#
# proc Mtx_do_Print {}
#----------------------------------------------------------------------------
# the print button internals.
#
#----------------------------------------------------------------------------
proc Mtx_do_Print {} {
  global ascMtxVect
  Print_configure $ascMtxVect(windowname) Printer
  if {[Print_cancelcheck]} {
    return
  }
  DispPrint [DispWriteSelection $ascMtxVect(canvas)]
  HUB_Message_to_HUB WINDOWPRINTED MTX
}

#
# proc Mtx_do_OK {}
#----------------------------------------------------------------------------
# the ok button internals.                                                  #
#----------------------------------------------------------------------------
proc Mtx_do_OK {} {
  global ascMtxVect
  View_Save_SpecialWindow_Values matrix
  set ascMtxVect(blkboxid) ""
  Solve_CloseMtx
}

#
# proc Mtx_do_Font {}
#---------------------------------------------------------------------------
# set the font for mtx
#---------------------------------------------------------------------------
proc Mtx_do_Font {args} {
  global ascMtxVect
  set font ""
  if {$args !=""} {
    set font $args
  } else {
    set font [ascFontGet]
  }
  if {"$font" == ""} {
    return
  }
  if {![winfo exists .mtx]} {
    set ascMtxVect(font) $args
    return
  }
  foreach i { col eqn row var blk } {
    .mtx.$i.label4 configure -font $font
    .mtx.$i.entry5 configure -font $font
  }
  .mtx.btn_ok configure -font $font
  .mtx.btn_mtx_red configure -font $font
  set ascMtxVect(font) $font
}
  
#
# proc Mtx_do_Help {}
#---------------------------------------------------------------------------
# the partial semantic description of the matrix                           #
#---------------------------------------------------------------------------
proc Mtx_do_Help {} {
  Help_button solver.display incidencematrix
}

#
# proc mp { cols rows colwid rowhit size func}
#----------------------------------------------------------------------------
# cols horiz/vert dim in sqrs , colwid rowhit spacing per square, size XxY
# func is external that returns a square type code for valid col/row args
# returns map to 0:no bitmap 1: solid 2: hollow 3: cross 4: cross hollow
# binds to set var/row indexes
#
# plot a test pattern
# this is good for up to 200 eqns, but gets expensive for large dense
# systems. use atobm from X distribution to build a bitmap in /tmp
# on the fly. Display monolith but set mouse divisions accordingly
#----------------------------------------------------------------------------
proc mp { cols rows colwid rowhit size func} {
   global ascMtxVect ascSolvStatVect
  .mtx.can_mtx.canvas2 delete all
  .mtx.can_mtx.canvas2 config -cursor left_ptr
  .mtx.can_mtx.canvas2 config -scrollregion \
    "0 0 [expr ($cols+1)*$colwid] [expr ($rows +1)*$rowhit]"
  set ascMtxVect(colwid) $colwid
  set ascMtxVect(rowhit) $rowhit
 # calc position from canvas coords. binding
  bind .mtx.can_mtx.canvas2 <Button-1>  {
    set ascMtxVect(colindex)  [expr 1+ [.mtx.can_mtx.canvas2 canvasx \
      [expr %x -2 ]]/$ascMtxVect(colwid)]
    set ascMtxVect(rowindex)  [expr 1+[.mtx.can_mtx.canvas2 canvasy  \
      [expr %y - 2]]/$ascMtxVect(rowhit)]}

  for {set i 1} { $i <= $cols} {set i [expr $i + 1]} {
    for {set j 1} { $j <= $rows} {set j [expr $j + 1]} {
      set x [expr $colwid*$i]
      set y [expr $rowhit*$j]
      switch [$func $i $j] {
        {0} {NoFunction}
        {1} {.mtx.can_mtx.canvas2 create bitmap $x $y \
              -bitmap "asc_sq_$size"}
        {2} {.mtx.can_mtx.canvas2 create bitmap $x $y \
              -bitmap "asc_sq_h$size"}
        {3} {.mtx.can_mtx.canvas2 create bitmap $x $y \
              -bitmap "asc_sq_c$size"}
        {4} {.mtx.can_mtx.canvas2 create bitmap $x $y \
              -bitmap "asc_sq_x$size"}
        default {NoFunction}
      }
    }
  }
}

#
# proc mtx_incident {var eqn}
#---------------------------------------------------------------------------
# test pattern generator
#---------------------------------------------------------------------------
proc mtx_incident {var eqn} {
  return [expr ($var + $eqn) %5]
}
#
# proc dbg_incident {var eqn}
#---------------------------------------------------------------------------
# check for incidence of variable in eqn
#---------------------------------------------------------------------------
proc dbg_incident {var eqn} {
  if {[lsearch [dbg_get_incidence $eqn] $var] != "-1"} {
    return 1
  }
}

#
# proc Mtx_Plot_CIncidence {cols rows sf relpart varpart new}
#----------------------------------------------------------------------------
# plot a matrix from slv                                                    #
# cols = total number of vars in system                                     #
# rows = total number of relations                                          #
# sf = size factor from 1 to 14, applied to bitmaps                         #
# relpart/varpart are dbg_get_order data                                    #
# plots free variables in included eqns as solid                            #
#       fixed vars in included eqns as crosses                              #
#       free vars in unincluded eqns as hollow squares                      #
#       fixed vars in unincluded eqns as hollow crossed squares             #
#
# code in disuse, at least until FIncidence proves buggy. This works
# with the old Redraw code
#----------------------------------------------------------------------------
proc Mtx_Plot_CIncidence {cols rows sf relpart varpart new} {

  global ascMtxVect ascMtxVarVect ascSolvStatVect 

  .mtx.can_mtx.canvas2 config -cursor left_ptr
  .mtx.can_mtx.canvas2 delete all
  .mtx.can_mtx.canvas2 config -scrollregion \
    "0 0 [expr ($cols+1)*$sf] [expr ($rows +1)*$sf]"
  set ascMtxVect(sf) $sf

 # set up the canvas binding for the grid given
  bind .mtx.can_mtx.canvas2 <Button-1>  {
  # grid coords go from 0 to n-1, matching the C
    set globx [.mtx.can_mtx.canvas2 canvasx [expr %x ]]
    set globy [.mtx.can_mtx.canvas2 canvasy [expr %y ]]
    set ascMtxVect(colindex)  [expr $globx / $ascMtxVect(sf)]
    set ascMtxVect(rowindex)  [expr $globy / $ascMtxVect(sf)]
  # sanity on grid input, due to scrollbar silliness potential
    if {[expr $ascMtxVect(colindex) <0]} {
      set ascMtxVect(colindex) 0
    }
    if {[expr $ascMtxVect(colindex) > [expr $ascSolvStatVect(inc_vars) -1]]} {
      set ascMtxVect(colindex) [expr $ascSolvStatVect(inc_vars) -1]
    }
    if {[expr $ascMtxVect(rowindex) <0]} {
      set ascMtxVect(rowindex) 0
    }
    if {[expr $ascMtxVect(rowindex) > [expr $ascSolvStatVect(rels)-1] ]} {
      set ascMtxVect(rowindex) [expr $ascSolvStatVect(rels) -1]
    }
  # get names
    set ascMtxVect(varindex) \
      [lindex $ascMtxVect(collist) $ascMtxVect(colindex)]
    set ascMtxVect(eqnindex) \
      [lindex $ascMtxVect(rowlist) $ascMtxVect(rowindex)]
    set ascMtxVect(eqnname) [dbg_write_rel 2 $ascMtxVect(eqnindex) 0]
    set ascMtxVect(varname) [dbg_write_var 2 $ascMtxVect(varindex) 0 0]
    set ascMtxVect(eqnnum) [expr $ascMtxVect(eqnindex)]
    set ascMtxVect(varnum) [expr $ascMtxVect(varindex)]
    set ascMtxVect(blknumber) [dbg_get_blk_of_var $ascMtxVect(varindex)]
    catch {.mtx.can_mtx.canvas2 delete $ascMtxVect(blkboxid)}
    set ascMtxVect(blkboxid) ""
    if {$ascMtxVect(blknumber)!="none"} {
      set ascMtxVect(blkcorners) [dbg_get_blk_coords $ascMtxVect(blknumber)]
      set ixlo [lindex $ascMtxVect(blkcorners) 0]
      set iylo [lindex $ascMtxVect(blkcorners) 1]
      set ixhi [lindex $ascMtxVect(blkcorners) 2]
      set iyhi [lindex $ascMtxVect(blkcorners) 3]
      if {$ixlo != $ixhi || $iylo != $iyhi} {
        set bxlo [expr 2+ $ixlo * $ascMtxVect(sf)]
        set bylo [expr 2+ $iylo * $ascMtxVect(sf)]
        set bxhi [expr 2+ (1+ $ixhi) * $ascMtxVect(sf)]
        set byhi [expr 2+ (1+ $iyhi) * $ascMtxVect(sf)]
        set ascMtxVect(blkboxid) \
          [.mtx.can_mtx.canvas2 create rectangle $bxlo $bylo $bxhi $byhi]
        set ascMtxVect(blkboxcorners) "$bxlo $bylo $bxhi $byhi"
      }
    } else {
      set ascMtxVect(blkboxid) ""
      set ascMtxVect(blkcorners) "0 0 0 0"
    }
  # prepend instance inplace of & in interpresult and remove braces
    regsub & $ascMtxVect(eqnname) $ascSolvVect(simname) ascMtxVect(eqnname)
    regsub & $ascMtxVect(varname) $ascSolvVect(simname) ascMtxVect(varname)
    regsub \{ $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
    regsub \} $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
    regsub \{ $ascMtxVect(varname) "" ascMtxVect(varname)
    regsub \} $ascMtxVect(varname) "" ascMtxVect(varname)
  }
 # end binding

 # in the Case where we only need a window resize, maybe
 # not a C update, skip all the variable manipulations and just plot
  if {!($ascMtxVect(oldvpart)==$varpart) ||
      !($ascMtxVect(oldrpart)==$relpart) ||
      ($new)} {
 #   redo from scratch
    set ascMtxVect(oldvpart) $varpart
    set ascMtxVect(oldrpart) $relpart

 #collist is just varpart now, but collist is all inclusive too
 # strip out phantom columns due to square mtx in C
    set  ascMtxVect(collist) ""
    foreach i $varpart {
      if {$i < $ascSolvStatVect(vars)} {lappend ascMtxVect(collist) $i}
    }
 # sort mtx ordering out to fixed/nonincident on right
 # move any fixed and incident he's partitioned to the right
 # move to wayfar right non-incident vars
    set fixedlist [dbg_list_vars 2]
    set notinclist [dbg_list_vars 1 not]
    set farright ""
    foreach i $fixedlist {
      if {[lsearch $notinclist $i] == "-1"} {
        lappend farright $i
      }
    }
    foreach i $farright {
      set cpos [lsearch $ascMtxVect(collist) $i]
      set ascMtxVect(collist) [lreplace $ascMtxVect(collist) $cpos $cpos]
      lappend ascMtxVect(collist) $i
    }
    foreach i $notinclist {
      set cpos [lsearch $ascMtxVect(collist) $i]
      set ascMtxVect(collist) [lreplace $ascMtxVect(collist) $cpos $cpos]
      lappend ascMtxVect(collist) $i
    }
    set ascMtxVect(usedcols) [llength $ascMtxVect(collist)]

 #set array which is columninfo subscripted by C var#
 # done for faster plotting purposes
    set ascMtxVect(col) 0
    foreach i $ascMtxVect(collist) {
      set ascMtxVarVect($i) $ascMtxVect(col)
      incr ascMtxVect(col)
    }

 # list created -> lindex list row# =Crelnumber
 # stick unassigned equations in middle since they dont appear on part list
 # mash unincluded to bottom
 # strip out phantom columns due to square mtx in C
    set  ascMtxVect(rowlist) ""
    foreach i $relpart {
      if {$i < $ascSolvStatVect(rels)} {lappend ascMtxVect(rowlist) $i}
    }
    set asslist [dbg_list_rels 4]
    if {$asslist !=""} {
      set notasslist [dbg_list_rels 4 not]
    } else {
      set notasslist ""
    }
    foreach i $notasslist {
      set rpos [lsearch $ascMtxVect(rowlist) $i]
      set ascMtxVect(rowlist) [lreplace $ascMtxVect(rowlist) $rpos $rpos]
      lappend ascMtxVect(rowlist) $i
    }
    set notinclist [dbg_list_rels 1 not]
    foreach i $notinclist {
      set rpos [lsearch $ascMtxVect(rowlist) $i]
      set ascMtxVect(rowlist) [lreplace $ascMtxVect(rowlist) $rpos $rpos]
      lappend ascMtxVect(rowlist) $i
    }
  }

 # start here if this is a replot
 #plot the matrix
  set ascMtxVect(drow) 0
  foreach rel $ascMtxVect(rowlist) {
    if {[catch {set varsinrow [dbg_get_incidence $rel]} ]} {
    } else {
      foreach var $varsinrow {
        set gx $ascMtxVarVect($var)
        set gy $ascMtxVect(drow)
        set x [expr $sf*$gx +2]
        set y [expr $sf*$gy+2]
 #puts stderr "picking var bitmap"
# if the code dies here, you have mismatch between libtcl.a and interface
# objects. use the same CC for both.
# command line symptom [dbg_write_rel 2 0 3] will die in Tcl_Parse
        if {[dbg_rel_included $rel]} {
          if {[dbg_var_fixed $var]} {
            set type "asc_sq_c"
          } else {
            set type "asc_sq_"
          }
        } else {
          if {[dbg_var_fixed $var]} {
            set type "asc_sq_x"
          } else {
            set type "asc_sq_h"
          }
        }
        .mtx.can_mtx.canvas2 create bitmap $x $y \
           -bitmap "$type$sf" -anchor nw
      }
    incr ascMtxVect(drow)
    }
  }
}

#
# proc Mtx_Plot_FIncidence {sf}
#----------------------------------------------------------------------------
# plot a matrix from slv                                                    #
# cols = total number of vars in system                                     #
# rows = total number of relations                                          #
# sf = size factor from 1 to 14, applied to bitmaps                         #
#                                                                           #
# cols and rows still needed at tcl level to bind canvas                    #
# plots free variables in included eqns as solid                            #
#       fixed vars in included eqns as crosses                              #
#       free vars in unincluded eqns as hollow squares                      #
#       fixed vars in unincluded eqns as hollow crossed squares             #
#----------------------------------------------------------------------------
proc Mtx_Plot_FIncidence {cols rows sf} {

  global ascMtxVect ascMtxVarVect ascSolvStatVect
  global ascMtxVect_ra
  global ascMtxVect_ca
  global ascMtxVect_va
  global ascMtxVect_ea
  .mtx.can_mtx.canvas2 config -cursor left_ptr
  .mtx.can_mtx.canvas2 delete all
  .mtx.can_mtx.canvas2 config -scrollregion \
    "0 0 [expr ($cols+1)*$sf] [expr ($rows +1)*$sf]"
  set ascMtxVect(sf) $sf

 # set up the canvas binding for the grid given
  bind .mtx.can_mtx.canvas2 <Button-1>  {
    global ascMtxVect
  # grid coords go from 0 to n-1, matching the C
    set globx [expr round([.mtx.can_mtx.canvas2 canvasx [expr %x ]])]
    set globy [expr round([.mtx.can_mtx.canvas2 canvasy [expr %y ]])]
    set ascMtxVect(colindex)  [expr $globx / $ascMtxVect(sf)]
    set ascMtxVect(rowindex)  [expr $globy / $ascMtxVect(sf)]
  # sanity on grid input, due to scrollbar silliness potential
    if {[expr $ascMtxVect(colindex) <0]} {
      set ascMtxVect(colindex) 0
    }
    if {[expr $ascMtxVect(colindex) > [expr $ascSolvStatVect(inc_vars) -1]]} {
      set ascMtxVect(colindex) [expr $ascSolvStatVect(inc_vars) -1]
    }
    if {[expr $ascMtxVect(rowindex) <0]} {
      set ascMtxVect(rowindex) 0
    }
    if {[expr $ascMtxVect(rowindex) > [expr $ascSolvStatVect(rels)-1] ]} {
      set ascMtxVect(rowindex) [expr $ascSolvStatVect(rels) -1]
    }
  # get names
    set ascMtxVect(varindex) $ascMtxVect_ca($ascMtxVect(colindex))
    set ascMtxVect(eqnindex) $ascMtxVect_ra($ascMtxVect(rowindex))
    set ascMtxVect(eqnname) [dbg_write_rel 2 $ascMtxVect(eqnindex) 0]
    set ascMtxVect(varname) [dbg_write_var 2 $ascMtxVect(varindex) 0 0]
    set ascMtxVect(eqnnum) [expr $ascMtxVect(eqnindex)]
    set ascMtxVect(varnum) [expr $ascMtxVect(varindex)]
    set ascMtxVect(blknumber) [dbg_get_blk_of_var $ascMtxVect(varindex)]
    catch {.mtx.can_mtx.canvas2 delete $ascMtxVect(blkboxid)}
    set ascMtxVect(blkboxid) ""
    if {$ascMtxVect(blknumber)!="none"} {
      set ascMtxVect(blkcorners) [dbg_get_blk_coords $ascMtxVect(blknumber)]
      set ixlo [lindex $ascMtxVect(blkcorners) 0]
      set iylo [lindex $ascMtxVect(blkcorners) 1]
      set ixhi [lindex $ascMtxVect(blkcorners) 2]
      set iyhi [lindex $ascMtxVect(blkcorners) 3]
      if {$ixlo != $ixhi || $iylo != $iyhi} {
        set bxlo [expr 2+ $ixlo * $ascMtxVect(sf)]
        set bylo [expr 2+ $iylo * $ascMtxVect(sf)]
        set bxhi [expr 2+ (1+ $ixhi) * $ascMtxVect(sf)]
        set byhi [expr 2+ (1+ $iyhi) * $ascMtxVect(sf)]
        set ascMtxVect(blkboxid) \
          [.mtx.can_mtx.canvas2 create rectangle $bxlo $bylo $bxhi $byhi]
        set ascMtxVect(blkboxcorners) "$bxlo $bylo $bxhi $byhi"
      }
    } else {
      set ascMtxVect(blkboxid) ""
      set ascMtxVect(blkcorners) "0 0 0 0"
    }
  # prepend instance inplace of & in interpresult and remove braces
    regsub & $ascMtxVect(eqnname) $ascSolvVect(simname) ascMtxVect(eqnname)
    regsub & $ascMtxVect(varname) $ascSolvVect(simname) ascMtxVect(varname)
    regsub \{ $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
    regsub \} $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
    regsub \{ $ascMtxVect(varname) "" ascMtxVect(varname)
    regsub \} $ascMtxVect(varname) "" ascMtxVect(varname)
  }
 # end binding
 # plot the beast
  mtx_gui_plot_incidence $sf 2 2 .mtx.can_mtx.canvas2 black white \
    ascMtxVect_ra ascMtxVect_ca \
    ascMtxVect_va ascMtxVect_ea
}

1	# MtxProc.tcl: Mtxview procedures
2	# by Benjamin A. Allan and Kirk A. Abbott
3	# Created: January 1994
4	# Part of ASCEND
5	# Revision: $Revision: 1.15 $
6	# Last modified on: $Date: 1998/06/18 15:54:50 $
7	# Last modified by: $Author: mthomas $
8	# Revision control file: $RCSfile: MtxProc.tcl,v $
9	#
10	# This file is part of the ASCEND Tcl/Tk Interface.
11	#
12	# Copyright (C) 1994-1998 Carnegie Mellon University
13	#
14	# The ASCEND Tcl/Tk Interface is free software; you can redistribute
15	# it and/or modify it under the terms of the GNU General Public
16	# License as published by the Free Software Foundation; either
17	# version 2 of the License, or (at your option) any later version.
18	#
19	# The ASCEND Tcl/Tk Interface is distributed in hope that it will be
20	# useful, but WITHOUT ANY WARRANTY; without even the implied warranty
21	# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22	# GNU General Public License for more details.
23	#
24	# You should have received a copy of the GNU General Public License
25	# along with the program; if not, write to the Free Software
26	# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the
27	# file named COPYING. COPYING is found in ../compiler.
28
29	# File structure:
30	# default set procedure
31	# menu button direct callbacks
32	# menu button internals
33	# utility routines
34	# routines that should be in other files
35	#
36	#
37	# proc set_Mtx_Defaults {}
38	#---------------------------------------------------------------------------
39	# set startup vars
40	#---------------------------------------------------------------------------
41	proc set_Mtx_Defaults {} {
42	global ascMtxVect
43	set ascMtxVect(blknumber) " "
44	set ascMtxVect(blkboxid) ""
45	set ascMtxVect(blkboxcorners) ""
46	# blkboxcorners is valid only when blkboxid != ""
47	# both are managed in the bindings
48	set ascMtxVect(oldvpart) " "
49	set ascMtxVect(oldrpart) " "
50	set ascMtxVect(sf) 9
51	set ascMtxVect(canvas) .mtx.can_mtx.canvas2
52	set ascMtxVect(windowname) .mtx
53	}
54
55	#
56	# proc Mtx_do_Redraw {}
57	#----------------------------------------------------------------------------
58	# Redraw button. Checks scale for map size and updates the plot. #
59	#----------------------------------------------------------------------------
60	proc Mtx_do_Redraw {} {
61	global ascSolvStatVect ascMtxVect ascSolvVect
62	if {$ascSolvVect(mtxup)} {
63	set ascMtxVect(sf) [.mtx.zoom get]
64	Mtx_Plot_FIncidence $ascSolvStatVect(vars) \
65	$ascSolvStatVect(rels) $ascMtxVect(sf)
66	}
67	}
68	# old version
69	#proc Mtx_do_Redraw {} {
70	# global ascSolvStatVect ascMtxVect ascSolvVect
71	# if {$ascSolvVect(mtxup)} {
72	# set ascMtxVect(sf) [.mtx.zoom get]
73	# Mtx_Plot_CIncidence $ascSolvStatVect(vars) \
74	# $ascSolvStatVect(rels) $ascMtxVect(sf) \
75	# [dbg_get_order r] \
76	# [dbg_get_order c] 1
77	# }
78	#}
79
80	#
81	# proc Mtx_do_Grill {}
82	#----------------------------------------------------------------------------
83	# Mtx attributes set command #
84	#----------------------------------------------------------------------------
85	proc Mtx_do_Grill {} {
86	puts stderr "There will be options when someone tells me what they want"
87	Mtx_do_Help
88	}
89
90	#
91	# proc Mtx_do_PrintBlock {}
92	#----------------------------------------------------------------------------
93	# the print block button internals. #
94	#----------------------------------------------------------------------------
95	proc Mtx_do_PrintBlock {} {
96	global ascMtxVect
97	if {"$ascMtxVect(blkboxid)" != ""} {
98	Print_configure $ascMtxVect(windowname) Printer
99	if {[Print_cancelcheck]} {
100	return
101	}
102	DispPrint [DispWriteCanvasRegion \
103	$ascMtxVect(canvas) $ascMtxVect(blkboxcorners)]
104	HUB_Message_to_HUB WINDOWPRINTED MTX
105	} else {
106	puts stderr "Can't print 1x1 or nonexistent blocks"
107	}
108	}
109
110	#
111	# proc Mtx_do_Print {}
112	#----------------------------------------------------------------------------
113	# the print button internals.
114	#
115	#----------------------------------------------------------------------------
116	proc Mtx_do_Print {} {
117	global ascMtxVect
118	Print_configure $ascMtxVect(windowname) Printer
119	if {[Print_cancelcheck]} {
120	return
121	}
122	DispPrint [DispWriteSelection $ascMtxVect(canvas)]
123	HUB_Message_to_HUB WINDOWPRINTED MTX
124	}
125
126	#
127	# proc Mtx_do_OK {}
128	#----------------------------------------------------------------------------
129	# the ok button internals. #
130	#----------------------------------------------------------------------------
131	proc Mtx_do_OK {} {
132	global ascMtxVect
133	View_Save_SpecialWindow_Values matrix
134	set ascMtxVect(blkboxid) ""
135	Solve_CloseMtx
136	}
137
138	#
139	# proc Mtx_do_Font {}
140	#---------------------------------------------------------------------------
141	# set the font for mtx
142	#---------------------------------------------------------------------------
143	proc Mtx_do_Font {args} {
144	global ascMtxVect
145	set font ""
146	if {$args !=""} {
147	set font $args
148	} else {
149	set font [ascFontGet]
150	}
151	if {"$font" == ""} {
152	return
153	}
154	if {![winfo exists .mtx]} {
155	set ascMtxVect(font) $args
156	return
157	}
158	foreach i { col eqn row var blk } {
159	.mtx.$i.label4 configure -font $font
160	.mtx.$i.entry5 configure -font $font
161	}
162	.mtx.btn_ok configure -font $font
163	.mtx.btn_mtx_red configure -font $font
164	set ascMtxVect(font) $font
165	}
166
167	#
168	# proc Mtx_do_Help {}
169	#---------------------------------------------------------------------------
170	# the partial semantic description of the matrix #
171	#---------------------------------------------------------------------------
172	proc Mtx_do_Help {} {
173	Help_button solver.display incidencematrix
174	}
175
176	#
177	# proc mp { cols rows colwid rowhit size func}
178	#----------------------------------------------------------------------------
179	# cols horiz/vert dim in sqrs , colwid rowhit spacing per square, size XxY
180	# func is external that returns a square type code for valid col/row args
181	# returns map to 0:no bitmap 1: solid 2: hollow 3: cross 4: cross hollow
182	# binds to set var/row indexes
183	#
184	# plot a test pattern
185	# this is good for up to 200 eqns, but gets expensive for large dense
186	# systems. use atobm from X distribution to build a bitmap in /tmp
187	# on the fly. Display monolith but set mouse divisions accordingly
188	#----------------------------------------------------------------------------
189	proc mp { cols rows colwid rowhit size func} {
190	global ascMtxVect ascSolvStatVect
191	.mtx.can_mtx.canvas2 delete all
192	.mtx.can_mtx.canvas2 config -cursor left_ptr
193	.mtx.can_mtx.canvas2 config -scrollregion \
194	"0 0 [expr ($cols+1)$colwid] [expr ($rows +1)$rowhit]"
195	set ascMtxVect(colwid) $colwid
196	set ascMtxVect(rowhit) $rowhit
197	# calc position from canvas coords. binding
198	bind .mtx.can_mtx.canvas2 <Button-1> {
199	set ascMtxVect(colindex) [expr 1+ [.mtx.can_mtx.canvas2 canvasx \
200	[expr %x -2 ]]/$ascMtxVect(colwid)]
201	set ascMtxVect(rowindex) [expr 1+[.mtx.can_mtx.canvas2 canvasy \
202	[expr %y - 2]]/$ascMtxVect(rowhit)]}
203
204	for {set i 1} { $i <= $cols} {set i [expr $i + 1]} {
205	for {set j 1} { $j <= $rows} {set j [expr $j + 1]} {
206	set x [expr $colwid*$i]
207	set y [expr $rowhit*$j]
208	switch [$func $i $j] {
209	{0} {NoFunction}
210	{1} {.mtx.can_mtx.canvas2 create bitmap $x $y \
211	-bitmap "asc_sq_$size"}
212	{2} {.mtx.can_mtx.canvas2 create bitmap $x $y \
213	-bitmap "asc_sq_h$size"}
214	{3} {.mtx.can_mtx.canvas2 create bitmap $x $y \
215	-bitmap "asc_sq_c$size"}
216	{4} {.mtx.can_mtx.canvas2 create bitmap $x $y \
217	-bitmap "asc_sq_x$size"}
218	default {NoFunction}
219	}
220	}
221	}
222	}
223
224	#
225	# proc mtx_incident {var eqn}
226	#---------------------------------------------------------------------------
227	# test pattern generator
228	#---------------------------------------------------------------------------
229	proc mtx_incident {var eqn} {
230	return [expr ($var + $eqn) %5]
231	}
232	#
233	# proc dbg_incident {var eqn}
234	#---------------------------------------------------------------------------
235	# check for incidence of variable in eqn
236	#---------------------------------------------------------------------------
237	proc dbg_incident {var eqn} {
238	if {[lsearch [dbg_get_incidence $eqn] $var] != "-1"} {
239	return 1
240	}
241	}
242
243	#
244	# proc Mtx_Plot_CIncidence {cols rows sf relpart varpart new}
245	#----------------------------------------------------------------------------
246	# plot a matrix from slv #
247	# cols = total number of vars in system #
248	# rows = total number of relations #
249	# sf = size factor from 1 to 14, applied to bitmaps #
250	# relpart/varpart are dbg_get_order data #
251	# plots free variables in included eqns as solid #
252	# fixed vars in included eqns as crosses #
253	# free vars in unincluded eqns as hollow squares #
254	# fixed vars in unincluded eqns as hollow crossed squares #
255	#
256	# code in disuse, at least until FIncidence proves buggy. This works
257	# with the old Redraw code
258	#----------------------------------------------------------------------------
259	proc Mtx_Plot_CIncidence {cols rows sf relpart varpart new} {
260
261	global ascMtxVect ascMtxVarVect ascSolvStatVect
262
263	.mtx.can_mtx.canvas2 config -cursor left_ptr
264	.mtx.can_mtx.canvas2 delete all
265	.mtx.can_mtx.canvas2 config -scrollregion \
266	"0 0 [expr ($cols+1)$sf] [expr ($rows +1)$sf]"
267	set ascMtxVect(sf) $sf
268
269	# set up the canvas binding for the grid given
270	bind .mtx.can_mtx.canvas2 <Button-1> {
271	# grid coords go from 0 to n-1, matching the C
272	set globx [.mtx.can_mtx.canvas2 canvasx [expr %x ]]
273	set globy [.mtx.can_mtx.canvas2 canvasy [expr %y ]]
274	set ascMtxVect(colindex) [expr $globx / $ascMtxVect(sf)]
275	set ascMtxVect(rowindex) [expr $globy / $ascMtxVect(sf)]
276	# sanity on grid input, due to scrollbar silliness potential
277	if {[expr $ascMtxVect(colindex) <0]} {
278	set ascMtxVect(colindex) 0
279	}
280	if {[expr $ascMtxVect(colindex) > [expr $ascSolvStatVect(inc_vars) -1]]} {
281	set ascMtxVect(colindex) [expr $ascSolvStatVect(inc_vars) -1]
282	}
283	if {[expr $ascMtxVect(rowindex) <0]} {
284	set ascMtxVect(rowindex) 0
285	}
286	if {[expr $ascMtxVect(rowindex) > [expr $ascSolvStatVect(rels)-1] ]} {
287	set ascMtxVect(rowindex) [expr $ascSolvStatVect(rels) -1]
288	}
289	# get names
290	set ascMtxVect(varindex) \
291	[lindex $ascMtxVect(collist) $ascMtxVect(colindex)]
292	set ascMtxVect(eqnindex) \
293	[lindex $ascMtxVect(rowlist) $ascMtxVect(rowindex)]
294	set ascMtxVect(eqnname) [dbg_write_rel 2 $ascMtxVect(eqnindex) 0]
295	set ascMtxVect(varname) [dbg_write_var 2 $ascMtxVect(varindex) 0 0]
296	set ascMtxVect(eqnnum) [expr $ascMtxVect(eqnindex)]
297	set ascMtxVect(varnum) [expr $ascMtxVect(varindex)]
298	set ascMtxVect(blknumber) [dbg_get_blk_of_var $ascMtxVect(varindex)]
299	catch {.mtx.can_mtx.canvas2 delete $ascMtxVect(blkboxid)}
300	set ascMtxVect(blkboxid) ""
301	if {$ascMtxVect(blknumber)!="none"} {
302	set ascMtxVect(blkcorners) [dbg_get_blk_coords $ascMtxVect(blknumber)]
303	set ixlo [lindex $ascMtxVect(blkcorners) 0]
304	set iylo [lindex $ascMtxVect(blkcorners) 1]
305	set ixhi [lindex $ascMtxVect(blkcorners) 2]
306	set iyhi [lindex $ascMtxVect(blkcorners) 3]
307	if {$ixlo != $ixhi \|\| $iylo != $iyhi} {
308	set bxlo [expr 2+ $ixlo * $ascMtxVect(sf)]
309	set bylo [expr 2+ $iylo * $ascMtxVect(sf)]
310	set bxhi [expr 2+ (1+ $ixhi) * $ascMtxVect(sf)]
311	set byhi [expr 2+ (1+ $iyhi) * $ascMtxVect(sf)]
312	set ascMtxVect(blkboxid) \
313	[.mtx.can_mtx.canvas2 create rectangle $bxlo $bylo $bxhi $byhi]
314	set ascMtxVect(blkboxcorners) "$bxlo $bylo $bxhi $byhi"
315	}
316	} else {
317	set ascMtxVect(blkboxid) ""
318	set ascMtxVect(blkcorners) "0 0 0 0"
319	}
320	# prepend instance inplace of & in interpresult and remove braces
321	regsub & $ascMtxVect(eqnname) $ascSolvVect(simname) ascMtxVect(eqnname)
322	regsub & $ascMtxVect(varname) $ascSolvVect(simname) ascMtxVect(varname)
323	regsub \{ $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
324	regsub \} $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
325	regsub \{ $ascMtxVect(varname) "" ascMtxVect(varname)
326	regsub \} $ascMtxVect(varname) "" ascMtxVect(varname)
327	}
328	# end binding
329
330	# in the Case where we only need a window resize, maybe
331	# not a C update, skip all the variable manipulations and just plot
332	if {!($ascMtxVect(oldvpart)==$varpart) \|\|
333	!($ascMtxVect(oldrpart)==$relpart) \|\|
334	($new)} {
335	# redo from scratch
336	set ascMtxVect(oldvpart) $varpart
337	set ascMtxVect(oldrpart) $relpart
338
339	#collist is just varpart now, but collist is all inclusive too
340	# strip out phantom columns due to square mtx in C
341	set ascMtxVect(collist) ""
342	foreach i $varpart {
343	if {$i < $ascSolvStatVect(vars)} {lappend ascMtxVect(collist) $i}
344	}
345	# sort mtx ordering out to fixed/nonincident on right
346	# move any fixed and incident he's partitioned to the right
347	# move to wayfar right non-incident vars
348	set fixedlist [dbg_list_vars 2]
349	set notinclist [dbg_list_vars 1 not]
350	set farright ""
351	foreach i $fixedlist {
352	if {[lsearch $notinclist $i] == "-1"} {
353	lappend farright $i
354	}
355	}
356	foreach i $farright {
357	set cpos [lsearch $ascMtxVect(collist) $i]
358	set ascMtxVect(collist) [lreplace $ascMtxVect(collist) $cpos $cpos]
359	lappend ascMtxVect(collist) $i
360	}
361	foreach i $notinclist {
362	set cpos [lsearch $ascMtxVect(collist) $i]
363	set ascMtxVect(collist) [lreplace $ascMtxVect(collist) $cpos $cpos]
364	lappend ascMtxVect(collist) $i
365	}
366	set ascMtxVect(usedcols) [llength $ascMtxVect(collist)]
367
368	#set array which is columninfo subscripted by C var#
369	# done for faster plotting purposes
370	set ascMtxVect(col) 0
371	foreach i $ascMtxVect(collist) {
372	set ascMtxVarVect($i) $ascMtxVect(col)
373	incr ascMtxVect(col)
374	}
375
376	# list created -> lindex list row# =Crelnumber
377	# stick unassigned equations in middle since they dont appear on part list
378	# mash unincluded to bottom
379	# strip out phantom columns due to square mtx in C
380	set ascMtxVect(rowlist) ""
381	foreach i $relpart {
382	if {$i < $ascSolvStatVect(rels)} {lappend ascMtxVect(rowlist) $i}
383	}
384	set asslist [dbg_list_rels 4]
385	if {$asslist !=""} {
386	set notasslist [dbg_list_rels 4 not]
387	} else {
388	set notasslist ""
389	}
390	foreach i $notasslist {
391	set rpos [lsearch $ascMtxVect(rowlist) $i]
392	set ascMtxVect(rowlist) [lreplace $ascMtxVect(rowlist) $rpos $rpos]
393	lappend ascMtxVect(rowlist) $i
394	}
395	set notinclist [dbg_list_rels 1 not]
396	foreach i $notinclist {
397	set rpos [lsearch $ascMtxVect(rowlist) $i]
398	set ascMtxVect(rowlist) [lreplace $ascMtxVect(rowlist) $rpos $rpos]
399	lappend ascMtxVect(rowlist) $i
400	}
401	}
402
403	# start here if this is a replot
404	#plot the matrix
405	set ascMtxVect(drow) 0
406	foreach rel $ascMtxVect(rowlist) {
407	if {[catch {set varsinrow [dbg_get_incidence $rel]} ]} {
408	} else {
409	foreach var $varsinrow {
410	set gx $ascMtxVarVect($var)
411	set gy $ascMtxVect(drow)
412	set x [expr $sf*$gx +2]
413	set y [expr $sf*$gy+2]
414	#puts stderr "picking var bitmap"
415	# if the code dies here, you have mismatch between libtcl.a and interface
416	# objects. use the same CC for both.
417	# command line symptom [dbg_write_rel 2 0 3] will die in Tcl_Parse
418	if {[dbg_rel_included $rel]} {
419	if {[dbg_var_fixed $var]} {
420	set type "asc_sq_c"
421	} else {
422	set type "asc_sq_"
423	}
424	} else {
425	if {[dbg_var_fixed $var]} {
426	set type "asc_sq_x"
427	} else {
428	set type "asc_sq_h"
429	}
430	}
431	.mtx.can_mtx.canvas2 create bitmap $x $y \
432	-bitmap "$type$sf" -anchor nw
433	}
434	incr ascMtxVect(drow)
435	}
436	}
437	}
438
439	#
440	# proc Mtx_Plot_FIncidence {sf}
441	#----------------------------------------------------------------------------
442	# plot a matrix from slv #
443	# cols = total number of vars in system #
444	# rows = total number of relations #
445	# sf = size factor from 1 to 14, applied to bitmaps #
446	# #
447	# cols and rows still needed at tcl level to bind canvas #
448	# plots free variables in included eqns as solid #
449	# fixed vars in included eqns as crosses #
450	# free vars in unincluded eqns as hollow squares #
451	# fixed vars in unincluded eqns as hollow crossed squares #
452	#----------------------------------------------------------------------------
453	proc Mtx_Plot_FIncidence {cols rows sf} {
454
455	global ascMtxVect ascMtxVarVect ascSolvStatVect
456	global ascMtxVect_ra
457	global ascMtxVect_ca
458	global ascMtxVect_va
459	global ascMtxVect_ea
460	.mtx.can_mtx.canvas2 config -cursor left_ptr
461	.mtx.can_mtx.canvas2 delete all
462	.mtx.can_mtx.canvas2 config -scrollregion \
463	"0 0 [expr ($cols+1)$sf] [expr ($rows +1)$sf]"
464	set ascMtxVect(sf) $sf
465
466	# set up the canvas binding for the grid given
467	bind .mtx.can_mtx.canvas2 <Button-1> {
468	global ascMtxVect
469	# grid coords go from 0 to n-1, matching the C
470	set globx [expr round([.mtx.can_mtx.canvas2 canvasx [expr %x ]])]
471	set globy [expr round([.mtx.can_mtx.canvas2 canvasy [expr %y ]])]
472	set ascMtxVect(colindex) [expr $globx / $ascMtxVect(sf)]
473	set ascMtxVect(rowindex) [expr $globy / $ascMtxVect(sf)]
474	# sanity on grid input, due to scrollbar silliness potential
475	if {[expr $ascMtxVect(colindex) <0]} {
476	set ascMtxVect(colindex) 0
477	}
478	if {[expr $ascMtxVect(colindex) > [expr $ascSolvStatVect(inc_vars) -1]]} {
479	set ascMtxVect(colindex) [expr $ascSolvStatVect(inc_vars) -1]
480	}
481	if {[expr $ascMtxVect(rowindex) <0]} {
482	set ascMtxVect(rowindex) 0
483	}
484	if {[expr $ascMtxVect(rowindex) > [expr $ascSolvStatVect(rels)-1] ]} {
485	set ascMtxVect(rowindex) [expr $ascSolvStatVect(rels) -1]
486	}
487	# get names
488	set ascMtxVect(varindex) $ascMtxVect_ca($ascMtxVect(colindex))
489	set ascMtxVect(eqnindex) $ascMtxVect_ra($ascMtxVect(rowindex))
490	set ascMtxVect(eqnname) [dbg_write_rel 2 $ascMtxVect(eqnindex) 0]
491	set ascMtxVect(varname) [dbg_write_var 2 $ascMtxVect(varindex) 0 0]
492	set ascMtxVect(eqnnum) [expr $ascMtxVect(eqnindex)]
493	set ascMtxVect(varnum) [expr $ascMtxVect(varindex)]
494	set ascMtxVect(blknumber) [dbg_get_blk_of_var $ascMtxVect(varindex)]
495	catch {.mtx.can_mtx.canvas2 delete $ascMtxVect(blkboxid)}
496	set ascMtxVect(blkboxid) ""
497	if {$ascMtxVect(blknumber)!="none"} {
498	set ascMtxVect(blkcorners) [dbg_get_blk_coords $ascMtxVect(blknumber)]
499	set ixlo [lindex $ascMtxVect(blkcorners) 0]
500	set iylo [lindex $ascMtxVect(blkcorners) 1]
501	set ixhi [lindex $ascMtxVect(blkcorners) 2]
502	set iyhi [lindex $ascMtxVect(blkcorners) 3]
503	if {$ixlo != $ixhi \|\| $iylo != $iyhi} {
504	set bxlo [expr 2+ $ixlo * $ascMtxVect(sf)]
505	set bylo [expr 2+ $iylo * $ascMtxVect(sf)]
506	set bxhi [expr 2+ (1+ $ixhi) * $ascMtxVect(sf)]
507	set byhi [expr 2+ (1+ $iyhi) * $ascMtxVect(sf)]
508	set ascMtxVect(blkboxid) \
509	[.mtx.can_mtx.canvas2 create rectangle $bxlo $bylo $bxhi $byhi]
510	set ascMtxVect(blkboxcorners) "$bxlo $bylo $bxhi $byhi"
511	}
512	} else {
513	set ascMtxVect(blkboxid) ""
514	set ascMtxVect(blkcorners) "0 0 0 0"
515	}
516	# prepend instance inplace of & in interpresult and remove braces
517	regsub & $ascMtxVect(eqnname) $ascSolvVect(simname) ascMtxVect(eqnname)
518	regsub & $ascMtxVect(varname) $ascSolvVect(simname) ascMtxVect(varname)
519	regsub \{ $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
520	regsub \} $ascMtxVect(eqnname) "" ascMtxVect(eqnname)
521	regsub \{ $ascMtxVect(varname) "" ascMtxVect(varname)
522	regsub \} $ascMtxVect(varname) "" ascMtxVect(varname)
523	}
524	# end binding
525	# plot the beast
526	mtx_gui_plot_incidence $sf 2 2 .mtx.can_mtx.canvas2 black white \
527	ascMtxVect_ra ascMtxVect_ca \
528	ascMtxVect_va ascMtxVect_ea
529	}
530