home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trpred.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  6.9 KB  |  195 lines
  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. (macsyma-module trpred)
  13. (transl-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. (DEF%TR MNOT (FORM) (CONS '$BOOLEAN (TRANSLATE-PREDICATE FORM)))
  26. (DEF-SAME%TR MAND MNOT)
  27. (DEF-SAME%TR MOR MNOT)
  28.  
  29. ;;; these don't have an imperitive predicate semantics outside of
  30. ;;; being used in MNOT, MAND, MOR, MCOND, $IS.
  31.  
  32. (DEF%TR MNOTEQUAL (FORM)
  33.        `($ANY . (SIMPLIFY (LIST '(,(CAAR FORM)) ,@(TR-ARGS (CDR FORM))))))
  34.  
  35. (DEF-SAME%TR MEQUAL    MNOTEQUAL)
  36. (DEF-SAME%TR $EQUAL    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.  
  43. ;;; It looks like it was copied from MRG;COMPAR > with 
  44. ;;; TRP- substituted for MEVALP. What a crockish way to dispatch,
  45. ;;; and in a system with a limited address space too!
  46. ;;; NOTE: See code for IS-BOOLE-CHECK, also duplication of MRG;COMPAR.
  47.  
  48. ;;; Note: This TRANSLATE-PREDICATE and TRANSLATE should be combinded
  49. ;;; to a single function which takes a second argument of the
  50. ;;; TARGET (mode). Targeting is a pretty basic concept in compilation
  51. ;;; so its suprising this was done. In order to make this change all
  52. ;;; special-forms need to do targetting.
  53.  
  54. (DEFTRFUN TRANSLATE-PREDICATE (FORM)
  55.   ;; N.B. This returns s-exp, not (<mode> . <s-exp>)
  56.   (COND ((ATOM FORM)
  57.      (let ((tform (TRANSLATE FORM)))
  58.        (COND ((EQ '$BOOLEAN (CAR tFORM)) (CDR tFORM))
  59.          (T
  60.           (WRAP-AN-IS (CDR TFORM) FORM)))))
  61.     ((EQ 'MNOT (CAAR FORM)) (TRP-MNOT FORM))
  62.     ((EQ 'MAND (CAAR FORM)) (TRP-MAND FORM))
  63.     ((EQ 'MOR (CAAR FORM)) (TRP-MOR FORM))
  64.     ((EQ 'MNOTEQUAL (CAAR FORM)) (TRP-MNOTEQUAL FORM))
  65.     ((EQ 'MEQUAL (CAAR FORM)) (TRP-MEQUAL FORM))
  66.     ((EQ '$EQUAL (CAAR FORM)) (TRP-$EQUAL FORM))
  67.     ((EQ 'MGREATERP (CAAR FORM)) (TRP-MGREATERP FORM))
  68.     ((EQ 'MGEQP (CAAR FORM)) (TRP-MGEQP FORM))
  69.     ((EQ 'MLESSP (CAAR FORM)) (TRP-MLESSP FORM))
  70.     ((EQ 'MLEQP (CAAR FORM)) (TRP-MLEQP FORM))
  71.     ((EQ 'MPROGN (CAAR FORM))
  72.      ;; it was a pain not to have this case working, so I just
  73.      ;; patched it in. Lets try not to lazily patch in every
  74.      ;; special form in macsyma!
  75.      `(PROGN ,@(TR-ARGS (NREVERSE (CDR (REVERSE (CDR FORM)))))
  76.          ,(TRANSLATE-PREDICATE (CAR (LAST (CDR FORM))))))
  77.     (T
  78.      (LET (((MODE . TFORM) (TRANSLATE FORM)))
  79.        (BOOLEAN-CONVERT MODE TFORM FORM)))))
  80.  
  81.  
  82. (DEFUN BOOLEAN-CONVERT (MODE EXP FORM)
  83.   (IF (EQ MODE '$BOOLEAN)
  84.       EXP
  85.       (WRAP-AN-IS EXP FORM)))
  86.  
  87. (DEFUN TRP-MNOT (FORM) 
  88.        (SETQ FORM (TRANSLATE-PREDICATE (CADR FORM)))
  89.        (COND ((NOT FORM) T)
  90.          ((EQ T FORM) NIL)
  91.          ((AND (NOT (ATOM FORM)) (EQ (CAR FORM) 'NOT)) (CADR FORM))
  92.          (T (LIST 'NOT FORM))))
  93.  
  94. (DEFUN TRP-MAND (FORM) 
  95.        (SETQ FORM (MAPCAR 'TRANSLATE-PREDICATE (CDR FORM)))
  96.        (DO ((L FORM (CDR L)) (NL))
  97.        ((NULL L) (CONS 'AND (NREVERSE NL)))
  98.        (COND ((CAR L) (SETQ NL (CONS (CAR L) NL)))
  99.          (T (RETURN (CONS 'AND (NREVERSE (CONS NIL NL))))))))
  100.  
  101. (DEFUN TRP-MOR (FORM) 
  102.        (SETQ FORM (MAPCAR 'TRANSLATE-PREDICATE (CDR FORM)))
  103.        (DO ((L FORM (CDR L)) (NL))
  104.        ((NULL L) (COND (NL (COND ((NULL (CDR NL))(CAR NL))
  105.                      (T (CONS 'OR (NREVERSE NL)))))))
  106.        (COND ((CAR L) (SETQ NL (CONS (CAR L) NL))))))
  107.  
  108.  
  109. (DEFUN WRAP-AN-IS (EXP IGNORE-FORM) IGNORE-FORM
  110.   (LIST WRAP-AN-IS EXP))
  111.  
  112. (defvar *number-types* '($float $number $fixnum ))
  113.  
  114. (DEFUN TRP-MGREATERP (FORM) 
  115.   (LET (MODE ARG1 ARG2)
  116.     (SETQ ARG1 (TRANSLATE (CADR FORM)) ARG2 (TRANSLATE (CADDR FORM))
  117.       MODE (*UNION-MODE (CAR ARG1) (CAR ARG2)))
  118.     (COND ((OR (EQ '$FIXNUM MODE) (EQ '$FLOAT MODE)
  119.            #+cl
  120.            (and (memq (car arg1) *number-types*)
  121.             (memq (car arg2) *number-types*)))
  122.        `(> ,(DCONV ARG1 MODE) ,(DCONV ARG2 MODE)))
  123.       ((EQ '$NUMBER MODE) `(GREATERP ,(CDR ARG1) ,(CDR ARG2)))
  124.       ('ELSE
  125.        (WRAP-AN-IS `(MGRP ,(DCONVX ARG1) ,(DCONVX ARG2))
  126.                FORM)))))
  127.  
  128. (DEFUN TRP-MLESSP (FORM) 
  129.   (LET (MODE ARG1 ARG2)
  130.     (SETQ ARG1 (TRANSLATE (CADR FORM)) ARG2 (TRANSLATE (CADDR FORM))
  131.       MODE (*UNION-MODE (CAR ARG1) (CAR ARG2)))
  132.     (COND ((OR (EQ '$FIXNUM MODE) (EQ '$FLOAT MODE)
  133.            #+cl
  134.        (and (memq (car arg1) *number-types*)
  135.         (memq (car arg2) *number-types*)))
  136.        `(< ,(DCONV ARG1 MODE) ,(DCONV ARG2 MODE)))
  137.       ((EQ '$NUMBER MODE) `(LESSP ,(CDR ARG1) ,(CDR ARG2)))
  138.       ('ELSE
  139.        (WRAP-AN-IS `(MLSP ,(DCONVX ARG1) ,(DCONVX ARG2))
  140.                FORM)))))
  141.  
  142. (DEFUN TRP-MEQUAL (FORM) 
  143.   (LET (MODE ARG1 ARG2)
  144.     (SETQ ARG1 (TRANSLATE (CADR FORM)) ARG2 (TRANSLATE (CADDR FORM))
  145.       MODE (*UNION-MODE (CAR ARG1) (CAR ARG2)))
  146.     (COND
  147.       #+cl
  148.       ((OR (EQ '$FIXNUM MODE)
  149.        (EQ '$FLOAT MODE))
  150.        `(eql ,(DCONV ARG1 MODE) ,(DCONV ARG2 MODE)))
  151.       ((EQ '$NUMBER MODE) `(EQUAL ,(CDR ARG1) ,(CDR ARG2)))
  152.       (T `(LIKE ,(DCONV ARG1 MODE) ,(DCONV ARG2 MODE))))))
  153.  
  154. (DEFUN TRP-$EQUAL (FORM) 
  155.   (LET (MODE ARG1 ARG2) 
  156.     (SETQ ARG1 (TRANSLATE (CADR FORM)) ARG2 (TRANSLATE (CADDR FORM))
  157.       MODE (*UNION-MODE (CAR ARG1) (CAR ARG2)))
  158.     (COND ((OR (EQ '$FIXNUM MODE) (EQ '$FLOAT MODE))
  159.        `(= ,(DCONV ARG1 MODE) ,(DCONV ARG2 MODE)))
  160.       ((EQ '$NUMBER MODE) `(MEQP ,(CDR ARG1) ,(CDR ARG2)))
  161.       ('ELSE
  162.        (WRAP-AN-IS `(MEQP ,(DCONVX ARG1) ,(DCONVX ARG2))
  163.                FORM)))))
  164.  
  165. (DEFUN TRP-MNOTEQUAL (FORM) (LIST 'NOT (TRP-MEQUAL FORM)))
  166.  
  167. (DEFUN TRP-MGEQP (FORM) (LIST 'NOT (TRP-MLESSP FORM)))
  168.  
  169. (DEFUN TRP-MLEQP (FORM) (LIST 'NOT (TRP-MGREATERP FORM)))
  170.  
  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 ((eq 'mand (caaar x))
  180.          (mapc #'(lambda (l) (setq nl (cons `(assume ,(dtranslate l)) nl)))
  181.            (cdar x)))
  182.         ((eq 'mnot (caaar x))
  183.          (setq nl (cons `(assume ,(dtranslate (pred-reverse (cadar x)))) nl)))
  184.         ((eq 'mor (caaar x))
  185.          (merror "ASSUME: Macsyma is unable to handle assertions involving 'OR'."))
  186.         ((eq (caaar x) 'mequal)
  187.          (merror "ASSUME: = means syntactic equality in Macsyma. ~
  188.              Maybe you want to use EQUAL."))
  189.         ((eq (caaar x) 'mnotequal)
  190.          (merror "ASSUME: # means syntactic unequality in Macsyma. ~
  191.              Maybe you want to use NOT EQUAL."))
  192.         ('else
  193.          (setq nl (cons `(assume ,(dtranslate (car x))) nl))))
  194.       (setq x (cdr x)))))
  195.