src/askp.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 ;;;
   9 ;;;     ** (c) Copyright 1981 Massachusetts Institute of Technology **
  10 ;;;
  11 ;;; Toplevel Functions: ($ASKINTEGER EXP <OPTIONAL-ARG>)
  12 ;;;
  13 ;;;                      EXP -> any Macsyma expression.
  14 ;;;                      <OPTIONAL-ARG> -> $EVEN, $ODD, $INTEGER.
  15 ;;;                                        If not given, defaults to $INTEGER.
  16 ;;;
  17 ;;;                      returns -> $YES, $NO, $UNKNOWN.
  18 ;;;
  19 ;;; If LIMITP is non-NIL the facts collected will be consed onto the list
  20 ;;; INTEGER-INFO.
  21 ;;;
  22 ;;; Implementors Functions: (ASK-INTEGER <EXP> <WHAT-KIND>)
  23 ;;;                         same as $ASKINTEGER with less error checking and
  24 ;;;                         requires two arguments.
  25 ;;;
  26 ;;; Support Functions: ASK-EVOD -> is a symbol an even or odd number?
  27 ;;;                    ASK-INTEGERP -> is a symbol an integer?
  28 ;;;                    ASK-PROP -> ask the user a question about a symbol.
  29 ;;;
  30
  31 (in-package :maxima)
  32
  33 (macsyma-module askp)
  34
  35 (defmfun $askinteger (x &optional (mode '$integer))
  36   (if (member mode '($even $odd $integer) :test #'eq)
  37       (ask-integer x mode)
  38       (improper-arg-err mode '$askinteger)))
  39
  40 (defun ask-integer (x even-odd)
  41   (setq x (sratsimp (sublis '((z** . 0) (*z* . 0)) x)))
  42   (cond ((ratnump x) '$no)
  43         ((eq even-odd '$integer) (ask-integerp x))
  44         (t (ask-evod x even-odd))))
  45
  46 (defun ask-evod (x even-odd)
  47   (if (and (mtimesp x) (equal (cadr x) -1)) (setq x (muln (cddr x) t)))
  48   (let ((evod-ans (evod x)) (is-integer (maxima-integerp x)))
  49     (cond ((equal evod-ans even-odd) '$yes)
  50           ((and ($numberp x) (not is-integer)) '$no)
  51           ((and is-integer evod-ans) '$no)
  52           ((eq (setq evod-ans
  53                      (ask-prop x (if (eq even-odd '$even) 'even 'odd) 'number))
  54                '$yes)
  55            (ask-declare x even-odd) '$yes)
  56           ((eq evod-ans '$no)
  57            (if is-integer
  58                (if (eq even-odd '$even) (ask-declare x '$odd)
  59                    (ask-declare x '$even)))
  60            '$no)
  61           (t '$unknown))))
  62
  63 (defun ask-integerp (x)
  64   (let (integer-ans)
  65     (if (and (mplusp x) (integerp (cadr x))) (setq x (addn (cddr x) t)))
  66     (if (and (mtimesp x) (equal (cadr x) -1)) (setq x (muln (cddr x) t)))
  67     (cond ((or (maxima-integerp x) (memalike x integerl)) '$yes)
  68           ((or ($numberp x) (nonintegerp x) (memalike x nonintegerl)) '$no)
  69           ((eq (setq integer-ans (ask-prop x 'integer nil)) '$yes)
  70            (ask-declare x '$integer) '$yes)
  71           ((eq integer-ans '$no)
  72            (ask-declare x '$noninteger) '$no)
  73           (t '$unknown))))
  74
  75 (defun ask-declare (x property)
  76   (cond ((atom x)
  77          (meval `(($declare) ,x ,property))
  78          (if limitp
  79              (setq *integer-info* (cons `(($kind) ,x ,property) *integer-info*))))
  80         ((and limitp (eq property '$integer))
  81          (setq integerl (cons x integerl)))
  82         ((and limitp (eq property '$noninteger))
  83          (setq nonintegerl (cons x nonintegerl)))))
  84
  85 ;;; Asks the user a question about the property of an object.
  86 ;;; Returns only $yes, $no or $unknown.
  87 (defun ask-prop (object property fun-or-number)
  88   (if fun-or-number (setq fun-or-number (list " " fun-or-number)))
  89   (do ((end-flag) (answer))
  90       (end-flag (cond ((member answer '($yes |$Y| |$y|) :test #'eq) '$yes)
  91                       ((member answer '($no |$N| |$n|) :test #'eq) '$no)
  92                       ((member answer '($unknown $uk) :test #'eq) '$unknown)))
  93     (setq answer (retrieve
  94                   `((mtext) "Is " ,object
  95                     ,(if (member (char (symbol-name property) 0)
  96                                  '(#\a #\e #\i #\o #\u) :test #'char-equal)
  97                          " an "
  98                          " a ")
  99                     ,property ,@fun-or-number "?")
 100                   nil))
 101     (cond ((member answer '($yes |$Y| |$y| |$N| |$n| $no $unknown $uk) :test #'eq)
 102            (setq end-flag t))
 103           (t (mtell "~%Acceptable answers are: yes, y, Y, no, n, N, unknown, uk~%")))))