;;; 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)
	)
)
