% File ARITH.MUS	(c)	8/24/80		The Soft Warehouse %


FUNCTION MULTIPLE (EX1, EX2),
  ZERO (MOD (EX1, EX2)),
ENDFUN $

FUNCTION POSMULT (EX1, EX2),
  POSITIVE (EX1)  AND  ZERO (MOD (EX1, EX2)),
ENDFUN $

FUNCTION NEGMULT (EX1, EX2),
  NEGATIVE (EX1)  AND  ZERO (MOD (EX1, EX2)),
ENDFUN $


FUNCTION SUB (EX1, EX2, EX3),
  WHEN EX1 = EX2, EX3 EXIT,
  WHEN ATOM (EX1), EX1 EXIT,
  ADJOIN (SUB (POP(EX1), EX2, EX3), SUB (EX1, EX2, EX3)),
ENDFUN $

FUNCTION EVSUB (EX1, EX2, EX3),
  EVAL (SUB (EX1, EX2, EX3)),
ENDFUN $


FUNCTION SUM (EX1),
  FIRST(EX1) EQ '+,
ENDFUN $

FUNCTION PRODUCT (EX1),
  FIRST(EX1) EQ '*,
ENDFUN $

FUNCTION POWER (EX1),
  FIRST(EX1) EQ '^,
ENDFUN $


FUNCTION RECIP (EX1),
  WHEN POWER(EX1) AND INTEGER(SECOND(EX1)), THIRD(EX1) EQ -1 EXIT,
ENDFUN $

FUNCTION NUMBER (EX1),
  WHEN INTEGER (EX1) OR RECIP (EX1) EXIT,
  WHEN PRODUCT (EX1) AND ATOM (RRREST(EX1)),
    RECIP (THIRD(EX1)) EXIT,
ENDFUN $


FUNCTION NEGCOEF (EX1),
  WHEN INTEGER (EX1), NEGATIVE (EX1) EXIT,
  WHEN PRODUCT (EX1), NEGATIVE (SECOND(EX1)) EXIT,
ENDFUN $


FUNCTION MKSUM (LEX1),
  WHEN ATOM (LEX1), 0 EXIT,
  WHEN ATOM (REST(LEX1)), FIRST (LEX1) EXIT,
  ADJOIN ('+, LEX1),
ENDFUN $

FUNCTION MKPROD (LEX1),
  WHEN ATOM (LEX1), 1 EXIT,
  WHEN ATOM (REST(LEX1)), FIRST (LEX1) EXIT,
  ADJOIN ('*, LEX1),
ENDFUN $


FUNCTION NUM (EX1),
  WHEN ATOM (EX1), EX1 EXIT,
  WHEN POWER (EX1),
    WHEN NEGCOEF (THIRD(EX1)), 1 EXIT,
    EX1 EXIT,
  WHEN PRODUCT (EX1), MKPROD (NUM1 (REST(EX1))) EXIT,
  EX1,
ENDFUN $

FUNCTION NUM1 (LEX1),
  WHEN ATOM (LEX1), LEX1 EXIT,
  WHEN POWER(EX1:POP(LEX1)) AND NEGCOEF(THIRD(EX1)), NUM1(LEX1) EXIT,
  ADJOIN (EX1, NUM1 (LEX1)),
ENDFUN $


FUNCTION DEN (EX1),
  WHEN ATOM (EX1), 1 EXIT,
  WHEN POWER (EX1),
    WHEN NEGCOEF(THIRD(EX1)), SECOND(EX1)^-THIRD(EX1)  EXIT,
    1 EXIT,
  WHEN PRODUCT (EX1), MKPROD (DEN1 (REST(EX1))) EXIT,
  1,
ENDFUN $

FUNCTION DEN1 (LEX1),
  WHEN ATOM (LEX1), LEX1 EXIT,
  WHEN POWER (EX1:POP(LEX1)) AND NEGCOEF (THIRD(EX1)),
    ADJOIN (SECOND(EX1)^-THIRD(EX1), DEN1(LEX1)) EXIT,
  DEN1 (LEX1),
ENDFUN $


FUNCTION < (EX1, EX2),
  WHEN INTEGER(EX1) AND INTEGER(EX2),  LESSER (EX1, EX2)  EXIT,
  WHEN NUMBER (EX1) AND NUMBER (EX2),
    LESSER (NUM(EX1)*DEN(EX2), NUM(EX2)*DEN(EX1)) EXIT,
ENDFUN $

FUNCTION > (EX1, EX2),
  EX2 < EX1,
ENDFUN $


FUNCTION MIN (EX1, EX2),
  WHEN EX1 = EX2, EX1 EXIT,
  WHEN NUMBER (EX1) AND NUMBER (EX2),
    WHEN EX1 < EX2, EX1 EXIT,
    EX2 EXIT,
  LIST ('MIN, EX1, EX2),
ENDFUN $


FUNCTION SIMPU (LOP1, EX1),
  WHEN NAME (EX1), LIST (LOP1, EX1) EXIT,
  WHEN APPLY (GET (LOP1, FIRST(EX1)), ARGEX (EX1)) EXIT,
  LIST (LOP1, EX1),
ENDFUN $

FUNCTION ABS (EX1),
  WHEN NUMBER (EX1),
    WHEN 0 < EX1, EX1 EXIT,
    -EX1 EXIT,
  SIMPU ('ABS, EX1),
ENDFUN $


FUNCTION GCD (EX1, EX2,
  % Local: %  EX3),
  WHEN INTEGER (EX1) AND INTEGER (EX2),
    LOOP
      WHEN ZERO (EX2),
        WHEN POSITIVE (EX1), EX1 EXIT,
        MINUS (EX1) EXIT,
      EX3: EX2,
      EX2: MOD (EX1, EX2),
      EX1: EX3,
    ENDLOOP EXIT,
  LIST ('GCD, EX1, EX2),
ENDFUN $

FUNCTION LCM (EX1, EX2),
  ABS (EX2*(EX1/GCD(EX1,EX2))),
ENDFUN $


FUNCTION CODIV (EX1),
  WHEN INTEGER (EX1), 1 EXIT,
  WHEN PRODUCT (EX1),
    WHEN INTEGER (SECOND(EX1)),
      WHEN RECIP (THIRD(EX1)), MKPROD (RRREST(EX1)) EXIT,
      MKPROD (RREST(EX1)) EXIT,
    WHEN RECIP (SECOND(EX1)), MKPROD (RREST(EX1)) EXIT,
    EX1 EXIT,
  WHEN RECIP (EX1), 1 EXIT,
  EX1,
ENDFUN $

FUNCTION COEFF (EX1),
  WHEN INTEGER (EX1), EX1 EXIT,
  WHEN PRODUCT (EX1),
    WHEN INTEGER (SECOND(EX1)),
      WHEN RECIP (THIRD(EX1)), LIST ('*, SECOND(EX1), THIRD(EX1)) EXIT,
      SECOND (EX1) EXIT,
    WHEN RECIP (SECOND(EX1)), SECOND (EX1) EXIT,
    1 EXIT,
  WHEN RECIP (EX1), EX1 EXIT,
  1,
ENDFUN $


FUNCTION BASE (EX1),
  WHEN POWER (EX1),
    WHEN RECIP (EX1), EX1 EXIT,
    SECOND (EX1) EXIT,
  EX1,
ENDFUN $

FUNCTION EXPON (EX1),
  WHEN POWER (EX1),
    WHEN RECIP (EX1), 1 EXIT,
    THIRD (EX1) EXIT,
  1,
ENDFUN $


FUNCTION DENOM (EX1),
  POWER (EX1) AND NEGCOEF (THIRD(EX1)),
ENDFUN $



FUNCTION ARGEX (EX1),
  WHEN ATOM (RRREST (EX1)), REST (EX1) EXIT,
  LIST (SECOND (EX1), ADJOIN (FIRST(EX1), RREST(EX1))),
ENDFUN $


FUNCTION ARGLIST (EX1),
  WHEN PRODUCT (EX1) OR SUM (EX1), LIST (REST(EX1)) EXIT,
  REST (EX1),
ENDFUN $


FUNCTION MKRAT (EX1, EX2),
  WHEN EX1 EQ 1, LIST ('^, EX2, -1) EXIT,
  LIST ('*, EX1, LIST ('^, EX2, -1)),
ENDFUN $

FUNCTION RATSUM (EX1, EX2, EX3),
  WHEN EX3 EQ 1, MKRAT (EX1, EX2) EXIT,
  EX1: QUOTIENT (EX1, EX3),
  EX2: QUOTIENT (EX2, EX3),
  EX3: GCD (EX1, EX3),
  EX2: QUOTIENT (EX2, EX3),
  WHEN EX2 EQ 1, QUOTIENT (EX1, EX3) EXIT,
  MKRAT (QUOTIENT(EX1,EX3), EX2),
ENDFUN $

FUNCTION ADDTERMS (EX1, EX2),
  WHEN ATOM (EX1),
    WHEN INTEGER (EX1),
      WHEN PLUS (EX1, EX2) EXIT,
      WHEN ZERO (EX1), EX2 EXIT,
      WHEN ATOM (EX2), FALSE EXIT,
      WHEN NUMBER (EX2),
	MKRAT (PLUS(NUM(EX2),TIMES(EX1,DEN(EX2))), DEN(EX2)) EXIT,
      APPLY (GET('+,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT,
    WHEN ATOM (EX2),
      WHEN ZERO (EX2), EX1 EXIT EXIT,
    APPLY (GET('+,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT,
  WHEN ATOM (EX2),
    WHEN INTEGER (EX2),
      WHEN ZERO (EX2), EX1 EXIT,
      WHEN NUMBER (EX1),
	MKRAT (PLUS(NUM(EX1),TIMES(EX2,DEN(EX1))), DEN(EX1)) EXIT,
      APPLY (GET('+,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT,
    APPLY (GET('+,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT,
  WHEN NUMBER (EX1)  AND  NUMBER (EX2), RATSUM (
    PLUS (TIMES(NUM(EX1),DEN(EX2)), TIMES(NUM(EX2),DEN(EX1))),
    TIMES (EX1:DEN(EX1), EX2:DEN(EX2)),
    GCD (EX1, EX2) ) EXIT,
  WHEN APPLY (GET('+,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT,
  APPLY (GET('+,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))),
ENDFUN $

FUNCTION INJECTERM (LEX1),
  % Fluid vars from MERGETERM: EX1, EX2=CODIV(EX1), EX3 %
  WHEN ATOM (LEX1), LIST (EX1) EXIT,
  EX3: CODIV (FIRST(LEX1)),
  WHEN EX2 = EX3,
    EX1: ADDTERMS (COEFF(EX1), COEFF(POP(LEX1))),
    WHEN ZERO (EX1), LEX1 EXIT,
    ADJOIN (EX1*EX2, LEX1) EXIT,
  WHEN ORDERED (EX2, EX3),
    ADJOIN (EX1, LEX1) EXIT,
  ADJOIN (POP(LEX1), INJECTERM (LEX1)),
ENDFUN $

FUNCTION MERGETERM (EX1, LEX1,
  % Local: %  EX2, EX3, LEX2, LEX3),
  LEX2: LEX1,
  LOOP
    WHEN ATOM (LEX2),
      EX2: CODIV (EX1),
      INJECTERM (LEX1) EXIT,
    WHEN EX3: ADDTERMS (EX1, EX2:POP(LEX2)),
      MERGESUM (EX3, REVERSE(LEX3,LEX2)) EXIT,
    PUSH (EX2, LEX3),
  ENDLOOP,
ENDFUN $

FUNCTION MERGESUM (EX1, LEX1,
  % Local: %  LEX2),
  WHEN ATOM (LEX1),
    WHEN SUM (EX1), REST (EX1) EXIT,
    LIST (EX1) EXIT,
  WHEN SUM (EX1),
    LEX2: REST (EX1),
    LOOP
      LEX1: MERGETERM (POP(LEX2), LEX1),
      WHEN ATOM (LEX2), LEX1 EXIT,
    ENDLOOP EXIT,
  MERGETERM (EX1, LEX1),
ENDFUN $

FUNCTION SUMLEX (LEX1,
  % Local: %  LEX2),
  LOOP
    LEX2: MERGESUM (POP(LEX1), LEX2),
    WHEN ATOM (LEX1),		% When the end of LEX1 is reached,  %
      MKSUM (LEX2) EXIT,	% make a sum of LEX2 and return.    %
  ENDLOOP,
ENDFUN $

FUNCTION + LEX1,		% Nary plus function		    %
  SUMLEX (LEX1),
ENDFUN $


FUNCTION - (EX1, % Optional: % EX2),
  WHEN EMPTY (EX2),  -1*EX1  EXIT,
  EX1 + -EX2,
ENDFUN $


FUNCTION MULTFACTS (EX1, EX2),
  WHEN ATOM (EX1),
    WHEN INTEGER (EX1),
      WHEN TIMES (EX1, EX2) EXIT,
      WHEN ZERO (EX1), 0 EXIT,
      WHEN EX1 EQ 1, EX2 EXIT,
      WHEN ATOM (EX2), FALSE EXIT,
      APPLY (GET('*,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT,
    WHEN ATOM (EX2),
      WHEN ZERO (EX2), 0 EXIT,
      WHEN EX2 EQ 1, EX1 EXIT EXIT,
    APPLY (GET('*,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))) EXIT,
  WHEN ATOM (EX2),
    WHEN INTEGER (EX2),
      WHEN ZERO (EX2), 0 EXIT,
      WHEN EX2 EQ 1, EX1 EXIT,
      APPLY (GET('*,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT,
    APPLY (GET('*,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT,
  WHEN APPLY (GET('*,FIRST(EX1)), ADJOIN(EX2,ARGLIST(EX1))) EXIT,
  APPLY (GET('*,FIRST(EX2)), ADJOIN(EX1,ARGLIST(EX2))),
ENDFUN $

FUNCTION MERGEFACT (EX1, LEX1,
  % Local: %  EX2, EX3, EX4, LEX2, LEX3),
  LEX2: LEX1,
  LOOP
    WHEN ATOM (LEX2),		% If no common BASE or combination  %
      WHEN INTEGER(EX1),  ADJOIN(EX1,LEX1)  EXIT,
      WHEN RECIP (EX1),
	WHEN INTEGER (EX3:FIRST(LEX1)),
	  ADJOIN (EX3, ADJOIN (EX1, REST(LEX1))) EXIT,
	ADJOIN (EX1, LEX1) EXIT,
      LEX3: FALSE,		% of EX1 in LEX1 found, insert EX1  %
      EX2: BASE (EX1),
      LOOP			% in LEX1 in the proper order.      %
	WHEN ATOM(LEX1),  REVERSE (LEX3, LIST(EX1))  EXIT,
	WHEN EX2 = (EX4: BASE(EX3:FIRST(LEX1))),
	  EX3: EXPON (EX3),
	  WHEN NUMBER (EX4:EXPON(EX1))  AND  NUMBER (EX3),
	    EX1: EX2 ^ ADDTERMS (EX4, EX3),
	    MERGEPROD (EX1, REVERSE (LEX3, REST(LEX1))) EXIT,
	  WHEN ORDERED (EX4, EX3),
	    REVERSE (LEX3, ADJOIN(EX1, LEX1)) EXIT,
	  REVERSE (LEX3, ADJOIN (POP(LEX1), ADJOIN(EX1,LEX1)))  EXIT,
	WHEN ORDERED (EX2, EX4)  AND  NOT RECIP (EX3),
	  REVERSE (LEX3, ADJOIN (EX1, LEX1)) EXIT,
	PUSH (EX3, LEX3),
	LEX1: REST (LEX1),
      ENDLOOP EXIT,
    WHEN EX3: MULTFACTS (EX1, EX2:POP(LEX2)),
      MERGEPROD (EX3, REVERSE(LEX3,LEX2)) EXIT,
    PUSH (EX2, LEX3),
  ENDLOOP,
ENDFUN $

FUNCTION MERGEPROD (EX1, LEX1,
  % Local: %  LEX2),
  WHEN ATOM (LEX1),
    WHEN PRODUCT (EX1), REST (EX1) EXIT,
    LIST (EX1) EXIT,
  WHEN PRODUCT (EX1),
    LEX2: REST (EX1),
    LOOP
      LEX1: MERGEFACT (POP(LEX2), LEX1),
      WHEN ATOM (LEX2), LEX1 EXIT,
    ENDLOOP EXIT,
  MERGEFACT (EX1, LEX1),
ENDFUN $

FUNCTION PRODLEX (LEX1, LEX2),
  LOOP
    LEX2: MERGEPROD (POP(LEX1), LEX2),
    WHEN ATOM (LEX1),		% When the end of LEX1 is reached,  %
      MKPROD (LEX2) EXIT,	% make a product of LEX2 and return.%
  ENDLOOP,
ENDFUN $

FUNCTION * LEX1,		% Nary product function.	    %
  PRODLEX (LEX1),
ENDFUN $


FUNCTION ? (EX1),
  PRINT (" *** WARNING:  "),
  PRTMATH (EX1, 0, 0, TRUE),
  NEWLINE (),
  LIST ('?, EX1),
ENDFUN $

FUNCTION / (EX1, EX2),
  WHEN ZERO (EX2), ?(LIST('/, EX1, EX2)) EXIT,
  EX1 * EX2^-1,
ENDFUN $


FUNCTION SQUARE (EX1),
  EX1*EX1,
ENDFUN $

FUNCTION EXPT (EX1, EX2,
  % Local: %  EX3),
  EX3: 1,
  LOOP
    BLOCK
      WHEN REST(EX2:DIVIDE(EX2,2)) EQ 1,  EX3: EX1*EX3  EXIT,
    ENDBLOCK,
    WHEN ZERO (EX2:FIRST(EX2)), EX3  EXIT,
    EX1: SQUARE(EX1),
  ENDLOOP,
ENDFUN $


ZEROBASE: FALSE $

ZEROEXPT: TRUE $

TRGEXPD: 0 $

LOGEXPD: 0 $

LOGBAS: #E $

FLAGS: '(TRGEXPD LOGEXPD LOGBAS ZEROBASE ZEROEXPT) $


FUNCTION ^ (EX1, EX2),
  WHEN INTEGER (EX2),
    WHEN INTEGER (EX1),
      WHEN EX1 EQ 1, 1 EXIT,
      WHEN ZERO(EX1) AND ZERO(EX2), ?(LIST('^, EX1, EX2)) EXIT,
      WHEN NEGATIVE (EX2),
        WHEN ZERO (EX1), ?(LIST('^, EX1, EX2)) EXIT,
        EX1: EXPT (EX1, -EX2),
        WHEN NEGATIVE (EX1), -((-EX1)^-1) EXIT,
	WHEN EX1 EQ 1, EX1 EXIT,
        LIST ('^, EX1, -1) EXIT,
      EXPT (EX1, EX2) EXIT,
    WHEN EX2 EQ 1, EX1 EXIT,
    WHEN ZERO (EX2) AND ZEROEXPT, 1 EXIT,
    WHEN EX1 EQ #I,
      EX2: MOD (EX2, 4),
      WHEN EX2 EQ 2, -1 EXIT,
      WHEN EX2 EQ 3, -#I EXIT,
      EX1^EX2 EXIT,
    WHEN ATOM (EX1), LIST ('^, EX1, EX2) EXIT,
    WHEN APPLY (GET('BASE,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1))) EXIT,
    LIST ('^, EX1, EX2) EXIT,
  WHEN ATOM (EX1),
    WHEN EX1 EQ 1, 1 EXIT,
    WHEN ZERO (EX1),
      WHEN EX2 < 0, ? (LIST('^, EX1, EX2))  EXIT,
      WHEN EX2 > 0 OR ZEROBASE, 0,  EXIT,
      LIST ('^, EX1, EX2)  EXIT,
    WHEN ATOM (EX2),
      WHEN EX1 EQ #E  AND  EX2 EQ #I  AND  NEGMULT(TRGEXPD,7),
	COS(1) + #I*SIN(1)  EXIT,
      WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR EX1<0),
        LOGBAS ^ (EX2*LOG(EX1,LOGBAS))  EXIT,
      LIST ('^, EX1, EX2)  EXIT,
    WHEN APPLY (GET('EXPON,FIRST(EX2)), ADJOIN(EX1,ARGEX(EX2)))  EXIT,
    WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR NUMBER(EX2) OR EX1<0),
      LOGBAS ^ (EX2*LOG(EX1,LOGBAS))  EXIT,
    LIST ('^, EX1, EX2)  EXIT,
  WHEN APPLY (GET('BASE,FIRST(EX1)), ADJOIN(EX2,ARGEX(EX1)))  EXIT,
  WHEN POSMULT(LOGEXPD,7) AND NOT(EX1=LOGBAS OR NUMBER(EX2) OR EX1<0),
    LOGBAS ^ (EX2*LOG(EX1,LOGBAS))  EXIT,
  WHEN ATOM(EX2), LIST ('^, EX1, EX2)  EXIT,
  WHEN APPLY (GET('EXPON,FIRST(EX2)), ADJOIN(EX1,ARGEX(EX2)))  EXIT,
  LIST ('^, EX1, EX2),
ENDFUN $


PROPERTY *, ^, FUNCTION (EX1, EX2, EX3),
  WHEN EX3 EQ -1,
    WHEN INTEGER (EX2),
      WHEN INTEGER (EX1),
	EX3: GCD (EX1, EX2),
	WHEN EX3 EQ 1, FALSE EXIT,
	EX1: QUOTIENT (EX1, EX3),
	EX2: QUOTIENT (EX2, EX3),
	WHEN EX2 EQ 1, EX1 EXIT,
	EX2: LIST ('^, EX2, -1),
	WHEN EX1 EQ 1, EX2 EXIT,
	LIST ('*, EX1, EX2) EXIT,
      WHEN RECIP(EX1), LIST ('^, TIMES(EX2,SECOND(EX1)), -1)  EXIT,
    EXIT EXIT,
ENDFUN $


PBRCH: TRUE $

PUSH ('PBRCH, FLAGS) $


PROPERTY BASE, ^, FUNCTION (EX1, EX2, EX3),
  WHEN INTEGER (EX1) OR PBRCH,
    EX2^(EX1*EX3) EXIT,
ENDFUN $


PROPERTY BASE, *, FUNCTION (EX1, EX2, EX3),
    EX2^EX1 * EX3^EX1,
ENDFUN $


PROPERTY PRTMATH, *, FUNCTION (LEX1,
  % Local: %  EX1, LEX2, LEX3),
  LOOP
    BLOCK
      WHEN DENOM (EX1:POP(LEX1)),
	BLOCK
	  WHEN THIRD(EX1) EQ -1,  EX1: SECOND(EX1)  EXIT,
	  EX1: LIST ('^, SECOND(EX1), -THIRD(EX1)),
	ENDBLOCK,
        PUSH (EX1, LEX3) EXIT,
      PUSH (EX1, LEX2),
    ENDBLOCK,
    WHEN ATOM (LEX1) EXIT,
  ENDLOOP,
  WHEN ATOM (LEX3),
    EX1: FIRST (LEX2:REVERSE(LEX2)),
    LEX1: REST (LEX2),
    WHEN EX1 EQ -1,
      PRTPAREN (LPAR),
      PRINT ('-),
      EX1: POP (LEX1),
      PRTSPACE (),
      WHEN ATOM (LEX1),
	PRTMATH (EX1, 130, 0),
	PRTPAREN (RPAR),
	TRUE EXIT,
      PRTMATH (EX1, 130, GET ('LBP, LOP1)),
      LOOP
	EX1: POP(LEX1),
	PRTSPACE (),
	PRINT (LOP1),
	PRTSPACE (),
	WHEN ATOM (LEX1) EXIT,
	PRTMATH (EX1, GET ('RBP, LOP1), GET ('LBP, LOP1)),
      ENDLOOP,
      PRTMATH (EX1, GET ('RBP, LOP1), 0),
      PRTPAREN (RPAR),
      TRUE EXIT,
    FALSE EXIT,
  PRTMATH (LIST ('/, MKPROD(REVERSE(LEX2)), MKPROD(REVERSE(LEX3))),
    RBP, LBP, PRTSPACE),
  TRUE,
ENDFUN $


PROPERTY PRTMATH, ^, FUNCTION (LEX1,
  % Local: %  EX1, EX2),
  EX1: FIRST (LEX1),
  WHEN NEGCOEF (EX2:SECOND(LEX1)),
    WHEN EX2 EQ -1,
      PRTMATH (LIST ('/, 1, EX1), RBP, LBP, PRTSPACE) EXIT,
    PRTMATH (LIST ('/, 1, LIST('^,EX1,-EX2)), RBP,
      LBP, PRTSPACE) EXIT,
ENDFUN $


%************* optional fractional-power package ******************%


PRIMES: '(2, 3, 5) $

FUNCTION ROOT (EX1, EX2, EX3, LEX1, EX4, EX5, EX6,
  % Local: %  EX7),
  LOOP
    BLOCK
      WHEN ZERO (REST (EX7: DIVIDE(EX6,FIRST(LEX1)))),
        EX6: FIRST(EX7),
        WHEN (EX5:EX5+1) EQ EX3,  EX4: EX4*FIRST(LEX1),  EX5: 0,  EXIT EXIT,
      EX5: 0,
      WHEN NOT (POP(LEX1) < FIRST(EX7)), EX6: 1  EXIT,
      WHEN ATOM(LEX1),
        EX7: EX3 - 1,
        LEX1: EX6,
        LOOP
          EX5: LEX1^EX7,
          WHEN NOT ((EX5:QUOTIENT(EX6+EX7*LEX1*EX5,EX3*EX5)) < LEX1) EXIT,
          LEX1: EX5
        ENDLOOP,
        WHEN LEX1^EX3 EQ EX6, EX4: EX4*LEX1,  EX6: 1  EXIT,
        EX6: 1  EXIT,
    ENDBLOCK,
    WHEN EX6 EQ 1,
      EX1: EX1/(EX4^EX3), EX4: EX4^EX2,
      WHEN EX1 EQ 1, EX4 EXIT,
      EX4 * LIST ('^, EX1, EX2/EX3)  EXIT
  ENDLOOP,
ENDFUN $

FUNCTION FREE (EX1, EX2),
  WHEN EX1 = EX2, FALSE  EXIT,
  WHEN ATOM(EX1)  EXIT,
  LOOP
    WHEN NOT FREE(POP(EX1),EX2), FALSE  EXIT,
    WHEN ATOM(EX1), EXIT
  ENDLOOP,
ENDFUN $

PION2: #PI/2 $

PROPERTY EXPON, *, FUNCTION (EX1, EX2, EX3),
  WHEN EX1 EQ #E,
    WHEN INTEGER(EX2: EX2*EX3/PION2/#I), #I^EX2 EXIT,
    WHEN NEGMULT(TRGEXPD,7),
      WHEN FREE (EX2: EX2*PION2, #I),
      COS(EX2) + #I*SIN(EX2)  EXIT EXIT EXIT,
  WHEN INTEGER(EX1),
    WHEN PBRCH AND INTEGER(EX2),
      WHEN INTEGER(EX3:1/EX3),
        WHEN EX1 > 0,
          ROOT(EX1, EX2, EX3, PRIMES, 1, 0, EX1)  EXIT,
        WHEN ZERO(MOD(EX3,2)),
          #I^(2*EX2/EX3)*ROOT(-EX1,EX2,EX3,PRIMES,1,0,-EX1) EXIT,
        (-1)^EX2 * ROOT(-EX1, EX2, EX3, PRIMES, 1, 0, -EX1)
        EXIT EXIT EXIT,
ENDFUN $

PROPERTY EXPON, ^, FUNCTION (EX1, EX2, EX3),
  WHEN INTEGER(EX1),
    WHEN INTEGER(EX2),
      WHEN PBRCH AND EX3 EQ -1,
        WHEN EX1 > 0, ROOT (EX1, 1, EX2, PRIMES, 1, 0, EX1)  EXIT,
        WHEN ZERO(MOD(EX2,2)),
          #I^(2/EX2) * ROOT(-EX1, 1, EX2, PRIMES, 1, 0, -EX1)  EXIT,
        -ROOT(-EX1, 1, EX2, PRIMES, 1, 0, -EX1) EXIT EXIT EXIT,
ENDFUN $

%****************** optional factorial package********************%


FUNCTION ! (EX1,
  % Local: %  EX2),
  WHEN ZERO (EX1) OR POSITIVE (EX1),
    EX2: 1,
    LOOP
      WHEN ZERO(EX1), EX2  EXIT,
      EX2: TIMES (EX1, EX2),
      EX1: DIFFERENCE (EX1, 1),
    ENDLOOP EXIT,
  SIMPU ('!, EX1),
ENDFUN $

PROPERTY LBP, !, 160 $


STOP $

RDS () $