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