interfaces/xmaxima/Tkmaxima/Macros.tcl

   1 ###### Macros.tcl ######################################################
   2 #
   3 # Copyright (C) 1998 William F. Schelter
   4 # For distribution under GNU public License.  See COPYING.tcl
   5 #
   6 #     Time-stamp: "2024-03-20 15:13:37 villate"
   7 #
   8 # Procedures defined in this file:
   9 #
  10 #  desetq   - set the values for several variables
  11 #  assoc    - returns the value of an option in an options list
  12 #  delassoc - removes an option from an options list
  13 #  putassoc - sets the value of an option in an options list
  14 #  ldelete  - removes all ocurrences of an item in a list
  15 #
  16 ########################################################################
  17 #
  18 #-----------------------------------------------------------------------
  19 # desetq lis1 lis2 -- for each vaiable name in lis1, set its value equal
  20 # to the corresponding value in list lis2 (in the scope where desetq was
  21 # issued). lis1 and lis2 must be two list with the same length.
  22 #-----------------------------------------------------------------------
  23 proc desetq {lis1 lis2} {
  24     foreach var $lis1 value $lis2 { uplevel 1 set $var [list $value]}}
  25
  26 ######  Options parsing functions ######################################
  27 # Options are assumed to be a list of keywords followed by a single vlaue
  28 #
  29 #-----------------------------------------------------------------------
  30 # assoc key lis args -- returns the value of option with keywork key in
  31 # options list lis, or the optional value args if lis doesn't have that
  32 # keyword.
  33 #-----------------------------------------------------------------------
  34 proc assoc {key lis args} {
  35     foreach {k val} $lis {if {$k eq $key} {return $val}}
  36     return [lindex $args 0]}
  37
  38 #-----------------------------------------------------------------------
  39 # delassoc key lis -- returns the options list lis excluding the option
  40 # with keyword key
  41 #-----------------------------------------------------------------------
  42 proc delassoc {key lis} {
  43     set new {}
  44     foreach {k val} $lis {
  45         if {$k ne $key} {lappend new $k $val}}
  46     return $new}
  47
  48 #-----------------------------------------------------------------------
  49 # putassoc key lis value -- returns the options list lis with the keyword
  50 # key associated to value. If the keyword key was already present its
  51 # associated value is replaced by value
  52 #-----------------------------------------------------------------------
  53 proc putassoc {key lis value} {
  54     set done 0
  55     set new {}
  56     foreach {k val} $lis {
  57         if {$k eq $key} {
  58             set done 1
  59             set val $value}
  60         lappend new $k $val}
  61     if {!$done} {lappend new $key $value }
  62     return $new}
  63 ######  End options parsing functions #################################
  64
  65 #-----------------------------------------------------------------------
  66 # intersect lis1 lis2 -- returns the list of common elements of the two
  67 # lists lis1 and lis2
  68 #-----------------------------------------------------------------------
  69 proc intersect {lis1 lis2} {
  70     set new {}
  71     foreach v $lis1 {
  72         foreach u $lis2 {
  73             if {$v eq $u} {lappend new $v}}}
  74     return $new}
  75
  76 #-----------------------------------------------------------------------
  77 # ldelete item lis -- returns list lis with all ocurrences of item
  78 # removed
  79 #-----------------------------------------------------------------------
  80 proc ldelete {item lis} {
  81     while {[set ind [lsearch $lis $item]] >= 0} {
  82         set lis [concat [lrange $lis 0 [expr {$ind-1}]] \
  83                      [lrange $lis [expr {$ind+1}] end]]}
  84     return $lis}
  85
  86 ## endsource macros.tcl