--- /dev/null
+;;; INTERCAL operators for the GNU Emacs Calculator.
+;;; Copyright (C) 1993 Jon Ferro <jferro@ece.cmu.edu>
+
+;;; 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.
+
+\f
+;;; 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))
+
+\f
+;;; 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)))))))
+\f
+;;; 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)))))
+\f
+;;; 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))))
+
+\f
+;;; 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))
+
+\f
+;;; 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))))
+\f
+;;; 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")
projects / intercal.git / commitdiff