Re: How to xor?
- From: Pascal Bourguignon <pjb@xxxxxxxxxxxxxxxxx>
- Date: Wed, 20 Jul 2005 20:10:23 +0200
Marcin 'Qrczak' Kowalczyk <qrczak@xxxxxxxxxx> writes:
> Sam Steingold <sds@xxxxxxx> writes:
>
>>> It should be an error: + should work only for numbers, string
>>> concatenation is a sufficiently different operation. But it doesn't
>>> mean that + shouldn't be generic.
>>
>> this is confusing.
>> on one hand, you say that "+ should work only for numbers".
>> since there is no way to create a new kind of numbers,
>
> There should be.
>
>> note that quaternion multiplication is not commutative,
>
> I don't mean quaternions, but e.g. decimal fixed point numbers for
> currencies (more efficient than rationals), or lazily computed
> arbitrary precision approximations of real numbers.
GPL'ed code follows. See invoice.lisp from:
cvs -z3 -d :pserver:anonymous@xxxxxxxxxxxxxxxxxxxxx:/usr/local/cvs/public/chrooted-cvs/cvs co common/common-lisp
;;;---------------------------------------------------------------------
;;; Monetary Amounts & Currency Syntax
;;;---------------------------------------------------------------------
;; Since floating point arithmetic is not adapted to accounting,
;; we will use integers for monetary amounts, and
;; percentages will be expressed as rationnals: 16 % = 16/100
;;
;; 123.45 € = 12345 ¢ = #978m123.45
;;
;; In addition monetary amounts are tagged with a currency, and
;; arithmetic operations are type-restricted.
;;
;; The reader syntax is: # [currency-code] m|M [+|-] digit+ [ . digit* ]
;; The currency code must be a numeric code of a currency found
;; in (com.informatimago.common-lisp.iso4217:get-currencies),
;; otherwise a read-time error is issued.
;; When the currency-code is not present, the currency designated
;; by *DEFAULT-CURRENCY* is used.
;; The number of digits after the decimal point must not be superior
;; to the minor unit attribute of the currency.
;; The value is converted to an integer number of minor unit and
;; the read result is an AMOUNT structure gathering the currency
;; and the value.
;;
;; The operations defined on AMOUNT values are:
;;
;; c: amount* --> boolean
;; with c in { <, <=, >, >=, =, /= }.
;;
;; +: amount* --> amount
;; -: amount* --> amount
;; *: amount X real* --> amount (commutatif and associatif)
;; /: amount X real* --> amount (not commutatif and not associatif)
;;
;; [ set* = Kleene closure of the set ]
;;
;; For now, all these operations work only when the currency of all amount
;; involved is the same.
;;
;; These Common-Lisp operators are shadowed, and functions are defined for
;; them, that extend the normal numeric functions for amounts.
;;
;; The AMOUNT structure has a printer that prints different format
;; depending on the *PRINT-READABLY*. It uses the reader syntax defined
;; above when *PRINT-READABLY* is true, or a "~V$ ~3A" format printing
;; the value followed by the alphabetic code of the currency.
(DEFSTRUCT (AMOUNT (:PREDICATE AMOUNTP) (:PRINT-OBJECT PRINT-OBJECT))
"An amount of money."
CURRENCY
(VALUE 0 :TYPE INTEGER))
(DEFMETHOD PRINT-OBJECT ((SELF AMOUNT) STREAM)
(IF *PRINT-READABLY*
(FORMAT STREAM "#~DM~V$"
(CURRENCY-NUMERIC-CODE (AMOUNT-CURRENCY SELF))
(CURRENCY-MINOR-UNIT (AMOUNT-CURRENCY SELF))
(AMOUNT-MAGNITUDE SELF))
(FORMAT STREAM "~V$ ~A"
(CURRENCY-MINOR-UNIT (AMOUNT-CURRENCY SELF))
(AMOUNT-MAGNITUDE SELF)
(CURRENCY-ALPHABETIC-CODE (AMOUNT-CURRENCY SELF))))
SELF);;PRINT-OBJECT
(DEFMETHOD CURRENCY ((SELF number))
nil)
(DEFMETHOD CURRENCY ((SELF AMOUNT))
(AMOUNT-CURRENCY SELF))
(defmethod amount-magnitude ((self number))
self)
(defmethod AMOUNT-MAGNITUDE ((SELF amount))
"
RETURN: A real equal to the value of the amount.
"
(* (AMOUNT-VALUE SELF)
(AREF #(1 1/10 1/100 1/1000 1/10000)
(CURRENCY-MINOR-UNIT (AMOUNT-CURRENCY SELF)))))
(DEFPARAMETER *ZERO-AMOUNTS* (MAKE-HASH-TABLE :TEST (FUNCTION EQ))
"A cache of 0 amount for the various currencies used.")
(DEFUN AMOUNT-ZERO (CURRENCY)
"
RETURN: A null amount of the given currency.
"
(LET ((ZERO (GETHASH (FIND-CURRENCY CURRENCY) *ZERO-AMOUNTS*)))
(UNLESS ZERO
(SETF ZERO
(SETF (GETHASH (FIND-CURRENCY CURRENCY) *ZERO-AMOUNTS*)
(MAKE-AMOUNT :CURRENCY (FIND-CURRENCY CURRENCY) :VALUE 0))))
ZERO));;AMOUNT-ZERO
(DEFMETHOD ABS ((SELF NUMBER)) (COMMON-LISP:ABS SELF))
(DEFMETHOD ABS ((SELF AMOUNT))
(MAKE-AMOUNT :CURRENCY (AMOUNT-CURRENCY SELF)
:VALUE (COMMON-LISP:ABS (AMOUNT-VALUE SELF))))
(DEFMETHOD ZEROP ((SELF NUMBER)) (COMMON-LISP:ZEROP SELF))
(DEFMETHOD ZEROP ((SELF AMOUNT)) (COMMON-LISP:ZEROP (AMOUNT-VALUE SELF)))
(DEFMETHOD POSITIVEP ((SELF NUMBER)) (COMMON-LISP:<= 0 SELF))
(DEFMETHOD POSITIVEP ((SELF AMOUNT)) (COMMON-LISP:<= 0 (AMOUNT-VALUE SELF)))
(DEFMETHOD NEGATIVEP ((SELF NUMBER)) (COMMON-LISP:> 0 SELF))
(DEFMETHOD NEGATIVEP ((SELF AMOUNT)) (COMMON-LISP:> 0 (AMOUNT-VALUE SELF)))
(DEFMETHOD ROUND ((SELF REAL) &OPTIONAL (DIVISOR 1))
(COMMON-LISP:ROUND SELF DIVISOR))
(DEFMETHOD ROUND ((SELF AMOUNT) &OPTIONAL (DIVISOR 1))
(MAKE-AMOUNT :CURRENCY (AMOUNT-CURRENCY SELF)
:VALUE (COMMON-LISP:ROUND (AMOUNT-VALUE SELF) DIVISOR)))
(DEFUN EURO-ROUND (MAGNITUDE CURRENCY)
"
MAGNITUDE: A REAL
CURRENCY: The currency of the amount.
RETURN: An integer in minor unit rounded according to the Euro rule."
(LET ((ROUNDER (AREF #(1 1/10 1/100 1/1000 1/10000)
(CURRENCY-MINOR-UNIT CURRENCY))))
(ROUND (+ MAGNITUDE (* (SIGNUM MAGNITUDE) (/ ROUNDER 10))) ROUNDER)))
(DEFUN EURO-VALUE-ROUND (VALUE)
"
VALUE: A REAL
CURRENCY: The currency of the amount.
RETURN: An integer in minor unit rounded according to the Euro rule."
(ROUND (+ VALUE (* (SIGNUM VALUE) 1/10))));;EURO-VALUE-ROUND
;; (with-output-to-string (out)
;; (dolist (*print-readably* '(t nil))
;; (print (make-amount :currency (find-currency :EUR) :value 12345) out)))
(define-condition multi-currency-error (error)
((format-control :initarg :format-control :accessor format-control)
(format-arguments :initarg :format-arguments :accessor format-arguments)
(operation :initarg :operation :accessor multi-currency-error-operation)
(amounts :initarg :amounts :accessor multi-currency-error-amounts))
(:report (lambda (self stream)
(let ((*print-pretty* nil))
(format stream "~A: (~A ~{~A~^, ~})~%~A"
(class-name (class-of self))
(multi-currency-error-operation self)
(multi-currency-error-amounts self)
(apply (function format) nil (format-control self)
(format-arguments self)))))))
(defun mcerror (operation amounts format-control &rest format-arguments)
(ERROR 'multi-currency-error
:operation operation :amounts amounts
:format-control format-control
:format-arguments format-arguments))
(defun types-of-arguments (args)
(labels ((display
(item)
(cond ((symbolp item) (symbol-name item))
((atom item) item)
(t (mapcar (function display) item)))))
(mapcar (lambda (arg) (display (type-of arg))) args)))
(DEFMACRO MAKE-COMPARISON-METHOD (NAME OPERATOR)
"
DO: Generate a comparison method.
"
`(DEFUN ,NAME (&REST ARGS)
(COND
((EVERY (FUNCTION NUMBERP) ARGS)
(APPLY (FUNCTION ,OPERATOR) ARGS))
((EVERY (FUNCTION AMOUNTP) ARGS)
(LET ((CURRENCY (FIND-CURRENCY (AMOUNT-CURRENCY (FIRST ARGS)))))
(IF (EVERY (LAMBDA (X) (EQ CURRENCY (FIND-CURRENCY (AMOUNT-CURRENCY X))))
(CDR ARGS))
(APPLY (FUNCTION ,OPERATOR) (MAPCAR (FUNCTION AMOUNT-VALUE) ARGS))
(mcerror ',name args "Comparison not implemented yet."))))
(T (mcerror ',name args "Incompatible types: ~A"
(types-of-arguments args))))))
(MAKE-COMPARISON-METHOD < COMMON-LISP:<)
(MAKE-COMPARISON-METHOD <= COMMON-LISP:<=)
(MAKE-COMPARISON-METHOD > COMMON-LISP:>)
(MAKE-COMPARISON-METHOD >= COMMON-LISP:>=)
(MAKE-COMPARISON-METHOD = COMMON-LISP:=)
(MAKE-COMPARISON-METHOD /= COMMON-LISP:/=)
(DEFUN + (&REST ARGS)
"
DO: A Generic addition with numbers or amounts.
"
(setf args (remove 0 args
:key (lambda (x) (if (typep x 'amount) (amount-value x) x))
:test (function equal)))
(COND
((EVERY (FUNCTION NUMBERP) ARGS)
(APPLY (FUNCTION COMMON-LISP:+) ARGS))
((EVERY (FUNCTION AMOUNTP) ARGS)
(LET ((CURRENCY (FIND-CURRENCY (AMOUNT-CURRENCY (FIRST ARGS)))))
(IF (EVERY (LAMBDA (X) (EQ CURRENCY (FIND-CURRENCY (AMOUNT-CURRENCY X))))
(CDR ARGS))
(MAKE-AMOUNT :CURRENCY CURRENCY
:VALUE (APPLY (FUNCTION COMMON-LISP:+)
(MAPCAR (FUNCTION AMOUNT-VALUE) ARGS)))
(mcerror '+ args "Addtion not implemented yet."))))
(T (mcerror '+ args "Incompatible types: ~A" (types-of-arguments args)))))
(DEFUN - (&REST ARGS)
"
DO: A Generic substraction with numbers or amounts.
"
(setf args (cons (car args)
(remove 0 (cdr args)
:key (lambda (x) (if (typep x 'amount) (amount-value x) x))
:test (function equal))))
(COND
((EVERY (FUNCTION NUMBERP) ARGS)
(APPLY (FUNCTION COMMON-LISP:-) ARGS))
((zerop (first args))
(- (apply (function +) (rest args))))
((EVERY (FUNCTION AMOUNTP) ARGS)
(LET ((CURRENCY (FIND-CURRENCY (AMOUNT-CURRENCY (FIRST ARGS)))))
(IF (EVERY (LAMBDA (X) (EQ CURRENCY (FIND-CURRENCY (AMOUNT-CURRENCY X))))
(CDR ARGS))
(MAKE-AMOUNT :CURRENCY CURRENCY
:VALUE (APPLY (FUNCTION COMMON-LISP:-)
(MAPCAR (FUNCTION AMOUNT-VALUE) ARGS)))
(mcerror '- args "Substraction not implemented yet."))))
(T (mcerror '- args "Incompatible types: ~A" (types-of-arguments args)))))
(DEFUN * (&REST ARGS)
"
DO: A Generic multiplication with numbers or amounts.
"
(IF (EVERY (FUNCTION NUMBERP) ARGS)
(APPLY (FUNCTION COMMON-LISP:*) ARGS)
(LET ((P (POSITION-IF (FUNCTION AMOUNTP) ARGS)))
(COND
((OR (NULL P) (NOT (EVERY (LAMBDA (X) (OR (AMOUNTP X)(REALP X))) ARGS)))
(mcerror '* args "Incompatible types: ~A" (types-of-arguments args)))
((POSITION-IF (FUNCTION AMOUNTP) ARGS :START (1+ P))
(mcerror '* args "Cannot multiply moneys."))
(T
(MAKE-AMOUNT
:CURRENCY (AMOUNT-CURRENCY (NTH P ARGS))
:VALUE (EURO-VALUE-ROUND
(APPLY (FUNCTION COMMON-LISP:*)
(MAPCAR (LAMBDA (X) (IF (AMOUNTP X) (AMOUNT-VALUE X) X))
ARGS)))))))))
(DEFUN / (&REST ARGS)
"
DO: A Generic division with numbers or amounts.
"
(COND
((EVERY (FUNCTION NUMBERP) ARGS)
(APPLY (FUNCTION COMMON-LISP:/) ARGS))
((and (cadr args)
(not (cddr args)) ; two arguments
(amountp (first args))
(amountp (second args))) ; both amounts
;; then return a number:
(/ (amount-value (first args)) (amount-value (second args))))
((AND (AMOUNTP (CAR ARGS))
(CDR ARGS) ;; cannot take the inverse of an amount!
(EVERY (FUNCTION REALP) (CDR ARGS)))
(MAKE-AMOUNT
:CURRENCY (AMOUNT-CURRENCY (CAR ARGS))
:VALUE (EURO-VALUE-ROUND (APPLY (FUNCTION COMMON-LISP:/)
(AMOUNT-VALUE (CAR ARGS)) (CDR ARGS)))))
(T (mcerror '/ args "Incompatible types: ~A" (types-of-arguments args)))))
(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
(DEFUN CURRENCY-SYNTAX (STREAM CHAR INFIX)
(DECLARE (IGNORE CHAR))
(LET ((CURRENCY (OR INFIX *DEFAULT-CURRENCY*)))
(SETF CURRENCY (FIND-CURRENCY CURRENCY))
(UNLESS CURRENCY
(mcerror 'currency-syntax (OR INFIX *DEFAULT-CURRENCY*)
"Invalid currency designator ~S" (OR INFIX *DEFAULT-CURRENCY*)))
(ASSERT (<= 0 (CURRENCY-MINOR-UNIT CURRENCY) 4) ()
"Unexpected minor unit for currency: ~S" CURRENCY)
(LET ((LEFT '())
(RIGHT '())
(DOT NIL)
(SIGN 1))
(LET ((CH (READ-CHAR STREAM NIL NIL)))
(COND
((NULL CH))
((CHAR= CH (CHARACTER "-" )) (SETF SIGN -1))
((CHAR= CH (CHARACTER "+" )))
(T (UNREAD-CHAR CH STREAM))))
(LOOP FOR CH = (PEEK-CHAR NIL STREAM NIL NIL)
WHILE (AND CH (DIGIT-CHAR-P CH))
DO (PUSH (READ-CHAR STREAM) LEFT)
FINALLY (SETF DOT (AND CH (CHAR= (CHARACTER ".") CH))))
(WHEN (ZEROP (LENGTH LEFT))
(mcerror 'currency-syntax currency "Missing an amount after #M"))
(WHEN DOT
(WHEN (ZEROP (CURRENCY-MINOR-UNIT CURRENCY))
(mcerror 'currency-syntax currency
"There is no decimal point in ~A" (CURRENCY-NAME CURRENCY)))
(READ-CHAR STREAM) ;; eat the dot
(LOOP FOR CH = (PEEK-CHAR NIL STREAM NIL NIL)
WHILE (AND CH (DIGIT-CHAR-P CH))
DO (PUSH (READ-CHAR STREAM) RIGHT))
(WHEN (< (CURRENCY-MINOR-UNIT CURRENCY) (LENGTH RIGHT))
(mcerror 'currency-syntax currency
"Too many digits after the decimal point for ~A"
(CURRENCY-NAME CURRENCY))))
(LOOP FOR I FROM (LENGTH RIGHT) BELOW (CURRENCY-MINOR-UNIT CURRENCY)
DO (PUSH (CHARACTER "0") RIGHT))
(MAKE-AMOUNT
:CURRENCY CURRENCY
;; (WITH-STANDARD-IO-SYNTAX
;; (INTERN (CURRENCY-ALPHABETIC-CODE CURRENCY) "KEYWORD"))
:VALUE (* SIGN (PARSE-INTEGER
(MAP 'STRING (FUNCTION IDENTITY)
(NREVERSE (NCONC RIGHT LEFT)))))
;;:divisor (AREF #(1 10 100 1000 10000)
;; (CURRENCY-MINOR-UNIT CURRENCY))
)))) ;;currency-syntax
(DEFPARAMETER *CURRENCY-READTABLE* (COPY-READTABLE *READTABLE*)
"The readtable used to read currencies.")
(SET-DISPATCH-MACRO-CHARACTER #\# #\M (FUNCTION CURRENCY-SYNTAX)
*CURRENCY-READTABLE*)
(SET-DISPATCH-MACRO-CHARACTER #\# #\M (FUNCTION CURRENCY-SYNTAX)
*CURRENCY-READTABLE*)
) ;;eval-when
--
__Pascal Bourguignon__ http://www.informatimago.com/
The mighty hunter
Returns with gifts of plump birds,
Your foot just squashed one.
.
- References:
- How to xor?
- From: Philippe Lorin
- Re: How to xor?
- From: Russell McManus
- Re: How to xor?
- From: Hannah Schroeter
- Re: How to xor?
- From: Kent M Pitman
- Re: How to xor?
- From: Paul F. Dietz
- Re: How to xor?
- From: Kent M Pitman
- Re: How to xor?
- From: Marcin 'Qrczak' Kowalczyk
- Re: How to xor?
- From: Sam Steingold
- Re: How to xor?
- From: Marcin 'Qrczak' Kowalczyk
- How to xor?
- Prev by Date: Re: Beyond CL?
- Next by Date: Re: How do you imagine future Common Lisp standard ?
- Previous by thread: Re: How to xor?
- Next by thread: Re: How to xor?
- Index(es):
Relevant Pages
|
