home *** CD-ROM | disk | FTP | other *** search
/ vis-ftp.cs.umass.edu / vis-ftp.cs.umass.edu.tar / vis-ftp.cs.umass.edu / pub / Software / ASCENDER / ascendMar8.tar / UMass / ISR / lispm.lisp < prev    next >
Text File  |  1995-04-11  |  8KB  |  230 lines
  1. ; -*-lisp-mode-*-
  2. ;--------------------------------------------------------
  3. ;  LISPM.LISP - lisp machine extras
  4. ;  Robert Heller Created on Wed Oct  2 08:59:01 1991
  5. ;   Last mod - 
  6. ;--------------------------------------------------------
  7. ;  Contents:
  8. ;--------------------------------------------------------
  9. ; (c) Copyright 1986 by The University of Massachusetts
  10. ;--------------------------------------------------------
  11.  
  12. (in-package "LISPM")
  13.  
  14. (shadow '(find find-if find-if-not) (find-package 'lispm))
  15.  
  16. ;; FIND  FIND-IF and FIND-IF-NOT
  17.  
  18. (eval-when (compile)
  19. ;; in LR processing, the leftmost item satisfying the test is returned. The search loop
  20. ;; is exited immediately upon finding such an item.
  21.  
  22.   (Defmacro WITH-FIND-LIST-BINDINGS (&BODY body)
  23.     `(LET* (thing-found
  24.         pos
  25.         (start (IF start (MAX 0 start) 0))
  26.         (len   (LENGTH list))
  27.         (end   (IF end (MIN end len) len))
  28.         (list  (NTHCDR start list)))
  29.        (PROGN . ,body)
  30.        (VALUES thing-found pos)))
  31.  
  32.   (Defmacro FIND-LIST-LR-BODY (loopvar pred)
  33.     `(DO ((,loopvar list (CDR ,loopvar))
  34.       (loopcnt start (1+ loopcnt)))
  35.      ((>= loopcnt end))
  36.        (WHEN ,pred 
  37.      (SETQ thing-found (CAR ,loopvar) 
  38.            pos loopcnt)
  39.      (RETURN))
  40.        ))
  41.   
  42.   (Defmacro FIND-LIST-LR-MACRO ()
  43.     `(COND (key
  44.         (IF test-not 
  45.         (Find-LIST-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
  46.         (Find-LIST-LR-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
  47.        (test-not 
  48.         (Find-LIST-LR-BODY z (NOT (FUNCALL test-not item (CAR z)))))
  49.        (t 
  50.         (Find-LIST-LR-BODY z (FUNCALL test item (CAR z))))))
  51.   
  52.   (Defmacro FIND-IF-LIST-LR-MACRO ()
  53.     `(IF key 
  54.      (Find-LIST-LR-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
  55.      (Find-LIST-LR-BODY z (FUNCALL pred (CAR z)))))
  56.   
  57.   (Defmacro FIND-IF-NOT-LIST-LR-MACRO ()
  58.     `(IF key 
  59.      (Find-LIST-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
  60.      (Find-LIST-LR-BODY z (NOT (FUNCALL pred (CAR z))))))
  61.   )
  62.  
  63. (eval-when (compile)
  64. ;; in RL processing, the rightmost item satisfying the test is sought. The list, however,
  65. ;; is searched left-to-right and instead of exiting when finding the item, we simply record
  66. ;; the item and its position. The values returned then correspond to the rightmost such item
  67. ;; in the list.
  68.  
  69.   (Defmacro FIND-LIST-RL-BODY (loopvar pred)
  70.     `(DO ((,loopvar list (CDR ,loopvar))
  71.       (loopcnt start (1+ loopcnt)))
  72.      ((>= loopcnt end))
  73.        (WHEN ,pred 
  74.      (SETQ thing-found (CAR ,loopvar)
  75.            pos loopcnt) 
  76.      )))
  77.  
  78.   (Defmacro FIND-LIST-RL-MACRO ()
  79.     `(COND (key
  80.         (IF test-not 
  81.         (Find-LIST-RL-BODY z (NOT (FUNCALL test-not item (FUNCALL key (CAR z)))))
  82.         (Find-LIST-RL-BODY z (FUNCALL test item (FUNCALL key (CAR z))))))
  83.        (test-not 
  84.         (Find-LIST-RL-BODY z (NOT (FUNCALL test-not item (CAR z)))))
  85.        (t
  86.         (Find-LIST-RL-BODY z (FUNCALL test item (CAR z))))))
  87.   
  88.   (Defmacro FIND-IF-LIST-RL-MACRO ()
  89.     `(IF key 
  90.      (Find-LIST-RL-BODY z (FUNCALL pred (FUNCALL key (CAR z))))
  91.      (Find-LIST-RL-BODY z (FUNCALL pred (CAR z)))))
  92.   
  93.   (Defmacro FIND-IF-NOT-LIST-RL-MACRO ()
  94.     `(IF key 
  95.      (Find-LIST-RL-BODY z (NOT (FUNCALL pred (FUNCALL key (CAR z)))))
  96.      (Find-LIST-RL-BODY z (NOT (FUNCALL pred (CAR z))))))
  97.   )
  98.  
  99. (Defun FIND-LIST (item list &OPTIONAL (test #'EQL) key test-not start end from-end)
  100.   (WITH-Find-LIST-BINDINGS
  101.     (IF from-end (FIND-LIST-RL-MACRO) (FIND-LIST-LR-MACRO))))
  102.  
  103. (Defun FIND-IF-LIST (pred list &OPTIONAL key start end from-end)
  104.   (WITH-FIND-LIST-BINDINGS
  105.     (IF from-end (FIND-IF-LIST-RL-MACRO) (FIND-IF-LIST-LR-MACRO))))
  106.  
  107. (Defun FIND-IF-NOT-LIST (pred list &OPTIONAL key start end from-end)
  108.   (WITH-FIND-LIST-BINDINGS
  109.     (IF from-end (FIND-IF-NOT-LIST-RL-MACRO)(FIND-IF-NOT-LIST-LR-MACRO))))
  110.  
  111.  
  112. (eval-when (compile)
  113.   (Defmacro WITH-FIND-VECTOR-BINDINGS (&BODY body)
  114.     `(LET* (thing-found
  115.         pos
  116.         (start (IF start (MAX 0 start) 0))
  117.         (len   (LENGTH vector))
  118.         (end   (IF end (MIN end len) len)))
  119.        (PROGN . ,body)
  120.        (VALUES thing-found pos)))
  121.   
  122.   (Defmacro FIND-VECTOR-LR-BODY (loopvar pred)
  123.     `(DO ((,loopvar start (1+ ,loopvar)))
  124.      ((>= ,loopvar end))
  125.        (WHEN ,pred 
  126.      (SETQ thing-found (AREF vector ,loopvar)
  127.            pos ,loopvar) 
  128.      (RETURN))
  129.      ))
  130.   
  131.   (Defmacro FIND-VECTOR-LR-MACRO ()
  132.     `(COND (key
  133.         (IF test-not 
  134.         (FIND-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (FUNCALL key (AREF vector Z)))))
  135.         (FIND-VECTOR-LR-BODY z (FUNCALL test item (FUNCALL key (AREF vector Z))))))
  136.        (test-not 
  137.         (FIND-VECTOR-LR-BODY z (NOT (FUNCALL test-not item (AREF vector Z)))))
  138.        (t 
  139.         (FIND-VECTOR-LR-BODY z (FUNCALL test item (AREF vector Z))))))
  140.   
  141.   (Defmacro FIND-IF-VECTOR-LR-MACRO ()
  142.     `(IF key 
  143.      (FIND-VECTOR-LR-BODY z (FUNCALL pred (FUNCALL key (AREF vector Z))))
  144.      (FIND-VECTOR-LR-BODY z (FUNCALL pred (AREF vector Z)))))
  145.   
  146.   (Defmacro FIND-IF-NOT-VECTOR-LR-MACRO ()
  147.     `(IF key 
  148.      (FIND-VECTOR-LR-BODY z (NOT (FUNCALL pred (FUNCALL key (AREF vector Z)))))
  149.      (FIND-VECTOR-LR-BODY z (NOT (FUNCALL pred (AREF vector Z))))))
  150.   )
  151.  
  152. (eval-when(compile)
  153.  
  154.   (Defmacro FIND-VECTOR-RL-BODY (loopvar pred)
  155.     `(DO ((,loopvar (1- end) (1- ,loopvar)))
  156.      ((< ,loopvar start))
  157.        (WHEN ,pred 
  158.      (SETQ thing-found (aref vector ,loopvar)
  159.            pos ,loopvar)
  160.      (RETURN))
  161.        ))
  162.   
  163.   (Defmacro FIND-VECTOR-RL-MACRO ()
  164.     `(COND (key
  165.         (IF test-not 
  166.         (FIND-VECTOR-RL-BODY z (NOT (FUNCALL test-not item (FUNCALL key (AREF vector Z)))))
  167.         (FIND-VECTOR-RL-BODY z (FUNCALL test item (FUNCALL key (AREF vector Z))))))
  168.        (test-not 
  169.         (FIND-VECTOR-RL-BODY z (NOT (FUNCALL test-not item (AREF vector Z)))))
  170.        (t
  171.         (FIND-VECTOR-RL-BODY z (FUNCALL test item (AREF vector Z))))))
  172.   
  173.   (Defmacro FIND-IF-VECTOR-RL-MACRO ()
  174.     `(IF key 
  175.      (FIND-VECTOR-RL-BODY z (FUNCALL pred (FUNCALL key (AREF vector Z))))
  176.      (FIND-VECTOR-RL-BODY z (FUNCALL pred (AREF vector Z)))))
  177.   
  178.   (Defmacro FIND-IF-NOT-VECTOR-RL-MACRO ()
  179.     `(IF key 
  180.      (FIND-VECTOR-RL-BODY z (NOT (FUNCALL pred (FUNCALL key (AREF vector Z)))))
  181.      (FIND-VECTOR-RL-BODY z (NOT (FUNCALL pred (AREF vector Z))))))
  182.   )
  183.  
  184.  
  185. (Defun FIND-VECTOR (item vector &OPTIONAL (test #'EQL) key test-not start end from-end)
  186.   (WITH-Find-VECTOR-BINDINGS
  187.     (IF from-end 
  188.     (FIND-VECTOR-RL-MACRO)
  189.     (FIND-VECTOR-LR-MACRO))))
  190.  
  191. (Defun FIND-IF-VECTOR (pred vector &OPTIONAL key start end from-end)
  192.   (WITH-FIND-VECTOR-BINDINGS
  193.     (IF from-end 
  194.     (FIND-IF-VECTOR-RL-MACRO)
  195.     (FIND-IF-VECTOR-LR-MACRO))))
  196.  
  197. (Defun FIND-IF-NOT-VECTOR (pred vector &OPTIONAL key start end from-end)
  198.   (WITH-FIND-VECTOR-BINDINGS
  199.     (IF from-end 
  200.     (FIND-IF-NOT-VECTOR-RL-MACRO)
  201.     (FIND-IF-NOT-VECTOR-LR-MACRO))))
  202.  
  203. (Defun FIND* (item sequence &OPTIONAL (test #'EQL) key test-not start end from-end)
  204.   (IF (ARRAYP sequence)
  205.       (FIND-VECTOR item sequence test key test-not start end from-end)
  206.       (FIND-LIST item sequence test key test-not start end from-end)))
  207.  
  208. (Defun FIND (item sequence &KEY key (test #'EQL) test-not start end from-end)
  209.   "Return first element of SEQUENCE that matches ITEM. Also returns the position
  210.  of the item."
  211.   (FIND* item sequence test key test-not start end from-end))
  212.  
  213. (Defun FIND-IF* (predicate sequence &OPTIONAL key start end from-end)
  214.   (IF (ARRAYP sequence)
  215.       (FIND-IF-VECTOR predicate sequence key start end from-end)
  216.       (FIND-IF-LIST predicate sequence key start end from-end)))
  217.  
  218. (Defun FIND-IF (predicate sequence &KEY key start end from-end)
  219.   "Return the first element of SEQUENCE that satisfies PREDICATE"
  220.   (FIND-IF* predicate sequence key start end from-end))
  221.  
  222. (Defun FIND-IF-NOT* (predicate sequence &OPTIONAL key start end from-end)
  223.   (IF (ARRAYP sequence)
  224.       (FIND-IF-NOT-VECTOR predicate sequence key start end from-end)
  225.       (FIND-IF-NOT-LIST predicate sequence key start end from-end)))
  226.  
  227. (Defun FIND-IF-NOT (predicate sequence &KEY key start end from-end)
  228.   "Return the first element of SEQUENCE that doesn't satisfy PREDICATE"
  229.   (FIND-IF-NOT* predicate sequence key start end from-end))
  230.