;;; INTERCAL operators for the GNU Emacs Calculator.
;;; Copyright (C) 1993 Jon Ferro
;;; This file is not part of GNU, and it's doubtful if they
;;; would even admit to its existence.
;;; This file is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY. No author or distributor
;;; accepts responsibility to anyone for the consequences of using it
;;; or for whether it serves any particular purpose or works at all,
;;; unless he says so in writing. Refer to the GNU Emacs General Public
;;; License for full details.
;;; Everyone is granted permission to copy, modify and redistribute
;;; this file, but only under the conditions described in the
;;; GNU Emacs General Public License. A copy of this license is
;;; supposed to have been given to you along with GNU Emacs so you
;;; can know your rights and responsibilities. It should be in a
;;; file named COPYING. Among other things, the copyright notice
;;; and this notice must be preserved on all copies.
;; "YIX" sets the base for future operations, defaults to 2 (72-standard).
;; "YI" is prefix for binary ops $ and ~, and unary ops &, V, @, ?, and ^.
;; See the INTERCAL manual for explanation of these operators.
;; A prefix argument will cause the following operation to treat its
;; operands as large numbers, for whatever suffices as "large" in the
;; current radix. Otherwise, the "small" version of the operation will be
;; performed if all appropriate operands fit in small variables. Higher
;; order whirls are specified by setting the Hyperbolic flag, in which case
;; the order is the first value from the stack and the operand is second.
;; (E.g., in quinary, say, #3@500 is calculated as a 12-quint value by
;; "500 RET 3 H C-u Y I @". No, I have no clue what that comes out to.)
(require 'calc-ext)
(require 'calc-macs)
(defun calc-Need-calc-intercal () 'shyeah-right-as-if nil)
;; Basic key (after the "third-party enhancement" prefix, "Y")
;; for Intercal commands.
(defvar calc-intercal-key "I")
;; Initial radix for Intercal calculations.
(defvar calc-intercal-radix 2)
;; Number of digits in a small number, by radix. (Double for large.)
(defconst calc-intercal-sizes-by-radix '(0 0 16 10 8 6 6 5))
;; Name for a digit in each radix. (Null for the default, 2).
(defconst calc-intercal-names-by-radix
'("" "" "" "Trits " "Quarts " "Quints " "Sexts " "Septs "))
;; Other counts of the current radix size, set for the default, 2.
(defvar calc-intercal-digits 16)
(defvar calc-intercal-small-size (calc-eval "2^16" 'raw))
(defvar calc-intercal-large-size (calc-eval "2^32" 'raw))
;; A further assumption of the default radix being 2 is that
;; calc-intercal-update-radix-display is not called until the
;; radix is actually changed.
;;; Package setup
(define-key calc-mode-map (format "Y%s$" calc-intercal-key)
'calc-intercal-mingle)
(define-key calc-mode-map (format "Y%s~" calc-intercal-key)
'calc-intercal-select)
(define-key calc-mode-map (format "Y%s&" calc-intercal-key)
'calc-intercal-ampersand)
(define-key calc-mode-map (format "Y%sV" calc-intercal-key)
'calc-intercal-book)
(define-key calc-mode-map (format "Y%s@" calc-intercal-key)
'calc-intercal-whirl)
(define-key calc-mode-map (format "Y%s?" calc-intercal-key)
'calc-intercal-what)
(define-key calc-mode-map (format "Y%s^" calc-intercal-key)
'calc-intercal-shark)
(define-key calc-mode-map (format "Y%sX" calc-intercal-key)
'calc-intercal-set-radix)
(setq calc-Y-help-msgs
(append (list (format "Intercal: %s + set-radiX, $ (mingle), ~ (select)" calc-intercal-key)
(format "Intercal: %s + & (and), V (or), @ (but)" calc-intercal-key)
(format "Intercal: %s + ^ (add-w/o-carry), ? (subtract-w/o-borrow)" calc-intercal-key))
calc-Y-help-msgs))
;;; Wrappers for functions accessible in the calculator.
;; All of these wrappers are as identical as possible, to minimize fuss,
;; but some of the calcFunc-intercal-* ignore their prefix argument.
(defun calc-intercal-mingle (n)
(interactive "P")
(calc-wrapper
(calc-enter-result 2 "ick$"
(append '(calcFunc-intercal-mingle)
(calc-top-list-n 2)
(and n (list (prefix-numeric-value n)))))))
(defun calc-intercal-select (n)
(interactive "P")
(calc-wrapper
(calc-enter-result 2 "ick~"
(append '(calcFunc-intercal-select)
(calc-top-list-n 2)
(and n (list (prefix-numeric-value n)))))))
(defun calc-intercal-ampersand (n)
(interactive "P")
(calc-wrapper
(calc-enter-result 1 "ick&"
(append '(calcFunc-intercal-ampersand)
(calc-top-list-n 1)
(and n (list (prefix-numeric-value n)))))))
(defun calc-intercal-book (n)
(interactive "P")
(calc-wrapper
(calc-enter-result 1 "ickV"
(append '(calcFunc-intercal-book)
(calc-top-list-n 1)
(and n (list (prefix-numeric-value n)))))))
(defun calc-intercal-whirl (n)
(interactive "P")
(calc-wrapper
(let ((hyp (if (calc-is-hyperbolic) 2 1)))
(calc-enter-result hyp "ick@"
(append '(calcFunc-intercal-whirl)
(calc-top-list-n hyp)
(if (calc-is-hyperbolic) nil '(1))
(and n (list (prefix-numeric-value n))))))))
(defun calc-intercal-what (n)
(interactive "P")
(calc-wrapper
(calc-enter-result 1 "ick?"
(append '(calcFunc-intercal-what)
(calc-top-list-n 1)
(and n (list (prefix-numeric-value n)))))))
(defun calc-intercal-shark (n)
(interactive "P")
(calc-wrapper
(calc-enter-result 1 "ick^"
(append '(calcFunc-intercal-shark)
(calc-top-list-n 1)
(and n (list (prefix-numeric-value n)))))))
;;; Radix operations
(defun calc-intercal-set-radix (n)
(interactive "NIntercal calculation radix (2-7): ")
(calc-wrapper
(if (and (>= n 2) (<= n 7))
(progn
(setq calc-intercal-radix n)
(setq calc-intercal-digits
(nth calc-intercal-radix calc-intercal-sizes-by-radix))
(setq calc-intercal-small-size
(math-pow calc-intercal-radix calc-intercal-digits))
(setq calc-intercal-large-size
(math-pow calc-intercal-radix (* 2 calc-intercal-digits)))
(calc-intercal-update-radix-display))
(setq n calc-intercal-radix))
(message "Intercal radix is %d." n)))
(defun calc-intercal-update-radix-display ()
(let ((names calc-intercal-names-by-radix)
(end nil))
;; Look for one of our modes, and replace if found.
(while (and names (not end))
(let ((top (member (car names) calc-other-modes)))
(if top
(progn
(rplaca top (nth calc-intercal-radix
calc-intercal-names-by-radix))
(setq end t))))
(setq names (cdr names)))
;; If loop was exited because no radix name was found, add one.
(or end (setq calc-other-modes
(cons (nth calc-intercal-radix
calc-intercal-names-by-radix)
calc-other-modes)))))
;;; Binary operators
(defun calcFunc-intercal-mingle (a b &optional n)
;; Check args.
(or (math-natnump a)
(math-reject-arg a 'natnump))
(or (math-natnump b)
(math-reject-arg b 'natnump))
(let ((r (reverse (calc-intercal-mince a)))
(s (reverse (calc-intercal-mince b))))
;; Check Intercal variable sizing.
(or (<= (length r) calc-intercal-digits)
(math-reject-arg a calc-intercal-size-err-msg))
(or (<= (length s) calc-intercal-digits)
(math-reject-arg b calc-intercal-size-err-msg))
(let ((result nil))
;; Alternate digits from each arg, until no more.
(while (or r s)
(setq result (cons (if (null s) 0 (car s)) result))
(setq s (cdr s))
(setq result (cons (if (null r) 0 (car r)) result))
(setq r (cdr r)))
(calc-intercal-liquefy result))))
(defun calcFunc-intercal-select (a b &optional n)
;; Check args.
(or (math-natnump a)
(math-reject-arg a 'natnump))
(or (math-natnump b)
(math-reject-arg b 'natnump))
(let ((r (reverse (calc-intercal-mince a)))
(s (reverse (calc-intercal-mince b))))
;; Check Intercal variable sizing.
(or (<= (length r) (* 2 calc-intercal-digits))
(math-reject-arg a calc-intercal-size-err-msg))
(or (<= (length s) (* 2 calc-intercal-digits))
(math-reject-arg b calc-intercal-size-err-msg))
(let ((result nil)
(rt r)
(st s)
(i (- calc-intercal-radix 1)))
;; Iterate downward through selector bits...
(while (> i 0)
(setq r rt)
(setq s st)
;; ... selecting and packing down the ones that match each iteration.
(while s
(if (= (car s) i)
(setq result (cons (calc-intercal-make-julienne-fries
(car r) (car s) 0)
result)))
(setq s (cdr s))
(setq r (cdr r)))
(setq i (1- i)))
(calc-intercal-liquefy result))))
;;; Unary operators
(defun calcFunc-intercal-whirl (a o &optional n)
;; Check args.
(or (math-natnump a)
(math-reject-arg a 'natnump))
;; Check intercal variable sizing.
;; Note that O is technically not a second arg, but rather
;; a specification of the ordinality of the whirl, which makes this
;; function capable of handling 7 different unary operations.
(or (and (math-fixnatnump o) (<= o (- calc-intercal-radix 1)))
(math-reject-arg o calc-intercal-arg-err-msg))
(let ((r (calc-intercal-mince a))
(s nil))
(or (<= (length r) (* 2 calc-intercal-digits))
(math-reject-arg a calc-intercal-size-err-msg))
;; Prepare args for merging.
(setq r (calc-intercal-whip r n))
(setq s (calc-intercal-puree r))
(setq r (nreverse r))
(setq s (nreverse s))
(let* ((result nil))
(while r
(setq result (cons (calc-intercal-make-julienne-fries
(car r) (car s) o)
result))
(setq r (cdr r))
(setq s (cdr s)))
(calc-intercal-liquefy result))))
(defun calcFunc-intercal-ampersand (a &optional n)
(calcFunc-intercal-whirl a 0 n))
(defun calcFunc-intercal-book (a &optional n)
(calcFunc-intercal-whirl a (- calc-intercal-radix 1) n))
;;; More unary operators
(defun calcFunc-intercal-shark (a &optional n)
;; Check args.
(or (math-natnump a)
(math-reject-arg a 'natnump))
;; Check intercal variable sizing.
(let ((r (calc-intercal-mince a))
(s nil))
(or (<= (length r) (* 2 calc-intercal-digits))
(math-reject-arg a calc-intercal-size-err-msg))
;; Prepare args for merging.
(setq r (calc-intercal-whip r n))
(setq s (calc-intercal-puree r))
(setq r (nreverse r))
(setq s (nreverse s))
(let* ((result nil))
(while r
(setq result (cons (calcFunc-mod (+ (car s) (car r))
calc-intercal-radix)
result))
(setq r (cdr r))
(setq s (cdr s)))
(calc-intercal-liquefy result))))
(defun calcFunc-intercal-what (a &optional n)
;; Check args.
(or (math-natnump a)
(math-reject-arg a 'natnump))
;; Check intercal variable sizing.
(let ((r (calc-intercal-mince a))
(s nil))
(or (<= (length r) (* 2 calc-intercal-digits))
(math-reject-arg a calc-intercal-size-err-msg))
;; Prepare args for merging.
(setq r (calc-intercal-whip r n))
(setq s (calc-intercal-puree r))
(setq r (nreverse r))
(setq s (nreverse s))
(let* ((result nil))
(while r
(setq result (cons (calcFunc-mod (- (car s) (car r))
calc-intercal-radix)
result))
(setq r (cdr r))
(setq s (cdr s)))
(calc-intercal-liquefy result))))
;;; Internals
;; Just what Intercal needs: more internal operations
;; with gratuitous names!
(defun calc-intercal-mince (a)
;; Turn a calculator number into a list of digits in the current radix.
(let ((digits nil))
(while (not (math-zerop a))
(let ((val (math-idivmod a calc-intercal-radix)))
(setq digits (cons (cdr val) digits))
(setq a (car val))))
digits))
(defun calc-intercal-liquefy (l)
;; Turn a list of digits into a number for the calculator.
(let ((a 0))
(while l
(setq a (math-add (car l) (math-mul a calc-intercal-radix)))
(setq l (cdr l)))
a))
(defun calc-intercal-whip (l d)
;; "Sign extend" a list of digits by padding out to the appropriate
;; size with extra zeros. Extend to the small size unless the list
;; is already too long or the second arg D is non-nil.
(let ((len (length l))
(goal (nth calc-intercal-radix calc-intercal-sizes-by-radix)))
(if (or d (> len goal))
(setq goal (* 2 goal)))
(while (< (length l) goal)
(setq l (cons 0 l)))
l))
(defun calc-intercal-puree (l)
;; Rotate the argument one to the right.
(let (result)
(while (cdr l)
(setq result (cons (car l) result))
(setq l (cdr l)))
(cons (car l) (nreverse result))))
(defun calc-intercal-make-julienne-fries (a b m)
;; Closest to the actual retail price without going over...
(cond ((and (<= a m) (<= b m)) (max a b))
((<= a m) a)
((<= b m) b)
(t (max a b))))
;; Still not used:
;; blend fold beat mix stir fluff
;; grate dice shred shave tenderize grind chop slice
;; chew swallow digest ingest masticate gnaw lick donotlick suck
;; Error messages.
(defconst calc-intercal-size-err-msg
"533 YOU WANT MAYBE WE SHOULD IMPLEMENT 64-BIT VARIABLES?")
(defconst calc-intercal-arg-err-msg
"997 ILLEGAL POSSESSION OF A CONTROLLED UNARY OPERATOR")