104 lines
3.3 KiB

;;;; c o m p l e x . s t k l o s -- The documentation example
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; 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 []
;;;; 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))