(FILECREATED "28-Jun-86 15:19:49" {QV}<PEDERSEN>LISP>IDLARRAYLABELS.;7 8944
changes to: (VARS IDLARRAYLABELSCOMS)
(FNS COPYLABELS)
previous date: "24-Jun-86 00:13:38" {QV}<PEDERSEN>LISP>IDLARRAYLABELS.;6)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IDLARRAYLABELSCOMS)
(RPAQQ IDLARRAYLABELSCOMS [(FNS COPYLABELS GETPROPBYVALUE IDLARRAY-DIMINDEX IDLARRAY-DIMLABEL
IDLARRAY-DIMLABELS IDLARRAY-GETDIMINDEX IDLARRAY-GETDIMLABEL
IDLARRAY-GETLEVELINDEX IDLARRAY-GETLEVELLABEL
IDLARRAY-HAS-DIMLABELS-P IDLARRAY-HAS-LEVELLABELS-P
IDLARRAY-LEVELINDEX IDLARRAY-LEVELLABEL IDLARRAY-LEVELLABELS
IDLARRAY-SETDIMLABEL IDLARRAY-SETDIMLABELS IDLARRAY-SETLEVELLABEL
IDLARRAY-SETLEVELLABELS PUTPROPBYVALUE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(DEFINEQ
(COPYLABELS
[LAMBDA (FROMARRAY TOARRAY) (* jop: "28-Jun-86 13:38")
(* *)
(if (IDLARRAY-HAS-DIMLABELS-P FROMARRAY)
then (IDLARRAY-SETDIMLABELS TOARRAY (IDLARRAY-DIMLABELS FROMARRAY)))
(for DIM from 0 upto (IDLARRAY-RANK FROMARRAY) when (IDLARRAY-HAS-LEVELLABELS-P
FROMARRAY DIM)
do (IDLARRAY-SETLEVELLABELS TOARRAY DIM (IDLARRAY-LEVELLABELS FROMARRAY DIM)))
TOARRAY])
(GETPROPBYVALUE
[LAMBDA (PROPLST VALUE) (* jop: " 8-Jun-86 14:12")
(* * Get the prop associated with a value -- assumes values are unique)
(LET ((VALUETAIL (MEMB VALUE PROPLST)))
(AND VALUETAIL (CAR (NLEFT PROPLST 1 VALUETAIL])
(IDLARRAY-DIMINDEX
[LAMBDA (IDLARRAY DIM-OR-LABEL) (* jop: "20-Jun-86 14:52")
(* *)
(if (LITATOM DIM-OR-LABEL)
then (IDLARRAY-GETDIMINDEX IDLARRAY DIM-OR-LABEL)
else DIM-OR-LABEL])
(IDLARRAY-DIMLABEL
[LAMBDA (IDLARRAY DIM-OR-LABEL) (* jop: "20-Jun-86 14:41")
(* *)
(if (LITATOM DIM-OR-LABEL)
then DIM-OR-LABEL
else (IDLARRAY-GETDIMLABEL IDLARRAY DIM-OR-LABEL])
(IDLARRAY-DIMLABELS
[LAMBDA (IDLARRAY START END) (* jop: "23-Jun-86 23:33")
(* *)
(if (NULL START)
then (SETQ START 0))
[if (NULL END)
then (SETQ END (SUB1 (IDLARRAY-RANK IDLARRAY]
(for I from START to END collect (IDLARRAY-GETDIMLABEL IDLARRAY I])
(IDLARRAY-GETDIMINDEX
[LAMBDA (IDLARRAY DIMLABEL) (* jop: "20-Jun-86 14:45")
(* *)
(OR (LISTGET (fetch (IDLARRAY DIMNAMES) of IDLARRAY)
DIMLABEL)
(ERROR "No such dimension" DIMLABEL])
(IDLARRAY-GETDIMLABEL
[LAMBDA (IDLARRAY DIMINDEX) (* jop: "20-Jun-86 14:47")
(* * DIMINDEX is a numeric index)
(OR (GETPROPBYVALUE (IDLARRAY-DIMNAMES IDLARRAY)
DIMINDEX)
DIMINDEX])
(IDLARRAY-GETLEVELINDEX
[LAMBDA (IDLARRAY DIMINDEX LEVELLABEL) (* jop: "20-Jun-86 14:46")
(* *)
(OR (LISTGET (LISTGET (IDLARRAY-LEVELNAMES IDLARRAY)
DIMINDEX)
LEVELLABEL)
(ERROR "No such level" LEVELLABEL])
(IDLARRAY-GETLEVELLABEL
[LAMBDA (IDLARRAY DIMINDEX LEVELINDEX) (* jop: "20-Jun-86 14:47")
(* *)
(OR (GETPROPBYVALUE (LISTGET (IDLARRAY-LEVELNAMES IDLARRAY)
DIMINDEX)
LEVELINDEX)
LEVELINDEX])
(IDLARRAY-HAS-DIMLABELS-P
[LAMBDA (IDLARRAY) (* jop: "22-Jun-86 12:56")
(* *)
(IDLARRAY-DIMNAMES IDLARRAY])
(IDLARRAY-HAS-LEVELLABELS-P
[LAMBDA (IDLARRAY DIMINDEX) (* jop: "23-Jun-86 20:58")
(* *)
(LISTGET (IDLARRAY-LEVELNAMES IDLARRAY)
DIMINDEX])
(IDLARRAY-LEVELINDEX
[LAMBDA (IDLARRAY DIM-OR-LABEL LEVEL-OR-LABEL) (* jop: "20-Jun-86 15:20")
(* *)
(if (LITATOM LEVEL-OR-LABEL)
then (IDLARRAY-GETLEVELINDEX IDLARRAY (IDLARRAY-DIMINDEX IDLARRAY DIM-OR-LABEL)
LEVEL-OR-LABEL)
else LEVEL-OR-LABEL])
(IDLARRAY-LEVELLABEL
[LAMBDA (IDLARRAY DIM-OR-LABEL LEVEL-OR-LABEL) (* jop: "20-Jun-86 14:55")
(* *)
(if (LITATOM LEVEL-OR-LABEL)
then LEVEL-OR-LABEL
else (IDLARRAY-GETLEVELLABEL IDLARRAY (IDLARRAY-DIMINDEX IDLARRAY DIM-OR-LABEL)
LEVEL-OR-LABEL])
(IDLARRAY-LEVELLABELS
[LAMBDA (IDLARRAY DIM START END) (* jop: "23-Jun-86 23:32")
(* *)
(if (NULL START)
then (SETQ START 0))
[if (NULL END)
then (SETQ END (SUB1 (IDLARRAY-DIMENSION IDLARRAY DIM]
(bind (DIMINDEX ←(IDLARRAY-DIMINDEX IDLARRAY DIM)) for I from START to END
collect (IDLARRAY-GETLEVELLABEL IDLARRAY DIMINDEX I])
(IDLARRAY-SETDIMLABEL
[LAMBDA (IDLARRAY DIMINDEX NEWLABEL) (* jop: "23-Jun-86 22:29")
(* *)
(if (NOT (LITATOM NEWLABEL))
then (ERROR "Not a LITATOM" NEWLABEL))
(if (SCALARP IDLARRAY)
then (ERROR "Cann't label a scalar" IDLARRAY))
(LET* ((DIMNAMES (fetch (IDLARRAY DIMNAMES) of IDLARRAY))
(OLDVALUE (GETPROPBYVALUE DIMNAMES DIMINDEX)))
(replace (IDLARRAY DIMNAMES) of IDLARRAY with (PUTPROPBYVALUE DIMNAMES DIMINDEX
NEWLABEL))
OLDVALUE])
(IDLARRAY-SETDIMLABELS
[LAMBDA (IDLARRAY LABELLST START) (* jop: "23-Jun-86 20:25")
(* *)
(if (NULL START)
then (SETQ START 0))
(if (NOT (ILEQ (LENGTH LABELLST)
(IDIFFERENCE (IDLARRAY-RANK IDLARRAY)
START)))
then (ERROR "LABELLST of too large" LABELLST))
(for DIM from START as LABEL in LABELLST when (LITATOM LABEL)
do (IDLARRAY-SETDIMLABEL IDLARRAY DIM LABEL])
(IDLARRAY-SETLEVELLABEL
[LAMBDA (IDLARRAY DIMINDEX LEVELINDEX NEWLABEL) (* jop: "23-Jun-86 22:29")
(* *)
(if (NOT (LITATOM NEWLABEL))
then (HELP "Not a LITATOM" NEWLABEL))
(if (SCALARP IDLARRAY)
then (ERROR "Cann't label a scalar" IDLARRAY))
(LET* ((LEVELNAMES (fetch (IDLARRAY LEVELNAMES) of IDLARRAY))
(LEVELPLST (LISTGET LEVELNAMES DIMINDEX))
(OLDVALUE (GETPROPBYVALUE LEVELPLST LEVELINDEX)))
(if (NULL LEVELNAMES)
then (replace (IDLARRAY LEVELNAMES) of IDLARRAY
with (LIST DIMINDEX (PUTPROPBYVALUE LEVELPLST LEVELINDEX NEWLABEL)))
else (LISTPUT LEVELNAMES DIMINDEX (PUTPROPBYVALUE LEVELPLST LEVELINDEX NEWLABEL)))
OLDVALUE])
(IDLARRAY-SETLEVELLABELS
[LAMBDA (IDLARRAY DIMINDEX LABELLST START) (* jop: "23-Jun-86 20:25")
(* *)
(if (NULL START)
then (SETQ START 0))
(if (NOT (ILEQ (LENGTH LABELLST)
(IDIFFERENCE (IDLARRAY-DIMENSION IDLARRAY DIMINDEX)
START)))
then (ERROR "LABELLST of too large" LABELLST))
(for LEVEL from START as LABEL in LABELLST when (LITATOM LABEL)
do (IDLARRAY-SETLEVELLABEL IDLARRAY DIMINDEX LEVEL LABEL])
(PUTPROPBYVALUE
[LAMBDA (PROPLST VALUE NEWPROP) (* jop: " 8-Jun-86 14:35")
(* * Change the PROP associated with value -- assumes values are unique)
[LET ((VALUETAIL (MEMB VALUE PROPLST)))
(if VALUETAIL
then [LET ((PROPTAIL (NLEFT PROPLST 1 VALUETAIL)))
(if NEWPROP
then (* Replace)
(RPLACA PROPTAIL NEWPROP)
else (* Delete)
(SETQ PROPTAIL (NLEFT PROPLST 1 PROPTAIL))
(if PROPTAIL
then (RPLACD PROPTAIL (CDR VALUETAIL))
else (SETQ PROPLST (CDR VALUETAIL]
else (if NEWPROP
then (* Add)
(SETQ PROPLST (NCONC PROPLST (LIST NEWPROP VALUE]
PROPLST])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS IDLARRAYLABELS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (931 8727 (COPYLABELS 941 . 1453) (GETPROPBYVALUE 1455 . 1773) (IDLARRAY-DIMINDEX 1775
. 2040) (IDLARRAY-DIMLABEL 2042 . 2306) (IDLARRAY-DIMLABELS 2308 . 2687) (IDLARRAY-GETDIMINDEX 2689
. 2964) (IDLARRAY-GETDIMLABEL 2966 . 3230) (IDLARRAY-GETLEVELINDEX 3232 . 3523) (
IDLARRAY-GETLEVELLABEL 3525 . 3803) (IDLARRAY-HAS-DIMLABELS-P 3805 . 3987) (IDLARRAY-HAS-LEVELLABELS-P
3989 . 4206) (IDLARRAY-LEVELINDEX 4208 . 4535) (IDLARRAY-LEVELLABEL 4537 . 4868) (
IDLARRAY-LEVELLABELS 4870 . 5336) (IDLARRAY-SETDIMLABEL 5338 . 5932) (IDLARRAY-SETDIMLABELS 5934 .
6458) (IDLARRAY-SETLEVELLABEL 6460 . 7275) (IDLARRAY-SETLEVELLABELS 7277 . 7832) (PUTPROPBYVALUE 7834
. 8725)))))
STOP