%  File:  ARRAY.ARI  (c)	03/17/81	The Soft Warehouse %


PROPERTY PREFIX, [, ADJOIN ('[, MATCH('])) $

PUSH ('], DELIMITER) $

PROPERTY PRTMATH, [, FUNCTION (LEX1),
  PRINT ('[),
  WHEN ATOM (LEX1),  PRINT ('])  EXIT,
  LOOP
    PRTMATH (POP(LEX1), 0, 0),
    WHEN ATOM (LEX1),  PRINT ('])  EXIT,
    PRINT (", "),
  ENDLOOP,
ENDFUN $

FUNCTION ROW (EX1),
  FIRST (EX1) EQ '[,
ENDFUN $

FUNCTION ARGLIST(EX1),
  WHEN MEMBER (POP(EX1), '(+ * [ {)),
    LIST (EX1)  EXIT,
  EX1,
ENDFUN $

FUNCTION MAPADD2 (LEX1, LEX2),
  WHEN ATOM (LEX1), LEX2  EXIT,
  WHEN ATOM (LEX2), LEX1  EXIT,
  ADJOIN (POP(LEX1)+POP(LEX2), MAPADD2(LEX1,LEX2)),
ENDFUN $

PROPERTY +, [, FUNCTION (EX1, LEX1),
  WHEN ROW (EX1),
    ADJOIN('[, MAPADD2(REST(EX1),LEX1))  EXIT,
ENDFUN $

FUNCTION MAPMULT1 (LEX1),
  % Fluid var from property "*[" or "*{":  EX1 %
  WHEN ATOM (LEX1), FALSE EXIT,
  ADJOIN (EX1*POP(LEX1), MAPMULT1(LEX1)),
ENDFUN $

FUNCTION MAPMULT2 (LEX1, LEX2),
  WHEN ATOM (LEX1), FALSE EXIT,
  WHEN ATOM (LEX2), FALSE EXIT,
  ADJOIN (POP(LEX1)*POP(LEX2), MAPMULT2(LEX1,LEX2)),
ENDFUN $

PROPERTY *, [, FUNCTION (EX1, LEX1),
  WHEN ROW (EX1),
    ADJOIN ('[, MAPMULT2(REST(EX1),LEX1))  EXIT,
  ADJOIN ('[, MAPMULT1(LEX1)),
ENDFUN $
Š
FUNCTION MAPEXPON (LEX1),
  % Fluid var from property "BASE[" or "BASE{":  EX1 %
  WHEN ATOM (LEX1), FALSE EXIT,
  ADJOIN (POP(LEX1)^EX1, MAPEXPON(LEX1)),
ENDFUN $

FUNCTION COL (EX1),
  FIRST (EX1) EQ '{,
ENDFUN $

FUNCTION ARRAY (EX1),
  ROW (EX1)  OR  COL (EX1),
ENDFUN $

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

PROPERTY BASE, [, FUNCTION (EX1, LEX1),
  ADJOIN ('[, MAPEXPON(LEX1)),
ENDFUN $

FUNCTION MAPBASE (LEX1),
  % Fluid var from property "EXPON[" or "EXPON{":  EX1 %
  WHEN ATOM (LEX1), FALSE EXIT,
  ADJOIN (EX1^POP(LEX1), MAPBASE(LEX1)),
ENDFUN $

PROPERTY EXPON, [, FUNCTION (EX1, LEX1),
  ADJOIN ('[, MAPBASE(LEX1)),
ENDFUN $

FUNCTION MAPFUN(LOP1, LEX1),
  WHEN ATOM (LEX1), FALSE EXIT,
  ADJOIN (LOP1(POP(LEX1)), MAPFUN(LOP1, LEX1)),
ENDFUN $

FUNCTION SIMPU (LOP1, EX1),
  WHEN NAME (EX1),
    LIST(LOP1,EX1) EXIT,
  WHEN APPLY (GET(LOP1,FIRST(EX1)), ARGEX(EX1)) EXIT,
  WHEN MEMBER (FIRST(EX1), '("==" [ {)),
    ADJOIN (POP(EX1), MAPFUN(LOP1,EX1))  EXIT,
  LIST (LOP1, EX1),
ENDFUN $


%******************** Optional Column Package *****************%


ŠPROPERTY PREFIX, {, ADJOIN ('{, MATCH('})) $

PUSH ('}, DELIMITER) $

PROPERTY +, {, FUNCTION (EX1, LEX1),
  WHEN COL (EX1),
    ADJOIN('{, MAPADD2(REST(EX1), LEX1))  EXIT,
ENDFUN $

PROPERTY *, {, FUNCTION (EX1, LEX1),
  WHEN COL (EX1),
    ADJOIN('{, MAPMULT2(REST(EX1), LEX1))  EXIT,
  ADJOIN ('{, MAPMULT1(LEX1)),
ENDFUN $

PROPERTY BASE, {, FUNCTION (EX1, LEX1),
  ADJOIN ('{, MAPEXPON(LEX1)),
ENDFUN $

PROPERTY EXPON, {, FUNCTION (EX1, LEX1),
  ADJOIN ('{, MAPBASE(LEX1)),
ENDFUN $

PROPERTY PRTMATH, {, FUNCTION (LEX1),
  PRINT('{),
  WHEN ATOM (LEX1),  PRINT ('})  EXIT,
  LOOP
    PRTMATH (POP(LEX1), 0, 0, TRUE),
    WHEN ATOM (LEX1) EXIT,
    PRINTLINE (COMMA),
    SPACES (4),
  ENDLOOP,
  PRINT ('}),
ENDFUN $


%******************** Optional Subscript Package **************%

PROPERTY INFIX, [, ADJOIN (SUBSCR, ADJOIN(EX1, MATCH(']))) $

PROPERTY LBP, [, 200 $

FUNCTION SUBSCR LEX1,
  SUBSCR1 (FIRST(LEX1), REST(LEX1)),
ENDFUN $

FUNCTION SUBSCR1 (EX1, LEX1),
  WHEN ATOM(LEX1), EX1 EXIT,
  WHEN ARRAY(EX1) AND POSITIVE(FIRST(LEX1)),
    SUBSCR2(REST(EX1), FIRST(LEX1)) EXIT,
  ADJOIN (SUBSCR, ADJOIN(EX1,LEX1)),
ENDFUN $

FUNCTION SUBSCR2 (LEX2, EX1),
  WHEN ATOM(LEX2), 0  EXIT,
Š  WHEN EX1 EQ 1,
    SUBSCR1 (FIRST(LEX2), REST(LEX1)) EXIT,
  SUBSCR2 (REST(LEX2), EX1 - 1),
ENDFUN $

PROPERTY PRTMATH, SUBSCR, FUNCTION (LEX1),
  PRTMATH (POP(LEX1), 0, 0),
  PRTMATH (ADJOIN ('[, LEX1), 0, 0),
ENDFUN $


%*************  Optional Subscripted Assignment Package  ************%

PROPERTY INFIX, :, COND (
  WHEN NAME (EX1),
    LIST (':, EX1, PARSE (SCAN,20)) EXIT,
  WHEN FIRST(EX1) EQ 'SUBSCR,
    LIST (UPDATE, SECOND(EX1), RREST(EX1), PARSE(SCAN,20)) EXIT,
  WHEN SYNTAX () EXIT) $

SUBROUTINE UPDATE (EX1, LEX1, EX2),
  ASSIGN (EX1, UPDATE1 (EVAL(EX1), LEX1)),
ENDSUB $

FUNCTION UPDATE1 (EX3, LEX1),
  WHEN ATOM (LEX1),
    EVAL (EX2) EXIT,
  WHEN ARRAY (EX3)  AND  POSITIVE (FIRST(LEX1)),
    ADJOIN (FIRST(EX3), UPDATE2(REST(EX3),FIRST(LEX1))) EXIT,
  ? (LIST ('_, EX1, EX2)),
ENDFUN $

FUNCTION UPDATE2 (LEX2, EX4),
  BLOCK
    WHEN ATOM (LEX2),
      LEX2: LIST(0) EXIT,
  ENDBLOCK,
  WHEN EX4 EQ 1,
    ADJOIN (UPDATE1(FIRST(LEX2),REST(LEX1)), REST(LEX2)) EXIT,
  ADJOIN (FIRST(LEX2), UPDATE2 (REST(LEX2), EX4-1)),
ENDFUN $

STOP $  RDS () $