src/mstuff.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   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
  13 (macsyma-module mstuff)
  14
  15 (defmfun $sort (l &optional (f 'lessthan))
  16   (let ((llist l) comparfun bfun ($prederror t))
  17     (unless ($listp llist)
  18       (merror (intl:gettext "sort: first argument must be a list; found: ~M") llist))
  19     (setq llist (copy-list (cdr llist))
  20           comparfun
  21           (mfunction1 (setq bfun (getopr f))))
  22     (when (member bfun '(lessthan great) :test #'eq)
  23       (setq llist (mapcar #'ratdisrep llist)))
  24     (cons '(mlist) (stable-sort llist comparfun))))
  25
  26 ;; cmulisp does not like the closure version.  Clisp insists on the
  27 ;; closure version.  Gcl likes either...  For the moment we will
  28 ;; leave a conditional here.
  29 (defun mfunction1 (fun)
  30   (if (functionp fun)
  31       (lambda (x y) (mevalp (funcall fun x y)))
  32       #+(or cmu scl)
  33       (lambda (x y) (mevalp `((,fun) ((mquote) ,x) ((mquote) ,y))))
  34       #-(or cmu scl)
  35       #'(lambda (x y) (mevalp `((,fun) ((mquote) ,x) ((mquote) ,y))))))
  36
  37 (defun lessthan (a b)
  38   (great b a))
  39
  40 (defmspec $makelist (x)
  41   (setq x (cdr x))
  42   (prog (n form arg a b c d lv)
  43      (setq n (length x))
  44      (cond
  45        ((= n 0) (return '((mlist))))
  46        ((= n 1)
  47         (setq form (first x))
  48         (return
  49           `((mlist) ,(meval `(($ev) ,@(list (list '(mquote) form)))))))
  50        ((= n 2)
  51         (setq form (first x))
  52         (setq b ($float (meval (second x))))
  53         (if (numberp b)
  54             (return
  55               (do
  56                ((m 1 (1+ m)) (ans))
  57                ((> m b) (cons '(mlist) (nreverse ans)))
  58                 (push (meval `(($ev) ,@(list (list '(mquote) form))))
  59                       ans)))
  60             (merror (intl:gettext "makelist: second argument must evaluate to a number; found: ~M") b)))
  61        ((= n 3)
  62         (setq form (first x))
  63         (setq arg (second x))
  64         (setq b (meval (third x)))
  65         (if ($listp b)
  66             (setq lv (mapcar #'(lambda (u) (list '(mquote) u)) (cdr b)))
  67             (progn
  68               (setq b ($float (meval b)))
  69               (if ($numberp b)
  70                   (return
  71                     (do
  72                      ((m 1 (1+ m)) (ans))
  73                      ((> m b) (cons '(mlist) (nreverse ans)))
  74                       (push
  75                        (meval
  76                         `(($ev) ,@(list (list '(mquote) form)
  77                                         (list '(mequal) arg m)))) ans)))
  78                 (merror (intl:gettext "makelist: third argument must be a number or a list; found: ~M") b)))))
  79        ((= n 4)
  80         (setq form (first x))
  81         (setq arg (second x))
  82         (setq a (meval (third x)))
  83         (setq b (meval (fourth x)))
  84         (setq d ($float (meval `((mplus) ,b ((mtimes) ,a -1)))))
  85         (if (numberp d)
  86             (setq lv (interval2 a 1 d))
  87             (merror (intl:gettext "makelist: the fourth argument minus the third one must evaluate to a number; found: ~M") d)))
  88        ((= n 5)
  89         (setq form (first x))
  90         (setq arg (second x))
  91         (setq a (meval (third x)))
  92         (setq b (meval (fourth x)))
  93         (setq c (meval (fifth x)))
  94         (setq d ($float
  95                  (meval
  96                   `((mtimes) ((mplus) ,b ((mtimes) ,a -1)) ((mexpt) ,c -1)))))
  97         (if (numberp d)
  98             (setq lv (interval2 a c d))
  99             (merror (intl:gettext "makelist: the fourth argument minus the third one, divided by the fifth one must evaluate to a number; found: ~M") d)))
 100        (t (merror (intl:gettext "makelist: maximum 5 arguments allowed; found: ~M.~%To create a list with sublists, use nested makelist commands.") n)))
 101      (return
 102        (do ((lv lv (cdr lv))
 103             (ans))
 104            ((null lv) (cons '(mlist) (nreverse ans)))
 105          (push (meval `(($ev)
 106                         ,@(list (list '(mquote) form)
 107                                 (list '(mequal) arg (car lv)))))
 108                ans)))))
 109
 110 (defun interval2 (i s d)
 111   (do ((nn i (meval `((mplus) ,s ,nn)))
 112        (m 0 (1+ m))
 113        (ans))
 114       ((> m d) (nreverse ans))
 115     (push nn ans)))
 116
 117 (defun interval (i j)
 118   (do ((nn i (add2 1 nn))
 119        (m 0 (1+ m))
 120        (k (sub* j i))
 121        (ans))
 122       ((> m k) (nreverse ans))
 123     (push nn ans)))
 124
 125 (defmfun $sublist (a f)
 126   (unless ($listp a)
 127     (merror (intl:gettext "sublist: first argument must be a list; found: ~M") a) )
 128   (do ((a (cdr a) (cdr a))
 129        (x))
 130       ((null a) (cons '(mlist) (nreverse x)))
 131     (if (definitely-so (mfuncall f (car a)))
 132         (push (car a) x))))