src/scs.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 1980 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module scs)
  14
  15 (defmfun $scsimp (expr &rest rules)
  16   (scs expr (mapcar #'meqhk rules)))
  17
  18 (defun scs (x zrs)
  19   (do ((flag t) (sz (conssize x)) (nx) (nsz))
  20       ((not flag) x)
  21     (do ((l zrs (cdr l)))
  22         ((null l) (setq flag nil))
  23       (setq nx (subscs 0 (car l) x) nsz (conssize nx))
  24       (if (< nsz sz) (return (setq x nx sz nsz))))))
  25
  26 (defun subscs (a b c)
  27   (cond ((atom b) (subsc a b c))
  28         ((eq 'mplus (caar b))
  29          (do ((l (cdr b) (cdr l)) (sz (conssize c)) (nl) (nc) (nsz)) ((null l) c)
  30            (setq nc (subscs (sub a (addn (revappend nl (cdr l)) t)) (car l) c)
  31                  nsz (conssize nc) nl (cons (car l) nl))
  32            (if (< nsz sz) (setq c nc sz nsz))))
  33         (t (subsc a b c))))
  34
  35 (defun subsc (a b c)
  36   ($expand ($ratsubst a b c)))
  37
  38 (defun dstrb (x l nl)
  39   (revappend (mapcar #'(lambda (u) (mul x u)) l) nl))
  40
  41 (defmfun $distrib (exp)
  42   (cond ((or (mnump exp) (symbolp exp)) exp)
  43         ((eq 'mtimes (caar exp))
  44          (setq exp (mapcar '$distrib (cdr exp)))
  45          (do ((l (cdr exp) (cdr l))
  46               (nl (if (mplusp (car exp)) (cdar exp) (list (car exp)))))
  47              ((null l) (addn nl t))
  48            (if (mplusp (car l))
  49                (do ((m (cdar l) (cdr m)) (ml)) ((null m) (setq nl ml))
  50                  (setq ml (dstrb (car m) nl ml)))
  51                (setq nl (dstrb (car l) nl nil)))))
  52         ((eq 'mequal (caar exp))
  53          (list '(mequal) ($distrib (cadr exp)) ($distrib (caddr exp))))
  54         ((eq 'mrat (caar exp)) ($distrib (ratdisrep exp)))
  55         (t exp)))
  56
  57 (defmfun $facout (x y)
  58   (if (mplusp y)
  59       (mul x (addn (mapcar #'(lambda (l) (div l x)) (cdr y)) t))
  60       y))