Share Gallery 1/share_gal_1.zip/share_gal_1/GR/GR505.ZIP/LSP.EXE/CALC.LSP

Text File | 1988-07-08 | 5KB | 238 lines

;
;    CALC.LSP
;
;        Written by Hugh S. Myers of:
;
;        Bazeghi-Myers
;        8414 Fairview Ave.
;        Boise, Idaho  83704
;
;        Or contact me through CompuServe,
;        User ID: 76314,3672
;        Not too surprisingly I hang out at !go adesk...
;
;        Cautions and such...I'm giving this stuff away
;        as is...I don't plan on real heavy support(i.e. none!)
;        but would like to hear of bugs or problems, certainly
;        would like to hear if you can improve, sort of give back
;        at least as much as you get plan(does that make this
;        golden rule ware???!)  At any rate, this is not a how
;        too for Autolisp, and the comments are not as thick as
;        they might be, but persevere(or at least persist) and
;        all should be made clear.
;
;        So, here goes.....
;
;
;    a few string handling functions
;

(DEFUN REDUCE(A)
    (SUBSTR A 2)
)

(DEFUN TRIMSTR(A)
    (SUBSTR A 1 (1- (STRLEN A)))
)

(DEFUN FIRSTCHAR(A)
    (SUBSTR A 1 1)
)

(DEFUN LASTCHAR(A)
    (SUBSTR A (STRLEN A))
)

(DEFUN NNUL(A)
    (NOT (ZEROP (STRLEN A)))
)

(DEFUN STRINGP(A)
    (EQUAL 'STR (TYPE A))
)

(DEFUN TEXPLODE(A)
    (SETQ L (LIST (FIRSTCHAR A)))
    (SETQ A (REDUCE A))
    (WHILE (NNUL A)
        (SETQ L (CONS (FIRSTCHAR A) L))
        (SETQ A (REDUCE A))
    )
    (REVERSE L)
)

(DEFUN SNUMBP(A)
    (IF (MEMBER A '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
        T
        NIL
    )
)

;
;    now a few necessary functions for a calculator, feet & inches...
;

(DEFUN GETSN(A)
    (SETQ L "")
    (WHILE (SNUMBP (FIRSTCHAR A))
        (SETQ L (STRCAT L (FIRSTCHAR A)))
        (SETQ A (REDUCE A))
    )
    (CONS L A)
)

(DEFUN GETSFRAC(A)
    (SETQ X1 (GETSN A))
    (SETQ Y1 (STRCAT (REDUCE (CDR X1)) ".0"))
    (SETQ X1 (STRCAT (CAR X1) ".0"))
    (/ (ATOF X1) (ATOF Y1))
)

(DEFUN GETSNUMB(A)
    (IF (EQUAL "-" (FIRSTCHAR A))
        (SETQ A (REDUCE A))
    )
    (SETQ X (GETSN A))
    (SETQ Y (FIRSTCHAR (CDR X)))
    (SETQ Z (REDUCE (CDR X)))
    (SETQ X (CAR X))
    (COND
        ((EQUAL "." Y)
            (PROGN
                (SETQ A (ATOF A))
                (SETQ Z "")
            )
        )
        ((EQUAL "/" Y)
            (PROGN
                (SETQ A (GETSN Z))
                (SETQ Z (CAR A))
                (SETQ ZZ (FIRSTCHAR (CDR A)))
                (SETQ A (GETSFRAC (STRCAT X Y Z)))
                (IF (EQUAL "'" ZZ)
                    (SETQ A (* A 12.0))
                )
                (SETQ Z "")
            )
        )
        ((EQUAL "'" Y) (SETQ A (* 12.0 (ATOF X))))
        (T (SETQ A (ATOF X)))
    )
    (CONS A Z)
)

(DEFUN GETFT&IN(X)
    (SETQ N 0)
    (WHILE (NNUL X)
        (SETQ X (GETSNUMB X))
        (SETQ N (+ N (CAR X)))
        (SETQ X (CDR X))
    )
    (EVAL N)
)

(DEFUN PUSH_NUM(N)
    (SETQ NUM_STACK (CONS N NUM_STACK))
)

(DEFUN POP_NUM()
    (SETQ N (CAR NUM_STACK))
    (SETQ NUM_STACK (CDR NUM_STACK))
    (EVAL N)
)

(DEFUN CLR_NUM()
    (SETQ NUM_STACK NIL)
)

(DEFUN NUM_OK(N)
    (> (LENGTH NUM_STACK) N)
)

(DEFUN C:CALC()
    (SETQ FLAG T)
    (WHILE FLAG
        (SETQ A (GETSTRING "CALC: "))
        (COND
            ((EQUAL A "CLR")
                (CLR_NUM))
            ((EQUAL A "STK")
                (PRIN1 NUM_STACK))
            ((EQUAL A "+")
                (IF (NUM_OK 1) (DO_PLUS)
                    (CALC_ERR "need at least two numbers")))
            ((EQUAL A "-")
                (IF (NUM_OK 1) (DO_MINUS)
                    (CALC_ERR "need at least two numbers")))
            ((EQUAL A "*")
                (IF (NUM_OK 1) (DO_TIMES)
                    (CALC_ERR "need at least two numbers")))
            ((EQUAL A "/")
                (IF (NUM_OK 1) (DO_DIVIDE)
                    (CALC_ERR "need at least two numbers")))
            ((EQUAL A "==")
                (IF (NUM_OK 0) (DO_DISPLAY)
                    (CALC_ERR "need at least one number")))
            ((EQUAL A "=D")
                (IF (NUM_OK 0) (DO_DDISPLAY)
                    (CALC_ERR "need at least one number")))
            ((EQUAL A "")
                (SETQ FLAG NIL))
            (T
                (PUSH_NUM (GETFT&IN A)))
        )
        (TERPRI)
    )
    (CLR_NUM)
)

(DEFUN DO_PLUS()
    (PUSH_NUM (+ (POP_NUM) (POP_NUM)))
)

(DEFUN DO_MINUS()
    (SETQ A (POP_NUM))
    (PUSH_NUM (- (POP_NUM) A))
)

(DEFUN DO_TIMES()
    (PUSH_NUM (* (POP_NUM) (POP_NUM)))
)

(DEFUN DO_DIVIDE()
    (SETQ A (POP_NUM))
    (PUSH_NUM (/ (POP_NUM) A))
)

(DEFUN DO_DISPLAY()
    (PRIN1 (RTOS (CAR NUM_STACK) 4 8))
)

(DEFUN DO_DDISPLAY()
    (PRIN1 (RTOS (CAR NUM_STACK) 2 8))
)

(DEFUN CALC_ERR(A)
    (PRIN1 (STRCAT "***CALC ERROR, " A))
)
;
;    I haven't taken the time to find out all the possible ways
;    to use the calculator.  The only thing that I have figured
;    out the first time through is a format like:
;
;    CALC: 1'3+2'6 <return>
;    CALC: == <return>
;    "3'-9""  <will be the answer>
;
;    CALC: clr  <will clear the stack>
;    CALC: stk  <will display the stack>
;
;    I think mabye some changes are in order to get the routine
;    to do fractions.  After I learn more, I will update the
;    commands.  If you figure it all out, you might add to the list.
;
;                        The ACADemy
;                           [phone]
;                          1200 baud
;