home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / utils.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  6.4 KB  |  200 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module utils)
  13.  
  14. ;;; General purpose Lisp utilities.  This file contains runtime functions which
  15. ;;; are simple extensions to Lisp.  The functions here are not very general, 
  16. ;;; but generalized forms would be useful in future Lisp implementations.
  17. ;;;
  18. ;;; No knowledge of the Macsyma system is kept here.  
  19. ;;;
  20. ;;; Every function in this file is known about externally.
  21.  
  22.  
  23.  
  24. ;;; N.B. this function is different than the lisp machine
  25. ;;; and maclisp standard one. (for now).
  26.  
  27. ;;; temporary until the new lispm make-list is installed
  28.  
  29. (DEFMFUN *MAKE-LIST (SIZE &OPTIONAL (VAL NIL) )
  30.      (DO ((L NIL (CONS VAL L)))
  31.          ((< (SETQ SIZE (f1- SIZE)) 0) L)))
  32.  
  33. ;;; F is assumed to be a function of two arguments.  It is mapped down L
  34. ;;; and applied to consequtive pairs of elements of the list.
  35. ;;; Useful for iterating over property lists.
  36.  
  37. (DEFMFUN MAP2C (F L)
  38.   (DO ((LLT L (CDDR LLT)) (LANS))
  39.       ((NULL LLT) LANS)
  40.       (SETQ LANS (CONS (FUNCALL F (CAR LLT) (CADR LLT)) LANS))))
  41.  
  42. ;;; (ANDMAPC #'INTEGERP '(1 2 3)) --> T
  43. ;;; (ANDMAPC #'INTEGERP '(1 2 A)) --> NIL
  44. ;;; (ORMAPC  #'INTEGERP '(1 2 A)) --> T
  45. ;;; (ORMAPC  #'INTEGERP '(A B C)) --> NIL
  46.  
  47. ;;; If you want the do loop generated inline rather than doing a function call,
  48. ;;; use the macros SOME and EVERY.  See LMLisp manual for more information.
  49. ;;; Note that the value returned by ORMAPC is slightly different from that
  50. ;;; returned by SOME.
  51.  
  52. (DEFMFUN ANDMAPC (F L)
  53.   (DO ((L L (CDR L)))
  54.       ((NULL L) T)
  55.       (IF (NOT (FUNCALL F (CAR L))) (RETURN NIL))))
  56.  
  57. (DEFMFUN ORMAPC (F L &AUX ANSWER)
  58.   (DO ((L L (CDR L)))
  59.       ((NULL L) NIL)
  60.       (SETQ ANSWER (FUNCALL F (CAR L)))
  61.       (IF ANSWER (RETURN ANSWER))))
  62.  
  63. ;;; Like MAPCAR, except if an application of F to any of the elements of L
  64. ;;; returns NIL, then the function returns NIL immediately.
  65.  
  66. (DEFMFUN ANDMAPCAR (F L &AUX D ANSWER)
  67.   (DO ((L L (CDR L)))
  68.       ((NULL L) (NREVERSE ANSWER))
  69.       (SETQ D (FUNCALL F (CAR L)))
  70.       (IF D (PUSH D ANSWER) (RETURN NIL))))
  71.  
  72. ;;; Returns T if either A or B is NIL, but not both.
  73.  
  74. (DEFMFUN XOR (A B) (OR (AND (NOT A) B) (AND (NOT B) A)))
  75.   
  76. ;;; A MEMQ which works at all levels of a piece of list structure.
  77. ;;;
  78. ;;; Note that (AMONG NIL '(A B C)) is T, however.  This could cause bugs.
  79. ;;; > This is false. (AMONG NIL anything) returns NIL always. -kmp
  80.  
  81. (DEFMFUN AMONG (X L) 
  82.   (COND ((NULL L) NIL)
  83.     ((ATOM L) (EQ X L))
  84.     (T (OR (AMONG X (CAR L)) (AMONG X (CDR L)))))) 
  85.  
  86. ;;; Similar to AMONG, but takes a list of objects to look for.  If any
  87. ;;; are found in L, returns T.
  88.  
  89. (DEFMFUN AMONGL (X L) 
  90.   (COND ((NULL L) NIL)
  91.     ((ATOM L) (MEMQ L X))
  92.     (T (OR (AMONGL X (CAR L)) (AMONGL X (CDR L)))))) 
  93.  
  94. ;;; (RECONC '(A B C) '(D E F)) --> (C B A D E F)
  95. ;;; Like NRECONC, but not destructive.
  96. ;;;
  97. ;;; Is this really faster than macroing into (NCONC (REVERSE L1) L2)?
  98. ;;; > Yes, it is. -kmp
  99.  
  100. (DEFMFUN RECONC (L1 L2)
  101.   #+NIL (revappend l1 l2)
  102.   #-NIL (DO () ((NULL L1) L2) (SETQ L2 (CONS (CAR L1) L2) L1 (CDR L1))))
  103.  
  104.  
  105. ;;; (FIRSTN 3 '(A B C D E)) --> (A B C)
  106. ;;;
  107. ;;; *NOTE* Given a negative first arg will work fine with this definition
  108. ;;;       but on LispM where the operation is primitive and defined 
  109. ;;;       differently, bad things will happen. Make SURE it gets a 
  110. ;;;       non-negative arg! -kmp
  111.  
  112. #+(OR PDP10 Franz)
  113. (DEFMFUN FIRSTN (N L)
  114.   (SLOOP FOR I FROM 1 TO N
  115.     FOR X IN L
  116.     COLLECT X))
  117.  
  118. ;;; Reverse ASSQ -- like ASSQ but tries to find an element of the alist whose
  119. ;;; cdr (not car) is EQ to the object.  To be renamed to RASSQ in the near
  120. ;;; future.
  121.  
  122. (DEFMFUN ASSQR (OBJECT ALIST)
  123.   (DOLIST (PAIR ALIST)
  124.       (IF (EQ OBJECT (CDR PAIR)) (RETURN PAIR))))
  125.  
  126. ;;; Should be open-coded at some point.  (Moved here from RAT;FACTOR)
  127. (DEFMFUN LOG2 (N) (f1- (HAULONG N)))
  128.  
  129. ;;; Tries to emulate Lispm/NIL FSET.  Won't work for LSUBRS, FEXPRS, or
  130. ;;; FSUBRS.
  131.  
  132. #+PDP10
  133. (DEFMFUN FSET (SYMBOL DEFINITION)
  134.   (COND ((SYMBOLP DEFINITION)
  135.      (PUTPROP SYMBOL DEFINITION 'EXPR))
  136.     ((EQ (ml-typep DEFINITION) 'RANDOM)
  137.      (PUTPROP SYMBOL DEFINITION 'SUBR))
  138.     ((consp DEFINITION)
  139.      (PUTPROP SYMBOL DEFINITION 'EXPR))
  140.     (T (MAXIMA-ERROR "Invalid symbol definition - FSET"
  141.           DEFINITION 'WRNG-TYPE-ARG))))
  142.  
  143. ;;; Takes a list in "alist" form and converts it to one in
  144. ;;; "property list" form, i.e. ((A . B) (C . D)) --> (A B C D).
  145. ;;; All elements of the list better be conses.
  146.  
  147. (DEFMFUN DOT2L (L)
  148.   (COND ((NULL L) NIL)
  149.     (T (LIST* (CAAR L) (CDAR L) (DOT2L (CDR L))))))
  150.  
  151.  
  152. ;;; (A-ATOM sym selector value   )
  153. ;;; (C-PUT  sym value    selector)
  154. ;;;
  155. ;;;  They make a symbol's property list look like a structure.
  156. ;;;
  157. ;;;  If the value to be stored is NIL,
  158. ;;;     then flush the property.
  159. ;;;     else store the value under the appropriate property.
  160. ;;;
  161. ;;; >>> Note: Since they do essentially the same thing, one (A-ATOM)
  162. ;;; >>>       should eventually be flushed...
  163.  
  164. (DEFMFUN A-ATOM (BAS SEL VAL) (CPUT BAS VAL SEL))
  165.  
  166. (DEFMFUN CPUT (BAS VAL SEL)
  167.   (COND ((NULL VAL) (zl-REMPROP BAS SEL) NIL)
  168.     (T (PUTPROP BAS VAL SEL))))
  169.  
  170. ;;; This is like the function SYMBOLCONC except that it binds base and *nopoint
  171.  
  172. #-Franz (progn 'compile
  173. #-NIL
  174. (DEFMFUN CONCAT N
  175.  (LET ((*print-base* 10.) #-cl (*NOPOINT T)) (IMPLODE (MAPCAN 'EXPLODEN (LISTIFY N)))))
  176. #+NIL
  177. ;In NIL, symbolconc does indeed effectively bind the base and *nopoint.
  178. ; This definition may not work if more generality is needed (flonums?
  179. ; random Lisp object?)
  180. (deff concat
  181.   #'symbolconc)
  182. ) ;#-franz
  183.  
  184. #-cl
  185. (progn 'compile
  186. (DECLARE (SPECIAL ALPHABET)) ; This should be DEFVAR'd somewhere.  Sigh. -kmp
  187.                         ;It is DEFVAR'd in Nparse-wfs
  188. (DEFMFUN ALPHABETP (N)
  189.  (DECLARE (FIXNUM N))
  190.  (OR (AND (>= N #\A) (<= N #\Z))  ; upper case
  191.      (AND (>= N #\a) (<= N #\z))  ; lower case
  192.      (zl-MEMBER N ALPHABET)))      ; test for %, _, or other declared
  193.                   ;    alphabetic characters.
  194.  
  195. (DEFMFUN ASCII-NUMBERP (NUM)
  196.   (DECLARE (FIXNUM NUM))
  197.   (AND (<= NUM #\9) (>= NUM #\0)))
  198. )
  199.  
  200.