share/algebra/solver/slvrtbox.mac

   1 /******************************************************************************/
   2 /*                                                                            */
   3 /* SLVRTBOX.MAC                                                               */
   4 /*                                                                            */
   5 /* Copyright (C) 2000 : Eckhard Hennig, Ralf Sommer                           */
   6 /* This library is free software; you can redistribute it and/or modify it    */
   7 /* under the terms of the GNU Library General Public License as published     */
   8 /* by the Free Software Foundation; either version 2 of the License, or (at   */
   9 /* your option) any later version.                                            */
  10 /*                                                                            */
  11 /* This library is distributed in the hope that it will be useful, but        */
  12 /* WITHOUT ANY WARRANTY; without even the implied warranty of                 */
  13 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU          */
  14 /* Library General Public License for more details.                           */
  15 /*                                                                            */
  16 /* You should have received a copy of the GNU Library General Public          */
  17 /* License along with this library; if not, write to the Free Software        */
  18 /* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA                  */
  19 /******************************************************************************/
  20 /* Author(s)    : Eckhard Hennig, Ralf Sommer                                 */
  21 /* Project start: 17.01.1995                                                  */
  22 /* Completed    : 17.01.1995                                                  */
  23 /* last change  : 17.08.1995                                                  */
  24 /* Time         : 15:38                                                       */
  25 /******************************************************************************/
  26 /* Changes      : ||||| |                                                     */
  27 /******************************************************************************/
  28
  29 put( 'SLVRTBOX, 1, 'Version )$
  30
  31 /* Version information: see below function definition of SetVersion */
  32
  33 /******************************************************************************/
  34 /* last change: 17.08.1995                                                    */
  35 /* Time       : 15:38                                                         */
  36 /* By         : Eckhard Hennig                                                */
  37 /* Description: Function Position now accepts non list arguments              */
  38 /******************************************************************************/
  39 /* last change: 28.06.1995                                                    */
  40 /* Time       : 13:53                                                         */
  41 /* By         : Eckhard Hennig                                                */
  42 /* Description: Function SortSolveOrder added.                                */
  43 /******************************************************************************/
  44 /* last change: 28.05.1995                                                    */
  45 /* Time       : 12:06                                                         */
  46 /* By         : Eckhard Hennig                                                */
  47 /* Description: Default function for Solver_Break_Test added.                 */
  48 /******************************************************************************/
  49 /* last change: 13.02.1995                                                    */
  50 /* Time       : 09.19                                                         */
  51 /* By         : Eckhard Hennig                                                */
  52 /* Description: Initial value of MsgLvl set to 0.                             */
  53 /******************************************************************************/
  54 /* last change: 31.01.1995                                                    */
  55 /* Time       : 10.06                                                         */
  56 /* By         : Eckhard Hennig                                                */
  57 /* Description: Problem with Solver_Verbose:false fixed.                      */
  58 /******************************************************************************/
  59 /* last change: 24.01.1995                                                    */
  60 /* Time       : 16.40                                                         */
  61 /* By         : Eckhard Hennig                                                */
  62 /* Description: Version property added.                                       */
  63 /******************************************************************************/
  64 /* last change: 17.01.1995                                                    */
  65 /* Time       : 18.20                                                         */
  66 /* By         : Eckhard Hennig, Ralf Sommer                                   */
  67 /* Description: Most functions moved from AI's TOOLBOX.MAC into SLVRTBOX.MAC  */
  68 /*              Variable Solver_Verbose added (linked to MsgLevel via         */
  69 /*              value_check property)                                         */
  70 /******************************************************************************/
  71
  72 /******************************************************************************/
  73 /* SetProp does the same as Put but the order of arguments is different. This */
  74 /* is useful because sometimes the Property is a rather lengthy segment of    */
  75 /* code which would otherwise have to be scrolled through to inspect the      */
  76 /* Indicator.                                                                 */
  77 /******************************************************************************/
  78
  79 SetProp( Atom, Indicator, Property ) := put( Atom, Property, Indicator )$
  80
  81
  82 /******************************************************************************/
  83 /* SetVersion stores some information about the loaded Analog Insydes package */
  84 /* for online version inspection.                                             */
  85 /******************************************************************************/
  86
  87 SetVersion( [ InfoList ] ) := (
  88
  89   mode_declare(
  90     InfoList, list
  91   ),
  92
  93   SetProp(
  94     'AI,
  95     InfoList[1],
  96
  97     map(
  98       '(
  99         lambda(
 100           [ x ],
 101           assoc( x, rest( InfoList ), "???" )
 102         )
 103       ),
 104       [ 'MODULE, 'DESCRIPTION, 'AUTHORS, 'DATE, 'LASTCHANGE, 'TIME, 'PLAN ]
 105     )
 106   )
 107 )$
 108
 109
 110 SetVersion(
 111   /* KEY    = */ 'SLVRTBOX,
 112   'MODULE      = "SLVRTBOX",
 113   'DESCRIPTION = "Collection of utility functions for SOLVER",
 114   'AUTHORS     = "Eckhard Hennig, Ralf Sommer",
 115   'DATE        = "17.01.1995",
 116   'LASTCHANGE  = "17.08.1995",
 117   'TIME        = "15:38",
 118   'PLAN        = ""
 119 )$
 120
 121
 122 /******************************************************************************/
 123 /* Global variables                                                           */
 124 /******************************************************************************/
 125
 126 define_variable( MsgLvl, 0, fixnum )$
 127
 128 /******************************************************************************/
 129 /* MsgLevel controls the amount of output AI generates. If MsgLevel is        */
 130 /* 'OFF there will be no screen output at all. 'SHORT restricts the output to */
 131 /* some important messages only whereas 'DETAIL allows extended information   */
 132 /* to be printed. The priority corresponding with a message must be supplied  */
 133 /* by the PrintMsg command:                                                   */
 134 /* PrintMsg( <'OFF | 'FALSE  |'SHORT | 'DETAIL | 'ALWAYS>, <stuff> ).         */
 135 /******************************************************************************/
 136
 137 define_variable( MsgLevel, 'FALSE, any_check )$
 138
 139 put(
 140   'MsgLevel,
 141   lambda(
 142     [ x ],
 143     if member( x, [ 'OFF, 'FALSE, 'SHORT, 'DETAIL ] )
 144       or ( debugmode and ( x = 'DEBUG ) )
 145     then
 146       MsgLvl : mode_identity(
 147         fixnum,
 148         assoc(
 149           x,
 150           [
 151             'OFF = 0, 'FALSE = 0, false = 0,
 152             'SHORT = 1, 'DETAIL = 2, 'DEBUG = 10
 153           ]
 154         )
 155       )
 156     else
 157       ErrorHandler( "InvMsgLvl", x, 'Fatal )
 158   ),
 159   'value_check
 160 )$
 161
 162
 163 define_variable( Solver_Verbose, false, any_check )$
 164
 165 put(
 166   'Solver_Verbose,
 167   lambda(
 168     [ VerboseMode ],
 169
 170     /*
 171     CASE( VerboseMode,
 172
 173       [ FALSE,     MsgLevel : 'FALSE  ],
 174       [ TRUE,      MsgLevel : 'SHORT  ],
 175       [ ALL,       MsgLevel : 'DETAIL ],
 176       [ OTHERWISE, ErrorHandler( "InvVerbMode", VerboseMode, 'Fatal ) ]
 177     )
 178     */
 179     if VerboseMode=false then MsgLevel : 'FALSE
 180     else if VerboseMode=true then MsgLevel : 'SHORT
 181     else if VerboseMode='all then MsgLevel : 'DETAIL
 182     else  ErrorHandler( "InvVerbMode", VerboseMode, 'Fatal)
 183   ),
 184   'value_check
 185 )$
 186
 187
 188 /******************************************************************************/
 189 /* GetUserProperties retrieves the list of user properties associated with    */
 190 /* Symbol.                                                                    */
 191 /******************************************************************************/
 192
 193 GetUserProperties( Symbol ) := (
 194
 195   mode_declare(
 196     Symbol, any
 197   ),
 198
 199   block(
 200     [ UserProps ],
 201
 202     mode_declare(
 203       User_Props, list
 204     ),
 205
 206     /* get all properties of Symbol and extract the sublist which begins      */
 207     /* with the keyword "User Properties".                                    */
 208
 209     UserProps : sublist(
 210       apply( 'properties, [ Symbol ] ),
 211       lambda( [x],
 212         listp(x) and ( length(x) > 1 ) and ( first(x) = "User Properties" )
 213       )
 214     ),
 215
 216     /* If the list of user properties is nonempty then return the list with   */
 217     /* the "User Properties" keyword removed. Otherwise, return an empty list.*/
 218
 219     if not empty( UserProps ) then
 220       return( rest( first( UserProps ) ) )
 221     else
 222       return( [] )
 223   )
 224 )$
 225
 226
 227 /******************************************************************************/
 228 /* GetVersion prints out the information stored by SetVersion.                */
 229 /******************************************************************************/
 230
 231 GetVersion() := block(
 232
 233   [ Package, VersionInfo, Fancy_Display : false ],
 234
 235   mode_declare(
 236     Package, any,
 237     VersionInfo, list
 238   ),
 239
 240   print( "Analog Insydes version information:" ),
 241
 242   for Package in GetUserProperties( 'AI ) do (
 243
 244     VersionInfo : get( 'AI, Package ),
 245     print( " " ),
 246     print( "Module name :", VersionInfo[1] ),
 247     print( "Description :", VersionInfo[2] ),
 248     print( "Author(s)   :", VersionInfo[3] ),
 249     print( "Implemented :", VersionInfo[4] ),
 250     print( "Last change :", VersionInfo[5] ),
 251     print( "Time        :", VersionInfo[6] ),
 252     print( "Plan        :", VersionInfo[7] )
 253
 254   )
 255 )$
 256
 257
 258 /******************************************************************************/
 259 /* The ErrorHandler prints out the error message belonging to ErrorCode and   */
 260 /* displays Arg as the error cause. Then the function variable Action is      */
 261 /* applied to Arg so corrective actions can be taken if necessary. If no      */
 262 /* action is required then use 'Ignore or 'Fatal as Action.                   */
 263 /******************************************************************************/
 264
 265 ErrorHandler( ErrorCode, Arg, Action ) := (
 266
 267    mode_declare(
 268      [ ErrorCode, Arg, Action ], any
 269    ),
 270
 271    print( "Error:", ErrMsg[ErrorCode] ),
 272
 273    if Arg # "" then
 274      print( "Cause:", Arg ),
 275
 276    apply( Action, [ Arg ] )
 277 )$
 278
 279
 280 /******************************************************************************/
 281 /* Error handler: ignore error and continue program execution.                */
 282 /******************************************************************************/
 283
 284 Ignore( Arg ) := print( ErrMsg["Ignore"] )$
 285
 286
 287 /******************************************************************************/
 288 /* Error handler: abort program execution and return to Macsyma toplevel.     */
 289 /******************************************************************************/
 290
 291 Fatal( Arg ) := error( ErrMsg["FatalErr"] )$
 292
 293
 294 /******************************************************************************/
 295 /* AssocP tests whether Object is an association list.                        */
 296 /******************************************************************************/
 297
 298 AssocP( Object ) :=
 299   listp( Object ) and not member( 'false, map( 'EquationP, Object ) )$
 300
 301
 302 /******************************************************************************/
 303 /* SumP tests whether Exp is a sum.                                           */
 304 /******************************************************************************/
 305
 306 SumP( Exp ) :=
 307   if part( Exp, 0 ) = "+" then
 308     true
 309   else
 310     false$
 311
 312
 313 /******************************************************************************/
 314 /* FunctionP tests whether Object is a function.                              */
 315 /******************************************************************************/
 316
 317 FunctionP( Object ) := (
 318
 319   mode_declare(
 320     Object, any
 321   ),
 322
 323   block(
 324
 325     [ ObjectProps ],
 326
 327     mode_declare(
 328       ObjectProps, list
 329     ),
 330
 331     ObjectProps : apply( 'properties,  [ Object ] ),
 332
 333     return(
 334       member( 'transfun, ObjectProps ) or member( 'function, ObjectProps )
 335     )
 336   )
 337 )$
 338
 339
 340 /******************************************************************************/
 341 /* Empty tests whether a list is empty.                                       */
 342 /******************************************************************************/
 343
 344 Empty( Lst ) :=
 345   if Lst = [] then
 346     true
 347   else
 348     false$
 349
 350
 351 /******************************************************************************/
 352 /* RowSize determines the row dimension of a matrix.                          */
 353 /******************************************************************************/
 354
 355 RowSize( Mat ) := (
 356
 357   mode_declare(
 358     Mat, any,
 359     function( length ), fixnum
 360   ),
 361
 362   length( Mat )
 363 )$
 364
 365
 366 /******************************************************************************/
 367 /* ColSize determines the column dimension of a matrix.                       */
 368 /******************************************************************************/
 369
 370 ColSize( Mat ) := (
 371
 372   mode_declare(
 373     Mat, any,
 374     function( length), fixnum
 375   ),
 376
 377   length( first( Mat ) )
 378 )$
 379
 380
 381 /******************************************************************************/
 382 /* AppendRows appends an additional row to a matrix.                          */
 383 /******************************************************************************/
 384
 385 AppendRows( Mat, r ) := (
 386
 387   mode_declare(
 388     Mat, any,
 389     [ r, function( ColSize ) ], fixnum
 390   ),
 391
 392   addrow( Mat, zeromatrix( r, ColSize( Mat ) ) )
 393 )$
 394
 395
 396 /******************************************************************************/
 397 /* AppendCols appends an additional column to a matrix.                       */
 398 /******************************************************************************/
 399
 400 AppendCols( Mat, c ) := (
 401
 402   mode_declare(
 403     Mat, any,
 404     [ c, function( RowSize ) ], fixnum
 405   ),
 406
 407   addcol( Mat, zeromatrix( RowSize( Mat ), c ) )
 408 )$
 409
 410
 411 /******************************************************************************/
 412 /* PrintMsg prints a message on the screen if MsgLevel is set appropriately.  */
 413 /******************************************************************************/
 414
 415 PrintMsg( Level, [ Messages ]) := (
 416
 417   mode_declare(
 418     Level, any,
 419     Messages, list
 420   ),
 421
 422   block(
 423
 424     [ MsgPriority ],
 425
 426     mode_declare(
 427       [ MsgPriority, function( assoc ) ], fixnum
 428     ),
 429
 430     if (
 431       MsgPriority : assoc(
 432         Level,
 433         [ 'ALWAYS = 0, 'SHORT = 1, 'DETAIL = 2, 'DEBUG = 10 ]
 434       )
 435     ) # false then (
 436       if MsgPriority <= MsgLvl then
 437         apply( 'print, Messages )
 438     )
 439   )
 440 )$
 441
 442
 443 /******************************************************************************/
 444 /* Flatten flattens out hierarchical lists.                                   */
 445 /******************************************************************************/
 446
 447 Flatten( Lst ) := (
 448
 449   mode_declare(
 450     Lst, list
 451   ),
 452
 453   apply(
 454     'append,
 455     map(
 456       lambda(
 457         [ Sublst ],
 458         if listp( Sublst ) then
 459           Flatten( Sublst )
 460         else
 461           [ Sublst ]
 462       ),
 463       Lst
 464     )
 465   )
 466 )$
 467
 468
 469 /******************************************************************************/
 470 /* ListMatrix transforms a matrix into a list of lists.                       */
 471 /******************************************************************************/
 472
 473 ListMatrix( Mat ) :=
 474   if matrixp( Mat ) then
 475     substpart( "[", copymatrix(Mat), 0 )
 476   else
 477     false$
 478
 479
 480 /******************************************************************************/
 481 /* Position determines the position of Element within the list Lst.           */
 482 /* If Element does not exist, Position returns 0.                             */
 483 /******************************************************************************/
 484
 485 Position( Element, Lst ) := (
 486
 487   mode_declare(
 488     [ Element, Lst ], any
 489   ),
 490
 491   block(
 492
 493     [ i, p, Found ],
 494
 495     mode_declare(
 496       [ i, p ], fixnum,
 497       Found, boolean
 498     ),
 499
 500     if not listp( Lst ) then
 501       Lst : [ Lst ],
 502
 503     Found : false,
 504     for i thru length( Lst ) unless Found do
 505       if Element = Lst[i] then (
 506         p : i,
 507         Found : true
 508       ),
 509
 510     if Found then
 511       return( p )
 512     else
 513       return( 0 )
 514   )
 515 )$
 516
 517
 518 /******************************************************************************/
 519 /* SolverJustDoIt is the default Solver_Break_Test function. It simply returns*/
 520 /* false, hence the Solver never stops.                                       */
 521 /******************************************************************************/
 522
 523 SolverJustDoIt( Eq, Var, Val ) := false$
 524
 525
 526 /******************************************************************************/
 527 /* SortSolveOrder sorts the list of valuations by least valuation.            */
 528 /******************************************************************************/
 529
 530 SortSolveOrder( SlvOrd ) :=
 531   sort(
 532     SlvOrd,
 533     lambda( [a, b], third( a ) < third( b ) )
 534   )$