Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Migrated generic.arithmetic

  • Loading branch information...
commit 6d228200b9c28bc4baa0cabf2564484adb5f096a 1 parent 42134c6
@khinsen khinsen authored
View
201 src/main/clojure/clojure/algo/generic/arithmetic.clj
@@ -0,0 +1,201 @@
+;; Generic interfaces for arithmetic operations
+
+;; by Konrad Hinsen
+
+;; Copyright (c) Konrad Hinsen, 2009-2011. All rights reserved. The use
+;; and distribution terms for this software are covered by the Eclipse
+;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this
+;; distribution. By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license. You must not
+;; remove this notice, or any other, from this software.
+
+(ns
+ ^{:author "Konrad Hinsen"
+ :doc "Generic arithmetic interface
+ This library defines generic versions of + - * / as multimethods
+ that can be defined for any type. The minimal required
+ implementations for a type are binary + and * plus unary - and /.
+ Everything else is derived from these automatically. Explicit
+ binary definitions for - and / can be provided for
+ efficiency reasons."}
+ clojure.algo.generic.arithmetic
+ (:use [clojure.algo.generic
+ :only (root-type nulary-type nary-type nary-dispatch)])
+ (:refer-clojure :exclude [+ - * /]))
+
+;
+; Universal zero and one values
+;
+(defrecord zero-type [])
+(derive zero-type root-type)
+(def zero (new zero-type))
+
+(defrecord one-type [])
+(derive one-type root-type)
+(def one (new one-type))
+
+;
+; Addition
+;
+; The minimal implementation is for binary my-type. It is possible
+; in principle to implement [::unary my-type] as well, though this
+; doesn't make any sense.
+;
+(defmulti +
+ "Return the sum of all arguments. The minimal implementation for type
+ ::my-type is the binary form with dispatch value [::my-type ::my-type]."
+ {:arglists '([x] [x y] [x y & more])}
+ nary-dispatch)
+
+(defmethod + nulary-type
+ []
+ zero)
+
+(defmethod + root-type
+ [x] x)
+
+(defmethod + [root-type zero-type]
+ [x y] x)
+
+(defmethod + [zero-type root-type]
+ [x y] y)
+
+(defmethod + nary-type
+ [x y & more]
+ (if more
+ (recur (+ x y) (first more) (next more))
+ (+ x y)))
+
+;
+; Subtraction
+;
+; The minimal implementation is for unary my-type. A default binary
+; implementation is provided as (+ x (- y)), but it is possible to
+; implement unary my-type explicitly for efficiency reasons.
+;
+(defmulti -
+ "Return the difference of the first argument and the sum of all other
+ arguments. The minimal implementation for type ::my-type is the binary
+ form with dispatch value [::my-type ::my-type]."
+ {:arglists '([x] [x y] [x y & more])}
+ nary-dispatch)
+
+(defmethod - nulary-type
+ []
+ (throw (java.lang.IllegalArgumentException.
+ "Wrong number of arguments passed")))
+
+(defmethod - [root-type zero-type]
+ [x y] x)
+
+(defmethod - [zero-type root-type]
+ [x y] (- y))
+
+(defmethod - [root-type root-type]
+ [x y] (+ x (- y)))
+
+(defmethod - nary-type
+ [x y & more]
+ (if more
+ (recur (- x y) (first more) (next more))
+ (- x y)))
+
+;
+; Multiplication
+;
+; The minimal implementation is for binary [my-type my-type]. It is possible
+; in principle to implement unary my-type as well, though this
+; doesn't make any sense.
+;
+(defmulti *
+ "Return the product of all arguments. The minimal implementation for type
+ ::my-type is the binary form with dispatch value [::my-type ::my-type]."
+ {:arglists '([x] [x y] [x y & more])}
+ nary-dispatch)
+
+(defmethod * nulary-type
+ []
+ one)
+
+(defmethod * root-type
+ [x] x)
+
+(defmethod * [root-type one-type]
+ [x y] x)
+
+(defmethod * [one-type root-type]
+ [x y] y)
+
+(defmethod * nary-type
+ [x y & more]
+ (if more
+ (recur (* x y) (first more) (next more))
+ (* x y)))
+
+;
+; Division
+;
+; The minimal implementation is for unary my-type. A default binary
+; implementation is provided as (* x (/ y)), but it is possible to
+; implement binary [my-type my-type] explicitly for efficiency reasons.
+;
+(defmulti /
+ "Return the quotient of the first argument and the product of all other
+ arguments. The minimal implementation for type ::my-type is the binary
+ form with dispatch value [::my-type ::my-type]."
+ {:arglists '([x] [x y] [x y & more])}
+ nary-dispatch)
+
+(defmethod / nulary-type
+ []
+ (throw (java.lang.IllegalArgumentException.
+ "Wrong number of arguments passed")))
+
+(defmethod / [root-type one-type]
+ [x y] x)
+
+(defmethod / [one-type root-type]
+ [x y] (/ y))
+
+(defmethod / [root-type root-type]
+ [x y] (* x (/ y)))
+
+(defmethod / nary-type
+ [x y & more]
+ (if more
+ (recur (/ x y) (first more) (next more))
+ (/ x y)))
+
+;
+; Macros to permit access to the / multimethod via namespace qualification
+;
+(defmacro defmethod*
+ "Define a method implementation for the multimethod name in namespace ns.
+ Required for implementing the division function from another namespace."
+ [ns name & args]
+ (let [qsym (symbol (str ns) (str name))]
+ `(defmethod ~qsym ~@args)))
+
+(defmacro qsym
+ "Create the qualified symbol corresponding to sym in namespace ns.
+ Required to access the division function from another namespace,
+ e.g. as (qsym clojure.algo.generic.arithmetic /)."
+ [ns sym]
+ (symbol (str ns) (str sym)))
+
+;
+; Minimal implementations for java.lang.Number
+;
+(defmethod + [java.lang.Number java.lang.Number]
+ [x y] (clojure.core/+ x y))
+
+(defmethod - java.lang.Number
+ [x] (clojure.core/- x))
+
+(defmethod * [java.lang.Number java.lang.Number]
+ [x y] (clojure.core/* x y))
+
+(defmethod / java.lang.Number
+ [x] (clojure.core// x))
+
View
175 src/test/clojure/clojure/algo/generic/test_arithmetic.clj
@@ -0,0 +1,175 @@
+;; Test routines for clojure.algo.generic.arithmetic
+
+;; Copyright (c) Konrad Hinsen, 2011. All rights reserved. The use
+;; and distribution terms for this software are covered by the Eclipse
+;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this
+;; distribution. By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license. You must not
+;; remove this notice, or any other, from this software.
+
+(ns clojure.algo.generic.test-arithmetic
+ (:use [clojure.test :only (deftest is are run-tests)]
+ [clojure.algo.generic :only (root-type)])
+ (:require [clojure.algo.generic.arithmetic :as ga]
+ [clojure.algo.generic.comparison :as gc]))
+
+; Define a basic complex number type
+(defrecord complex-number [real imag])
+
+(defn complex
+ [real imag]
+ (new complex-number real imag))
+
+(defn real
+ [c]
+ (:real c))
+
+(defn imag
+ [c]
+ (:imag c))
+
+; Minimal implementation of generic.comparison to facilitate testing
+(defmethod gc/zero? complex-number
+ [x]
+ (and (zero? (real x)) (zero? (imag x))))
+
+(defmethod gc/= [complex-number complex-number]
+ [x y]
+ (and (gc/= (real x) (real y))
+ (gc/= (imag x) (imag y))))
+
+(defmethod gc/= [complex-number root-type]
+ [x y]
+ (and (gc/zero? (imag x)) (gc/= (real x) y)))
+
+(defmethod gc/= [root-type complex-number]
+ [x y]
+ (and (gc/zero? (imag y)) (gc/= x (real y))))
+
+; Arithmetic
+(defmethod ga/+ [complex-number complex-number]
+ [x y]
+ (complex (ga/+ (real x) (real y)) (ga/+ (imag x) (imag y))))
+
+(defmethod ga/+ [complex-number root-type]
+ [x y]
+ (complex (ga/+ (real x) y) (imag x)))
+
+(defmethod ga/+ [root-type complex-number]
+ [x y]
+ (complex (ga/+ x (real y)) (imag y)))
+
+(defmethod ga/- complex-number
+ [x]
+ (complex (ga/- (real x)) (ga/- (imag x))))
+
+(defmethod ga/* [complex-number complex-number]
+ [x y]
+ (complex (ga/- (ga/* (real x) (real y)) (ga/* (imag x) (imag y)))
+ (ga/+ (ga/* (real x) (imag y)) (ga/* (imag x) (real y)))))
+
+(defmethod ga/* [complex-number root-type]
+ [x y]
+ (complex (ga/* (real x) y) (ga/* (imag x) y)))
+
+(defmethod ga/* [root-type complex-number]
+ [x y]
+ (complex (ga/* x (real y)) (ga/* x (imag y))))
+
+(ga/defmethod* ga / complex-number
+ [x]
+ (let [rx (real x)
+ ix (imag x)
+ den ((ga/qsym ga /) (ga/+ (ga/* rx rx) (ga/* ix ix)))]
+ (complex (ga/* rx den) (ga/- (ga/* ix den)))))
+
+; Complex number tests
+(deftest complex-addition
+ (is (gc/= (ga/+ (complex 1 2) (complex 1 2)) (complex 2 4)))
+ (is (gc/= (ga/+ (complex 1 2) (complex -3 -7)) (complex -2 -5)))
+ (is (gc/= (ga/+ (complex -3 -7) (complex 1 2)) (complex -2 -5)))
+ (is (gc/= (ga/+ (complex 1 2) 3) (complex 4 2)))
+ (is (gc/= (ga/+ 3 (complex 1 2)) (complex 4 2)))
+ (is (gc/= (ga/+ (complex -3 -7) (complex 1 2)) (complex -2 -5)))
+ (is (gc/= (ga/+ (complex 1 2) (complex -3 -7)) (complex -2 -5)))
+ (is (gc/= (ga/+ (complex -3 -7) (complex -3 -7)) (complex -6 -14)))
+ (is (gc/= (ga/+ (complex -3 -7) -1) (complex -4 -7)))
+ (is (gc/= (ga/+ -1 (complex -3 -7)) (complex -4 -7)))
+ (is (gc/= (ga/+ 3 (complex 1 2)) (complex 4 2)))
+ (is (gc/= (ga/+ (complex 1 2) 3) (complex 4 2)))
+ (is (gc/= (ga/+ -1 (complex -3 -7)) (complex -4 -7)))
+ (is (gc/= (ga/+ (complex -3 -7) -1) (complex -4 -7))))
+
+(deftest complex-subtraction
+ (is (gc/= (ga/- (complex 1 2) (complex 1 2)) 0))
+ (is (gc/= (ga/- (complex 1 2) (complex -3 -7)) (complex 4 9)))
+ (is (gc/= (ga/- (complex -3 -7) (complex 1 2)) (complex -4 -9)))
+ (is (gc/= (ga/- (complex 1 2) 3) (complex -2 2)))
+ (is (gc/= (ga/- 3 (complex 1 2)) (complex 2 -2)))
+ (is (gc/= (ga/- (complex 1 2) -1) (complex 2 2)))
+ (is (gc/= (ga/- -1 (complex 1 2)) (complex -2 -2)))
+ (is (gc/= (ga/- (complex -3 -7) (complex 1 2)) (complex -4 -9)))
+ (is (gc/= (ga/- (complex 1 2) (complex -3 -7)) (complex 4 9)))
+ (is (gc/= (ga/- (complex -3 -7) (complex -3 -7)) 0))
+ (is (gc/= (ga/- (complex -3 -7) 3) (complex -6 -7)))
+ (is (gc/= (ga/- 3 (complex -3 -7)) (complex 6 7)))
+ (is (gc/= (ga/- (complex -3 -7) -1) (complex -2 -7)))
+ (is (gc/= (ga/- -1 (complex -3 -7)) (complex 2 7)))
+ (is (gc/= (ga/- 3 (complex 1 2)) (complex 2 -2)))
+ (is (gc/= (ga/- (complex 1 2) 3) (complex -2 2)))
+ (is (gc/= (ga/- 3 (complex -3 -7)) (complex 6 7)))
+ (is (gc/= (ga/- (complex -3 -7) 3) (complex -6 -7)))
+ (is (gc/= (ga/- -1 (complex 1 2)) (complex -2 -2)))
+ (is (gc/= (ga/- (complex 1 2) -1) (complex 2 2)))
+ (is (gc/= (ga/- -1 (complex -3 -7)) (complex 2 7)))
+ (is (gc/= (ga/- (complex -3 -7) -1) (complex -2 -7))))
+
+(deftest complex-multiplication
+ (is (gc/= (ga/* (complex 1 2) (complex 1 2)) (complex -3 4)))
+ (is (gc/= (ga/* (complex 1 2) (complex -3 -7)) (complex 11 -13)))
+ (is (gc/= (ga/* (complex -3 -7) (complex 1 2)) (complex 11 -13)))
+ (is (gc/= (ga/* (complex 1 2) 3) (complex 3 6)))
+ (is (gc/= (ga/* 3 (complex 1 2)) (complex 3 6)))
+ (is (gc/= (ga/* (complex 1 2) -1) (complex -1 -2)))
+ (is (gc/= (ga/* -1 (complex 1 2)) (complex -1 -2)))
+ (is (gc/= (ga/* (complex -3 -7) (complex 1 2)) (complex 11 -13)))
+ (is (gc/= (ga/* (complex 1 2) (complex -3 -7)) (complex 11 -13)))
+ (is (gc/= (ga/* (complex -3 -7) (complex -3 -7)) (complex -40 42)))
+ (is (gc/= (ga/* (complex -3 -7) 3) (complex -9 -21)))
+ (is (gc/= (ga/* 3 (complex -3 -7)) (complex -9 -21)))
+ (is (gc/= (ga/* (complex -3 -7) -1) (complex 3 7)))
+ (is (gc/= (ga/* -1 (complex -3 -7)) (complex 3 7)))
+ (is (gc/= (ga/* 3 (complex 1 2)) (complex 3 6)))
+ (is (gc/= (ga/* (complex 1 2) 3) (complex 3 6)))
+ (is (gc/= (ga/* 3 (complex -3 -7)) (complex -9 -21)))
+ (is (gc/= (ga/* (complex -3 -7) 3) (complex -9 -21)))
+ (is (gc/= (ga/* -1 (complex 1 2)) (complex -1 -2)))
+ (is (gc/= (ga/* (complex 1 2) -1) (complex -1 -2)))
+ (is (gc/= (ga/* -1 (complex -3 -7)) (complex 3 7)))
+ (is (gc/= (ga/* (complex -3 -7) -1) (complex 3 7))))
+
+(let [div (ga/qsym ga /)]
+ (deftest complex-division
+ (is (gc/= (div (complex 1 2) (complex 1 2)) 1))
+ (is (gc/= (div (complex 1 2) (complex -3 -7)) (complex -17/58 1/58)))
+ (is (gc/= (div (complex -3 -7) (complex 1 2)) (complex -17/5 -1/5)))
+ (is (gc/= (div (complex 1 2) 3) (complex 1/3 2/3)))
+ (is (gc/= (div 3 (complex 1 2)) (complex 3/5 -6/5)))
+ (is (gc/= (div (complex 1 2) -1) (complex -1 -2)))
+ (is (gc/= (div -1 (complex 1 2)) (complex -1/5 2/5)))
+ (is (gc/= (div (complex -3 -7) (complex 1 2)) (complex -17/5 -1/5)))
+ (is (gc/= (div (complex 1 2) (complex -3 -7)) (complex -17/58 1/58)))
+ (is (gc/= (div (complex -3 -7) (complex -3 -7)) 1))
+ (is (gc/= (div (complex -3 -7) 3) (complex -1 -7/3)))
+ (is (gc/= (div 3 (complex -3 -7)) (complex -9/58 21/58)))
+ (is (gc/= (div (complex -3 -7) -1) (complex 3 7)))
+ (is (gc/= (div -1 (complex -3 -7)) (complex 3/58 -7/58)))
+ (is (gc/= (div 3 (complex 1 2)) (complex 3/5 -6/5)))
+ (is (gc/= (div (complex 1 2) 3) (complex 1/3 2/3)))
+ (is (gc/= (div 3 (complex -3 -7)) (complex -9/58 21/58)))
+ (is (gc/= (div (complex -3 -7) 3) (complex -1 -7/3)))
+ (is (gc/= (div -1 (complex 1 2)) (complex -1/5 2/5)))
+ (is (gc/= (div (complex 1 2) -1) (complex -1 -2)))
+ (is (gc/= (div -1 (complex -3 -7)) (complex 3/58 -7/58)))
+ (is (gc/= (div (complex -3 -7) -1) (complex 3 7)))))
Please sign in to comment.
Something went wrong with that request. Please try again.