home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume1 / 8707 / 49 / frpoly.cl < prev    next >
Encoding:
Text File  |  1990-07-13  |  5.4 KB  |  215 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         frpoly.cl
  3. ; Description:  FRPOLY benchmark
  4. ; Author:       Richard Gabriel and Richard Fateman
  5. ; Created:      11-Apr-85
  6. ; Modified:     9-Jul-85 16:23:18 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic.
  13. ;;; Originally writen in Franz Lisp by Richard Fateman.
  14. ;;; PDIFFER1 appears in the code, but is not defined; is not called for in the
  15. ;;; test, however.
  16.  
  17. (defvar f)
  18. (defvar *i*)
  19. (defvar v)
  20. (defvar *x*)
  21. (defvar *alpha*)
  22. (defvar *a*)
  23. (defvar *b*)
  24. (defvar u*)
  25. (defvar *y*)
  26. (defvar r)
  27. (defvar r2)
  28. (defvar r3)
  29.  
  30. (defmacro pointergp (x y) `(> (get ,x 'order) (get ,y 'order)))
  31.  
  32. (defmacro pcoefp (e) `(atom ,e))
  33.  
  34. (defmacro pzerop (x) `(if (numberp ,x) (zerop ,x)))              
  35.  
  36. (defmacro pzero () 0)
  37.  
  38. (defmacro cplus (x y) `(+ ,x ,y))
  39.  
  40. (defmacro ctimes (x y) `(* ,x ,y))
  41.  
  42. (defun pcoefadd (e c x) 
  43.   (if (pzerop c)
  44.       x
  45.       (cons e (cons c x))))
  46.  
  47. (defun pcplus (c p)
  48.   (if (pcoefp p)
  49.       (cplus p c)
  50.       (psimp (car p) (pcplus1 c (cdr p)))))
  51.  
  52. (defun pcplus1 (c x)
  53.   (cond ((null x)
  54.      (if (pzerop c)
  55.          nil
  56.          (cons 0 (cons c nil))))
  57.     ((pzerop (car x))
  58.      (pcoefadd 0 (pplus c (cadr x)) nil))
  59.     (t
  60.      (cons (car x) (cons (cadr x) (pcplus1 c (cddr x)))))))
  61.  
  62. (defun pctimes (c p) 
  63.   (if (pcoefp p)
  64.       (ctimes c p)
  65.       (psimp (car p) (pctimes1 c (cdr p)))))
  66.  
  67. (defun pctimes1 (c x)
  68.   (if (null x)
  69.       nil
  70.       (pcoefadd (car x)
  71.         (ptimes c (cadr x))
  72.         (pctimes1 c (cddr x)))))
  73.  
  74. (defun pplus (x y) 
  75.   (cond ((pcoefp x)
  76.      (pcplus x y))
  77.     ((pcoefp y)
  78.      (pcplus y x))
  79.     ((eq (car x) (car y))
  80.      (psimp (car x) (pplus1 (cdr y) (cdr x))))
  81.     ((pointergp (car x) (car y))
  82.      (psimp (car x) (pcplus1 y (cdr x))))
  83.     (t
  84.      (psimp (car y) (pcplus1 x (cdr y))))))
  85.  
  86. (defun pplus1 (x y)
  87.   (cond ((null x) y)
  88.     ((null y) x)
  89.     ((= (car x) (car y))
  90.      (pcoefadd (car x)
  91.            (pplus (cadr x) (cadr y))
  92.            (pplus1 (cddr x) (cddr y))))
  93.     ((> (car x) (car y))
  94.      (cons (car x) (cons (cadr x) (pplus1 (cddr x) y))))
  95.     (t (cons (car y) (cons (cadr y) (pplus1 x (cddr y)))))))
  96.  
  97. (defun psimp (var x)
  98.   (cond ((null x) 0)
  99.     ((atom x) x)
  100.     ((zerop (car x))
  101.      (cadr x))
  102.     (t
  103.      (cons var x))))
  104.  
  105. (defun ptimes (x y) 
  106.   (cond ((or (pzerop x) (pzerop y))
  107.      (pzero))
  108.     ((pcoefp x)
  109.      (pctimes x y))
  110.     ((pcoefp y)
  111.      (pctimes y x))
  112.     ((eq (car x) (car y))
  113.      (psimp (car x) (ptimes1 (cdr x) (cdr y))))
  114.     ((pointergp (car x) (car y))
  115.      (psimp (car x) (pctimes1 y (cdr x))))
  116.     (t
  117.      (psimp (car y) (pctimes1 x (cdr y))))))
  118.  
  119. (defun ptimes1 (*x* y) 
  120.   (prog (u* v)
  121.     (setq v (setq u* (ptimes2 y)))
  122.      a  
  123.     (setq *x* (cddr *x*))
  124.     (if (null *x*)
  125.         (return u*))
  126.     (ptimes3 y)
  127.     (go a)))
  128.  
  129. (defun ptimes2 (y)
  130.   (if (null y)
  131.       nil
  132.       (pcoefadd (+ (car *x*) (car y))
  133.         (ptimes (cadr *x*) (cadr y))
  134.         (ptimes2 (cddr y)))))
  135.  
  136. (defun ptimes3 (y) 
  137.   (prog (e u c) 
  138.      a1    (if (null y) 
  139.         (return nil))
  140.     (setq e (+ (car *x*) (car y))
  141.           c (ptimes (cadr y) (cadr *x*) ))
  142.     (cond ((pzerop c)
  143.            (setq y (cddr y)) 
  144.            (go a1))
  145.           ((or (null v) (> e (car v)))
  146.            (setq u* (setq v (pplus1 u* (list e c))))
  147.            (setq y (cddr y))
  148.            (go a1))
  149.           ((= e (car v))
  150.            (setq c (pplus c (cadr v)))
  151.            (if (pzerop c)             ; never true, evidently
  152.            (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v)))))
  153.            (rplaca (cdr v) c))
  154.            (setq y (cddr y))
  155.            (go a1)))
  156.      a  (cond ((and (cddr v) (> (caddr v) e))
  157.            (setq v (cddr v))
  158.            (go a)))
  159.     (setq u (cdr v))
  160.      b  (if (or (null (cdr u)) (< (cadr u) e))
  161.         (rplacd u (cons e (cons c (cdr u)))) (go e))
  162.     (cond ((pzerop (setq c (pplus (caddr u) c)))
  163.            (rplacd u (cdddr u))
  164.            (go d))
  165.           (t
  166.            (rplaca (cddr u) c)))
  167.      e  (setq u (cddr u))
  168.      d  (setq y (cddr y))
  169.     (if (null y)
  170.         (return nil))
  171.     (setq e (+ (car *x*) (car y))
  172.           c (ptimes (cadr y) (cadr *x*)))
  173.      c  (cond ((and (cdr u) (> (cadr u) e))
  174.            (setq u (cddr u))
  175.            (go c)))
  176.     (go b))) 
  177.  
  178. (defun pexptsq (p n)
  179.   (do ((n (floor n 2) (floor n 2))
  180.        (s (if (oddp n) p 1)))
  181.       ((zerop n) s)
  182.     (setq p (ptimes p p))
  183.     (and (oddp n) (setq s (ptimes s p)))))
  184.  
  185. (eval-when (load eval)
  186.  
  187. (setf (get 'x 'order) 1)
  188. (setf (get 'y 'order) 2)
  189. (setf (get 'z 'order) 3)
  190. (setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))    ; r= x+y+z+1
  191.       r2 (ptimes r 100000)                ; r2 = 100000*r
  192.       r3 (ptimes r 1.0)))                ; r3 = r in flonums
  193.  
  194. ;;; four sets of three tests, call:
  195. ;;; (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) 
  196. ;;; (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5)
  197. ;;; (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10)
  198. ;;; (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15)
  199.  
  200. (run-benchmark "Frpoly Power=2 r=x+y+z+1" '(pexptsq r  2))
  201. (run-benchmark "Frpoly Power=2 r2=1000r" '(pexptsq r2 2))
  202. (run-benchmark "Frpoly Power=2 r3=r in flonums" '(pexptsq r3 2))
  203.  
  204. (run-benchmark "Frpoly Power=5 r=x+y+z+1" '(pexptsq r  5))
  205. (run-benchmark "Frpoly Power=5 r2=1000r" '(pexptsq r2 5))
  206. (run-benchmark "Frpoly Power=5 r3=r in flonums" '(pexptsq r3 5))
  207.  
  208. (run-benchmark "Frpoly Power=10 r=x+y+z+1" '(pexptsq r  10))
  209. (run-benchmark "Frpoly Power=10 r2=1000r" '(pexptsq r2 10))
  210. (run-benchmark "Frpoly Power=10 r3=r in flonums" '(pexptsq r3 10))
  211.  
  212. (run-benchmark "Frpoly Power=15 r=x+y+z+1" '(pexptsq r  15))
  213. (run-benchmark "Frpoly Power=15 r2=1000r" '(pexptsq r2 15))
  214. (run-benchmark "Frpoly Power=15 r3=r in flonums" '(pexptsq r3 15))
  215.