Liren Large Software Subsidy 13/13.iso/p/p065/3.img/CALC.LSP

Lisp/Scheme | 1990-09-07 | 15.8 KB | 503 lines

;;;   CALC.lsp
;;;   Copyright (C) 1990 by Autodesk, Inc.
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;   by Jan S. Yoder
;;;   01 February 1990
;;;
;;;--------------------------------------------------------------------------;
;;; DESCRIPTION
;;;   This is a command line implementation of an TI type calculator.  It
;;;   supports addition, subtraction, multiplication, division, square roots,
;;;   raising Y to the x power, and numerous memory functions.  There is no
;;;   built-in limit to the number of lisp variables that may be assigned -
;;;   this is limited by the user's memory.  Values may be stored to variables,
;;;   listed, deleted, and used in calculations as desired.
;;;
;;;   There is also support for sine, cosine, tangent and the Arc functions;
;;;   Arcsine, Arccosine, and Arctangent.  All angles are in degrees, radians
;;;   and gradians are not supported.
;;;
;;;   This function tries to be understanding about unit types and precision,
;;;   but no claim is made that it is universally adequate about performing
;;;   said task.   For instance, if the user does several multiplication
;;;   sequences, the printed display will show first units, then square units,
;;;   cubic units, and finally revert back to units, as I don't quite know
;;;   what to call forth order dimensions - perhaps teracted units.  There is
;;;   also no way to tell whether a number is a unit or unitless multiplier.
;;;--------------------------------------------------------------------------;
;;;
(defun myerror (s)                    ; If an error (such as CTRL-C) occurs
                                      ; while this command is active...
  (if (/= s "Function cancelled")
    (princ (strcat "\nError: " s))
  )
  (setvar "cmdecho" ocmd)             ; Restore saved modes
  (setvar "blipmode" oblp)
  (setq *error* olderr)               ; Restore old *error* handler
  (princ)
)
;;;
;;; Main control function.
;;;
(defun a:calc (task / calc_n calc_a calc_s temp sbtask save_m)
  (setvar "cmdecho" 0)
  (command "undo" "group")
  (setq calc_n 0)
  (menucmd "s=calc")
  (cond
    ;; The trig functions; sine, cosine, tangent, arctangent
    ((= task "Trig")
      (setq calc_c 1)
      (cal_tr)
    )
    ;; The square root of calc_m
    ((= task "Sq-rt")
      (setq calc_c 1)
      (cal_sq)
    )
    ;; calc_m to the x power.  Negative numbers used as x
    ;; result in fractions as such - (1/mt)^x
    ((= task "Y")
      (setq calc_c 1)
      (cal_yx)
    )
    ;; Memory subfunctions
    ((= task "Mem")
      (setq calc_c 1)
      (cal_mm)
    )
    ;; Add, subtract, multiply and divide
    (T
      (setq calc_n (getdist "Next number: "))
      (if calc_n
        (cond
          ;; add the number to the display
          ((= task "+")
           (setq calc_c 1
                  calc_m (+ calc_m calc_n)
                 calc_a (strcat (rtos calc_m)
                          (if (= (getvar "lunits") 4) (strcat
                            ", or " (rtos calc_m 2)) "") " units. ")
            )
          )
          ;; subtract the number from the display
          ((= task "-")
            (setq calc_c 1
                  calc_m (- calc_m calc_n)
                  calc_a (strcat (rtos calc_m)
                          (if (= (getvar "lunits") 4) (strcat
                            ", or " (rtos calc_m 2)) "") " units. ")
            )
          )
          ;; multiply the display by the number
          ((= task "*")
            ;; Take care of power to a number when multiplied
            (setq calc_c (1+ calc_c)) ; placed count here to
            (cond                     ; figure out whether to put
              ((= calc_c 2) (setq calc_s " square")); square if 2 times
              ((= calc_c 3) (setq calc_s " cubic")) ; cubic if 3 times
              (T (setq calc_s ""))
            )
            (setq calc_m (* calc_m calc_n))
            (if (= (getvar "lunits") 4)
              (if (or (= calc_c 2) (= calc_c 3))
                (setq calc_a (strcat "\n" (rtos (/ calc_m 12) 2)
                                     calc_s "Feet or "
                                     (rtos calc_m 2) calc_s " Inches" ))
                (setq calc_a (strcat (rtos calc_m) calc_s " units. "))
              )
              (setq calc_a (strcat (rtos calc_m 2) calc_s " units. "))
            )
          )
          ;; divide the display by the number
          ((= task "/")
            (setq calc_c 1
                  calc_m (/ calc_m calc_n)
                  calc_a (strcat (rtos calc_m)
                          (if (= (getvar "lunits") 4) (strcat
                            ", or " (rtos calc_m 2)) "") " units. ")
            )
          )
          (T                          ; error
            (exit)
          )
        )
      )
      ;; Display the result
      (if calc_n (princ (strcat "\n" calc_a)))
    )
  )
)
;;;
;;; Trig functions
;;;
(defun cal_tr ()
  (menucmd "s=calc3")
  (if (null sbtask) (setq sbtask "Exit"))
  (initget "ACosine ASine ATangent Sine Cosine Tangent Exit")
  (setq temp (getkword (strcat
    "\nTrig: ACosine ASine ATangent Cosine Sine Tangent <" sbtask ">: ")))
  (if temp (setq sbtask temp))
  (cond
    ((= sbtask "ACosine")
      (cal_ac)
    )
    ((= sbtask "ASine")
      (cal_as)
    )
    ((= sbtask "ATangent")
      (setq save_m calc_m
            calc_m    (* (atan calc_m) (/ 180 pi))
      )
      (cal_pr "The arctangent of " save_m " is " calc_m " degrees. ")
    )
    ((= sbtask "Cosine")
      (setq save_m calc_m
            calc_m    (cos (/ calc_m (/ 180 pi)))
      )
      (cal_pr "The cosine of " save_m " degrees is " calc_m ". ")
    )
    ((= sbtask "Sine")
      (setq save_m calc_m
            calc_m    (sin (/ calc_m (/ 180 pi)))
      )
      (cal_pr "The sine of " save_m " degrees is " calc_m ". ")
    )
    ((= sbtask "Tangent")
      (setq save_m calc_m
            calc_m    (/ (sin (/ calc_m (/ 180 pi)))
                         (cos (/ calc_m (/ 180 pi))))
      )
      (cal_pr "The tangent of " save_m " degrees is " calc_m ". ")
    )
    (T
      (princ)
    )
  )
)
;;;
;;; Arc-Cosine function.
;;; The function must be bound between the range -1 <= calc_m <= 1
;;; arc_cos(x) = arc_tan(x/sqrt(1-x^2))
;;;
(defun cal_ac ()
  (if (and (< calc_m 1.0)
           (> calc_m -1.0))
    (progn
      (setq save_m calc_m
            calc_m (* (/ 180 pi)
                      (atan (sqrt (- 1 (expt calc_m 2))) calc_m))
      )
      (cal_pr "The arccosine of " save_m " is " calc_m " degrees. ")
    )
    (cond
      ((= calc_m 1.0)
        (cal_pr "The arccosine of " calc_m " is " (eval 0.0) " degrees. ")
        (setq calc_m 0)
      )
      ((= calc_m -1.0)
        (cal_pr "The arccosine of " calc_m " is " (eval 180.0) " degrees. ")
        (setq calc_m 180)
      )
      (progn
        (cal_pr "The arccosine of " calc_m " is undefined. " nil "")
        (princ "\nValid range is (0 <= Input value < 1).")
      )
    )
  )
)
;;;
;;; Arc-Sine function.
;;; The function must be bound between the range -1 <= calc_m <= 1
;;; arc_sin(x) = PI/2 - arc_cos(x)
;;;
(defun cal_as ()
  (if (and (< calc_m 1.0)
           (> calc_m -1.0))
    (progn
      (setq save_m calc_m
            calc_m (- 90.0
                      (* (/ 180 pi)
                         (atan (sqrt (- 1 (expt calc_m 2))) calc_m)))
      )
      (cal_pr "The arcsine of " save_m " is " calc_m " degrees. ")
    )
    (cond
      ((= calc_m 1.0)
        (cal_pr "The arcsine of " calc_m " is " (eval 90.0) " degrees. ")
        (setq calc_m 90)
      )
      ((= calc_m -1.0)
        (cal_pr "The arcsine of " calc_m " is " (eval -90.0) " degrees. ")
        (setq calc_m -90)
      )
      (progn
        (cal_pr "The arcsine of " calc_m " is undefined. " nil "")
        (princ "\nValid range is (0 <= Input value < 1).")
      )
    )
  )
)
;;;
;;; Print a concatenated string with a symbols value.
;;;
(defun cal_pr (str1 val1 str2 val2 str3)
  (princ (strcat "\n"
                 str1
                 (if val1 (rtos val1 2) "")
                 str2
                 (if val2 (rtos val2 2) "")
                 str3 "\n"))
)
;;;
;;; Calculate the square of the number.
;;;
(defun cal_sq ()
  (setq save_m calc_m
        calc_m (sqrt calc_m)
  )
  (if (= (getvar "lunits") 4)
    (progn
      (princ (strcat "\nThe square root of " (rtos save_m) " is "
                                     (rtos calc_m) ", or"))
      (princ (strcat "\nthe square root of " (rtos save_m 2) " is "
                                     (rtos calc_m 2) ". "))
    )
    (cal_pr "The square root of " save_m " is " calc_m ". ")
  )
)
;;;
;;; Calculate the result of Y to the x power
;;;
(defun cal_yx ()
  (setq calc_a (getreal "\Enter the power of x: "))
  (if (= calc_a 0.0)
    (princ "\nInvalid power of x. ")
    (progn
      (setq save_m calc_m
            calc_m    (expt calc_m calc_a))
      (princ (strcat "\n" (rtos save_m 2)
                     " to the power of " (rtos calc_a 2)
                     " is " (rtos calc_m 2)
                     (if (< calc_a 0)
                       (strcat " or 1/" (rtos (/ 1.0 calc_m) 2))
                       ""
                     )
                     ". \n"
            )
      )
    )
  )
)
;;;
;;; Memory functions -- main function
;;;
(defun cal_mm ()
  (menucmd "s=calc2")
  (if (null sbtask) (setq sbtask "Set"))
  (initget (strcat "+ - * / Delete Set Recall List Exit"
                   "ADd SUbtract MUltiply DIvide"))
  (setq temp (getkword (strcat
    "\nMem : Delete/Exit/List/Recall/Set or + - * / <" sbtask ">: ")))
  (if temp (setq sbtask temp))
  (cond
    ;; List the non-nil declared variables in the calculator
    ((= sbtask "List")
      (cal_ml)
    )
    ((= sbtask "Exit")
      (princ)
    )
    (T
      (cal_mt)
    )
  )
)
;;;
;;; Memory list function.
;;;
(defun cal_ml ()
  (setq nwlist '())
  (if (null vlist)
    (princ "\nNo variables defined. ")
    (progn
      (foreach n vlist
        (princ (if (or (= (type (eval (read n))) 'REAL)
                       (= (type (eval (read n))) 'INT))
                 (progn
                   (setq nwlist (append nwlist (list n)))
                   (if (= (getvar "lunits") 4)
                     (strcat "\n     " n " = "
                             (rtos (eval (read n)))
                             ", or "
                             (rtos (eval (read n)) 2)
                     )
                     (strcat "\n     " n " = "
                             (rtos (eval (read n)))
                     )
                   )
                 )
                 (princ)
               )
        )
      )
    )
  )
  (if nwlist
    (progn
      (setq vlist  nwlist
            nwlist nil
      )
    )
  )
)
;;;
;;; Memory operation functions.
;;;
(defun cal_mt ()
  (setq v_name (getstring (cond
    ((= sbtask "+") (strcat "Add " (rtos calc_m 2) " to: "))
    ((= sbtask "-") (strcat "Subtract " (rtos calc_m 2) " from: "))
    ((= sbtask "*") (strcat "Multiply by "  (rtos calc_m 2) ": "))
    ((= sbtask "/") (strcat "Divide by " (rtos calc_m 2) ": "))
    ((= sbtask "Delete") "Delete (All = *C): ")
    ((= sbtask "Set") "Set: ")
    ((= sbtask "Recall") "Recall: ")
  )))
  (if (or (= v_name "")
          (null v_name)
          (and (/= (ascii v_name) 42)
               (< (ascii v_name) 65)
          )
          (and (> (ascii v_name) 90)
               (< (ascii v_name) 97)
          )
          (> (ascii v_name) 122)
      )
    (progn
      (setq v_name "")
    )

    ;; Set up list of variable names and avoid
    ;; duplicate variable names on the list

    (progn
      (if (= (strcase v_name) "*C")   ; if deleting all variables
         (progn
           (princ "\nSetting all variables nil.")
           (setq vlist nil)
         )
         (progn                       ; else
           (setq v_name (strcase v_name)
                 vlist  (if (null vlist)
                          (list v_name)
                          (progn
                            (if (not (member v_name vlist))
                              (append vlist (list v_name))
                              vlist
                            )
                          )
                        )
          )
          (cond
            ;; set the variable name to the number
            ((= sbtask "Set")
              (set (read v_name) calc_m)
              (eval (read v_name))
            )
            ;; recall the value of the variable
            ((= sbtask "Recall")
              (setq calc_m (eval (read v_name)))
              (print calc_m)
            )
            ;; delete the variable (set to nil)
            ((= sbtask "Delete")
              (set (read v_name) nil)
            )
            ;; add the number to the variable
            ((= sbtask "+")
              (set (read v_name) (+ (eval (read v_name)) calc_m))
              (setq calc_m (read v_name))
              (print (eval (read v_name)))
            )
            ;; subtract the number from the variable
            ((= sbtask "-")
              (set (read v_name) (- (eval (read v_name)) calc_m))
              (setq calc_m (read v_name))
              (print (eval (read v_name)))
            )
            ;; multiply the value of the variable by the   number
            ((= sbtask "*")
              (set (read v_name) (* (eval (read v_name)) calc_m))
              (setq calc_m (read v_name))
              (print (eval (read v_name)))
            )
            ;; divide the value of the variable by the n  umber
            ((= sbtask "/")
              (set (read v_name) (/ (eval (read v_name)) calc_m))
              (setq calc_m (read v_name))
              (print (eval (read v_name)))
            )
            ((null (eval (read v_name)))
               (princ "\nNot a valid lisp symbol. ")
            )
          )
        )
      )
    )
  )
)
;;;
;;; C:calc definition
;;;
(defun c:calc (/ olderr ocmd oblp calver cal_er cal_oe s calc_m
                 temp task calc_c hlf_pi nwlist)

  (setq calver "1.00")
  ;;
  ;; Body of CALC function
  ;;

  (setq olderr  *error*
        *error* myerror)
  (setq ocmd (getvar "cmdecho"))
  (setq oblp (getvar "blipmode"))
  (setvar "cmdecho" 0)
  (setq task "Clear" calc_c 1 hlf_pi (/ pi 2))
  (princ (strcat "\nCALC, Version " calver ", (c) 1990 by Autodesk, Inc. "))
  (setq calc_m (getdist "\nFirst number: "))
  (while (and calc_m (/= task "Exit"))
    (menucmd "s=calc")
    (initget (strcat "+ - * / Clear Mem Y Sq-rt Trig Exit "
                     " ADd SUbtract MUltiply DIvide"))
    (setq temp (getkword (strcat
      "\nCalc: Clear/Exit/Mem/Sq-rt/Trig/Y^x or + - * / <" task ">: ")))
    (if temp (setq task temp))
    (if (= task "Clear")
      (setq calc_m (getdist "\nFirst number: "))
      (if (and calc_m (/= task "Exit"))
        (a:calc task)
      )
    )
  )
  ;; Delete all "nil" entries from the variable list when exiting
  (setq nwlist '())
  (foreach n vlist
    (if (null (eval (read n)))
       (eval (read n))
       (setq nwlist (append nwlist (list n)))
    )
  )
  (if nwlist (setq vlist nwlist nwlist nil))
  (setvar "cmdecho" ocmd)
  (setvar "blipmode" oblp)
  (setq *error* olderr)               ; Restore old *error* handler
  (princ)
)
(princ "\n\tC:CALC.LSP loaded.  Start command with CALC.")
(princ)