src/trpred.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 trpred)
  14
  15 ; $is, $maybe or mcond
  16 (defvar wrap-a-pred '$is)
  17
  18 (defun wrap-pred (form &optional (evalp t))
  19   (let ((boole-fun (get wrap-a-pred
  20                         (if evalp
  21                             'tr-boole-eval
  22                             'tr-boole-verify))))
  23     (cons '$any `(,boole-fun ,form))))
  24
  25 (defun tr-is/maybe (wrap-type form)
  26   (let* ((wrap-a-pred wrap-type)
  27          (tr (translate-predicate form)))
  28     (destructuring-bind (mode . tr-form) tr
  29       (if (eq mode '$boolean)
  30           tr
  31           (cons '$any tr-form)))))
  32
  33 (def%tr $is (form)
  34   (tr-is/maybe '$is (cadr form)))
  35
  36 (def%tr $maybe (form)
  37   (tr-is/maybe '$maybe (cadr form)))
  38
  39 ;;; these don't have an imperative predicate semantics outside of
  40 ;;; being used in MNOT, MAND, MOR, MCOND, $IS.
  41
  42 (def%tr mnotequal (form)
  43   `($any . (simplify (list '(,(caar form)) ,@(tr-args (cdr form))))))
  44
  45 (def-same%tr mequal    mnotequal)
  46 (def-same%tr $equal    mnotequal)
  47 (def-same%tr $notequal mnotequal)
  48 (def-same%tr mgreaterp mnotequal)
  49 (def-same%tr mgeqp     mnotequal)
  50 (def-same%tr mlessp    mnotequal)
  51 (def-same%tr mleqp     mnotequal)
  52
  53 ;;; It looks like it was copied from MRG;COMPAR > with
  54 ;;; TRP- substituted for MEVALP. What a crockish way to dispatch,
  55 ;;; and in a system with a limited address space too!
  56 ;;; NOTE: See code for IS-BOOLE-CHECK, also duplication of MRG;COMPAR.
  57
  58 ;;; Note: This TRANSLATE-PREDICATE and TRANSLATE should be combined
  59 ;;; to a single function which takes a second argument of the
  60 ;;; TARGET (mode). Targeting is a pretty basic concept in compilation
  61 ;;; so its surprising this was done. In order to make this change all
  62 ;;; special-forms need to do targeting.
  63
  64 (defun translate-predicate (form)
  65   (cond ((atom form) (trp-with-boolean-convert form))
  66         ((eq 'mnot (caar form)) (trp-mnot form))
  67         ((eq 'mand (caar form)) (trp-mand form))
  68         ((eq 'mor (caar form)) (trp-mor form))
  69         ((eq 'mnotequal (caar form)) (trp-mnotequal form))
  70         ((eq 'mequal (caar form)) (trp-mequal form))
  71         ((eq '$equal (caar form)) (trp-$equal form))
  72         ((eq '$notequal (caar form)) (trp-$notequal form))
  73         ((eq 'mgreaterp (caar form)) (trp-mgreaterp form))
  74         ((eq 'mgeqp (caar form)) (trp-mgeqp form))
  75         ((eq 'mlessp (caar form)) (trp-mlessp form))
  76         ((eq 'mleqp (caar form)) (trp-mleqp form))
  77         ((eq 'mprogn (caar form))
  78          ;; it was a pain not to have this case working, so I just
  79          ;; patched it in. Lets try not to lazily patch in every
  80          ;; special form in macsyma!
  81          (let ((exprs (cdr form)))
  82            (destructuring-bind (mode . last)
  83                (translate-predicate (car (last exprs)))
  84              (cons mode
  85                    `(progn
  86                       ,@(tr-args (butlast exprs))
  87                       ,last)))))
  88         (t (trp-with-boolean-convert form))))
  89
  90 (defun trp-with-boolean-convert (form)
  91   (let ((tr (translate form)))
  92     (destructuring-bind (mode . exp) tr
  93       (if (eq mode '$boolean)
  94           tr
  95           (wrap-pred exp)))))
  96
  97 (defmacro mnot_tr (operand)
  98   `(is-mnot #'identity ,operand))
  99
 100 (defun trp-mnot (form)
 101   (let ((exp (cadr form)))
 102     (cond ((not exp)
 103            (cons '$boolean t))
 104           ((eq t exp)
 105            (cons '$boolean nil))
 106           ((and (not (atom exp)) (eq (caar exp) 'mnot))
 107            (translate-predicate (cadr exp)))
 108           (t
 109            (destructuring-bind (mode . operand) (translate-predicate exp)
 110              (if (eq mode '$boolean)
 111                  (cons mode (list 'not operand))
 112                  (wrap-pred (list 'mnot_tr operand) nil)))))))
 113
 114 (defun mand/mor_tr (mop operands top bot)
 115   (let ((val (tr-gensym))
 116         (ext (tr-gensym)))
 117     `(let ((,val nil)
 118            (,ext '()))
 119        ,(reduce (lambda (x acc)
 120                   `(cond ((eq (setq ,val ,x) ,bot)
 121                           ,bot)
 122                          (t
 123                           (unless (eq ,val ,top)
 124                             (push ,val ,ext))
 125                           ,acc)))
 126                 operands
 127                 :from-end t
 128                 :initial-value
 129                   `(cond ((null ,ext)
 130                           ,top)
 131                          ((null (cdr ,ext))
 132                           (car ,ext))
 133                          (t
 134                           (cons '(,mop) (nreverse ,ext))))))))
 135
 136 (defmacro mand_tr (&rest operands)
 137   (mand/mor_tr 'mand operands t nil))
 138
 139 (defmacro mor_tr (&rest operands)
 140   (mand/mor_tr 'mor operands nil t))
 141
 142 (defun simplify-mand/mor-operands_tr (operands top bot)
 143   (loop for o in operands unless (eq o top) collect o until (eq o bot)))
 144
 145 (defun map-trp (l)
 146   (reduce (lambda (x a)
 147             (destructuring-bind (mode . body) (translate-predicate x)
 148               (cons (*union-mode (car a) mode) (cons body (cdr a)))))
 149           l
 150           :from-end t
 151           :initial-value (cons nil '())))
 152
 153 (defun trp-mand/mor (operands lisp-op max-op top bot)
 154   (let ((operands (simplify-mand/mor-operands_tr operands top bot)))
 155     (cond ((null operands)
 156            (cons '$boolean top))
 157           ((null (cdr operands))
 158            (trp-with-boolean-convert (car operands)))
 159           (t
 160            (destructuring-bind (mode . tr-operands) (map-trp operands)
 161              (if (eq mode '$boolean)
 162                  (cons mode (cons lisp-op tr-operands))
 163                  (wrap-pred (cons max-op tr-operands) nil)))))))
 164
 165 (defun trp-mand (form)
 166   (trp-mand/mor (cdr form) 'and 'mand_tr t nil))
 167
 168 (defun trp-mor (form)
 169   (trp-mand/mor (cdr form) 'or 'mor_tr nil t))
 170
 171 (defvar *number-types* '($float $number $fixnum ))
 172
 173 (defun trp-inequality (args lisp-op max-op)
 174   (let* ((arg1 (translate (car args)))
 175          (arg2 (translate (cadr args)))
 176          (mode (*union-mode (car arg1) (car arg2))))
 177     (cond ((or (member mode '($fixnum $float) :test #'eq)
 178                (and (member (car arg1) *number-types* :test #'eq)
 179                     (member (car arg2) *number-types* :test #'eq)))
 180            `($boolean . (,lisp-op ,(dconv arg1 mode) ,(dconv arg2 mode))))
 181           ((eq '$number mode)
 182            `($boolean . (,lisp-op ,(cdr arg1) ,(cdr arg2))))
 183           (t
 184            (wrap-pred `(,max-op ,(dconvx arg1) ,(dconvx arg2)) nil)))))
 185
 186 (defun trp-mlessp (form)
 187   (trp-inequality (cdr form) '< 'mlsp))
 188
 189 (defun trp-mgreaterp (form)
 190   (trp-inequality (cdr form) '> 'mgrp))
 191
 192 (defun trp-mgeqp (form)
 193   (trp-inequality (cdr form) '>= 'mgqp))
 194
 195 (defun trp-mleqp (form)
 196   ; No mlqp in sight
 197   (translate-predicate `((mgeqp) ,@(reverse (cdr form)))))
 198
 199 (defun trp-mequal (form)
 200   (destructuring-let (((mode1 . arg1) (translate (cadr form)))
 201                       ((mode2 . arg2) (translate (caddr form))))
 202     (cons '$boolean
 203           (if (and (covers '$number mode1) (covers '$number mode2))
 204               `(eql ,arg1 ,arg2)
 205               `(like ,arg1 ,arg2)))))
 206
 207 (defun trp-mnotequal (form)
 208   (translate-predicate `((mnot) ((mequal) ,@(cdr form)))))
 209
 210 (defun trp-$equality (args lisp-op max-op)
 211   (let* ((arg1 (translate (car args)))
 212          (arg2 (translate (cadr args)))
 213          (mode (*union-mode (car arg1) (car arg2))))
 214     (cond ((member mode '($fixnum $float) :test #'eq)
 215            `($boolean . (,lisp-op ,(dconv arg1 mode) ,(dconv arg2 mode))))
 216           ((eq '$number mode)
 217            `($any . (,max-op ,(cdr arg1) ,(cdr arg2))))
 218           (t
 219            (wrap-pred `(,max-op ,(dconvx arg1) ,(dconvx arg2)) nil)))))
 220
 221 (defun trp-$equal (form)
 222   (trp-$equality (cdr form) '= 'meqp))
 223
 224 (defun trp-$notequal (form)
 225   (trp-$equality (cdr form) '/= 'mnqp))
 226
 227 ;;; sigh, i have to copy a lot of the $assume function too.
 228
 229 (def%tr $assume (form)
 230   (let ((x (cdr form)))
 231     (do ((nl))
 232         ((null x)
 233          `($any . (simplify (list '(mlist) ,@(nreverse nl)))))
 234       (cond ((atom (car x))
 235              (setq nl (cons `(assume ,(dtranslate (car x))) nl)))
 236             ((eq 'mand (caaar x))
 237              (mapc #'(lambda (l) (setq nl (cons `(assume ,(dtranslate l)) nl)))
 238                    (cdar x)))
 239             ((eq 'mnot (caaar x))
 240              (setq nl (cons `(assume ,(dtranslate (pred-reverse (cadar x)))) nl)))
 241             ((eq 'mor (caaar x))
 242              (merror (intl:gettext "assume: argument cannot be an 'or' expression; found ~M") (car x)))
 243             ((eq (caaar x) 'mequal)
 244              (merror (intl:gettext "assume: argument cannot be an '=' expression; found ~M~%assume: maybe you want 'equal'.") (car x)))
 245             ((eq (caaar x) 'mnotequal)
 246              (merror (intl:gettext "assume: argument cannot be a '#' expression; found ~M~%assume: maybe you want 'not equal'.") (car x)))
 247             ('else
 248              (setq nl (cons `(assume ,(dtranslate (car x))) nl))))
 249       (setq x (cdr x)))))