%%HP: T(3)A(R)F(.);
"!NO CODE
!RPL
*
* ABSSLV: ( symb ID \-> {} {} )
* replacement for the SOLVE
* command that handle ABS() in
* better way.
*
* 2007-03-17:
*  - first version
*
* 2007-03-18:
*  - fix error on ABS(X)
*  - fix SORT error on signtabs
*    with symbs as bounds
*
::
  CK2NOLASTWD
  OVER TYPESYMB? NcaseTYPEERR
  DUPTYPEIDNT? NcaseTYPEERR

* This is ABSFIND, a recursive
* routine to find sub-exprs that
* are ABS-ed in the expr given
* as argument.
* FIXME: also find embedded ABS
  ' :: ( ob \-> {} )
    DUP TYPESYMB?
    NOTcasedrop NULL{}
    xOBJ>
    ' xABS EQUALcasedrp ONE{}N
    NULL{}
    SWAP COERCE
    ZERO_DO
      SWAP
      LAM ABSFIND EVAL
      &COMP
    LOOP
  ;
  {
    LAM e        ( the equation )
    LAM x        ( VX )
    LAM ABSFIND
  }
  BIND

  LAM x xUNASSUME
  xSTOVX    ( ROM >= 1.19-6 )

  LAM e
  ::  ( SYMB \-> {} {} {} )
    LAM ABSFIND EVAL
    DUPNULL{}? case DUPDUP
    NULL{}
    NULL{}
    3PICK LENCOMP
    #1+_ONE_DO
      3PICK INDEX@ NTHCOMPDROP
      xSIGNTAB
      CDRCOMP
      DUP 4ROLLSWAP >TCOMP UNROT
      BEGIN
       DUPLENCOMP BINT3 #< NOT
      WHILE
      ::
        CDRCOMP
        DUP CDRCOMP
        SWAP CARCOMP
        ROTSWAP
        DUP3PICK
        matchob? case DROPSWAP
        DROP
        >TCOMP
        SWAP
      ;
      REPEAT
      DROP
    LOOP
  ;

  DUPNULL{}?
  ITE
  ::
    3DROP
    \\"No ABS() in expr\\" DISPROW1
    LAM e LAM x xSOLVE
  ;
  ::
    %1
    ' :: xDUP x>NUM SWAP TWO{}N ;
    xDOLIST
    xSORT
    %1
    ' :: BINT2 NTHCOMPDROP ;
    xDOLIST

    NULL{}
    xNOVAL
    {
      LAM el ( given by ABSFIND )
      LAM sl ( list of signtabs )
      LAM b   ( list of bounds )
      LAM res ( result )
      LAM M   ( current upper bound )
    }
    BIND
    ERRSET
    ::
* Loop for each slice, which
* bounds are in LAM b
      LAM b LENCOMP #1+
      ZERO_DO
       LAM x xUNASSUME DROP

       (lower bound of the slice)
       INDEX@
       #0<>
       ITE
       ::
        LAM x
        LAM b INDEX@ NTHCOMPDROP
        ' x>=?
        BINT3 SYMBN
        xASSUME
        DO>STR
       ;
       NULL$
       DISPROW1

       ( find upper bound )
       INDEX@ #1+ ISTOP@ #<>
       ITE
       ::
        LAM x
        LAM b INDEX@ #1+ NTHCOMPDROP
        DUP ' LAM M STOLAM
        ' x<=?
        BINT3 SYMBN
        xASSUME
        DO>STR
       ;
       ::
        SYMBOL x\oo xNEGNEG ;
        ' LAM M STOLAM
        NULL$
       ;
       DISPROW2

       LAM e

* Replace ABS(expr) by \177expr
       LAM el LENCOMP
       #1+_ONE_DO
        LAM el INDEX@ NTHCOMPDROP
        DUP symcomp ' xABS >TCOMP
        SWAP
        LAM sl INDEX@ NTHCOMPDROP
        DUP
        LAM M
        ' ::
          OVER' x+ EQUALcase 2DROPFALSE
          OVER' x- EQUALcase 2DROPFALSE
          x>=?
          xTHEN TRUE ( use xTHEN to simplify symbs )
          xELSE FALSE
          xIFEND
        ;
        POSCOMP

        DUP BINT2 #< casedrop ABORT
        #1-
        NTHCOMPDROP
        ::
          DUP' x+ EQUAL caseDROP
          DUP' x? EQUALcase :: 2DROP SYMBOL x? ; ;
          ' x- EQUALNOTcase ABORT
          symcomp
          ' xNEG >TCOMP
        ;

        TWO{}N
        xMATCHDN DROP
       LOOP

* Now solve for the current slice
       LAM x
       xSOLVE

       LAM res xSWAP >TCOMP
       ' LAM res STOLAM
      LOOP
    ;
    ERRTRAP
    ::
      LAM x xUNASSUME
      ERRJMP
    ;

    LAM x xUNASSUME
    SYMBOL x\oo  xNEG ;
    LAM b INNERCOMP
    SYMBOL x\oo  ;
    SWAP
    #2+ {}N
    SWAP
    x->TAG
    LAM res
    ABND
  ;
  ABND
;
@"