home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / system / kepler9.mod (.txt) < prev    next >
Oberon Text  |  1977-12-31  |  11KB  |  308 lines
  1. Syntax10.Scn.Fnt
  2. MODULE Kepler9;
  3. (* Semesterarbeit Wintersemester 91/92 von Samuel Urech
  4.     Erweiterung des Graphikeditors Kepler um Objektklassen f
  5. r geometrische Zeichnungen.
  6.     Programmiersprache: Oberon-2 auf Ceres-1
  7.     Autor: Samuel Urech, Tannenrauchstrasse 35/107, 8038 Z
  8.                 Tel. 01 481 92 92    Stud.Nr. 87-906-434
  9.     Datum: 8.1.92            Stand: 15.1.92 *)
  10.     IMPORT Math, Files, KeplerFrames, KeplerGraphs;
  11.     TYPE
  12.         Parallel* = POINTER TO ParallelDesc;
  13.         ParallelDesc* = RECORD
  14.             ( KeplerGraphs.PlanetDesc )
  15.         END;
  16.         RightAngle* = POINTER TO RightAngleDesc;
  17.         RightAngleDesc* = RECORD
  18.             ( KeplerGraphs.PlanetDesc )
  19.         END;
  20.         Intersection* = POINTER TO IntersectionDesc;
  21.         IntersectionDesc* = RECORD
  22.             ( KeplerGraphs.PlanetDesc )
  23.         END;
  24.         Extension* = POINTER TO ExtensionDesc;
  25.         ExtensionDesc* = RECORD
  26.             ( KeplerGraphs.PlanetDesc )
  27.         END;
  28.         Tangent* = POINTER TO TangentDesc;
  29.         TangentDesc* = RECORD
  30.             ( KeplerGraphs.PlanetDesc )
  31.             sign* : SHORTINT;    (* -1 oder 1 f
  32. r den einen oder anderen Punkt *)
  33.         END;
  34.         CircleInter* = POINTER TO CircleIntersection;    (* by jt and ww *)
  35.         CircleIntersection* = RECORD
  36.             (KeplerGraphs.PlanetDesc)
  37.             sign*: SHORTINT
  38.         END;
  39.         CircleLineInter* = POINTER TO CircleLineIntersection;    (* by jt and ww *)
  40.         CircleLineIntersection* = RECORD
  41.             (KeplerGraphs.PlanetDesc)
  42.             sign*: SHORTINT
  43.         END;
  44. (* ---------------------------------------  Parallel  ---------------------------------------- *)
  45.     PROCEDURE ( self : Parallel ) Calc*;
  46.     BEGIN (* Calc *)
  47.         self.x := self.c.p[ 2 ].x + self.c.p[ 1 ].x - self.c.p[ 0 ].x;
  48.         self.y := self.c.p[ 2 ].y + self.c.p[ 1 ].y - self.c.p[ 0 ].y;
  49.     END Calc;
  50.     PROCEDURE NewParallel*;
  51.         VAR new : Parallel;
  52.     BEGIN (* NewParallel *)
  53.         IF KeplerFrames.nofpts >= 3 THEN
  54.             NEW( new );
  55.             NEW( new.c );
  56.             new.c.nofpts := 3;
  57.             KeplerFrames.ConsumePoint( new.c.p[ 0 ] );
  58.             KeplerFrames.ConsumePoint( new.c.p[ 1 ] );
  59.             KeplerFrames.ConsumePoint( new.c.p[ 2 ] );
  60.             new.Calc;
  61.             KeplerFrames.Focus.Append( new );
  62.             KeplerFrames.Focus.FlipSelection( new );
  63.         END; (* IF *)
  64.     END NewParallel;
  65. (* ---------------------------------------  Right Angle  ---------------------------------------- *)
  66.     PROCEDURE ( self : RightAngle ) Calc*;
  67.         VAR x0, y0, x1, y1, x2, y2 : LONGINT;
  68.                 f : REAL;
  69.     BEGIN (* Calc *)
  70.         x0 := self.c.p[ 0 ].x;
  71.         y0 := self.c.p[ 0 ].y;
  72.         x1 := self.c.p[ 1 ].x;
  73.         y1 := self.c.p[ 1 ].y;
  74.         x2 := self.c.p[ 2 ].x;
  75.         y2 := self.c.p[ 2 ].y;
  76.         f := ( ( x1 - x0 ) * ( x2 - x0 ) + ( y1 - y0 ) * ( y2 - y0 ) ) / ( ( x1 - x0 ) * ( x1 - x0 ) + ( y1 - y0 ) * ( y1 - y0 ) );
  77.         self.x := SHORT( ENTIER( x0 + ( x1 - x0 ) * f ) );
  78.         self.y := SHORT( ENTIER( y0 + ( y1 - y0 ) * f ) );
  79.     END Calc;
  80.     PROCEDURE NewRightAngle*;
  81.         VAR new : RightAngle;
  82.     BEGIN (* NewRightAngle *)
  83.         IF KeplerFrames.nofpts >= 3 THEN
  84.             NEW( new );
  85.             NEW( new.c );
  86.             new.c.nofpts := 3;
  87.             KeplerFrames.ConsumePoint( new.c.p[ 0 ] );
  88.             KeplerFrames.ConsumePoint( new.c.p[ 1 ] );
  89.             KeplerFrames.ConsumePoint( new.c.p[ 2 ] );
  90.             new.Calc;
  91.             KeplerFrames.Focus.Append( new );
  92.             KeplerFrames.Focus.FlipSelection( new );
  93.         END; (* IF *)
  94.     END NewRightAngle;
  95. (* ---------------------------------------  Line * Line Intersection  ---------------------------------------- *)
  96.     PROCEDURE ( self : Intersection ) Calc*;
  97.         VAR f, x0, y0, x1, y1, x2, y2, x3, y3 : LONGINT;
  98.     BEGIN (* Calc *)
  99.         x0 := self.c.p[ 0 ].x;
  100.         y0 := self.c.p[ 0 ].y;
  101.         x1 := self.c.p[ 1 ].x;
  102.         y1 := self.c.p[ 1 ].y;
  103.         x2 := self.c.p[ 2 ].x;
  104.         y2 := self.c.p[ 2 ].y;
  105.         x3 := self.c.p[ 3 ].x;
  106.         y3 := self.c.p[ 3 ].y;
  107.         f := ( x3 - x2 ) * ( y1 - y0 ) - ( x1 - x0 ) * ( y3 - y2 );
  108.         IF f # 0 THEN (* sonst alte Werte beibehalten *)
  109.             self.x := SHORT( ( ( x3 - x2 ) * ( x1 - x0 ) * ( y2 - y0 ) + ( x3 - x2 ) * ( y1 - y0 ) * x0 - ( x1 - x0 ) * ( y3 - y2 ) * x2 ) DIV f );
  110.             self.y := SHORT( ( ( y3 - y2 ) * ( y1 - y0 ) * ( x2 - x0 ) + ( y3 - y2 ) * ( x1 - x0 ) * y0 - ( y1 - y0 ) * ( x3 - x2 ) * y2 ) DIV ( - f ) );
  111.         END; (* IF *)
  112.     END Calc;
  113.     PROCEDURE NewLineIntersection*;
  114.         VAR new : Intersection;
  115.     BEGIN (* NewIntersection *)
  116.         IF KeplerFrames.nofpts >= 4 THEN
  117.             NEW( new );
  118.             NEW( new.c );
  119.             new.c.nofpts := 4;
  120.             KeplerFrames.ConsumePoint( new.c.p[ 0 ] );
  121.             KeplerFrames.ConsumePoint( new.c.p[ 1 ] );
  122.             KeplerFrames.ConsumePoint( new.c.p[ 2 ] );
  123.             KeplerFrames.ConsumePoint( new.c.p[ 3 ] );
  124.             new.Calc;
  125.             KeplerFrames.Focus.Append( new );
  126.             KeplerFrames.Focus.FlipSelection( new );
  127.         END; (* IF *)
  128.     END NewLineIntersection;
  129. (* ---------------------------------------  Circle * Circle Intersection  ---------------------------------------- *)
  130.     PROCEDURE (self : CircleInter) Calc*;
  131.         VAR M1x, M2x, M1y, M2y, R1x, R2x, R1y, R2y,
  132.             mx, my, d, c, s, r1, r2, qx, qy, h: REAL;
  133.     BEGIN
  134.         M1x := self.c.p[0].x; M2x := self.c.p[2].x;
  135.         M1y := self.c.p[0].y; M2y := self.c.p[2].y;
  136.         R1x := self.c.p[1].x; R2x := self.c.p[3].x;
  137.         R1y := self.c.p[1].y; R2y := self.c.p[3].y;
  138.         mx := M2x - M1x; my := M2y - M1y; d := Math.sqrt(mx * mx + my * my);
  139.         IF d # 0 THEN
  140.             c := my / d; s := -mx / d;
  141.             r1 := (M1x - R1x) * (M1x - R1x) + (M1y - R1y) * (M1y - R1y);
  142.             r2 := (M2x - R2x) * (M2x - R2x) + (M2y - R2y) * (M2y - R2y);
  143.             qy := (d + (r1 - r2) / d) / 2;
  144.             h := r1 - qy * qy;
  145.             IF h >= 0 THEN
  146.                 qx := self.sign * Math.sqrt(h);
  147.                 self.x := SHORT(ENTIER(c * qx - s * qy + M1x));
  148.                 self.y := SHORT(ENTIER(s * qx + c * qy + M1y))
  149.             END
  150.         END
  151.     END Calc;
  152.     PROCEDURE (self : CircleInter) Read*(VAR r : Files.Rider);
  153.     BEGIN
  154.         Files.Read(r, self.sign);
  155.         self.Read^(r);
  156.     END Read;
  157.     PROCEDURE (self : CircleInter) Write*(VAR r : Files.Rider);
  158.     BEGIN
  159.         Files.Write(r, self.sign);
  160.         self.Write^(r);
  161.     END Write;
  162.     PROCEDURE NewCircleIntersection*;
  163.         VAR new1, new2 : CircleInter;
  164.     BEGIN
  165.         IF KeplerFrames.nofpts >= 4 THEN
  166.             NEW(new1); new1.sign := 1; NEW(new1.c ); new1.c.nofpts := 4;
  167.             NEW(new2); new2.sign := -1; NEW(new2.c ); new2.c.nofpts := 4;
  168.             KeplerFrames.ConsumePoint(new1.c.p[0]); (* middle 1 *)
  169.             KeplerFrames.ConsumePoint(new1.c.p[1]); (* periphery 1 *)
  170.             KeplerFrames.ConsumePoint(new1.c.p[2]); (* middle 2 *)
  171.             KeplerFrames.ConsumePoint(new1.c.p[3]); (* periphery 2 *)
  172.             new2.c.p[0] := new1.c.p[0]; INC(new1.c.p[0].refcnt);
  173.             new2.c.p[1] := new1.c.p[1]; INC(new1.c.p[1].refcnt);
  174.             new2.c.p[2] := new1.c.p[2]; INC(new1.c.p[2].refcnt);
  175.             new2.c.p[3] := new1.c.p[3]; INC(new1.c.p[3].refcnt);
  176.             new1.Calc; new2.Calc;
  177.             KeplerFrames.Focus.Append(new1); KeplerFrames.Focus.Append(new2);
  178.             KeplerFrames.Focus.FlipSelection(new1); KeplerFrames.Focus.FlipSelection(new2)
  179.         END
  180.     END NewCircleIntersection;
  181. (* ---------------------------------------  Circle * Line Intersection  ---------------------------------------- *)
  182.     PROCEDURE (self : CircleLineInter) Calc*;
  183.         VAR M1x, L1x, M1y, L1y, R1x, L2x, R1y, L2y, M2x, M2y,
  184.             mx, my, d, c, s, r1, qy, h: REAL;
  185.     BEGIN
  186.         M1x := self.c.p[0].x; L1x := self.c.p[2].x;
  187.         M1y := self.c.p[0].y; L1y := self.c.p[2].y;
  188.         R1x := self.c.p[1].x; L2x := self.c.p[3].x;
  189.         R1y := self.c.p[1].y; L2y := self.c.p[3].y;
  190.         mx := L2x - L1x; my := L2y - L1y; d := Math.sqrt(mx * mx + my * my);
  191.         IF d # 0 THEN
  192.             c := my / d; s := -mx / d;
  193.             r1 := (M1x - R1x) * (M1x - R1x) + (M1y - R1y) * (M1y - R1y);
  194.             M1x := M1x - L2x; M1y := M1y - L2y;
  195.             M2x := c * M1x + s * M1y; M2y := c * M1y - s * M1x;
  196.             h := r1 - M2x * M2x;
  197.             IF h >= 0 THEN
  198.                 qy := self.sign * Math.sqrt(h) + M2y;
  199.                 self.x := SHORT(ENTIER(-s * qy + L2x));
  200.                 self.y := SHORT(ENTIER(c * qy + L2y))
  201.             END
  202.         END
  203.     END Calc;
  204.     PROCEDURE (self : CircleLineInter) Read*(VAR r : Files.Rider);
  205.     BEGIN
  206.         Files.Read(r, self.sign);
  207.         self.Read^(r);
  208.     END Read;
  209.     PROCEDURE (self : CircleLineInter) Write*(VAR r : Files.Rider);
  210.     BEGIN
  211.         Files.Write(r, self.sign);
  212.         self.Write^(r);
  213.     END Write;
  214.     PROCEDURE NewCircleLineIntersect*;
  215.         VAR new1, new2 : CircleLineInter;
  216.     BEGIN
  217.         IF KeplerFrames.nofpts >= 4 THEN
  218.             NEW(new1); new1.sign := 1; NEW(new1.c ); new1.c.nofpts := 4;
  219.             NEW(new2); new2.sign := -1; NEW(new2.c ); new2.c.nofpts := 4;
  220.             KeplerFrames.ConsumePoint(new1.c.p[0]); (* middle 1 *)
  221.             KeplerFrames.ConsumePoint(new1.c.p[1]); (* periphery 1 *)
  222.             KeplerFrames.ConsumePoint(new1.c.p[2]); (* line start *)
  223.             KeplerFrames.ConsumePoint(new1.c.p[3]); (* line end *)
  224.             new2.c.p[0] := new1.c.p[0]; INC(new1.c.p[0].refcnt);
  225.             new2.c.p[1] := new1.c.p[1]; INC(new1.c.p[1].refcnt);
  226.             new2.c.p[2] := new1.c.p[2]; INC(new1.c.p[2].refcnt);
  227.             new2.c.p[3] := new1.c.p[3]; INC(new1.c.p[3].refcnt);
  228.             new1.Calc; new2.Calc;
  229.             KeplerFrames.Focus.Append(new1); KeplerFrames.Focus.Append(new2);
  230.             KeplerFrames.Focus.FlipSelection(new1); KeplerFrames.Focus.FlipSelection(new2)
  231.         END
  232.     END NewCircleLineIntersect;
  233. (* ---------------------------------------  Extension  ---------------------------------------- *)
  234.     PROCEDURE ( self : Extension ) Calc*;
  235.     BEGIN (* Calc *)
  236.         self.x := 2 * self.c.p[ 1 ].x - self.c.p[ 0 ].x;
  237.         self.y := 2 * self.c.p[ 1 ].y - self.c.p[ 0 ].y;
  238.     END Calc;
  239.     PROCEDURE NewExtension*;
  240.         VAR new : Extension;
  241.     BEGIN (* NewExtension *)
  242.         IF KeplerFrames.nofpts >= 2 THEN
  243.             NEW( new );
  244.             NEW( new.c );
  245.             new.c.nofpts := 2;
  246.             KeplerFrames.ConsumePoint( new.c.p[ 0 ] );
  247.             KeplerFrames.ConsumePoint( new.c.p[ 1 ] );
  248.             new.Calc;
  249.             KeplerFrames.Focus.Append( new );
  250.             KeplerFrames.Focus.FlipSelection( new );
  251.         END; (* IF *)
  252.     END NewExtension;
  253. (* ---------------------------------------  Tangent  ---------------------------------------- *)
  254.     PROCEDURE ( self : Tangent ) Calc*;
  255.         VAR x0, x1, x2, y0, y1, y2 : LONGINT;
  256.                 r2, d2, x3, y3, faktor : REAL;
  257.     BEGIN (* Calc *)
  258.         x0 := self.c.p[ 0 ].x;
  259.         x1 := self.c.p[ 1 ].x;
  260.         x2 := self.c.p[ 2 ].x;
  261.         y0 := self.c.p[ 0 ].y;
  262.         y1 := self.c.p[ 1 ].y;
  263.         y2 := self.c.p[ 2 ].y;
  264.         r2 := ( x1 - x0 ) * ( x1 - x0 ) + ( y1 - y0 ) * ( y1 - y0 );
  265.         d2 := ( x2 - x0 ) * ( x2 - x0 ) + ( y2 - y0 ) * ( y2 - y0 );
  266.         IF r2 < d2 THEN (* Punkt liegt ausserhalb des Kreises *)
  267.             x3 := x0 + ( x2 - x0 ) * r2 / d2;
  268.             y3 := y0 + ( y2 - y0 ) * r2 / d2;
  269.             faktor := Math.sqrt( r2 / d2 - r2 * r2 / d2 / d2 );
  270.             self.x := SHORT( ENTIER( x3 + self.sign * faktor * ( y2 - y0 ) ) );
  271.             self.y := SHORT( ENTIER( y3 + self.sign * faktor * ( x0 - x2 ) ) );
  272.         END; (* IF *)
  273.     END Calc;
  274.     PROCEDURE ( self : Tangent ) Read*( VAR r : Files.Rider );
  275.     BEGIN
  276.         Files.Read( r, self.sign );
  277.         self.Read^( r );
  278.     END Read;
  279.     PROCEDURE ( self : Tangent ) Write*( VAR r : Files.Rider );
  280.     BEGIN
  281.         Files.Write( r, self.sign );
  282.         self.Write^( r );
  283.     END Write;
  284.     PROCEDURE NewTangent*;
  285.         VAR new : Tangent;
  286.             p0, p1, p2 : KeplerGraphs.Star;
  287.             i : SHORTINT;
  288.     BEGIN
  289.         IF KeplerFrames.nofpts >= 3 THEN
  290.             KeplerFrames.ConsumePoint( p0 ); INC( p0.refcnt );
  291.             KeplerFrames.ConsumePoint( p1 ); INC( p1.refcnt );
  292.             KeplerFrames.ConsumePoint( p2 ); INC( p2.refcnt );
  293.             FOR i := 0 TO 1 DO
  294.                 NEW( new );
  295.                 new.sign := 2 * i - 1;
  296.                 NEW( new.c );
  297.                 new.c.nofpts := 3;
  298.                 new.c.p[ 0 ] := p0;
  299.                 new.c.p[ 1 ] := p1;
  300.                 new.c.p[ 2 ] := p2;
  301.                 new.Calc;
  302.                 KeplerFrames.Focus.Append( new );
  303.                 KeplerFrames.Focus.FlipSelection( new );
  304.             END
  305.         END
  306.     END NewTangent;
  307. END Kepler9.
  308.