src/trpred.lisp

   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
  13 (macsyma-module trpred)
  14
  15 (defvar wrap-an-is 'is-boole-check "How to verify booleans")
  16
  17 (def%tr $is (form)
  18   (let ((wrap-an-is 'is-boole-check))
  19     (cons '$boolean (translate-predicate (cadr form)))))
  20
  21 (def%tr $maybe (form)
  22   (let ((wrap-an-is 'maybe-boole-check))
  23     (cons '$any (translate-predicate (cadr form)))))
  24
  25 ;;; these don't have an imperitive predicate semantics outside of
  26 ;;; being used in MNOT, MAND, MOR, MCOND, $IS.
  27
  28 (def%tr mnotequal (form)
  29   `($any . (simplify (list '(,(caar form)) ,@(tr-args (cdr form))))))
  30
  31 (def-same%tr mequal    mnotequal)
  32 (def-same%tr $equal    mnotequal)
  33 (def-same%tr $notequal mnotequal)
  34 (def-same%tr mgreaterp mnotequal)
  35 (def-same%tr mgeqp     mnotequal)
  36 (def-same%tr mlessp    mnotequal)
  37 (def-same%tr mleqp     mnotequal)
  38
  39 ;;; It looks like it was copied from MRG;COMPAR > with
  40 ;;; TRP- substituted for MEVALP. What a crockish way to dispatch,
  41 ;;; and in a system with a limited address space too!
  42 ;;; NOTE: See code for IS-BOOLE-CHECK, also duplication of MRG;COMPAR.
  43
  44 ;;; Note: This TRANSLATE-PREDICATE and TRANSLATE should be combinded
  45 ;;; to a single function which takes a second argument of the
  46 ;;; TARGET (mode). Targeting is a pretty basic concept in compilation
  47 ;;; so its surprising this was done. In order to make this change all
  48 ;;; special-forms need to do targeting.
  49
  50 (defun translate-predicate (form)
  51   ;; N.B. This returns s-exp, not (<mode> . <s-exp>)
  52   (cond ((atom form)
  53          (let ((tform (translate form)))
  54            (cond ((eq '$boolean (car tform)) (cdr tform))
  55                  (t
  56                   (wrap-an-is (cdr tform) form)))))
  57         ((eq 'mnot (caar form)) (trp-mnot form))
  58         ((eq 'mand (caar form)) (trp-mand form))
  59         ((eq 'mor (caar form)) (trp-mor form))
  60         ((eq 'mnotequal (caar form)) (trp-mnotequal form))
  61         ((eq 'mequal (caar form)) (trp-mequal form))
  62         ((eq '$equal (caar form)) (trp-$equal form))
  63         ((eq '$notequal (caar form)) (trp-$notequal form))
  64         ((eq 'mgreaterp (caar form)) (trp-mgreaterp form))
  65         ((eq 'mgeqp (caar form)) (trp-mgeqp form))
  66         ((eq 'mlessp (caar form)) (trp-mlessp form))
  67         ((eq 'mleqp (caar form)) (trp-mleqp form))
  68         ((eq 'mprogn (caar form))
  69          ;; it was a pain not to have this case working, so I just
  70          ;; patched it in. Lets try not to lazily patch in every
  71          ;; special form in macsyma!
  72          `(progn ,@(tr-args (nreverse (cdr (reverse (cdr form)))))
  73            ,(translate-predicate (car (last (cdr form))))))
  74         (t
  75          (destructuring-let (((mode . tform) (translate form)))
  76            (boolean-convert mode tform form)))))
  77
  78 (defun boolean-convert (mode exp form)
  79   (if (eq mode '$boolean)
  80       exp
  81       (wrap-an-is exp form)))
  82
  83 (defun trp-mnot (form)
  84   (setq form (translate-predicate (cadr form)))
  85   (cond ((not form) t)
  86         ((eq t form) nil)
  87         ((and (not (atom form)) (eq (car form) 'not)) (cadr form))
  88         (t (list 'not form))))
  89
  90 (defun trp-mand (form)
  91   (setq form (mapcar #'translate-predicate (cdr form)))
  92   (do ((l form (cdr l)) (nl))
  93       ((null l) (cons 'and (nreverse nl)))
  94     (cond ((car l) (setq nl (cons (car l) nl)))
  95           (t (return (cons 'and (nreverse (cons nil nl))))))))
  96
  97 (defun trp-mor (form)
  98   (setq form (mapcar #'translate-predicate (cdr form)))
  99   (do ((l form (cdr l)) (nl))
 100       ((null l) (cond (nl (cond ((null (cdr nl))(car nl))
 101                                 (t (cons 'or (nreverse nl)))))))
 102     (cond ((car l) (setq nl (cons (car l) nl))))))
 103
 104 (defun wrap-an-is (exp ignore-form)
 105   (declare (ignore ignore-form))
 106   (list wrap-an-is exp))
 107
 108 (defvar *number-types* '($float $number $fixnum ))
 109
 110 (defun trp-mgreaterp (form)
 111   (let (mode arg1 arg2)
 112     (setq arg1 (translate (cadr form)) arg2 (translate (caddr form))
 113           mode (*union-mode (car arg1) (car arg2)))
 114     (cond ((or (eq '$fixnum mode) (eq '$float mode)
 115                (and (member (car arg1) *number-types* :test #'eq)
 116                     (member (car arg2) *number-types* :test #'eq)))
 117            `(> ,(dconv arg1 mode) ,(dconv arg2 mode)))
 118           ((eq '$number mode) `(> ,(cdr arg1) ,(cdr arg2)))
 119           ('else
 120            (wrap-an-is `(mgrp ,(dconvx arg1) ,(dconvx arg2))
 121                        form)))))
 122
 123 (defun trp-mlessp (form)
 124   (let (mode arg1 arg2)
 125     (setq arg1 (translate (cadr form)) arg2 (translate (caddr form))
 126           mode (*union-mode (car arg1) (car arg2)))
 127     (cond ((or (eq '$fixnum mode) (eq '$float mode)
 128                (and (member (car arg1) *number-types* :test #'eq)
 129                     (member (car arg2) *number-types* :test #'eq)))
 130            `(< ,(dconv arg1 mode) ,(dconv arg2 mode)))
 131           ((eq '$number mode) `(< ,(cdr arg1) ,(cdr arg2)))
 132           ('else
 133            (wrap-an-is `(mlsp ,(dconvx arg1) ,(dconvx arg2))
 134                        form)))))
 135
 136 (defun trp-mequal (form)
 137   (destructuring-let (((mode1 . arg1) (translate (cadr form)))
 138                       ((mode2 . arg2) (translate (caddr form))))
 139     (if (and (covers '$number mode1) (covers '$number mode2))
 140         `(eql ,arg1 ,arg2)
 141         `(like ,arg1 ,arg2))))
 142
 143 (defun trp-$equal (form)
 144   (let (mode arg1 arg2)
 145     (setq arg1 (translate (cadr form)) arg2 (translate (caddr form))
 146           mode (*union-mode (car arg1) (car arg2)))
 147     (cond ((or (eq '$fixnum mode) (eq '$float mode))
 148            `(= ,(dconv arg1 mode) ,(dconv arg2 mode)))
 149           ((eq '$number mode) `(meqp ,(cdr arg1) ,(cdr arg2)))
 150           ('else
 151            (wrap-an-is `(meqp ,(dconvx arg1) ,(dconvx arg2)) form)))))
 152
 153 ;; Logical not for predicates.  Do the expected thing, except return
 154 (defun trp-not (val)
 155   (case val
 156     ((t) nil)
 157     ((nil) t)
 158     (otherwise val)))
 159
 160 (defun trp-$notequal (form)
 161   (list 'trp-not (trp-$equal form)))
 162
 163 (defun trp-mnotequal (form)
 164   (list 'trp-not (trp-mequal form)))
 165
 166 (defun trp-mgeqp (form)
 167   (list 'trp-not (trp-mlessp form)))
 168
 169 (defun trp-mleqp (form)
 170   (list 'trp-not (trp-mgreaterp form)))
 171
 172 ;;; sigh, i have to copy a lot of the $assume function too.
 173
 174 (def%tr $assume (form)
 175   (let ((x (cdr form)))
 176     (do ((nl))
 177         ((null x)
 178          `($any . (simplify (list '(mlist) ,@(nreverse nl)))))
 179       (cond ((atom (car x))
 180              (setq nl (cons `(assume ,(dtranslate (car x))) nl)))
 181             ((eq 'mand (caaar x))
 182              (mapc #'(lambda (l) (setq nl (cons `(assume ,(dtranslate l)) nl)))
 183                    (cdar x)))
 184             ((eq 'mnot (caaar x))
 185              (setq nl (cons `(assume ,(dtranslate (pred-reverse (cadar x)))) nl)))
 186             ((eq 'mor (caaar x))
 187              (merror (intl:gettext "assume: argument cannot be an 'or' expression; found ~M") (car x)))
 188             ((eq (caaar x) 'mequal)
 189              (merror (intl:gettext "assume: argument cannot be an '=' expression; found ~M~%assume: maybe you want 'equal'.") (car x)))
 190             ((eq (caaar x) 'mnotequal)
 191              (merror (intl:gettext "assume: argument cannot be a '#' expression; found ~M~%assume: maybe you want 'not equal'.") (car x)))
 192             ('else
 193              (setq nl (cons `(assume ,(dtranslate (car x))) nl))))
 194       (setq x (cdr x)))))