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