A1(dragon-curve 10)(defclass dragon-turtle (turtle)) (defmethod draw-dragon-curve ((this dragon-turtle) n) t (cond ((= n 0) (forward this 10)) ((> n 0) (progn (draw-dragon-curve this (- n 1)) (right this 90) (draw-dragon-curve this (- 1 n)))) (t (progn (draw-dragon-curve this (- 0 1 n)) (left this 90) (draw-dragon-curve this (+ 1 n)))))) (defproc dragon-curve (n) (let ((turtle (new dragon-turtle))) (progn (pen-down turtle) (draw-dragon-curve turtle n) (get-picture turtle))))complex7local:complexDieses Modul definiert eine Datenstruktur für komplexe Zahlen (complex), und die passenden Methoden für die Grundrechenarten (add, sub, times und quotient). Die Methoden real und imaginary greifen auf den Real- und Imaginärteil der Zahl zu. Die Funktion conjugate konjugiert eine komplexe Zahl. Die Methode zero? prüft, ob eine komplexe Zahl 0 ist. Die Methode approximate nähert eine komplexe Zahl auf eine angegebene Genauigkeit.complex initialize real imaginary add sub times quotient conjugate zero? approximate(defstruct complex (real imaginary) (and (number? real) (number? imaginary))) (defmethod simplify ((this complex)) t (if (zero? (. this imaginary)) (. this real) this)) (defmethod real (r) (number? r) r) (defmethod real ((this complex)) t (. this real)) (defmethod imaginary (r) (number? r) 0) (defmethod imaginary ((this complex)) t (. this imaginary)) (defmethod add ((this complex) (that complex)) t (simplify (new complex (+ (. this real) (. that real)) (+ (. this imaginary) (. that imaginary))))) (defmethod add ((this complex) r) (number? r) (add this (new complex r 0))) (defmethod add (r (this complex)) (number? r) (add (new complex r 0) this)) (defmethod sub ((this complex) (that complex)) t (simplify (new complex (- (. this real) (. that real)) (- (. this imaginary) (. that imaginary))))) (defmethod sub ((this complex) r) (number? r) (sub this (new complex r 0))) (defmethod sub (r (this complex)) (number? r) (sub (new complex r 0) this)) (defmethod times ((this complex) (that complex)) t (simplify (new complex (- (* (. this real) (. that real)) (* (. this imaginary) (. that imaginary))) (+ (* (. this real) (. that imaginary)) (* (. this imaginary) (. that real)))))) (defmethod times ((this complex) r) (number? r) (times this (new complex r 0))) (defmethod times (r (this complex)) (number? r) (times (new complex r 0) this)) (defmethod conjugate ((this complex)) t (if (zero? (. this imaginary)) (. this real) (new complex (. this real) (- (. this imaginary))))) (defmethod conjugate (r) (number? r) r) (defmethod quotient ((this complex) r) (number? r) (simplify (new complex (/ (. this real) r) (/ (. this imaginary) r)))) (defmethod quotient ((this complex) (that complex)) t (/ (* this (conjugate that)) (* that (conjugate that)))) (defmethod quotient (r (this complex)) (number? r) (quotient (new complex r 0) this)) (defmethod zero? ((this complex)) t (and (zero? (. this real)) (zero? (. this imaginary)))) (defmethod approximate ((this complex) precision) t (simplify (new complex (approximate (. this real) precision) (approximate (. this imaginary) precision))))square-root7local:square-rootDie Funktion square-root berechnet die Quadratwurzel einer positiven Zahl (erstes Argument) mit einer gewünschten Genauigkeit (zweites Argument).square-root(defproc halley-square-root-next (a x) (- x (/ (* 2 (- (* x x x) (* a x))) (+ (* 3 x x) a)))) (defproc halley-square-root-iteration (a x delta) (let ((x-next (approximate (halley-square-root-next a x) delta))) (if (< (abs (- (* x-next x-next) a)) delta) x-next (halley-square-root-iteration a x-next delta)))) (defproc square-root (a delta) (if (< a 0) (throw (quote error) "negative argument for square-root") (approximate (halley-square-root-iteration a 1 (* delta delta)) delta)))polar-coordinates3local:polar-coordinatesDie Methode to-polar wandet eine komplexe Zahl (erstes Argument) in die Darstellung mit Polarkoordinaten um. Die gewünschte Genauigkeit kann angegeben werden (zweites Argument). Bei den Polarkoordinaten handelt es sich um eine zweielementige Liste mit Radius und Winkel im Bogenmaß. Die Methode from-polar macht die umgekehrte Transformation von einer Liste (erstes Argument) zu einer komplexen Zahl mit einer gewünschten Genauigkeit (zweites Argument). Die Methode abs berechnet den Betrag einer komplexen Zahl (erstes Argument) mit einer gewünschte Genauigkeit (zweites Argument). Die Funktion pi berechnet die Kreiszahl mit einer gewünschten Genauigkeit (einziges Argument) über den Arkustangens. Die Funktion cosine-sine berechnet Cosinus und Sinus eines Winkels im Bogenmaß (erstes Argument) über die komplexe Exponentialfunktion mit einer gewünschten Genauigkeit (zweites Argument). Die beiden Funktionswerte werden zusammen als komplexe Zahl zurückgegeben - der Cosinus als Realteil und der Sinus als Imaginärteil.to-polar from-polar abs pi cosine-sine(defmethod to-polar ((this complex) precision) t (list (square-root (* this (conjugate this)) precision) (quadrant-arctangent (. this real) (. this imaginary) precision))) (defmethod from-polar (pair precision) (list? pair) (from-polar (first pair) (second pair) precision)) (defmethod from-polar (radius angle precision) (and (number? radius) (>= radius 0) (number? angle)) (* radius (cosine-sine angle precision))) (defproc quadrant-arctangent (x y precision) (if (= x 0) (if (< y 0) (* 3/2 (pi precision)) (* 1/2 (pi precision))) (let ((a (arctangent (/ y x) precision))) (if (< x 0) (+ a (pi precision)) a)))) (defproc arctangent (x precision) (cond ((< x 0) (- (arctangent (- x) precision))) ((> x 1) (- (* 1/2 (pi precision)) (arctangent (/ x) precision))) ((= x 1) (* 2 (arctangent (/ x (+ 1 (square-root (+ 1 (* x x)) precision))) precision))) (t (let ((summand nil) (sum 0) (power x) (divisor 1)) (loop (setq summand (/ power divisor)) (setq sum (+ sum summand)) (setq power (* power x x)) (setq divisor (if (greater? divisor 0) (- (+ divisor 2)) (+ (- divisor) 2))) (when (< (abs summand) precision) (return (approximate sum precision)))))))) (defmethod abs (r precision) (number? r) (approximate (abs r) precision)) (defmethod abs ((this complex) precision) t (first (to-polar this precision))) (defproc pi (precision) (- (* 16 (arctangent 1/5 precision)) (* 4 (arctangent 1/239 precision)))) (defproc cosine-sine (x precision) (if (> (abs x) 1/4) (let ((y (cosine-sine (/ x 2) precision))) (* y y)) (let ((summand nil) (imaginary-unit (new complex 0 1)) (sum 0) (power 1) (divisor 1) (index 1)) (loop (setq summand (/ power divisor)) (setq sum (+ sum summand)) (setq power (* power x imaginary-unit)) (setq divisor (* divisor index)) (setq index (+ 1 index)) (when (< (* summand (conjugate summand)) (* precision precision)) (return (approximate sum precision)))))))complex7local:complexsquare-root7local:square-rootturtle7local:turtleDie Klasse turtle simuliert eine Schildkröte mit einem Stift, die sich über Kommandos steuern lässt: Stift hoch (pen-up), Stift runter (pen-down), nach links drehen (left), nach rechts drehen (right), bewegen (forward), zu einem Punkt bewegen (move-to). Die Methode get-picture liefert schließlich das entstandene Bild.turtle initialize pen-up pen-down is-pen-down? right left set-heading round forward move-to get-polylines get-bounds get-picture(defclass turtle ()) (defmethod initialize ((this turtle)) t (progn (.= this position 0) (.= this heading 0) (.= this pen-state (quote up)) (.= this current-polyline nil) (.= this polylines nil) (.= this *pi* (pi 1e-30)) this)) (defmethod pen-up ((this turtle)) t (progn (when (. this current-polyline) (.= this polylines (cons (reverse (. this current-polyline)) (. this polylines))) (.= this current-polyline nil)) (.= this pen-state (quote up)))) (defmethod pen-down ((this turtle)) t (.= this pen-state (quote down))) (defmethod is-pen-down? ((this turtle)) t (= (. this pen-state) (quote down))) (defmethod right ((this turtle) degrees) t (set-heading this (- (. this heading) degrees))) (defmethod left ((this turtle) degrees) t (set-heading this (+ degrees (. this heading)))) (defmethod set-heading ((this turtle) heading) t (cond ((< heading 0) (set-heading this (+ 360 heading))) ((< heading 360) (.= this heading heading)) (t (set-heading this (- heading 360))))) (defmethod round (x) (number? x) (floor (+ x 1/2))) (defmethod round ((c complex)) t (new complex (round (. c real)) (round (. c imaginary)))) (defmethod forward ((this turtle) distance) t (move-to this (round (+ (. this position) (get-movement this distance))))) (defmethod move-to ((this turtle) (next complex)) (and (integer? (. next real)) (integer? (. next imaginary))) (progn (when (is-pen-down? this) (.= this current-polyline (aif (. this current-polyline) (cons next it) (list next (. this position))))) (.= this position next))) (defmethod move-to ((this turtle) next-x next-y) t (move-to this (new complex next-x next-y))) (defmethod move-to ((this turtle) next-x) (number? next-x) (move-to this next-x 0)) (defmethod get-movement ((this turtle) distance) t (* distance (cosine-sine (get-radiant this) 1e-30))) (defmethod get-radiant ((this turtle)) t (* 2/360 (. this *pi*) (. this heading))) (defmethod get-polylines ((this turtle)) t (with-slots-read-only (current-polyline polylines) this (if current-polyline (cons current-polyline polylines) polylines))) (defmethod get-bounds ((this turtle)) t (let ((min-x nil) (min-y nil) (max-x nil) (max-y nil)) (dolist (polyline (get-polylines this) (list min-x min-y (- max-x min-x) (- max-y min-y))) (dolist (point polyline) (when (or (null? min-x) (< (real point) min-x)) (setq min-x (real point))) (when (or (null? min-y) (< (imaginary point) min-y)) (setq min-y (imaginary point))) (when (or (null? max-x) (> (real point) max-x)) (setq max-x (real point))) (when (or (null? max-y) (> (imaginary point) max-y)) (setq max-y (imaginary point))))))) (defmethod get-picture ((this turtle)) t (let ((bounds (get-bounds this))) (grid (third bounds) (fourth bounds) (map-with (lambda (polyline) (map-with (lambda (point) (list (- (real point) (first bounds)) (- (imaginary point) (second bounds)))) polyline)) (get-polylines this)))))complex7local:complexsquare-root7local:square-rootpolar-coordinates3local:polar-coordinates1110110101000010110110011001111011010111110110110001000010010000