LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032546. :SYSTEM-TYPE :LOGICAL :VERSION 32. :TYPE "LISP" :NAME "AUXILIARY_UTILITIES" :DIRECTORY ("REL3-PUBLIC" "PUBLIC") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2753213163. :AUTHOR "REL3" :LENGTH-IN-BYTES 36583. :LENGTH-IN-BLOCKS 36. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   ;;; -*- Mode:Common-Lisp; Package:AUX; Base:10 -*-;;===============================================================================;;   This data and information is proprietary to, and a valuable trade secret of;   Texas Instruments, Incorporated, a Delaware corporation.  It is given in;   confidence by Texas Instruments, and may not be used as the basis of;   manufacture, or be reproduced or copied, or be distributed to any other;   party, in whole or in part, without the prior written consent of Texas;   Instruments.;;===============================================================================;;   (c) Unpublished Copyright 1984 by Texas Instruments.  All rights reserved.;;===============================================================================;(IN-PACKAGE "AUX" :use '(lisp ticl zlc));;;;;; Correction History;;;;;; 04/04/86  LGOReplaced RPLASSQ with a new faster version;;; 04/04/86  LGOFixed bugs in GRADE-DOWNER - replaced EQUAL tests with =;;; 04/04/86  LGOCommon-lisp conversion;;; 02/06/86  DANFixed bug in RANDOM-INITIALIZE;;;File  ceg:old-aux     27-APR-1982  11:32:10.67;;;Function Names:  (setq auxfcns '(ALL-INDICIES              BIND-ITEM              BIND-LIST              CHOOSE      COMPRESS      CONSTRUCT-ASSOC-LIST              CONVERT-TO-LIST              DEAL      delassq      DELETE-NTH              DO-SORT              ELEMENT*/?              ELEMENT-COVER-SET      FC-AND ;macro      FC-APPEND ;macro      FC-AVERAGE ;macro      FC-CONDCONS ;macro      FC-CONS ;macro      FC-MAX ;macro      FC-MIN ;macro      FC-NIL ;macro      FC-OR ;macro      FC-PLUS ;macro      FIND-OB ;macro                    FIRST-NON-MATCH              GEN-SYM              GET-KEY              GRADE-DOWN              INDEX-GENERATOR      INSERT-NTH              ITEM-PLEX      MAKESET ;macro      MAPTREE      MOVE-TO-FRONT      MOVE-TO-BACK      ndelete-nth      ninsert-nth      nreplace-nth      nreplace-nths      nscramble      nunroll      ORDERED-ADD-ELEMENT      ORDERED-ELEMENT      ORDERED-MAKESET      ORDERED-REMOVE-ELEMENT      PERCENTAGE              PLEX      prompt-read              QSETQ      random-initialize      RECORD-SCHEMA      REMOVE-ASSOC      REPLACE-NTH              REPLACE-NTHS              ROLL      ROTATE      rplassq              S-COPY              SCRAMBLE      SELECT-ASSOC ;macro              SELECT-CAR      SELECTOR              SELEX      SET-DIFFERENCE      SHAKE              SNOC              SORT      STAR ;macro              SUBSET-POSITION              TAKE              UNROLL      UNBOUNDL      UNBOUNDP      UPDATE-ASSOC-LIST              VECTOR-AVE              VECTOR-DIFF              VECTOR-LENGTH                   VECTOR-SUM)) ;;;This file contains auxillary functions that were developed as subroutines ;;;for the CEG, FMS and CSG systems.  They perform various utility tasks ;;;that are not particular to any system but are of general use to any ;;;lisp system. Documentation can be found in UMASS COINS TR 82-? CEG 2.2 ;;;User's Manual.;;;--------------------------------------------------------MACROS----------------------;;;Functional Combinator Macros(eval-when (load compile eval)(defun make-loop (lists)  (do ((alist lists (cdr alist))       (result nil)       (vars (cons (gensym) nil) (cons (gensym) vars)))      ((null alist)       (values  result (nreverse (cdr vars))))    (setq result `(for ,(car vars) in ,(car alist)       ,@result)))));;; FC-ARGS(defvar *fc-args*);;;-----------------------------------------------------------------;;; FC-ARG-TO-LOOP-MAC(eval-when (compile load eval)   (defun fc-arg-to-loop-mac (lists)     (cond ((null lists) nil)   (t (let ((anam (gensym)))(push anam (symeval *fc-args*))`(for ,anam in ,(car lists)      ,@(fc-arg-to-loop-mac (cdr lists))))))));;;------------------------------------------------------------------;;; FC-AND(defmacro fc-and (functions &body lists)  "AND the results of (car functions) applied to car of each of lists   with the cadr . . . etc."  (multiple-value-bind (loop-form vars)      (make-loop lists)    `(loop ,@loop-form   for a-function in ,functions   always (funcall a-function ,@vars))));;;---------------------------------------------------------------;;; FC-APPEND(defmacro fc-append (functions &body lists)  "APPEND the results of (car functions) applied to car of each of lists   with the cadr . . . etc."  (multiple-value-bind (loop-form vars)       (make-loop lists)       `(loop  ,@loop-form       for a-function in ,functions       append (funcall a-function ,@vars))));;;----------------------------------------------------------------;;; FC-AVERAGE(defmacro fc-average (functions &body lists)  "Find the Average of the results of (car functions) applied to car of each of lists  with the cadr . . . etc."  (multiple-value-bind (loop-form vars)(make-loop lists)`(loop  ,@loop-formfor a-function in ,functions sum (funcall a-function ,@vars) into sum-var count t into count-var finally (return (quotient sum-var count-var)) )));;;-----------------------------------------------------------------;;; FC-CONDCONS(defmacro fc-condcons (functions &body lists)  "CONS the results of (car functions) applied to car of each of lists  with the cadr . . . etc if that result is not nil."  (multiple-value-bind (loop-form vars)      (make-loop lists)    (LET ((dummy (gensym)))      `(LET (,dummy) (loop  ,@loop-formfor a-function in ,functionsDO (SETQ ,dummy (funcall a-function ,@vars))IF ,dummy collect ,dummy)))))  ;;;------------------------------------------------------------------;;; FC-CONS(defmacro fc-cons (functions &body lists)  "CONS the results of (car functions) applied to car of each of lists   with the cadr . . . etc."  (multiple-value-bind (loop-form vars)      (make-loop lists)    `(loop ,@loop-form   for a-function in ,functions   collect (funcall a-function ,@vars))));;;----------------------------------------------------------------;;; FC-MAX(defmacro fc-max (functions &body lists)  "Find the Maximum of the results of (car functions) applied to car of each of lists  with the cadr . . . etc."  (multiple-value-bind (loop-form vars)       (make-loop lists)       `(loop  ,@loop-form       for a-function in ,functions       maximize (funcall a-function ,@vars))));;;----------------------------------------------------------------;;; FC-MIN(defmacro fc-min (functions &body lists)  "Find the Minimum of the results of (car functions) applied to car of each of lists  with the cadr . . . etc."  (multiple-value-bind (loop-form vars)       (make-loop lists)       `(loop  ,@loop-form       for a-function in ,functions       minimize (funcall a-function ,@vars))));;;----------------------------------------------------------------;;; FC-NIL(defmacro fc-nil (functions &body lists)  "Discard the results of (car functions) applied to car of each of lists   with the cadr . . . etc."  (multiple-value-bind (loop-form vars)      (make-loop lists)    `(loop  ,@loop-form    for a-function in ,functions    do (funcall a-function ,@vars))));;;------------------------------------------------------------------;;; FC-OR(defmacro fc-or (functions &body lists)  "OR the results of (car functions) applied to car of each of lists   with the cadr . . . etc."  (multiple-value-bind (loop-form vars)      (make-loop lists)    `(loop ,@loop-form   for a-function in ,functions   thereis (funcall a-function ,@vars))));;;----------------------------------------------------------------;;; FC-PLUS(defmacro fc-plus (functions &body lists)  "Add up the results of (car functions) applied to car of each of lists  with the cadr . . . etc."  (multiple-value-bind (loop-form vars)       (make-loop lists)       `(loop  ,@loop-form       for a-function in ,functions       sum (funcall a-function ,@vars))));;;--------------------------------------------------------;;;FIND-OB(DEFUN find-ob (item)  "If ITEM is an object, return it, otherwise symeval until an object is found."  (IF (INSTANCEP item) item (find-ob (EVAL item))));;;--------------------------------------------------------;;; MAKESET(defmacro makeset (lst)  "Turn LST into a Set"  `(UNION ,lst));;;-----------------------------------------------------------------;;; SELECT-ASSOC;;(defmacro select-assoc (x alst)  "Returns the associated value to X in association list ALST"  `(cdr (assq ,x ,alst)));;;-----------------------------------------------------------------------;;; STAR(defmacro star (arg)  "Kleene star function - an infinite list of ARG"  `(circular-list ,arg));;;------------------------------------------------------------------;;;UNBOUNDP(defmacro unboundp (item)  `(not (boundp ,item)));;;--------------------------------------------------------FUNCTIONS-------------------;;; ALL-INDICIES                                    12-MAR-1982  13:25:35.43(DEFUN ALL-INDICIES (ITEM LST)  "Returns a list of the indices of all occurances of ITEM in LST"  (COND ((NULL (position ITEM (the list LST) :test #'equal)) NIL)        (T (CONS (position ITEM (the list LST) :test #'equal)                 (ALL-INDICIES ITEM                               (REPLACE-NTH LST                                            (position ITEM (the list LST) :test #'equal)                                            '**$*$*$**$*$*$*$**$*$**$*$))))));;;--------------------------------------------------------;;; BIND-ITEM                                    21-JAN-1982  21:59:38.11(DEFUN BIND-ITEM (ITEM TYPE)  "Returns a gen-sym'ed symbol of TYPE with a value of ITEM"  (PROG (NAM) (SETQ NAM (GEN-SYM TYPE)) (SET NAM ITEM) (RETURN NAM))) ;;;--------------------------------------------------------;;; BIND-LIST                                    16-JAN-1982  20:10:27.80(DEFUN BIND-LIST (LST TYPE)  "Returns a list of gen-sym'ed symbols of TYPE corresponding to each value of LST"  (COND ((NULL LST) NIL)        (T (PROG (NAM)             (SETQ NAM (GEN-SYM TYPE))             (SET NAM (CAR LST))             (RETURN (CONS NAM (BIND-LIST (CDR LST) TYPE))))))) ;;;--------------------------------------------------------;;; BSORT                                    17-FEB-1982  19:19:34.06(DEFUN BSORT (DATA FIELD)  "One pass of a Bubble sort. Used by MSORT and DO-SORT."  (declare (special *test))  (COND ((NULL (CDR DATA)) DATA)        ((string-lessp (NTH FIELD (CADR DATA))       (NTH FIELD (CAR DATA)))         (SETQ *TEST T)         (CONS (CADR DATA) (BSORT (CONS (CAR DATA) (CDDR DATA)) FIELD)))        (T (CONS (CAR DATA) (BSORT (CDR DATA) FIELD))))) ;;;--------------------------------------------------------;;; CHOOSE                                    17-JAN-1982  12:23:04.43(DEFUN CHOOSE (ITEM TLIST &functional PICK-FN &functional SELECT-FN)  "Return an element chosen by SELECT-FN from a tuple in TLIST for which   ITEM is equal to the element determined by PICK-FN.  This is like a   generic ASSQ, e. g. if PICK-FN was CAR, SELECT-FN was CDR, ITEM   was an atom and each tuple a list of atoms, then Choose would be the   same as ASSQ."  (COND ((NULL TLIST) NIL)        ((EQUAL ITEM (funcall PICK-FN (CAR TLIST)))         (funcall SELECT-FN (CAR TLIST)))        (T (CHOOSE ITEM (CDR TLIST) PICK-FN SELECT-FN)))) ;;;--------------------------------------------------------;;; COMPRESS(DEFUN COMPRESS (LST COMPRESSION-VECTOR)  "Similar to APL Compression function, returns a list from LST where    every coresponding element in COMPRESSION-VECTOR with a T is kept,    and every corresponding element with a NIL is discarded."  (COND ((NULL LST) NIL)((NULL (CAR COMPRESSION-VECTOR)) (COMPRESS (CDR LST)(CDR COMPRESSION-VECTOR)))(T (CONS (CAR LST)(COMPRESS (CDR LST)(CDR COMPRESSION-VECTOR))))));;;--------------------------------------------------------;;; CONSTRUCT-ASSOC-LIST(defun construct-assoc-list (alst x1 x2)  "Build an assoc list from list X1 and X2 if ALST is nil else add to back of ALST"  (append alst (pairlis (list x1) (list x2))));;;-----------------------------------------------------------------------;;; CONVERT-TO-LIST                                    16-JAN-1982  20:10:27.97(DEFUN CONVERT-TO-LIST (ITEM)  "Insure that item is a list"  (COND ((LISTP ITEM) ITEM)        (T (LIST ITEM)))) ;;;--------------------------------------------------------;;; delassq                                 14-may-1985 (defun delassq (item alist)  "Delete item from alist"  (if (eq item (caar alist))      (cdr alist)      (loop for previous first alist then list    for list on alist    do (when (eq item (caar list)) (return (rplacd previous (cdr list)))))));;;--------------------------------------------------------;;; DEAL                                    16-JAN-1982  20:10:28.29(DEFUN DEAL (NUM OF)  "Similar to APL Deal function, returns a random list of NUM numbers   between 0 and OF without replacement."  (TAKE NUM (NSCRAMBLE (INDEX-GENERATOR OF)))) ;;;--------------------------------------------------------;;; SCRAMBLE                                    16-JAN-1982  20:10:28.39(EVAL-WHEN (COMPILE LOAD EVAL)(DEFSUBST nth-to-front (LIST index)  "Move the INDEX-th item list to the front of list destructively"  (IF (PLUSP index)      (LET* ((t1 (NTHCDR (1- index) list))     (t2 (CDR t1)))(RPLACD t1 (CDR t2))      ;delete from middle of nlist(RPLACD t2 list))      ;Put deleted item at front      list)))(DEFUN NSCRAMBLE (LIST)  "Randomly re-order LIST destructively."  (LET* ((len1 (LENGTH list)) (var (roll len1)))    (SETQ LIST (nth-to-front LIST var))      ;Put deleted item at front    (LOOP for len from (1- len1) above 1  for nlist on LIST DO  (SETQ var (roll len))  (RPLACD nlist (nth-to-front (CDR nlist) var))))  list)(DEFUN SCRAMBLE (NLIST)  "Randomly re-order LIST."  (nscramble (COPY-LIST nlist)));;;--------------------------------------------------------;;; DELETE-NTH(defun delete-nth (lst ind)  "Delete the IND'th item in LST"  (cond ((null lst)nil)((equal ind 0) (cdr lst))(t (cons (car lst)(delete-nth (cdr lst) (1- ind))))))(defun Ndelete-nth (lst ind)  "Destructively Delete the IND'th item in LST"  (COND ((PLUSP ind) (LET ((temp (NTHCDR (1- ind) lst)))   (RPLACD temp (CDDR temp))   lst))((ZEROP ind) (CDR lst))(t (FERROR "List item number must be positive"))));;;----------------------------------------------------------------------;;; DO-SORT                                    17-FEB-1982  19:11:18.50(DEFUN DO-SORT (DATA FIELD-LIST)  "Do a multifield sort of the tuples in DATA by precidence of the tuple items (fields)   specified by indicies in FIELD-LIST, most major field first."  (COND ((NULL FIELD-LIST) DATA)        (T (MSORT (DO-SORT DATA (CDR FIELD-LIST))                 (CAR FIELD-LIST)                 T                 (LENGTH DATA))))) ;;;--------------------------------------------------------;;; ELEMENT*?                                    21-JAN-1982  18:30:55.36(DEFUN ELEMENT*? (ITEM LST)  "Does ITEM occur anywhere in LST at any depth?"  (COND ((NULL LST) NIL)        ((ATOM LST) (EQ ITEM LST))        (T (OR (ELEMENT*? ITEM (CAR LST)) (ELEMENT*? ITEM (CDR LST)))))) ;;;--------------------------------------------------------;;; ELEMENT-COVER                                    23-FEB-1982  01:08:07.06(DEFUN ELEMENT-COVER (ITEMLIST)  "Used by ELEMENT-COVER-SET to generate cover sets."  (PROG (TS)    (COND ((NULL ITEMLIST) NIL)          ((NULL (INTERSECTION (CAR ITEMLIST)                               (SETQ TS (ELEMENT-COVER (CDR ITEMLIST)))))           (CONS (CAAR ITEMLIST) TS))          (T TS)))) ;;;--------------------------------------------------------;;; ELEMENT-COVER-SET                                    23-FEB-1982  01:08:54.52(DEFUN ELEMENT-COVER-SET (ITEMLIST)  "Return a set built from the tuples in ITEMLIST such that each tuple in ITEMLIST   has at least one of its elements is in the returned set."  (NREVERSE (ELEMENT-COVER (REVERSE ITEMLIST)))) ;;;--------------------------------------------------------;;; FIRST-NON-MATCH                                    20-FEB-1982  21:06:15.06(DEFUN FIRST-NON-MATCH (SET1 SET2)  "Compares SET1 and SET2 and returns the index of the first element where they differ.   If they are the same, then the result will equal the length of the sets."  (LOOP for s1 in set1for s2 in set2for i from 0WHEN (NEQ s1 s2) DO (RETURN i)finally (RETURN (1+ i))));;;--------------------------------------------------------;;;                          FRAMES;;  ;;Using of frames allows the dynamic manipulation of DefStruct forms;;without having to imbede the slot name in the code.  E. g., one can;;develop code for some process that "on the fly" needs to choose a;;slot but doesn't want to (or isn't able to) determine at compile time;;which slot should be changed.  These functions access and modify;;DefStruct values by generating access macro names on the fly and then;;evaluating them.  This is obviously slower than hard coding in the names,;;but more general.;;; FRAME-SLOTNUM(DEFUN frame-slotnum (type slot)  "Find the slot number given a defstruct type"  (DECLARE (values index type))  (LET ((description (GET type 'si:defstruct-description)))    (UNLESS description (FERROR "~s is not the name of a defstruct" type))    (LOOP for s in (FOURTH description)  for i from 0  WHEN (EQ (CAR s) slot) DO (RETURN i (SECOND description))  finally (FERROR "~s is not a slot in ~s" slot type))));;; FRAME-GET                                     9-JAN-1982  13:14:10.26(DEFUN FRAME-GET (FRAME TYPE SLOT)  "Get the value of SLOT in the structure FRAME where FRAME is of type TYPE"  (MULTIPLE-VALUE-BIND (index type) (frame-slotnum type slot)    (CASE type      (:array (AREF frame index))      (:list (NTH index frame))      (otherwise (FERROR "~s is a unsupported frame type")))));;;--------------------------------------------------------;;; FRAME-PUT                                    21-JAN-1982  18:05:23.91(DEFUN FRAME-PUT (FRAME TYPE SLOT VALUE)  "Supply a new VALUE for SLOT in FRAME of type TYPE"  (MULTIPLE-VALUE-BIND (index type) (frame-slotnum type slot)    (CASE type      (:array (SETF (AREF FRAME INDEX) VALUE))      (:list (SETF (NTH index frame) value))      (otherwise (FERROR "~s is a unsupported frame type")))));;;------------------------------------------------------------------;;; GEN-SYM                                    16-JAN-1982  20:10:28.52(DEFVAR *gen-sym-count-list* nil "Assq list of gensym names and counts")(DEFUN GEN-SYM (TYPE &optional (resetp nil) &aux count)  "Return a gensym atom where the entire value of TYPE is the prefix."  (WHEN (NULL (SETQ count (ASSOC type *gen-sym-count-list*)))    (PUSH (SETQ count `(,type . 0.)) *gen-sym-count-list*))  (WHEN resetp (SETF (CDR count) 0))  (INCF (CDR count))  (intern (FORMAT nil "~a~4,vd" type #\0 (CDR count))))(DEFUN reset-gen-sym (item-or-list &aux count)  "reset items in list to start back at gensym 1"  (IF (ATOM item-or-list)      (WHEN (SETQ count (ASSOC item-or-list *gen-sym-count-list*))(RPLACD count 0.))      (LOOP for item in item-or-list    WHEN (SETQ count (ASSOC (CAR item-or-list) *gen-sym-count-list*))    DO (RPLACD count 0.))));;;--------------------------------------------------------;;; GET-KEY                                    20-MAR-1982  10:35:36.75(DEFUN GET-KEY (TEXT ACCEPT LEVEL)  "Prompt user for key using TEXT until ACCEPT-able word entered.  LEVEL can be   a mudule name to let user know where s/he is or who is asking."  (fquery (list ':type ':readline ':list-choices nil':choices (mapcar #'(lambda (x) (list x (string x))) accept))  "~A: ~A"  level text)) ;;;--------------------------------------------------------;;; GRADE-DOWN                                     9-MAR-1982  22:14:48.08(DEFUN GRADE-DOWN (LST)  "Similar to APL Grade-Down Function.  Returns a list of indicies in the numeric LST   Such that selection of the indexed items would sort LST in decreasing order."  (LET ((minx (1- (APPLY #'MIN lst))))    (grade-downer lst minx)))(DEFUN grade-downer (lst minx)  (COND ((NULL LST) NIL)        ((EQUAL minx (APPLY #'MAX LST)) NIL)        (T (CONS (POSITION (APPLY #'MAX LST) LST :test #'=)                 (GRADE-DOWNER (INSERT-NTH (DELETE-NTH   LST   (POSITION (APPLY #'MAX LST) LST :test #'=)) (POSITION (APPLY #'MAX LST) LST :test #'=) minx)       minx))))) ;;;--------------------------------------------------------;;; INDEX-GENERATOR                                    16-JAN-1982  20:10:28.69(DEFUN INDEX-GENERATOR (LENGTH)  "Similar to Index-Generator in APL.  Returns a list of LENGTH numbers from 0 to (1- LENGTH)."  (LOOP for n from 0 to (1- length) collect n));;;--------------------------------------------------------;;; INSERT-NTH(defun insert-nth (lst ind value)  "Insert VALUE into LST *BEFORE* the IND position.  I. E., VALUE becomes the   IND'th item. If IND is > length of LST, VALUE is Thrown Away."  (SETQ ind (MIN ind (LENGTH lst)))  (NCONC (FIRSTN ind lst) (CONS value (NTHCDR ind lst))))(defun Ninsert-nth (lst ind value)  "Desctuctively Insert VALUE into LST *BEFORE* the IND position.  I. E., VALUE becomes the   IND'th item. If IND is > length of LST, VALUE is Thrown Away."  (COND ((PLUSP ind) (SETQ ind (MIN ind (LENGTH lst))) (LET ((temp (NTHCDR (1- ind) lst)))   (RPLACD temp (CONS value (CDR temp)))) lst)((ZEROP ind) (CONS value lst))(t (FERROR "Negative index ~s given to ninsert-nth" ind))));;;----------------------------------------------------------------------;;; ITEM-PLEX                                    21-JAN-1982  22:01:41.47(DEFUN ITEM-PLEX (ITEM LST)  "Return a list of pairs of ITEM paired with every element of LST."  (LOOP for x in lstcollect (LIST item x)));;;-------------------------------------------------------------------;;; MAPTREE(DEFUN maptree (fn tree &rest args)  "apply FN to each leaf of TREE, using ARGS on each. In other   words, the arglist ARGS is applied to each element of TREE - no   structure matching on the ARGS is performed."  (COND ((NULL tree)nil)((ATOM tree)(APPLY fn tree args))(t (CONS (APPLY #'maptree `(,fn ,(CAR tree) ,@args)) (APPLY #'maptree `(,fn ,(CDR tree) ,@args)) ))));;;--------------------------------------------------------;;; MEMBER-TO-FRONT14-FEB-1984  LaMott Oren(DEFMACRO member-to-front (LIST thing)  "Destructively modify LIST moving THING to the front (tests for EQUAL, works for dotted lists)."  `(SETF ,LIST (member-to-front-internal ,LIST ,thing)))(DEFUN member-to-front-internal (LIST thing)  "Destructively modify LIST moving THING to the front (tests for EQUAL, works for dotted lists)."  (LOOP for previous FIRST (LOCF LIST) then elementfor element FIRST LIST then (CDR element)DO(WHEN (EQUAL thing (CAR element))  (RPLACD previous (CDR element)) ;splice out thing  (RPLACD element list)  ;and put it at the front of the list  (RETURN (SETQ LIST element)))(WHEN (ATOM (CDR element))  ;dotted list case  (WHEN (EQUAL thing (CDR element))    (RPLACD previous (CAR element))    (RPLACA element (CDR element))    (RPLACD element LIST)    (SETQ LIST element))  (RETURN)))  LIST);;;--------------------------------------------------------;;; MEMBER-TO-BACK14-FEB-1984  LaMott Oren(DEFMACRO member-to-back (LIST thing)  "Destructively modify LIST moving THING to the end of the list (tests for EQUAL, works for dotted lists)."  `(SETF ,LIST (member-to-back-internal ,LIST ,thing)))(DEFUN member-to-back-internal (LIST thing)  "Destructively modify LIST moving THING to the end of the list (tests for EQUAL, works for dotted lists)."  (LOOP for previous FIRST (LOCF LIST) then elementfor element FIRST LIST then (CDR element) while (LISTP element)with LASTDO (WHEN (EQUAL thing (CAR element))     (RPLACD previous (CDR element));splice out thing     (SETQ LAST (LAST element))     (COND ((CDR LAST)  ;If a dotted list    (RPLACD element (CAR element))    (RPLACA element (CDR LAST)))   (t (RPLACD element nil)))     (RETURN (RPLACD LAST element))))  LIST);;;--------------------------------------------------------;;; ORDERED-ADD-ELEMENT(defun ordered-add-element (x olist)  "Add X to the Ordered Set OLIST"  (cond ((ordered-element\? x olist) olist)(t (sort (cons x olist) #'string-lessp))));;;------------------------------------------------------------------;;; ORDERED-ELEMENT\?(defun ordered-element\? (x oset)  "Add X to the Ordered Set OSET in its correct position"  (cond ((null oset) nil)((equal x (car oset)) oset)((string-lessp x (car oset)) nil)(t (ordered-element\? x (cdr oset)))));;;------------------------------------------------------------------;;; ODERED-MAKESET(defun ordered-makeset (lst)  "Make LST an Ordered Set"  (sort (UNION LST :TEST #'EQ) #'string-lessp));;;-----------------------------------------------------------------;;; ORDERED-REMOVE-ELEMENT(defmacro ordered-remove-element (x oset)  "Remove X from Ordered Set OSET"  `(remove ,x ,oset));;;-------------------------------------------------------------------;;; PERCENTAGE(DEFUN percentage (percent-likely)  "Return whether a 100 sided die has come up less than PERCENT-LIKELY."  (< (aux:roll 100) percent-likely));;;--------------------------------------------------------;;; PLEX                                    16-JAN-1982  20:10:28.88(DEFUN PLEX (ALST LLST)  "Return a list of pairs of every element of ALST paired with every element of LLST"  (LOOP for a in alst NCONC(LOOP for l in llst collect (LIST a l))));;;--------------------------------------------------------;;; PROMPT-READ;;(defmacro prompt-read (str &optional stream)  "Prompt on STREAM with STR and then do whatever was asked."  (IF stream      `(LET ((query-io ,stream)) (PROMPT-AND-READ ':expression-or-end ,str))      `(PROMPT-AND-READ ':expression-or-end ,str)));;;-----------------------------------------------------------------;;; QSETQ                                    16-JAN-1982  20:10:29.03(DEFUN QSETQ (&quote symbol value)  "Without evaluating either argument, set SYMBOL to VALUE."  (SET symbol value)) ;;;--------------------------------------------------------(DEFUN random-initialize (&optional seed)  "set the random number generator to a random value"  (si:random-initialize (si:make-random-state) (OR seed (REMAINDER (TIME:FIXNUM-MICROSECOND-TIME) 10000))));;;--------------------------------------------------------;;; RECORD-SCHEMA(defun record-schema (prefix itemlist)  "Return a list of symbols with numeric values from 0 to (1- (length ITEMLIST)   The symbols are of the form PREFIX-foo where foo is each of the items in   ITEMLIST.  What this does is provide a series of Names to use as indicies   into an array rather than having to remember the position.  Useful if you   Haven't bothered to build a DefStruct or don't need to for your application."  (record-schema1 prefix itemlist 0))(defun record-schema1 (prefix itemlist itemv)  (cond ((null itemlist) nil)(t (cons (let ((nam (intern (string-append (string prefix)   "-"   (string (car     itemlist))))))      (set nam itemv)      nam) (record-schema1 prefix (cdr itemlist) (1+ itemv))))));;;----------------------------------------------------------------------- ;;;REMOVE-ASSOC(defun remove-assoc (x alst)  "Actually remove X and it's associated value from ALST"  (DELETE X (THE LIST ALST) :TEST #'(LAMBDA (ITEM ELEMENT)      (EQ ITEM (CAR ELEMENT)))));;;-------------------------------------------------------------------------;;; REPLACE-NTH(defun replace-nth (lst ind value)  "Replace the IND'th item of LST with VALUE"  (IF (PLUSP ind)      (NCONC (FIRSTN ind lst) (LIST value) (NTHCDR (1+ ind) lst))      (CONS value (CDR lst))))(defun Nreplace-nth (lst ind value)  "Destructively replace the IND'th item of LST with VALUE"  (RPLACA (NTHCDR ind lst) value))     ;;;----------------------------------------------------------------------;;; REPLACE-NTHS                                    16-JAN-1982  20:10:29.71(DEFUN NREPLACE-NTHS (LST IS XS)  "Replace the elements of LST denoted by the index list IS with the elements of XS."  (LOOP for i in isfor x in xsDO (RPLACA (NTHCDR i lst) x))  lst)(DEFUN REPLACE-NTHS (LST IS XS)   "Destructively replace the elements of LST denoted by the index list IS with the elements of XS."   (nreplace-nths (COPY-LIST lst) is xs));;;--------------------------------------------------------;;; ROLL                                    16-JAN-1982  20:10:30.64(DEFUN ROLL (DIE)  "Roll a DIE sided die. Returns a number between 0 and DIE minus one."   (IF (> die 0.)(RANDOM (FLOOR DIE)) 0.));;;--------------------------------------------------------(DEFUN rotate (lst n)  "rotate lst by n to the left.  0 means no change. negative is to the right."  ; there's got to be a more effecient way to do this...  (take (LENGTH lst) (NTHCDR (LET ((ROTe (REMAINDER (FLOOR N) (LENGTH LST))))       (IF (MINUSP n) (+ rote (LENGTH lst)) rote))      (APPEND lst lst))));;;--------------------------------------------------------;;; RPLASSQ      4-APR-1986 LGO(DEFUN rplassq (item alist)  "If ITEM is in ALIST, destructively replace its value, otherwise add it to the end of ALIST."  (LOOP for m on alistwith search = (CAR item)when (EQ (CAAR m) search)do (RETURN (RPLACD (CAR m) (CDR item)))finally (SETQ alist (NCONC alist (LIST item))))  alist);;;--------------------------------------------------------;;; S-COPY                                    16-JAN-1982  20:10:30.83(DEFUN S-COPY (STRUCT)  "Make a copy of a structure."  (PROG (NEWS)    (COMMENT ONLY WORKS FOR LINEAR (VECTOR) ARRAYS doesnot yet work for flavors)    (COND ((NULL STRUCT) (RETURN NIL))          ((NUMBERP STRUCT) (RETURN STRUCT))          ((STRINGP STRUCT) (RETURN STRUCT))          ((LISTP STRUCT)           (RETURN (CONS (S-COPY (CAR STRUCT)) (S-COPY (CDR STRUCT)))))          ((SYMBOLP STRUCT) (RETURN STRUCT))          ((ARRAYP STRUCT)           (SETQ NEWS (cond ((not (typep struct 'array))(eval  `,(read-from-string      (format nil "(MAKE-~A)" (TYPE-OF struct)))))       (t (make-array    (array-dimensions struct)    ':type (array-type struct)))))           (loop for I from 0 to (1- (car (array-dimensions struct))) do (SETF (AREF NEWS I) (S-COPY (AREF STRUCT I))))           (RETURN NEWS)))));;;--------------------------------------------------------;;; SELECTS(DEFUN SELECTS (item table &optional (fn #'EQ))  "Similar to SELECT. Select a piece of code from TABLE by finding a match    of the CAR of a TABLE entry to ITEM.  The difference between SELECT is   that here you can specify your matching FN, e. g., >, <, ELEMENT, etc.";  (FSIGNAL "Using SELECTS - there's got to be a better way!!!")  (COND ((NULL table) nil)((FUNCALL fn  item (caar table))(eval (cadar table)))((EQ t (CAAR table)) (EVAL (CADAR table)))    ;an otherwise clause(t (SELECTS item (cdr table) fn))));;;--------------------------------------------------------;;; SELEX                                     6-FEB-1982  13:39:44.32(DEFUN SELEX (LST INDX)  "Return the items of LST indicated by the index list INDX."  (FC-CONS (STAR #'NTH) INDX (STAR LST))) ;;;--------------------------------------------------------;;; SHAKE(DEFUN shake (num die)  "roll NUM number of DIE sided dice"  (DOTIMES (i (1- num)) (RANDOM 10)) ; Skip num-1 numbers in the random number sequence  (IF (PLUSP num) (roll die) 0))     ; Return the num'th random number, or zero if num is zero.;;;--------------------------------------------------------;;; SNOC                                    16-JAN-1982  20:10:31.17(DEFUN SNOC (X1 X2)  "Cons X1 onto the back of X2."  (APPEND X2 (LIST X1))) ;;;--------------------------------------------------------;;; MSORT                                    17-FEB-1982  19:13:42.65;;;Declarations List:  (DEFUN MSORT (DATA FIELD *TEST ITER)  "Multi-field sort.  Used by DO-SORT."  (DECLARE (SPECIAL *TEST))   (COND ((OR (NULL *TEST) (< ITER 2.)) DATA)        (T (SETQ *TEST NIL)           (MSORT (BSORT DATA FIELD) FIELD *TEST (1- ITER))))) ;;;--------------------------------------------------------;;; SUBSET-POSITION                                    20-FEB-1982  23:06:26.05(DEFUN SUBSET-POSITION (SUB SETL)  "Find tuple in SETL that SUB is a member of."  (COND ((NULL SETL) 1.)        ((MEMBER SUB (CAR SETL)) 1.)        (T (1+ (SUBSET-POSITION SUB (CDR SETL)))))) ;;;--------------------------------------------------------;;; TAKE                                    16-JAN-1982  20:10:31.31(DEFUN TAKE (NUM LIST)  "Similar to APL Take function.  Take the first NUM elements of LIST.   If NUM is negative, take from the end of LIST.  If NUM is larger   than LIST is long, fill with nils or zeros depending on type of list."  (COND ((ZEROP NUM) NIL)((> (ABS NUM) (LENGTH LIST))         (APPEND LIST                 (MAKE-LIST (- (ABS NUM) (LENGTH LIST))    ':initial-value (COND ((NUMBERP (CAR LIST)) 0.)  (T NIL)))))((PLUSP num)  (FIRSTN num list))(t (NTHCDR (+ (LENGTH list) num) list))));;;--------------------------------------------------------;;; UNBOUNDL(DEFUN UNBOUNDL (LST)  "Return the items of LST that are unbound."  (LOOP for l in lstWHEN (AND (SYMBOLP l) (NOT (BOUNDP l)))collect l));;;--------------------------------------------------------;;; UNROLL                                    17-JAN-1982  13:22:25.11(DEFUN UNROLL (LST)  "Return LST with 'all parens' removed, i. e., completely flattened."  (COND ((NULL LST) NIL)        ((ATOM LST) (LIST LST))        (T (APPEND (UNROLL (CAR LST)) (UNROLL (CDR LST))))))(DEFUN NUNROLL (LST)  "Return LST with 'all parens' removed, i. e., completely flattened.Destroys LST."  (COND ((NULL LST) NIL)        ((ATOM LST) (LIST LST))        (T (NCONC (UNROLL (CAR LST)) (UNROLL (CDR LST)))))) ;;;--------------------------------------------------------;;; UPDATE-ASSOC-LIST(defun update-assoc-list (x alst &functional fun)  "Apply FUN to the associated value of X in assoc list ALST, or else nil if no   association is found.  RPLACD's the assoc list."  (let ((glub (ASSOC X ALST :TEST #'EQ)))    (cond (glub (rplacd (ASSOC X ALST :TEST #'EQ) (funcall fun (cdr glub))) alst)  (t (append alst (pairlis (list x)(funcall fun nil)))))));;;----------------------------------------------------------------------;;; VECTOR-AVE                                    16-JAN-1982  20:10:31.51(DEFUN VECTOR-AVE (VEC-LIST)  "VEC-LIST is a list of (x y) coordinate pairs.  Return the average."  (LIST (FC-AVERAGE (STAR #'CAR) VEC-LIST)        (FC-AVERAGE (STAR #'CADR) VEC-LIST))) ;;;--------------------------------------------------------;;; VECTOR-DIFF                                    16-JAN-1982  20:10:33.27(DEFUN VECTOR-DIFF (MINUEND SUBTRAHEND)  "Return (x y) coordinate vector difference"  (LIST (- (CAR MINUEND) (CAR SUBTRAHEND))        (- (CADR MINUEND) (CADR SUBTRAHEND)))) ;;;--------------------------------------------------------;;; VECTOR-LENGTH                                    15-JAN-1982  13:36:42.80(DEFUN VECTOR-LENGTH (VEC)  "Length of (x y) coordinate vector VEC."  (SQRT (+ (* (FLOAT (CAR VEC)) (FLOAT (CAR VEC)))   (* (FLOAT (CADR VEC)) (FLOAT (CADR VEC)))))) ;;;--------------------------------------------------------;;; VECTOR-SUM                                    19-JAN-1982  20:40:28.33(DEFUN VECTOR-SUM (AD1 AD2)  "Sum of two (x y) coordinate vectors."  (LIST (+ (CAR AD1) (CAR AD2)) (+ (CADR AD1) (CADR AD2)))) ;;;--------------------------------------------------------wish it to be created in the current      default directory.   b. The Explorer will now say "Press any key when the IBM is ready to send.  DO      NOT do this (i.e. press a key) until step c is completed.   c. Prepare the IBM by calling up some modem program (e.g. procomm, q