(FILECREATED "17-Jun-86 18:25:13" {QV}<PEDERSEN>LISP>EARRAY-SORTFNS.;2 8597
changes to: (VARS EARRAY-SORTFNSCOMS)
previous date: "16-Jun-86 18:37:45" {QV}<PEDERSEN>LISP>EARRAY-SORTFNS.;1)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT EARRAY-SORTFNSCOMS)
(RPAQQ EARRAY-SORTFNSCOMS ((* File created by Coms Manager.)
(FNS EARRAY-FLOAT-MEDIAN EARRAY-FLOAT-QUANTILE EARRAY-GENERIC-MEDIAN EARRAY-GENERIC-QUANTILE
EARRAY-GRADE-DOWN EARRAY-GRADE-DOWN-SCAN EARRAY-GRADE-UP EARRAY-GRADE-UP-SCAN
EARRAY-INDEX-GRADE-DOWN EARRAY-INDEX-GRADE-DOWN-SCAN EARRAY-INDEX-GRADE-UP
EARRAY-INDEX-GRADE-UP-SCAN EARRAY-INDEX-SORT EARRAY-MEDIAN EARRAY-MEDIAN-REDUCE
EARRAY-QUANTILE EARRAY-SORT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))))
(* File created by Coms Manager.)
(DEFINEQ
(EARRAY-FLOAT-MEDIAN
[LAMBDA (FLOATVECTOR) (* jop: "16-Jun-86 17:59")
(* *)
(LET* ((SIZE (EARRAY-TOTAL-SIZE FLOATVECTOR))
(INDEX (IQUOTIENT (SUB1 SIZE)
2)))
(if (ODDP SIZE)
then (FLOAT-ARRAY-KTH-ELT FLOATVECTOR INDEX)
else (FQUOTIENT (FPLUS (FLOAT-ARRAY-KTH-ELT FLOATVECTOR INDEX)
(FLOAT-ARRAY-KTH-ELT FLOATVECTOR (ADD1 INDEX)))
2.0])
(EARRAY-FLOAT-QUANTILE
[LAMBDA (QUANTILE FLOATVECTOR) (* jop: "16-Jun-86 18:00")
(* *)
(LET* ((SIZE (EARRAY-TOTAL-SIZE FLOATVECTOR))
(INDEX (FTIMES QUANTILE (SUB1 SIZE)))
(FLOOR-INDEX (SCALAR-FLOOR INDEX)))
(if (EQP INDEX FLOOR-INDEX)
then (FLOAT-ARRAY-KTH-ELT FLOATVECTOR FLOOR-INDEX)
else (FQUOTIENT (FPLUS (FLOAT-ARRAY-KTH-ELT FLOATVECTOR FLOOR-INDEX)
(FLOAT-ARRAY-KTH-ELT FLOATVECTOR (SCALAR-CEILING INDEX)))
2.0])
(EARRAY-GENERIC-MEDIAN
[LAMBDA (VECTOR) (* jop: "16-Jun-86 17:59")
(* *)
(LET* ((SIZE (EARRAY-TOTAL-SIZE VECTOR))
(INDEX (IQUOTIENT (SUB1 SIZE)
2)))
(if (ODDP SIZE)
then (ARRAY-KTH-ELT VECTOR INDEX COMPAREFN)
else (FQUOTIENT (FPLUS (ARRAY-KTH-ELT VECTOR INDEX)
(ARRAY-KTH-ELT VECTOR (ADD1 INDEX)))
2.0])
(EARRAY-GENERIC-QUANTILE
[LAMBDA (QUANTILE VECTOR) (* jop: "16-Jun-86 18:00")
(* *)
(LET* ((SIZE (EARRAY-TOTAL-SIZE VECTOR))
(INDEX (FTIMES QUANTILE (SUB1 SIZE)))
(FLOOR-INDEX (SCALAR-FLOOR INDEX)))
(if (EQP INDEX FLOOR-INDEX)
then (ARRAY-KTH-ELT VECTOR FLOOR-INDEX)
else (FQUOTIENT (FPLUS (ARRAY-KTH-ELT VECTOR FLOOR-INDEX)
(ARRAY-KTH-ELT VECTOR (SCALAR-CEILING INDEX)))
2.0])
(EARRAY-GRADE-DOWN
[LAMBDA (VECTOR RESULT) (* jop: "16-Jun-86 11:28")
(* *)
(EARRAY-SORT VECTOR (QUOTE GREATERP)
RESULT])
(EARRAY-GRADE-DOWN-SCAN
[LAMBDA (ARRAY AXIS RESULT) (* jop: "16-Jun-86 12:24")
(* *)
(EARRAY-SCAN (QUOTE GRADE-DOWN)
ARRAY AXIS RESULT (EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-GRADE-UP
[LAMBDA (VECTOR RESULT) (* jop: "16-Jun-86 11:26")
(* *)
(EARRAY-SORT VECTOR (QUOTE LESSP)
RESULT])
(EARRAY-GRADE-UP-SCAN
[LAMBDA (ARRAY AXIS RESULT) (* jop: "16-Jun-86 12:24")
(* *)
(EARRAY-SCAN (QUOTE GRADE-UP)
ARRAY AXIS RESULT (EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-INDEX-GRADE-DOWN
[LAMBDA (VECTOR RESULT) (* jop: "16-Jun-86 11:29")
(* *)
(EARRAY-INDEX-SORT VECTOR (QUOTE GREATERP)
RESULT])
(EARRAY-INDEX-GRADE-DOWN-SCAN
[LAMBDA (ARRAY AXIS RESULT) (* jop: "16-Jun-86 12:25")
(* *)
(EARRAY-SCAN (QUOTE INDEX-GRADE-DOWN)
ARRAY AXIS RESULT (EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-INDEX-GRADE-UP
[LAMBDA (VECTOR RESULT) (* jop: "16-Jun-86 11:29")
(* *)
(EARRAY-INDEX-SORT VECTOR (QUOTE LESSP)
RESULT])
(EARRAY-INDEX-GRADE-UP-SCAN
[LAMBDA (ARRAY AXIS RESULT) (* jop: "16-Jun-86 12:25")
(* *)
(EARRAY-SCAN (QUOTE INDEX-GRADE-UP)
ARRAY AXIS RESULT (EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-INDEX-SORT
[LAMBDA (VECTOR COMPAREFN RESULT) (* jop: "13-Jun-86 14:56")
(* *)
(if (NOT (EQ (EARRAY-RANK VECTOR)
1))
then (ERROR "Array not of rank 1" VECTOR))
(if (NULL COMPAREFN)
then (SETQ COMPAREFN (QUOTE LESSP)))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (EARRAY-DIMENSIONS VECTOR)))
(if (EQ (EARRAY-ELEMENT-TYPE VECTOR)
(QUOTE SINGLE-FLOAT))
then (if (EQ COMPAREFN (QUOTE LESSP))
then (INDEX-FLOAT-ARRAY-SORT VECTOR RESULT)
elseif (EQ COMPAREFN (QUOTE GREATERP))
then (INDEX-FLOAT-ARRAY-SORT VECTOR RESULT T)
else (INDEX-ARRAY-SORT VECTOR RESULT COMPAREFN))
else (INDEX-ARRAY-SORT VECTOR RESULT COMPAREFN])
(EARRAY-MEDIAN
[LAMBDA (VECTOR RESULT) (* jop: "16-Jun-86 17:59")
(* *)
(if (NOT (EQ (EARRAY-RANK VECTOR)
1))
then (ERROR "Array not of rank 1" VECTOR))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (EARRAY-DIMENSIONS VECTOR)
(EARRAY-ELEMENT-TYPE VECTOR)))
(if (NEQ VECTOR RESULT)
then (EARRAY-BLT VECTOR NIL RESULT))
(if (EQ (EARRAY-ELEMENT-TYPE RESULT)
(QUOTE SINGLE-FLOAT))
then (EARRAY-FLOAT-MEDIAN RESULT)
else (EARRAY-GENERIC-MEDIAN RESULT])
(EARRAY-MEDIAN-REDUCE
[LAMBDA (ARRAY AXIS RESULT) (* jop: "16-Jun-86 18:16")
(* *)
(EARRAY-REDUCE (FUNCTION MEDIAN)
ARRAY AXIS RESULT (EARRAY-ELEMENT-TYPE ARRAY])
(EARRAY-QUANTILE
[LAMBDA (QUANTILE VECTOR RESULT) (* jop: "16-Jun-86 18:00")
(* *)
(if (NOT (AND (GREATERP QUANTILE 0)
(LESSP QUANTILE 1.0)))
then (ERROR "QUANTILE out of bounds" QUANTILE))
(if (NOT (EQ (EARRAY-RANK VECTOR)
1))
then (ERROR "Array not of rank 1" VECTOR))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (EARRAY-DIMENSIONS VECTOR)
(EARRAY-ELEMENT-TYPE VECTOR)))
(if (NEQ VECTOR RESULT)
then (EARRAY-BLT VECTOR NIL RESULT))
(if (EQ (EARRAY-ELEMENT-TYPE RESULT)
(QUOTE SINGLE-FLOAT))
then (EARRAY-FLOAT-QUANTILE QUANTILE RESULT)
else (EARRAY-GENERIC-QUANTILE QUANTILE RESULT])
(EARRAY-SORT
[LAMBDA (VECTOR COMPAREFN RESULT) (* jop: "13-Jun-86 14:56")
(* *)
(if (NOT (EQ (EARRAY-RANK VECTOR)
1))
then (ERROR "Array not of rank 1" VECTOR))
(if (NULL COMPAREFN)
then (SETQ COMPAREFN (QUOTE LESSP)))
(SETQ RESULT (EARRAY-TEST-RESULT RESULT (EARRAY-DIMENSIONS VECTOR)
(EARRAY-ELEMENT-TYPE VECTOR)))
(if (NEQ VECTOR RESULT)
then (EARRAY-BLT VECTOR NIL RESULT))
(if (AND (EQ (EARRAY-ELEMENT-TYPE VECTOR)
(QUOTE SINGLE-FLOAT))
(EQ (EARRAY-ELEMENT-TYPE RESULT)
(QUOTE SINGLE-FLOAT)))
then (if (EQ COMPAREFN (QUOTE LESSP))
then (FLOAT-ARRAY-SORT RESULT)
elseif (EQ COMPAREFN (QUOTE GREATERP))
then (FLOAT-ARRAY-SORT RESULT T)
else (ARRAY-SORT RESULT COMPAREFN))
else (ARRAY-SORT RESULT COMPAREFN])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(PUTPROPS EARRAY-SORTFNS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (877 8408 (EARRAY-FLOAT-MEDIAN 887 . 1387) (EARRAY-FLOAT-QUANTILE 1389 . 1962) (
EARRAY-GENERIC-MEDIAN 1964 . 2440) (EARRAY-GENERIC-QUANTILE 2442 . 2979) (EARRAY-GRADE-DOWN 2981 .
3187) (EARRAY-GRADE-DOWN-SCAN 3189 . 3433) (EARRAY-GRADE-UP 3435 . 3636) (EARRAY-GRADE-UP-SCAN 3638 .
3878) (EARRAY-INDEX-GRADE-DOWN 3880 . 4097) (EARRAY-INDEX-GRADE-DOWN-SCAN 4099 . 4355) (
EARRAY-INDEX-GRADE-UP 4357 . 4569) (EARRAY-INDEX-GRADE-UP-SCAN 4571 . 4823) (EARRAY-INDEX-SORT 4825 .
5692) (EARRAY-MEDIAN 5694 . 6329) (EARRAY-MEDIAN-REDUCE 6331 . 6576) (EARRAY-QUANTILE 6578 . 7378) (
EARRAY-SORT 7380 . 8406)))))
STOP