src/askp.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 ;;;
   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 (declare-top (special limitp integer-info))
  36
  37 (defmfun $askinteger (x &optional (mode '$integer))
  38   (if (member mode '($even $odd $integer) :test #'eq)
  39       (ask-integer x mode)
  40       (improper-arg-err mode '$askinteger)))
  41
  42 (defun ask-integer (x even-odd)
  43   (setq x (sratsimp (sublis '((z** . 0) (*z* . 0)) x)))
  44   (cond ((ratnump x) '$no)
  45         ((eq even-odd '$integer) (ask-integerp x))
  46         (t (ask-evod x even-odd))))
  47
  48 (defun ask-evod (x even-odd)
  49   (if (and (mtimesp x) (equal (cadr x) -1)) (setq x (muln (cddr x) t)))
  50   (let ((evod-ans (evod x)) (is-integer (maxima-integerp x)))
  51     (cond ((equal evod-ans even-odd) '$yes)
  52           ((and ($numberp x) (not is-integer)) '$no)
  53           ((and is-integer evod-ans) '$no)
  54           ((eq (setq evod-ans
  55                      (ask-prop x (if (eq even-odd '$even) 'even 'odd) 'number))
  56                '$yes)
  57            (ask-declare x even-odd) '$yes)
  58           ((eq evod-ans '$no)
  59            (if is-integer
  60                (if (eq even-odd '$even) (ask-declare x '$odd)
  61                    (ask-declare x '$even)))
  62            '$no)
  63           (t '$unknown))))
  64
  65 (defun ask-integerp (x)
  66   (let (integer-ans)
  67     (if (and (mplusp x) (integerp (cadr x))) (setq x (addn (cddr x) t)))
  68     (if (and (mtimesp x) (equal (cadr x) -1)) (setq x (muln (cddr x) t)))
  69     (cond ((or (maxima-integerp x) (memalike x integerl)) '$yes)
  70           ((or ($numberp x) (nonintegerp x) (memalike x nonintegerl)) '$no)
  71           ((eq (setq integer-ans (ask-prop x 'integer nil)) '$yes)
  72            (ask-declare x '$integer) '$yes)
  73           ((eq integer-ans '$no)
  74            (ask-declare x '$noninteger) '$no)
  75           (t '$unknown))))
  76
  77 (defun ask-declare (x property)
  78   (cond ((atom x)
  79          (meval `(($declare) ,x ,property))
  80          (if limitp
  81              (setq integer-info (cons `(($kind) ,x ,property) integer-info))))
  82         ((and limitp (eq property '$integer))
  83          (setq integerl (cons x integerl)))
  84         ((and limitp (eq property '$noninteger))
  85          (setq nonintegerl (cons x nonintegerl)))))
  86
  87 ;;; Asks the user a question about the property of an object.
  88 ;;; Returns only $yes, $no or $unknown.
  89 (defun ask-prop (object property fun-or-number)
  90   (if fun-or-number (setq fun-or-number (list " " fun-or-number)))
  91   (do ((end-flag) (answer))
  92       (end-flag (cond ((member answer '($yes |$Y| |$y|) :test #'eq) '$yes)
  93                       ((member answer '($no |$N| |$n|) :test #'eq) '$no)
  94                       ((member answer '($unknown $uk) :test #'eq) '$unknown)))
  95     (setq answer (retrieve
  96                   `((mtext) "Is " ,object
  97                     ,(if (member (char (symbol-name property) 0)
  98                                  '(#\a #\e #\i #\o #\u) :test #'char-equal)
  99                          " an "
 100                          " a ")
 101                     ,property ,@fun-or-number "?")
 102                   nil))
 103     (cond ((member answer '($yes |$Y| |$y| |$N| |$n| $no $unknown $uk) :test #'eq)
 104            (setq end-flag t))
 105           (t (mtell "~%Acceptable answers are: yes, y, Y, no, n, N, unknown, uk~%")))))