<> <> <<>> DIRECTORY Rope, IO, Basics, Ieee, Real, RealFns, Vector, Vector2, Atom, Convert, AlgebraClasses, MathConstructors, Bools, Ints, Reals, Complexes; ComplexesImpl: CEDAR PROGRAM IMPORTS IO, Convert, Rope, Real, RealFns, AlgebraClasses, MathConstructors, Ints, Reals EXPORTS Complexes = BEGIN OPEN Complexes, Convert, AC: AlgebraClasses; <> ComplexesError: PUBLIC SIGNAL [reason: ATOM _ $Unspecified] = CODE; bitsPerWord: CARDINAL = Basics.bitsPerWord; CARD: TYPE = LONG CARDINAL; ROPE: TYPE = Rope.ROPE; STREAM: TYPE = IO.STREAM; Object: TYPE = AC.Object; Method: TYPE = AC.Method; <> PrintName: PUBLIC AC.ToRopeOp = { RETURN["Complexes"]; }; ShortPrintName: PUBLIC AC.ToRopeOp = { RETURN["C"]; }; Characteristic: PUBLIC AC.StructureRankOp = { RETURN[ 0 ] }; <> Recast: PUBLIC AC.BinaryOp = { <> IF AC.StructureEqual[firstArg.class, Complexes] THEN RETURN[firstArg]; IF Reals.CanRecast[firstArg, Reals.Reals] THEN { real: REAL _ Reals.ToREAL[Reals.Recast[firstArg, Reals.Reals] ]; RETURN[FromPairREAL[real, 0.0] ]; }; RETURN[NIL]; }; CanRecast: PUBLIC AC.BinaryPredicate = { firstArgStructure: Object _ IF firstArg.flavor = StructureElement THEN firstArg.class ELSE IF firstArg.flavor = Structure THEN firstArg ELSE ERROR; SELECT TRUE FROM AC.StructureEqual[firstArgStructure, Complexes] => RETURN[TRUE]; Reals.CanRecast[firstArg, Reals.Reals] => RETURN[TRUE]; ENDCASE; RETURN[FALSE]; }; LegalFirstChar: PUBLIC AC.LegalFirstCharOp = { SELECT char FROM = '( => RETURN[TRUE]; ENDCASE; RETURN[Reals.LegalFirstChar[char, structure] ]; }; Read: PUBLIC AC.ReadOp ~ { puncChar, imagChar: CHAR; var: Rope.ROPE; real, imag: REAL; negative: BOOL _ FALSE; <> { []_ in.SkipWhitespace[]; puncChar _ in.GetChar[ ]; IF puncChar # '( THEN GO TO Error; []_ in.SkipWhitespace[]; real _ in.GetReal[]; []_ in.SkipWhitespace[]; puncChar _ in.GetChar[]; IF puncChar = '- THEN negative _ TRUE ELSE IF puncChar # '+ THEN GO TO Error; []_ in.SkipWhitespace[]; imagChar _ in.PeekChar[]; IF imagChar # '. AND NOT imagChar IN ['0..'9] THEN imag _ 1.0 ELSE imag _ in.GetReal[]; IF negative THEN imag _ - imag; var _ in.GetID[]; IF NOT Rope.Equal[var,"i"] AND NOT Rope.Equal[var,"I"] THEN GO TO Error; []_ in.SkipWhitespace[]; puncChar _ in.GetChar[]; IF puncChar # ') THEN GO TO Error; RETURN[ FromPairREAL[real, imag] ]; EXITS Error => { in.SetIndex[0]; RETURN[Recast[ Reals.Read[in, Reals.Reals], Complexes] ] }; }; }; FromRope: PUBLIC AC.FromRopeOp = { stream: IO.STREAM _ IO.RIS[in]; RETURN[ Read[stream, structure] ]; }; ToRope: PUBLIC AC.ToRopeOp = { data: ComplexData _ NARROW[in.data]; out _ "("; out _ Rope.Concat[ out, RopeFromReal[data.x] ]; IF data.y < 0 THEN out _ Rope.Concat[ out, " - " ] ELSE out _ Rope.Concat[ out, " + " ]; out _ Rope.Concat[ out, RopeFromReal[ABS[data.y]] ]; out _ Rope.Concat[ out, " i )" ]; }; Write: PUBLIC AC.WriteOp = { IO.PutRope[ stream, ToRope[in] ] }; ToExpr: PUBLIC AC.ToExprOp = { data: ComplexData _ NARROW[in.data]; RETURN[MathConstructors.MakeComplex[ MathConstructors.MakeReal[data.x], MathConstructors.MakeReal[data.y]] ] }; FromPairReal: PUBLIC AC.BinaryOp = { RETURN[ FromPairREAL[Reals.ToREAL[firstArg], Reals.ToREAL[secondArg] ] ]; }; RealArgsDesired: PUBLIC AC.UnaryToListOp ~ { RETURN[ LIST[Reals.Reals] ]; }; FromPairREAL: PUBLIC PROC [realPart, imagPart: REAL] RETURNS [out: Complex] = { RETURN[ NEW[AC.ObjectRec _ [class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [realPart, imagPart] ] ] ] ]; }; ToPairREAL: PUBLIC PROC [in: Complex] RETURNS [realPart, imagPart: REAL] = { data: ComplexData _ NARROW[in.data]; RETURN[realPart: data.x, imagPart: data.y]; }; <> Equal: PUBLIC AC.BinaryPredicate = { RETURN[ AlmostEqual[firstArg, secondArg] ] }; <> Zero: PUBLIC AC.NullaryOp = { RETURN[ ComplexZero ] }; One: PUBLIC AC.NullaryOp = { RETURN[ ComplexOne ] }; Add: PUBLIC AC.BinaryOp ~ { firstData: ComplexData _ NARROW[firstArg.data]; secondData: ComplexData _ NARROW[secondArg.data]; RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [firstData.x + secondData.x, firstData.y + secondData.y] ] ] ] ]; }; Negate: PUBLIC AC.UnaryOp ~ { data: ComplexData _ NARROW[arg.data]; RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [-data.x, -data.y] ] ] ] ]; }; Subtract: PUBLIC AC.BinaryOp ~ { firstData: ComplexData _ NARROW[firstArg.data]; secondData: ComplexData _ NARROW[secondArg.data]; RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [firstData.x - secondData.x, firstData.y - secondData.y] ] ] ] ]; }; Multiply: PUBLIC AC.BinaryOp ~ { firstData: ComplexData _ NARROW[firstArg.data]; secondData: ComplexData _ NARROW[secondArg.data]; RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [ (firstData.x*secondData.x - firstData.y*secondData.y), (firstData.x*secondData.y + firstData.y*secondData.x) ] ] ] ] ]; }; Conjugate: PUBLIC AC.UnaryOp ~ { data: ComplexData _ NARROW[arg.data]; RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [data.x, -data.y] ] ] ] ]; }; Modulus: PUBLIC AC.UnaryOp = { data: ComplexData _ NARROW[arg.data]; RETURN[Reals.FromREAL[Real.SqRt[data.x*data.x+data.y*data.y] ] ] }; -- same as Vector.Mag ModulusSquared: PUBLIC PROC [a: Complex] RETURNS [REAL] ~ { data: ComplexData _ NARROW[a.data]; RETURN[data.x*data.x + data.y*data.y]; }; ObjectAndIntDesired: PUBLIC AC.UnaryToListOp ~ { RETURN[ LIST[arg, Ints.Ints] ]; -- arg assumed to be a Structure }; Power: PUBLIC AC.BinaryOp ~ { -- this simple algorithm is Structure independent power: INT _ Ints.ToINT[secondArg]; structure: Object _ firstArg.class; one: Object _ AC.ApplyLkpNoRecastObject[$one, structure, LIST[structure] ]; productMethod: Method _ AC.LookupMethodInStructure[$product, structure]; IF power < 0 THEN { invertMethod: Method _ AC.LookupMethodInStructure[$invert, structure]; temp: Object; IF invertMethod = NIL THEN ERROR; temp _ Power[firstArg, Ints.FromINT[ABS[power] ] ]; RETURN[AC.ApplyNoLkpNoRecastObject[invertMethod, LIST[temp] ] ]; }; IF power = 0 THEN RETURN[one]; result _ firstArg; FOR i:INT IN [2..power] DO result _ AC.ApplyNoLkpNoRecastObject[productMethod, LIST[firstArg, result] ]; ENDLOOP; }; Invert: PUBLIC AC.UnaryOp ~ { m: REAL _ ModulusSquared[arg]; data: ComplexData _ NARROW[arg.data]; RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [data.x / m , -data.y / m ] ] ] ] ]; }; Divide: PUBLIC AC.BinaryOp ~ { RETURN[ Multiply[firstArg, Invert[secondArg]] ]; }; Paren: PUBLIC AC.UnaryOp ~ { RETURN[NEW[AC.ObjectRec _ [ flavor: StructureElement, class: Complexes, data: arg.data ] ] ]; }; Exponent: PROCEDURE [x: REAL] RETURNS [INTEGER] = INLINE BEGIN fl: Ieee.SingleReal _ LOOPHOLE[x]; RETURN[fl.exp]; END; AlmostEqual: PUBLIC PROCEDURE [a: Complex, b: Complex, mag:[-126..0] _ -20] RETURNS [BOOLEAN] = BEGIN sumSqrAbs: REAL _ ModulusSquared[a] + ModulusSquared[b]; sqrAbsDif: REAL _ ModulusSquared[Subtract[a, b]]; RETURN [Exponent[sumSqrAbs]+mag+mag-1>Exponent[sqrAbsDif]]; END; FromPolar: PUBLIC PROCEDURE [r: REAL, radians: REAL] RETURNS [Complex] ~ { RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [ r*RealFns.Cos[radians] , r*RealFns.Sin[radians] ] ] ] ] ]; }; Arg: PUBLIC PROCEDURE [a: Complex] RETURNS [REAL] = { data: ComplexData _ NARROW[a.data]; RETURN[RealFns.ArcTan[data.y, data.x]] }; Exp: PUBLIC PROCEDURE [a: Complex] RETURNS [Complex] = { data: ComplexData _ NARROW[a.data]; RETURN[FromPolar[RealFns.Exp[data.x], data.y]]}; <> Ln: PUBLIC PROCEDURE [a: Complex] RETURNS [Complex] = { RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [ RealFns.Ln[Reals.ToREAL[Modulus[a] ] ], Arg[a] ] ] ] ] ]; }; Sqr: PUBLIC PROCEDURE [a: Complex] RETURNS [Complex] = { data: ComplexData _ NARROW[a.data]; RETURN[NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [(data.x*data.x - data.y*data.y) , (2*data.x*data.y) ] ] ] ] ]; }; SqRt: PUBLIC PROCEDURE [a: Complex] RETURNS [Complex] = { <> data: ComplexData _ NARROW[a.data]; z: Complex _ (IF data.y>=0 THEN FromPairREAL[1, 1] ELSE FromPairREAL[1, -1]); zData: ComplexData _ NARROW[z.data]; oldz:Complex; IF data.y = 0 THEN BEGIN IF data.x>0 THEN zData.y_0 -- real square root ELSE IF data.x<0 THEN zData.x_0 -- pure imaginary ELSE RETURN[FromPairREAL[0, 0]] END; FOR I:NAT IN [0..50) DO oldz _ z; z _ Add[z, Divide[a, z]]; zData _ NARROW[z.data]; z _ NEW[AC.ObjectRec _ [ class: Complexes, flavor: StructureElement, data: NEW[Vector2.VEC _ [zData.x / 0.5 , zData.y / 0.5 ] ] ] ]; IF AlmostEqual[z, oldz, -20] THEN EXIT; ENDLOOP; RETURN[z]; }; <> ComplexesDesired: PUBLIC AC.UnaryToListOp ~ { <> RETURN[ LIST[Complexes] ]; }; <> <> <> <> <> <> <> <> <<] ];>> <<>> ComplexClass: Object _ AC.MakeClass["ComplexClass", NIL, NIL]; Complexes: PUBLIC Object _ AC.MakeStructure["Complexes", ComplexClass, NIL]; ComplexOne: Complex _ FromPairREAL[1.0, 0.0]; -- do after Complexes set ComplexZero: Complex _ FromPairREAL[0.0, 0.0]; categoryMethod: Method _ AC.MakeMethod[Value, FALSE, NEW[AC.Category _ field], NIL, "category"]; groundStructureMethod: Method _ AC.MakeMethod[Value, FALSE, NIL, NIL, "groundStructure"]; shortPrintNameMethod: Method _ AC.MakeMethod[ToRopeOp, FALSE, NEW[AC.ToRopeOp _ ShortPrintName], NIL, "shortPrintName"]; recastMethod: Method _ AC.MakeMethod[BinaryOp, TRUE, NEW[AC.BinaryOp _ Recast], NIL, "recast"]; canRecastMethod: Method _ AC.MakeMethod[BinaryPredicate, TRUE, NEW[AC.BinaryPredicate _ CanRecast], NIL, "canRecast"]; legalFirstCharMethod: Method _ AC.MakeMethod[LegalFirstCharOp, FALSE, NEW[AC.LegalFirstCharOp _ LegalFirstChar], NIL, "legalFirstChar"]; readMethod: Method _ AC.MakeMethod[ReadOp, FALSE, NEW[AC.ReadOp _ Read], NIL, "read"]; fromRopeMethod: Method _ AC.MakeMethod[FromRopeOp, TRUE, NEW[AC.FromRopeOp _ FromRope], NIL, "fromRope"]; toRopeMethod: Method _ AC.MakeMethod[ToRopeOp, FALSE, NEW[AC.ToRopeOp _ ToRope], NIL, "toRope"]; toExprMethod: Method _ AC.MakeMethod[ToExprOp, FALSE, NEW[AC.ToExprOp _ ToExpr], NEW[AC.UnaryToListOp _ ComplexesDesired], "toExpr"]; complexMethod: Method _ AC.MakeMethod[BinaryOp, FALSE, NEW[AC.BinaryOp _ FromPairReal], NEW[AC.UnaryToListOp _ RealArgsDesired], "complex"]; zeroMethod: Method _ AC.MakeMethod[NullaryOp, FALSE, NEW[AC.NullaryOp _ Zero], NIL, "zero"]; oneMethod: Method _ AC.MakeMethod[NullaryOp, FALSE, NEW[AC.NullaryOp _ One], NIL, "one"]; parenMethod: Method _ AC.MakeMethod[UnaryOp, FALSE, NEW[AC.UnaryOp _ Paren], NIL, "paren"]; sumMethod: Method _ AC.MakeMethod[BinaryOp, TRUE, NEW[AC.BinaryOp _ Add], NEW[AC.UnaryToListOp _ ComplexesDesired], "sum"]; negationMethod: Method _ AC.MakeMethod[UnaryOp, TRUE, NEW[AC.UnaryOp _ Negate], NEW[AC.UnaryToListOp _ ComplexesDesired], "negation"]; differenceMethod: Method _ AC.MakeMethod[BinaryOp, TRUE, NEW[AC.BinaryOp _ Subtract], NEW[AC.UnaryToListOp _ ComplexesDesired], "difference"]; productMethod: Method _ AC.MakeMethod[BinaryOp, TRUE, NEW[AC.BinaryOp _ Multiply], NEW[AC.UnaryToListOp _ ComplexesDesired], "product"]; commutativeMethod: Method _ AC.MakeMethod[Value, FALSE, NIL, NIL, "commutative"]; powerMethod: Method _ AC.MakeMethod[BinaryOp, TRUE, NEW[AC.BinaryOp _ Power], NEW[AC.UnaryToListOp _ ObjectAndIntDesired], "power"]; conjugateMethod: Method _ AC.MakeMethod[UnaryOp, TRUE, NEW[AC.UnaryOp _ Conjugate], NEW[AC.UnaryToListOp _ ComplexesDesired], "conjugate"]; modulusMethod: Method _ AC.MakeMethod[UnaryOp, TRUE, NEW[AC.UnaryOp _ Modulus], NEW[AC.UnaryToListOp _ ComplexesDesired], "modulus"]; invertMethod: Method _ AC.MakeMethod[UnaryOp, TRUE, NEW[AC.UnaryOp _ Invert], NEW[AC.UnaryToListOp _ ComplexesDesired], "invert"]; fractionMethod: Method _ AC.MakeMethod[BinaryOp, TRUE, NEW[AC.BinaryOp _ Divide], NEW[AC.UnaryToListOp _ ComplexesDesired], "fraction"]; equalMethod: Method _ AC.MakeMethod[BinaryPredicate, TRUE, NEW[AC.BinaryPredicate _ Equal], NEW[AC.UnaryToListOp _ ComplexesDesired], "equals"]; AC.AddMethodToClass[$category, categoryMethod, ComplexClass]; AC.AddMethodToClass[$groundStructure, categoryMethod, ComplexClass]; AC.AddMethodToClass[$shortPrintName, shortPrintNameMethod, ComplexClass]; AC.AddMethodToClass[$recast, recastMethod, ComplexClass]; AC.AddMethodToClass[$canRecast, canRecastMethod, ComplexClass]; AC.AddMethodToClass[$legalFirstChar, legalFirstCharMethod, ComplexClass]; AC.AddMethodToClass[$read, readMethod, ComplexClass]; AC.AddMethodToClass[$fromRope, fromRopeMethod, ComplexClass]; AC.AddMethodToClass[$toRope, toRopeMethod, ComplexClass]; AC.AddMethodToClass[$toExpr, toExprMethod, ComplexClass]; AC.AddMethodToClass[$complex, complexMethod, ComplexClass]; AC.AddMethodToClass[$zero, zeroMethod, ComplexClass]; AC.AddMethodToClass[$one, oneMethod, ComplexClass]; AC.AddMethodToClass[$paren, parenMethod, ComplexClass]; AC.AddMethodToClass[$sum, sumMethod, ComplexClass]; AC.AddMethodToClass[$negation, negationMethod, ComplexClass]; AC.AddMethodToClass[$difference, differenceMethod, ComplexClass]; AC.AddMethodToClass[$product, productMethod, ComplexClass]; AC.AddMethodToClass[$commutative, commutativeMethod, ComplexClass]; AC.AddMethodToClass[$pow, powerMethod, ComplexClass]; AC.AddMethodToClass[$conjugate, conjugateMethod, ComplexClass]; AC.AddMethodToClass[$modulus, modulusMethod, ComplexClass]; AC.AddMethodToClass[$invert, invertMethod, ComplexClass]; AC.AddMethodToClass[$fraction, fractionMethod, ComplexClass]; AC.AddMethodToClass[$eqFormula, equalMethod, ComplexClass]; AC.InstallStructure[Complexes]; AC.SetSuperClass[Reals.Reals, Complexes]; END.