Shareware Overload/ShartewareOverload.cdr/wp/brcalc.zip/CALC.M

Text File | 1984-11-02 | 14KB | 772 lines

;;; calculator program
;;; written by Mark U. Edwards
;;; 11-02-84

#define MAXSTRING 16

(macro calc
    (
        (int    c_orig_buffer
                c_acc
                c_ans_buff
                c_base
                c_op
                c_first_digit
                c_stage
                c_carry
                c_number_in
                c_display
                c_tape_on
                c_line
                c_digits
        )
        (string c_number_out)
        (global    c_number_in
                    c_number_out
                    c_acc
                    c_ans_buff
                    c_base
                    c_op
                    c_first_digit
                    c_display
                    c_tape_on
                    c_line
                    c_digits
                    c_stage
                    c_carry
        )

        (pause_on_error)
        (= c_ans_buff (create_buffer "Calculator" "$c$.tmp" 1))
        (= c_orig_buffer (inq_buffer))
        (set_buffer c_ans_buff)
        (create_window 52 21 77 19 "F1 for Help")
        (attach_buffer c_ans_buff)
        (refresh)
        (keyboard_push)
        (assign_to_key "#27" "exit")
        (assign_to_key "#48" "c_n_0")
        (assign_to_key "#49" "c_n_1")
        (assign_to_key "#50" "c_n_2")
        (assign_to_key "#51" "c_n_3")
        (assign_to_key "#52" "c_n_4")
        (assign_to_key "#53" "c_n_5")
        (assign_to_key "#54" "c_n_6")
        (assign_to_key "#55" "c_n_7")
        (assign_to_key "#56" "c_n_8")
        (assign_to_key "#57" "c_n_9")
        (assign_to_key "#97" "c_n_A")
        (assign_to_key "#65" "c_n_A")
        (assign_to_key "#98" "c_n_B")
        (assign_to_key "#66" "c_n_B")
        (assign_to_key "#99" "c_n_C")
        (assign_to_key "#67" "c_n_C")
        (assign_to_key "#100" "c_n_D")
        (assign_to_key "#68" "c_n_D")
        (assign_to_key "#101" "c_n_E")
        (assign_to_key "#69" "c_n_E")
        (assign_to_key "#102" "c_n_F")
        (assign_to_key "#70" "c_n_F")
        (assign_to_key "%#46" "c_clr_ent")
        (assign_to_key "%#30" "c_clr_acc")
        (assign_to_key "#13" "c_equals")
        (assign_to_key "%#48" "c_to_bin")
        (assign_to_key "%#32" "c_to_dec")
        (assign_to_key "%#35" "c_to_hex")
        (assign_to_key "#43" "c_plus")
        (assign_to_key "#42" "c_times")
        (assign_to_key "#45" "c_minus")
        (assign_to_key "#47" "c_div")
        (assign_to_key "#37" "c_mod")
        (assign_to_key "#35" "c_plus_minus")
        (assign_to_key "%#59" "c_help")
        (assign_to_key "%#20" "c_tape")
        (assign_to_key "%#25" "c_print")
        (= c_acc 0)
        (= c_number_in 0)    ;;; initialize
        (= c_tape_on 0)
        (= c_base 10)
        (= c_line 1)
        (= c_digits 0)
        (c_print_base)
        (move_abs c_line 16)
        (= c_op 0)                ;;; no operation at present
        (= c_first_digit 0)    ;;; first digit not yet typed
        (= c_stage 1)            ;;; entering first number
        (= c_display 1)        ;;; displaying c_number_in
        (process)
        (keyboard_pop)
        (delete_window)
        (delete_buffer c_ans_buff)
        (set_buffer c_orig_buffer)
    )
)
(macro _num
    (
        (string digit)
        (int d)
        (get_parm 0 digit)
        (get_parm 1 d)
        (if (== c_number_in 0)
            (
                (move_abs c_line 19)
                (delete_char)
                (insert " ")
                (= c_digits 0)
            )
        )
        (if (== c_first_digit 0)    ;;; first digit of new num
            (
                (= c_number_in 0)
                (c_print_base)
                (= c_first_digit 1)
                (= c_digits 0)
            )
        )
        (= c_digits (+ c_digits 1))
        (if (||    (&& (== c_base 2) (<= c_digits 16))
             (||  (&& (== c_base 10) (<= c_digits 5))
                     (&& (== c_base 16) (<= c_digits 4))))
            (
                (if (== c_stage 3)
                    (c_clr_acc)
                )
                (move_abs c_line 3)
                (delete_char)
                (move_abs c_line 19)
                (= c_display 1)
                (insert digit)
                (move_abs c_line 19)
                (= c_number_in (+ (* c_number_in c_base) d))
            )
            ;else
            (beep)
        )
    )
)
(macro c_n_0
    (
        (_num "0" 0)
    )
)
(macro c_n_1
    (
        (_num "1" 1)
    )
)
(macro c_n_2
    (
        (if (> c_base 2)
            (_num "2" 2)
            ;else
            (beep)
        )
    )
)
(macro c_n_3
    (
        (if (> c_base 2)
            (_num "3" 3)
            ;else
            (beep)
        )
    )
)
(macro c_n_4
    (
        (if (> c_base 2)
            (_num "4" 4)
            ;else
            (beep)
        )
    )
)
(macro c_n_5
    (
        (if (> c_base 2)
            (_num "5" 5)
            ;else
            (beep)
        )
    )
)
(macro c_n_6
    (
        (if (> c_base 2)
            (_num "6" 6)
            ;else
            (beep)
        )
    )
)
(macro c_n_7
    (
        (if (> c_base 2)
            (_num "7" 7)
            ;else
            (beep)
        )
    )
)
(macro c_n_8
    (
        (if (> c_base 2)
            (_num "8" 8)
            ;else
            (beep)
        )
    )
)
(macro c_n_9
    (
        (if (> c_base 2)
            (_num "9" 9)
            ;else
            (beep)
        )
    )
)
(macro c_n_A
    (
        (if (> c_base 10)
            (_num "A" 10)
            ;else
            (beep)
        )
    )
)
(macro c_n_B
    (
        (if (> c_base 10)
            (_num "B" 11)
            ;else
            (beep)
        )
    )
)
(macro c_n_C
    (
        (if (> c_base 10)
            (_num "C" 12)
            ;else
            (beep)
        )
    )
)
(macro c_n_D
    (
        (if (> c_base 10)
            (_num "D" 13)
            ;else
            (beep)
        )
    )
)
(macro c_n_E
    (
        (if (> c_base 10)
            (_num "E" 14)
            ;else
            (beep)
        )
    )
)
(macro c_n_F
    (
        (if (> c_base 10)
            (_num "F" 15)
            ;else
            (beep)
        )
    )
)
(macro c_clr_ent
    (
        (move_abs c_line 1)
        (delete_line)
        (= c_number_in 0)
        (c_print_base)
        (= c_digits 0)
        (move_abs c_line 19)
    )
)
(macro c_clr_acc
    (
        (= c_acc 0)
        (c_clr_ent)
        (= c_stage 1)
        (= c_op 0)
        (move_abs 1 1)
        (drop_anchor)
        (end_of_buffer)
        (delete_block)
        (= c_line 1)
        (c_print_base)
        (move_abs c_line 19)
    )
)
(macro c_print_result
    (
        (string num)
        (get_parm 0 num)
        (move_abs c_line 3)
        (delete_to_eol)
        (if (< (strlen num) 20)
            (move_abs c_line (- 20 (strlen num)))
            ;else
            (
                (move_abs c_line 5)
                (= num "- Error -")
                (beep)
            )
        )
        (insert num)
        (move_abs c_line 19)
    )
)
(macro c_to_bin
    (
        (= c_line (+ c_line 1))
        (message "Converting...")
        (if (== c_display 1)
            (= c_number_out (c_dtob c_number_in))
            ;else
            (= c_number_out (c_dtob c_acc))
        )
        (= c_base 2)
        (message "")
        (= c_digits (strlen c_number_out))
        (c_print_result c_number_out)
        (c_print_base)
        (move_abs c_line 19)
    )
)
(macro c_to_dec
    (
        (= c_line (+ c_line 1))
        (message "Converting...")
        (if (== c_display 1)
            (sprintf c_number_out "%d" c_number_in)
            ;else
            (sprintf c_number_out "%d" c_acc)
        )
        (= c_base 10)
        (message "")
        (= c_digits (strlen c_number_out))
        (c_print_result c_number_out)
        (c_print_base)
        (move_abs c_line 19)
    )
)
(macro c_to_hex
    (
        (= c_line (+ c_line 1))
        (message "Converting...")
        (if (== c_display 1)
            (= c_number_out (c_dtoh c_number_in))
            ;else
            (= c_number_out (c_dtoh c_acc))
        )
        (= c_base 16)
        (message "")
        (= c_digits (strlen c_number_out))
        (c_print_result c_number_out)
        (c_print_base)
        (move_abs c_line 19)
    )
)
(macro c_print_base
    (
        (move_abs c_line 21)
        (delete_char)
        (delete_char)
        (delete_char)
        (if (== c_base 2)
            (insert "Bin")
            ;else
            (if (== c_base 10)
                (insert "Dec")
                ;else
                (insert "Hex")
            )
        )
        (move_abs c_line 19)
        (refresh)
    )
)
(macro c_print_acc
    (
        (= c_display 2)    ;;; displaying accumulator
        (if (!= c_base 10)
            (
                (if (== c_base 2)
                    (= c_number_out (c_dtob c_acc))
                    ;else
                    (= c_number_out (c_dtoh c_acc))
                )
            )
            ;else
            (
                (sprintf c_number_out "%d" c_acc)
            )
        )
        (c_print_result c_number_out)
    )
)
(macro c_print_number_in
    (
        (if (!= c_base 10)
            (
                (if (== c_base 2)
                    (= c_number_out (c_dtob c_number_in))
                    ;else
                    (= c_number_out (c_dtoh c_number_in))
                )
            )
            ;else
            (
                (sprintf c_number_out "%d" c_number_in)
            )
        )
        (c_print_result c_number_out)
    )
)

(macro c_print_ans
    (
        (if (== c_op 1)
            (= c_acc (+ c_acc c_number_in))
        )
        (if (== c_op 2)
            (= c_acc (- c_acc c_number_in))
        )
        (if (== c_op 3)
            (= c_acc (* c_acc c_number_in))
        )
        (if (== c_op 4)
            (if (!= c_number_in 0)
                (= c_acc (/ c_acc c_number_in))
                ;else
                (
                    (message "Attempting to div by 0!")
                    (beep)
                    (c_clr_acc)
                )
            )
        )
        (if (== c_op 5)
            (if (!= c_number_in 0)
                (= c_acc (% c_acc c_number_in))
                ;else
                (
                    (message "Attempting to div by 0!")
                    (beep)
                    (c_clr_acc)
                )
            )
        )
        (= c_number_in 0)
        (c_print_acc)
        (c_print_base)
        (message "")
    )
)
(macro c_equals
    (
        (= c_line (+ c_line 1))
        (move_abs c_line 2)
        (delete_char)
        (insert "=")
        (c_print_ans)
        (= c_stage 3)  ;;; signals that already calculated
        (= c_first_digit 0)
    )
)
(macro c_plus
    (
        (if (== c_stage 2)
            (c_equals)
        )
        (= c_line (+ c_line 1))
        (move_abs c_line 2)
        (delete_char)
        (insert "+")
        (if (== c_stage 1)
            (= c_acc c_number_in)
        )
        (= c_op 1)  ;;; next operation is addition
        (= c_stage 2)
        (= c_first_digit 0)
    )
)
(macro c_times
    (
        (if (== c_stage 2)
            (c_equals)
        )
        (= c_line (+ c_line 1))
        (move_abs c_line 2)
        (delete_char)
        (insert "*")
        (if (== c_stage 2)
            (c_print_ans)
        )
        (if (== c_stage 1)
            (= c_acc c_number_in)
        )
        (= c_op 3)  ;;; next operation is multiplication
        (= c_stage 2)
        (= c_first_digit 0)
    )
)
(macro c_minus
    (
        (if (== c_stage 2)
            (c_equals)
        )
        (= c_line (+ c_line 1))
        (move_abs c_line 2)
        (delete_char)
        (insert "-")
        (if (== c_stage 2)
            (c_print_ans)
        )
        (if (== c_stage 1)
            (= c_acc c_number_in)
        )
        (= c_op 2)  ;;; next operation is subtraction
        (= c_stage 2)
        (= c_first_digit 0)
    )
)
(macro c_div
    (
        (if (== c_stage 2)
            (c_equals)
        )
        (= c_line (+ c_line 1))
        (move_abs c_line 2)
        (delete_char)
        (insert "/")
        (if (== c_stage 2)
            (c_print_ans)
        )
        (if (== c_stage 1)
            (= c_acc c_number_in)
        )
        (= c_op 4)  ;;; next operation is division
        (= c_stage 2)
        (= c_first_digit 0)
    )
)
(macro c_mod
    (
        (if (== c_stage 2)
            (c_equals)
        )
        (= c_line (+ c_line 1))
        (move_abs c_line 2)
        (delete_char)
        (insert "%")
        (if (== c_stage 2)
            (c_print_ans)
        )
        (if (== c_stage 1)
            (= c_acc c_number_in)
        )
        (= c_op 5)  ;;; next operation is modulo
        (= c_stage 2)
        (= c_first_digit 0)
    )
)
(macro c_dtoh
    (
        (int n)
        (get_parm 0 n)
        (string num)
        (= num (c_dtob n))        ;;; first convert to binary string
        (= num (c_btoh num))        ;;; then convert to hex string
        (returns num)
    )
)
(macro c_dtob
    (
        (string r remain)
        (int i n rmdr neg)
        (get_parm 0 n)
        (= r "")
        (= neg 0)    ;;; set neg flag off
        (if (< n 0)
            (
                (= n (+ n 1))    ;;; adjust for twos complement
                (= neg 1)        ;;; signal that negative number
                (= n (* n -1))
            )
        )
        (= rmdr 0)
        (= i 0)
        (while (!= n 0)
            (
                (= i (+ i 1))
                (message "Binary digit %d" i)
                (= rmdr (% n 2))
                (= n (/ n 2))
                (sprintf remain "%d" rmdr)
                (= r (+ remain r))
            )
        )
        (if (== neg 1)
            (= r (ones_complement r))
        )
        (if (== r "")
            (= r "0")
        )
        (returns r)
    )
)
(macro c_btoh        ;;; binary to hex, using strings
    (
        (string r n t)
        (int i len j nn)
        (get_parm 0 n)
        (= len (strlen n))
        (= j (% len 4))
        (if (> j 0) (= n (+ (substr "000" j) n)))    ;;; make even packets
        (= len (strlen n))
        (= i 1)
        (while (<= i len)
            (
                (= t (substr n i 4))    ;;; pick up hex packet
                (= nn 0)
                (= j 1)
                (while (<= j 4)
                    (
                        (= nn (* nn 2))
                        (if (== "1" (substr t j 1)) (= nn (+ nn 1)))
                        (= j (+ j 1))
                    )
                )
                (= r (+ r (substr "0123456789ABCDEF" (+ nn 1) 1)))
                (= i (+ i 4))
            )
        )
        (returns r)
    )
)
(macro ones_complement
    (
        (string n t)
        (int i len)
        (get_parm 0 n)
        (= n (+ "0" n))
        (= len (strlen n))
        (= t "")
        (= i 1)
         (while (<= i len)                ;;; ones complement
            (
                (if (== "0" (substr n i 1))
                    (= t (+ t "1"))
                    ;else
                    (= t (+ t "0"))
                )
                (= i (+ i 1))
            )
        )
        (while (< len MAXSTRING)    ;;; fill out to MAXSTRING digits
            (
                (= t (+ "1" t))
                (= len (+ len 1))
            )
        )
        (returns t)
    )
)
(macro c_plus_minus
    (
        (= c_line (+ c_line 1))
        (move_abs c_line 2)
        (delete_char)
        (insert "#")
        (if (== c_display 1)
            (
                (= c_number_in (* c_number_in -1))
                (c_print_number_in)
            )
            ;else
            (
                (= c_acc (* c_acc -1))
                (c_print_acc)
            )
        )
        (c_print_base)
    )
)
(macro c_help
    (
        (int     c_help_buf
                c_calc_buf
        )
        (= c_help_buf (create_buffer "Help" "$h$.tmp" 1))
        (= c_calc_buf (inq_buffer))
        (set_buffer c_help_buf)
        (create_window 2 16 50 1 "ESC to exit from Help")
        (attach_buffer c_help_buf)
        (refresh)
        (keyboard_push)
        (assign_to_key "#27" "exit")
        (move_abs 1 1)
        (insert " 16 Bit Calculator: range 32767 to -32768\n\n")
        (insert " NumLck must be on for Number Pad to work\n")
        (insert "             Operations\n")
        (insert " + plus,   - minus,   * times,   / divide\n")
        (insert " % modulo, # changes sign\n")
        (insert " ALT-C Clear Entry  ALT-A clear Accumulator\n")
        (insert " ALT-T toggle Tape  ALT-P Print tape\n")
        (insert "            Changing Base\n")
        (insert " ALT-D Decimal           [Digits 0..9]\n")
        (insert " ALT-B Binary            [Digits 0..1]\n")
        (insert " ALT-H Hex               [Digits 0..9, A..F]\n\n")
        (insert "        ESC to exit from Calculator")
        (refresh)
        (process)
        (keyboard_pop)
        (delete_window)
        (delete_buffer c_help_buf)
        (set_buffer c_calc_buf)

    )
)
(macro c_tape
    (
        (if (== c_tape_on 0)
            (
                (delete_window)
                (create_window 52 21 77 2 "F1 for Help")
                (attach_buffer c_ans_buff)
                (refresh)
                (= c_tape_on 1)
                ;(change_window 2)    ;;; correct direction??
            )
            ; else
            (
                ;(change_window 0)    ;;; correct direction??
                (delete_window)
                (= c_tape_on 0)
                (create_window 52 21 77 19 "F1 for Help")
                (attach_buffer c_ans_buff)
            )
        )
    )
)
(macro c_print
    (
        (int x y)
        (inq_position y x)
        (move_abs 1 1)
        (drop_anchor)
        (end_of_buffer)
        (print)
        (move_abs y x)
    )
)