104 lines
3.3 KiB
Plaintext
104 lines
3.3 KiB
Plaintext
;;;;
|
|
;;;; c o m p l e x . s t k l o s -- The documentation example
|
|
;;;;
|
|
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
;;;; Creation date: 20-Jan-1998 17:28
|
|
;;;; Last file update: 3-Sep-1999 20:08 (eg)
|
|
|
|
|
|
;;;;
|
|
;;;; This file corresponds to the example shown in the STklos documentation
|
|
;;;;
|
|
|
|
|
|
; ==== Class definition
|
|
|
|
(define-class <complex> (<number>)
|
|
(;; True slots use rectangular coordinates
|
|
(r :initform 0 :accessor real-part :init-keyword :r)
|
|
(i :initform 0 :accessor imag-part :init-keyword :i)
|
|
;; Virtual slots access do the conversion
|
|
(m :accessor magnitude :init-keyword :magn
|
|
:allocation :virtual
|
|
:slot-ref (lambda (o)
|
|
(let ((r (slot-ref o 'r)) (i (slot-ref o 'i)))
|
|
(sqrt (+ (* r r) (* i i)))))
|
|
:slot-set! (lambda (o m)
|
|
(let ((a (slot-ref o 'a)))
|
|
(slot-set! o 'r (* m (cos a)))
|
|
(slot-set! o 'i (* m (sin a))))))
|
|
(a :accessor angle :init-keyword :angle
|
|
:allocation :virtual
|
|
:slot-ref (lambda (o)
|
|
(atan (slot-ref o 'i) (slot-ref o 'r)))
|
|
:slot-set! (lambda(o a)
|
|
(let ((m (slot-ref o 'm)))
|
|
(slot-set! o 'r (* m (cos a)))
|
|
(slot-set! o 'i (* m (sin a))))))))
|
|
|
|
|
|
;==== The scheme MAKE-RECTANGULAR and MAKE-POLAR procedures
|
|
|
|
(define make-rectangular (lambda (x y) (make <complex> :r x :i y)))
|
|
|
|
(define make-polar (lambda (x y) (make <complex> :magn x :angle y)))
|
|
|
|
|
|
;==== Define methods to pretty print complex numbers
|
|
|
|
(define-method write-object ((c <complex>) port)
|
|
(format port "#.(make <complex> :r ~S :i ~S)" (real-part c) (imag-part c)))
|
|
|
|
(define-method display-object ((c <complex>) port)
|
|
(format port "~S+~Si" (real-part c) (imag-part c)))
|
|
|
|
;==== Define methods to compare complex numbers
|
|
|
|
(define-method object-eqv? ((a <complex>) (b <complex>))
|
|
(and (= (real-part a) (real-part b))
|
|
(= (imag-part a) (imag-part b))))
|
|
|
|
(define-method object-equal? ((a <complex>) (b <complex>))
|
|
(eqv? a b))
|
|
|
|
|
|
(define-generic new-+)
|
|
|
|
(let ((+ +))
|
|
(define-method new-+ ((a <real>) (b <real>)) (+ a b))
|
|
|
|
(define-method new-+ ((a <real>) (b <complex>))
|
|
(make-rectangular (+ a (real-part b)) (imag-part b)))
|
|
|
|
(define-method new-+ ((a <complex>) (b <real>))
|
|
(make-rectangular (+ (real-part a) b) (imag-part a)))
|
|
|
|
(define-method new-+ ((a <complex>) (b <complex>))
|
|
(make-rectangular (+ (real-part a) (real-part b))
|
|
(+ (imag-part a) (imag-part b))))
|
|
|
|
(define-method new-+ ((a <number>)) a)
|
|
|
|
(define-method new-+ () 0)
|
|
|
|
(define-method new-+ args (new-+ (car args) (apply new-+ (cdr args))))
|
|
)
|
|
|
|
(set! + new-+)
|
|
|
|
(define c1 (make <complex> :r 2 :i 3))
|
|
(define c2 (make <complex> :r 3 :i 4))
|
|
(define c3 (make-rectangular 3 2))
|
|
|