123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472 |
- #| -*-Scheme-*-
- Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
- Institute of Technology
- This file is part of MIT/GNU Scheme.
- MIT/GNU Scheme is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or (at
- your option) any later version.
- MIT/GNU Scheme is distributed in the hope that it will be useful, but
- WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with MIT/GNU Scheme; if not, write to the Free Software
- Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
- USA.
- |#
- ;;;; Primitive Generic Operation Declarations
- (declare (usual-integrations))
- ;;; Unary Operators
- (define g:type (make-generic-operator 1 'type))
- (define g:type-predicate (make-generic-operator 1 'type-predicate))
- (define g:arity (make-generic-operator 1 'arity (lambda (x) #f)))
- (define g:inexact?
- (make-generic-operator 1 'inexact?))
- (define g:zero-like
- (make-generic-operator 1 'zero-like (lambda (x) :zero)))
- (define g:one-like
- (make-generic-operator 1 'one-like (lambda (x) :one)))
- (define g:identity-like
- (make-generic-operator 1 'identity-like (lambda (x) g:identity)))
- ;;; Generic tests are conservative.
- ;;; They will return #f unless the answer is known true.
- (define generic:zero?
- (make-generic-operator 1 'zero? (lambda (x) #f)))
- (define (g:zero? x)
- (if (number? x) (exact-zero? x) (generic:zero? x)))
- (define generic:one? (make-generic-operator 1 'one? (lambda (x) #f)))
- (define (g:one? x)
- (if (number? x) (exact-one? x) (generic:one? x)))
- (define g:identity? (make-generic-operator 1 'identity? (lambda (x) #f)))
- (define g:negate (make-generic-operator 1 'negate))
- (define g:invert (make-generic-operator 1 'invert))
- (define g:square (make-generic-operator 1 'square (lambda (x) (g:* x x))))
- (define g:sqrt (make-generic-operator 1 'sqrt))
- (define g:exp (make-generic-operator 1 'exp))
- (define g:log (make-generic-operator 1 'log))
- (define g:sin (make-generic-operator 1 'sin))
- (define g:cos (make-generic-operator 1 'cos))
- (define g:asin (make-generic-operator 1 'asin))
- (define g:acos (make-generic-operator 1 'acos))
- (define g:sinh (make-generic-operator 1 'sinh))
- (define g:cosh (make-generic-operator 1 'cosh))
- (define g:abs (make-generic-operator 1 'abs))
- (define g:determinant (make-generic-operator 1 'determinant))
- ;;; FBE start: trace-both not defined
- ;; (define g:trace
- ;; (make-generic-operator 1
- ;; 'trace
- ;; ;;overlays system trace procedure trace-both
- ;; trace-both))
- (define g:trace
- (make-generic-operator 1 'trace))
- ;;; FBE end
- (define* (g:transpose thing #:optional shape)
- (if (default-object? shape)
- (g:transpose-1-arg thing)
- (s:transpose1 thing shape)))
- (define g:transpose-1-arg
- (make-generic-operator 1 'transpose))
- ;;; FBE start: coordinate-system-dimension is defined in
- ;;; 'generic-environment'. We copy here the definition from
- ;;; calculus/manifold.scm.
- (define (coordinate-system coordinate-system-name patch)
- ((patch 'get-coordinate-system) coordinate-system-name))
- (define (coordinate-system-dimension coordinate-system)
- (coordinate-system 'dimension))
- ;;; FBE end.
- (define g:dimension
- (make-generic-operator 1
- 'dimension
- (lambda (x)
- ;;definition in calculus/manifold.scm
- (coordinate-system-dimension x))))
- (define g:solve-linear
- (make-generic-operator 2 'solve-linear))
- ;;; Duplicate of text in OPERATOR.SCM, except that the explicit type
- ;;; tag is here rather than the variable operator-type-tag. This is
- ;;; necessary because of a problem of load order.
- (define* (make-operator p #:optional name subtype arity #:rest opts)
- (if (default-object? name) (set! name #f))
- (if (default-object? subtype) (set! subtype #f))
- (if (default-object? arity) (set! arity (procedure-arity p)))
- (make-apply-hook p `(*operator* ,subtype ,name ,arity ,@opts)))
- (define generic:partial-derivative
- (make-generic-operator 2 'partial-derivative))
- (define g:derivative
- (make-operator
- (lambda (f)
- (generic:partial-derivative f '()))
- 'derivative))
- (define (g:partial-derivative f . varspecs)
- (generic:partial-derivative f varspecs))
- (define (g:partial . varspecs)
- (make-operator
- (lambda (f)
- (generic:partial-derivative f varspecs))
- `(partial ,@varspecs)))
- ;;; Binary Operators
- (define generic:= (make-generic-operator 2 '= (lambda (x y) #f)))
- (define (g:=:bin x y)
- (if (and (number? x) (number? y)) (= x y) (generic:= x y)))
- (define generic:< (make-generic-operator 2 '< (lambda (x y) #f)))
- (define (g:<:bin x y)
- (if (and (number? x) (number? y)) (< x y) (generic:< x y)))
-
- (define generic:<= (make-generic-operator 2 '<= (lambda (x y) #f)))
- (define (g:<=:bin x y)
- (if (and (number? x) (number? y)) (<= x y) (generic:<= x y)))
- (define generic:> (make-generic-operator 2 '> (lambda (x y) #f)))
- (define (g:>:bin x y)
- (if (and (number? x) (number? y)) (> x y) (generic:> x y)))
- (define generic:>= (make-generic-operator 2 '>= (lambda (x y) #f)))
- (define (g:>=:bin x y)
- (if (and (number? x) (number? y)) (>= x y) (generic:>= x y)))
- (define generic:+ (make-generic-operator 2 '+))
- (define (g:+:bin x y)
- (cond ((and (number? x) (number? y)) (+ x y))
- ((g:zero? x) y)
- ((g:zero? y) x)
- (else (generic:+ x y))))
- (define generic:- (make-generic-operator 2 '-))
- (define (g:-:bin x y)
- (cond ((and (number? x) (number? y)) (- x y))
- ((g:zero? y) x)
- ((g:zero? x) (g:negate y))
- (else (generic:- x y))))
- (define generic:* (make-generic-operator 2 '*))
- (define (g:*:bin x y)
- (cond ((and (number? x) (number? y)) (* x y))
- ((exact-zero? x) (g:zero-like y))
- ((exact-zero? y) (g:zero-like x))
- ((g:one? x) y)
- ((g:one? y) x)
- (else (generic:* x y))))
- ;;; In g:*:bin we test for exact (numerical) zero
- ;;; because it is possible to produce a wrong-type
- ;;; zero here, as follows:
- ;;; |0| |0|
- ;;; |a b c| |0| |0| |0|
- ;;; |d e f| |0| = |0|, not |0|
- ;;; We are less worried about the zero? below,
- ;;; because any invertible matrix is square.
- (define generic:/ (make-generic-operator 2 '/))
- (define (g:/:bin x y)
- (cond ((and (number? x) (number? y)) (/ x y))
- ;; ((g:zero? x) (g:zero-like y)) ; Ancient bug! No consequence.
- ;; ((g:zero? x) x)
- ((g:one? y) x)
- (else (generic:/ x y))))
- (define generic:expt (make-generic-operator 2 'expt))
- (define (g:expt x y)
- (cond ((and (number? x) (number? y)) (n:expt x y))
- ;;((g:zero? x) x) ;No! consider 0^{-1}
- ((g:one? x) x)
- ((g:zero? y) (g:one-like x))
- ((g:one? y) x)
- (else (generic:expt x y))))
- (define g:gcd:bin (make-generic-operator 2 'gcd))
- (define g:dot-product (make-generic-operator 2 'dot-product))
- (define g:cross-product (make-generic-operator 2 'cross-product))
- (define g:outer-product (make-generic-operator 2 'outer-product))
- ;;; Complex Operators
- (define g:make-rectangular (make-generic-operator 2 'make-rectangular))
- (define g:make-polar (make-generic-operator 2 'make-polar))
- (define g:real-part (make-generic-operator 1 'real-part))
- (define g:imag-part (make-generic-operator 1 'imag-part))
- (define g:magnitude (make-generic-operator 1 'magnitude))
- (define g:angle (make-generic-operator 1 'angle))
- (define g:conjugate (make-generic-operator 1 'conjugate))
- ;;; Weird operators
- (define* (g:atan y #:optional x)
- (if (default-object? x) (g:atan1 y) (g:atan2 y x)))
- (define g:atan1 (make-generic-operator 1 'atan1))
- (define g:atan2 (make-generic-operator 2 'atan2))
- (define generic:apply (make-generic-operator 2 'apply))
- (define (g:apply f . apply-args)
- (define (collapse l)
- (if (null? (cdr l))
- (car l)
- (cons (car l)
- (collapse (cdr l)))))
- (if (null? apply-args)
- (error "No argument list for G:APPLY")
- (let ((args (collapse apply-args)))
- (cond ((procedure? f)
- (apply f args))
- ((applicable-literal? f)
- (apply
- (literal-function f
- (permissive-function-type (length args)))
- args))
- #|
- ((eq? f second)
- (apply (access second system-global-environment)
- args))
- |#
- (else
- (generic:apply f args))))))
- (define (applicable-literal? f)
- ;; FBE
- ;; (and (symbol? f) *enable-literal-apply*)
- (and (symbol? f) (*enable-literal-apply*)))
- ;;; *enable-literal-apply* is modulated by with-literal-apply-enabled.
- ;;; This procedure is defined in extapply.scm.
- ;;; This feature is used explicitly in ode/interface.scm.
- ;;; N-ary Operator extensions
- (define (g:= . args)
- (g:=:n args))
- (define (g:=:n args)
- (cond ((null? args) #t)
- ((null? (cdr args)) #t)
- (else
- (let lp ((args (cddr args))
- (larg (cadr args))
- (ans (g:=:bin (car args) (cadr args))))
- (if (null? args)
- ans
- (lp (cdr args)
- (car args)
- (and ans (g:=:bin larg (car args)))))))))
- (define (g:< . args)
- (g:<:n args))
- (define (g:<:n args)
- (cond ((null? args) #t)
- ((null? (cdr args)) #t)
- (else
- (let lp ((args (cddr args))
- (larg (cadr args))
- (ans (g:<:bin (car args) (cadr args))))
- (if (null? args)
- ans
- (lp (cdr args)
- (car args)
- (and ans (g:<:bin larg (car args)))))))))
- (define (g:<= . args)
- (g:<=:n args))
- (define (g:<=:n args)
- (cond ((null? args) #t)
- ((null? (cdr args)) #t)
- (else
- (let lp ((args (cddr args))
- (larg (cadr args))
- (ans (g:<=:bin (car args) (cadr args))))
- (if (null? args)
- ans
- (lp (cdr args)
- (car args)
- (and ans (g:<=:bin larg (car args)))))))))
- (define (g:> . args)
- (g:>:n args))
- (define (g:>:n args)
- (cond ((null? args) #t)
- ((null? (cdr args)) #t)
- (else
- (let lp ((args (cddr args))
- (larg (cadr args))
- (ans (g:>:bin (car args) (cadr args))))
- (if (null? args)
- ans
- (lp (cdr args)
- (car args)
- (and ans (g:>:bin larg (car args)))))))))
- (define (g:>= . args)
- (g:>=:n args))
- (define (g:>=:n args)
- (cond ((null? args) #t)
- ((null? (cdr args)) #t)
- (else
- (let lp ((args (cddr args))
- (larg (cadr args))
- (ans (g:>=:bin (car args) (cadr args))))
- (if (null? args)
- ans
- (lp (cdr args)
- (car args)
- (and ans (g:>=:bin larg (car args)))))))))
- (define (g:+ . args)
- (g:+:n args))
- (define (g:+:n args)
- (cond ((null? args) :zero)
- ((null? (cdr args)) (car args))
- (else
- (let lp ((args (cddr args))
- (ans (g:+:bin (car args) (cadr args))))
- (if (null? args)
- ans
- (lp (cdr args)
- (g:+:bin ans (car args))))))))
- (define (g:* . args)
- (g:*:n args))
- (define (g:*:n args)
- (cond ((null? args) :one)
- ((null? (cdr args)) (car args))
- (else
- (let lp ((args (cddr args))
- (ans (g:*:bin (car args) (cadr args))))
- (if (null? args)
- ans
- (lp (cdr args)
- (g:*:bin ans (car args))))))))
- (define (g:- . args)
- (g:-:n args))
- (define (g:-:n args)
- (cond ((null? args) :zero)
- ((null? (cdr args)) (g:negate (car args)))
- (else
- (g:-:bin (car args)
- (g:+:n (cdr args))))))
- (define (g:/ . args)
- (g:/:n args))
- (define (g:/:n args)
- (cond ((null? args) :one)
- ((null? (cdr args)) (g:invert (car args)))
- (else
- (g:/:bin (car args)
- (g:*:n (cdr args))))))
- (define (g:gcd . args)
- (g:gcd:n args))
- (define (g:gcd:n args)
- (cond ((null? args) :zero)
- ((null? (cdr args)) (car args))
- (else
- (let lp
- ((as (cddr args))
- (ans (g:gcd:bin (car args) (cadr args))))
- (cond ((null? as) ans)
- ((g:one? ans) ans)
- (else
- (lp (cdr as) (g:gcd:bin ans (car as)))))))))
|