home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / system / kepler8.mod (.txt) < prev    next >
Oberon Text  |  1977-12-31  |  16KB  |  342 lines
  1. Syntax10.Scn.Fnt
  2. MODULE Kepler8;
  3. (* Semesterarbeit Wintersemester 91/92 von Samuel Urech
  4.     Erweiterung des Graphikeditors Kepler um Objektklassen f
  5. r das Zeichnen von technischen Graphen.
  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: 13.12.91            Stand: 12.2.92
  10.     J. Templ, 18.06.92, NewEllipIntersect renamed to NewEllipseIntersect
  11.     J. Templ, 01.07.93 expressions simplified
  12.     IMPORT Display, Math, Files, KeplerPorts, KeplerGraphs, KeplerFrames, In;
  13.     CONST
  14.         EPS = 0.001;
  15.         fg = Display.white;
  16.     TYPE RectIntersect* = POINTER TO RectIntersectDesc;
  17.             RectIntersectDesc* = RECORD
  18.                 ( KeplerGraphs.PlanetDesc )
  19.             END; (* RectIntersect *)
  20.             CircleIntersect* = POINTER TO CircleIntersectDesc;
  21.             CircleIntersectDesc* = RECORD
  22.                 ( KeplerGraphs.PlanetDesc )
  23.             END; (* CircleIntersect *)
  24.             EllipIntersect* = POINTER TO EllipIntersectDesc;
  25.             EllipIntersectDesc* = RECORD
  26.                 ( KeplerGraphs.PlanetDesc )
  27.             END; (* EllipIntersect *)
  28.             AttrRect* = POINTER TO AttrRectDesc;
  29.             AttrRectDesc* = RECORD
  30.                 ( KeplerGraphs.ConsDesc )
  31.                 texture* : INTEGER;    (* Textur des Inneren des Rechtecks *)
  32.                 lineWidth* : INTEGER;    (* Liniendicke *)
  33.                 shadow* : INTEGER;    (* Textur des Schattens; <= 0: kein Schatten *)
  34.                 shadowWidth* : INTEGER; (* Breite des Schattens; <= 0: kein Schatten *)
  35.                 corner* : INTEGER;    (* Radius der Ecken; <= 1: keine Abrundungen *)
  36.             END; (* AttrRect *)
  37.             FilledCircle* = POINTER TO FilledCircleDesc;
  38.             FilledCircleDesc* = RECORD
  39.                 ( KeplerGraphs.ConsDesc )
  40.                 texture* : INTEGER;    (* Textur des Inneren des Kreises *)
  41.             END; (* FilledCircle *)
  42. (* ----------------------------------------  Hilfsprozeduren  ---------------------------------------- *)
  43.     PROCEDURE MinMax( a, b : INTEGER; VAR min, max: INTEGER );
  44.     BEGIN
  45.         IF a < b THEN min := a; max := b ELSE min := b; max := a END
  46.     END MinMax;
  47. (* -----------------------------------------  RectIntersect  ----------------------------------------- *)
  48.     PROCEDURE ( self : RectIntersect ) Calc*;
  49.         VAR mx, my, x1, y1, x2, y2 : INTEGER;
  50.                 slope : REAL;
  51.     BEGIN (* Calc *)
  52.         mx := ( self.c.p[ 0 ].x + self.c.p[ 1 ].x ) DIV 2;
  53.         my := ( self.c.p[ 0 ].y + self.c.p[ 1 ].y ) DIV 2;
  54.         IF ( mx = self.c.p[ 2 ].x ) & ( my = self.c.p[ 2 ].y ) THEN
  55.             self.x := mx;
  56.             self.y := self.c.p[ 1 ].y;
  57.         ELSE
  58.             IF self.c.p[ 2 ].x - mx # 0 THEN
  59.                 slope := ( self.c.p[ 2 ].y - my ) / ( self.c.p[ 2 ].x - mx );
  60.                 IF ( self.c.p[ 1 ].x # mx ) & ( ABS( slope ) > ABS( ( self.c.p[ 1 ].y - my ) / ( self.c.p[ 1 ].x - mx ) ) ) THEN
  61.                     (* Gerade schneidet auf waagrechter Linie *)
  62.                     IF ( ( self.c.p[ 2 ].y < my ) & ( self.c.p[ 0 ].y < my ) ) OR ( ( self.c.p[ 2 ].y > my ) & ( self.c.p[ 0 ].y > my ) ) THEN
  63.                         self.y := self.c.p[ 0 ].y;
  64.                         self.x := mx + SHORT( ENTIER( ( self.c.p[ 0 ].y - my ) / slope ) );
  65.                     ELSE
  66.                         self.y := self.c.p[ 1 ].y;
  67.                         self.x := mx + SHORT( ENTIER( ( self.c.p[ 1 ].y - my ) / slope ) );
  68.                     END; (* IF *)
  69.                 ELSE (* Gerade schneidet auf senkrechter Linie *)
  70.                     IF self.c.p[ 2 ].y - my # 0 THEN
  71.                         IF ( ( self.c.p[ 2 ].x < mx ) & ( self.c.p[ 0 ].x < mx ) ) OR ( ( self.c.p[ 2 ].x > mx ) & ( self.c.p[ 0 ].x > mx ) ) THEN
  72.                             self.x := self.c.p[ 0 ].x;
  73.                             self.y := my + SHORT( ENTIER( ( self.c.p[ 0 ].x - mx ) * slope ) );
  74.                         ELSE
  75.                             self.x := self.c.p[ 1 ].x;
  76.                             self.y := my + SHORT( ENTIER( ( self.c.p[ 1 ].x - mx ) * slope ) );
  77.                         END; (* IF *)
  78.                     ELSE (* Gerade ist parallel zur Horizontalen *)
  79.                         self.y := my;
  80.                         IF ( ( self.c.p[ 2 ].x < mx ) & ( self.c.p[ 0 ].x < mx ) ) OR ( ( self.c.p[ 2 ].x > mx ) & ( self.c.p[ 0 ].x > mx ) ) THEN
  81.                             self.x := self.c.p[ 0 ].x;
  82.                         ELSE
  83.                             self.x := self.c.p[ 1 ].x;
  84.                         END; (* IF *)
  85.                     END; (* IF *)
  86.                 END; (* IF *)
  87.             ELSE (* Gerade ist parallel zur Vertikalen *)
  88.                 self.x := mx;
  89.                 IF ( ( self.c.p[ 2 ].y < my ) & ( self.c.p[ 0 ].y < my ) ) OR ( ( self.c.p[ 2 ].y > my ) & ( self.c.p[ 0 ].y > my ) ) THEN
  90.                     self.y := self.c.p[ 0 ].y;
  91.                 ELSE
  92.                     self.y := self.c.p[ 1 ].y;
  93.                 END; (* IF *)
  94.             END; (* IF *)
  95.         END; (* IF *)
  96.     END Calc;
  97.     PROCEDURE NewRectIntersect*;
  98.     (* Liest drei Fokuspunkte ein und bestimmt einen Planeten am Schnittpunkt zwischen dem Rechteck, das durch die
  99.         ersten beiden Punkte bestimmt wird und der Gerade durch den Mittelpunkt des Rechtecks und den dritten Punkt. *)
  100.         VAR new : RectIntersect;
  101.     BEGIN (* NewRectIntersect *)
  102.         IF KeplerFrames.nofpts >= 3 THEN
  103.             NEW( new );
  104.             NEW( new.c );
  105.             new.c.nofpts := 3;
  106.             KeplerFrames.ConsumePoint( new.c.p[ 0 ] );
  107.             KeplerFrames.ConsumePoint( new.c.p[ 1 ] );
  108.             KeplerFrames.ConsumePoint( new.c.p[ 2 ] );
  109.             new.Calc;
  110.             KeplerFrames.Focus.Append( new );
  111.             KeplerFrames.Focus.FlipSelection( new );
  112.         END; (* IF *)
  113.     END NewRectIntersect;
  114. (* --------------------------------------------  CircleIntersect  -------------------------------------- *)
  115.     PROCEDURE ( self : CircleIntersect ) Calc*;
  116.         VAR factor : REAL;
  117.                 x0, y0, x1, y1, x2, y2 : LONGINT;
  118.     BEGIN (* Calc *)
  119.         x0 := self.c.p[ 0 ].x;
  120.         y0 := self.c.p[ 0 ].y;
  121.         x1 := self.c.p[ 1 ].x;
  122.         y1 := self.c.p[ 1 ].y;
  123.         x2 := self.c.p[ 2 ].x;
  124.         y2 := self.c.p[ 2 ].y;
  125.         IF ( x0 = x2 ) & ( y0 = y2 ) THEN
  126.             self.x := SHORT( x1 );
  127.             self.y := SHORT( y1 );
  128.         ELSE
  129.             factor := Math.sqrt( ( ( ( x1 - x0 ) * ( x1 - x0 ) ) + ( ( y1 - y0 ) * ( y1 - y0 ) ) ) /
  130.                                              ( ( ( x2 - x0 ) * ( x2 - x0 ) ) + ( ( y2 - y0 ) * ( y2 - y0 ) ) ) );
  131.             self.x := SHORT( x0 ) + SHORT( ENTIER( factor * ( x2 - x0 ) ) );
  132.             self.y := SHORT( y0 ) + SHORT( ENTIER( factor * ( y2 - y0 ) ) );
  133.         END; (* IF *)
  134.     END Calc;
  135.     PROCEDURE NewCircleIntersect*;
  136.     (* Liest drei Fokuspunkte ein und bestimmt einen Planeten am Schnittpunkt zwischen dem Kreis, dessen Mittelpunkt
  137.         durch den ersten Punkt und dessen Radius durch den zweiten Punkt gegeben ist sowie der Gerade zwischen dem
  138.         Mittelpunkt des Kreises und dem dritten Punkt. *)
  139.         VAR new : CircleIntersect;
  140.     BEGIN (* NewCircleIntersect *)
  141.         IF KeplerFrames.nofpts >= 3 THEN
  142.             NEW( new );
  143.             NEW( new.c );
  144.             new.c.nofpts := 3;
  145.             KeplerFrames.ConsumePoint( new.c.p[ 0 ] );
  146.             KeplerFrames.ConsumePoint( new.c.p[ 1 ] );
  147.             KeplerFrames.ConsumePoint( new.c.p[ 2 ] );
  148.             new.Calc;
  149.             KeplerFrames.Focus.Append( new );
  150.             KeplerFrames.Focus.FlipSelection( new );
  151.         END; (* IF *)
  152.     END NewCircleIntersect;
  153. (* --------------------------------------------  EllipIntersect  -------------------------------------- *)
  154.     PROCEDURE ( self : EllipIntersect ) Calc*;
  155.         VAR a2, b2 : LONGINT;
  156.                 slope2, temp : REAL;
  157.                 xsign, ysign, t : INTEGER;
  158.     BEGIN (* Calc *)
  159.         IF self.c.p[ 3 ].x > self.c.p[ 0 ].x THEN
  160.             xsign := 1;
  161.         ELSE
  162.             xsign := -1;
  163.         END; (* IF *)
  164.         IF self.c.p[ 3 ].y > self.c.p[ 0 ].y THEN
  165.             ysign := 1;
  166.         ELSE
  167.             ysign := -1;
  168.         END; (* IF *)
  169.         IF self.c.p[ 3 ].x # self.c.p[ 0 ].x THEN
  170.             IF self.c.p[ 3 ].y # self.c.p[ 0 ].y THEN
  171.                 a2 := self.c.p[ 1 ].x - self.c.p[ 0 ].x;
  172.                 a2 := a2 * a2;
  173.                 b2 := self.c.p[ 2 ].y - self.c.p[ 0 ].y;
  174.                 b2 := b2 * b2;
  175.                 t := self.c.p[ 3 ].y - self.c.p[ 0 ].y; slope2 := ( t ) / ( self.c.p[ 3 ].x - self.c.p[ 0 ].x );
  176.                 slope2 := slope2 * slope2;
  177.                 temp := a2 / ( b2 + a2*slope2 ) * b2;
  178.                 self.x := xsign * SHORT( ENTIER( Math.sqrt( temp ) ) ) + self.c.p[ 0 ].x;
  179.                 self.y := ysign * SHORT( ENTIER( Math.sqrt( slope2 * temp ) ) ) + self.c.p[ 0 ].y;
  180.             ELSE (* Gerade ist horizontal *)
  181.                 t := self.c.p[ 1 ].x - self.c.p[ 0 ].x; self.x := self.c.p[ 0 ].x + xsign * ( t );
  182.                 self.y := self.c.p[ 0 ].y;
  183.             END; (* IF *)
  184.         ELSE (* Gerade ist vertikal *)
  185.             self.x := self.c.p[ 0 ].x;
  186.             t := self.c.p[ 2 ].y - self.c.p[ 0 ].y; self.y := self.c.p[ 0 ].y + ysign * ( t );
  187.         END; (* IF *)
  188.     END Calc;
  189.     PROCEDURE NewEllipseIntersect*;
  190.     (* Liest vier Fokuspunkte ein und bestimmt einen Planeten am Schnittpunkt zwischen der Ellipse, die durch die
  191.         ersten drei Punkte gegeben ist, sowie der Gerade zwischen dem Mittelpunkt der Ellipse und dem vierten Punkt. *)
  192.         VAR new : EllipIntersect;
  193.     BEGIN (* NewEllipIntersect *)
  194.         IF KeplerFrames.nofpts >= 4 THEN
  195.             NEW( new );
  196.             NEW( new.c );
  197.             new.c.nofpts := 4;
  198.             KeplerFrames.ConsumePoint( new.c.p[ 0 ] );
  199.             KeplerFrames.ConsumePoint( new.c.p[ 1 ] );
  200.             KeplerFrames.ConsumePoint( new.c.p[ 2 ] );
  201.             KeplerFrames.ConsumePoint( new.c.p[ 3 ] );
  202.             new.Calc;
  203.             KeplerFrames.Focus.Append( new );
  204.             KeplerFrames.Focus.FlipSelection( new );
  205.         END; (* IF *)
  206.     END NewEllipseIntersect;
  207. (* --------------------------------------------  AttrRect  -------------------------------------- *)
  208.     PROCEDURE ( self : AttrRect ) Read*( VAR r : Files.Rider );
  209.     BEGIN (* Read *)
  210.         Files.ReadInt( r, self.texture );
  211.         Files.ReadInt( r, self.lineWidth );
  212.         Files.ReadInt( r, self.shadow );
  213.         Files.ReadInt( r, self.shadowWidth );
  214.         Files.ReadInt( r, self.corner );
  215.         self.Read^( r );
  216.     END Read;
  217.     PROCEDURE ( self : AttrRect ) Write*( VAR r : Files.Rider );
  218.     BEGIN (* Write *)
  219.         Files.WriteInt( r, self.texture );
  220.         Files.WriteInt( r, self.lineWidth );
  221.         Files.WriteInt( r, self.shadow );
  222.         Files.WriteInt( r, self.shadowWidth );
  223.         Files.WriteInt( r, self.corner );
  224.         self.Write^( r );
  225.     END Write;
  226.     PROCEDURE ( self : AttrRect ) Draw*( f : KeplerPorts.Port );
  227.         VAR x1, y1, x2, y2 : INTEGER;
  228.     BEGIN
  229.         MinMax( self.p[ 0 ].x, self.p[ 1 ].x, x1, x2 );
  230.         MinMax( self.p[ 0 ].y, self.p[ 1 ].y, y1, y2 );
  231.         IF self.corner > 1 THEN    (* rounded edges *)
  232.             IF ( self.shadow > 0 ) & ( self.shadowWidth > 0 ) THEN (* draw shadow *)
  233.                 f.FillCircle( x2 + self.shadowWidth - self.corner, y2 - self.shadowWidth - self.corner, self.corner, fg, self.shadow,
  234.                                     Display.replace );
  235.                 f.FillCircle( x1 + self.shadowWidth + self.corner, y1 - self.shadowWidth + self.corner, self.corner, fg, self.shadow,
  236.                                     Display.replace );
  237.                 f.FillCircle( x2 + self.shadowWidth - self.corner, y1 - self.shadowWidth + self.corner, self.corner, fg, self.shadow,
  238.                                     Display.replace );
  239.                 IF self.shadowWidth > self.corner THEN
  240.                     f.FillRect( x2, y2 - self.shadowWidth - self.corner, self.shadowWidth - self.corner, self.corner + f.scale, fg, self.shadow,
  241.                                     Display.replace );
  242.                     f.FillRect( x1 + self.shadowWidth, y1 - self.shadowWidth + self.corner, self.corner, self.shadowWidth - self.corner, fg,
  243.                                     self.shadow, Display.replace );
  244.                     f.FillRect( x2 - self.corner + f.scale, y1 - f.scale, self.corner, self.corner, fg, self.shadow, Display.replace );
  245.                 END;
  246.                 f.FillRect( x2 + f.scale, y1 - self.shadowWidth + self.corner, self.shadowWidth, y2 - y1 - 2 * self.corner, fg, self.shadow,
  247.                                 Display.replace );
  248.                 f.FillRect( x1 + self.shadowWidth + self.corner, y1 - self.shadowWidth - f.scale, x2 - x1 - 2 * self.corner,
  249.                                 self.shadowWidth, fg, self.shadow, Display.replace );
  250.             END;
  251.             f.FillCircle( x1 + self.corner, y1 + self.corner, self.corner, fg, 5, Display.replace );
  252.             f.FillCircle( x2 - self.corner, y1 + self.corner, self.corner, fg, 5, Display.replace );
  253.             f.FillCircle( x2 - self.corner, y2 - self.corner, self.corner, fg, 5, Display.replace );
  254.             f.FillCircle( x1 + self.corner, y2 - self.corner, self.corner, fg, 5, Display.replace );
  255.             IF self.corner > self.lineWidth THEN
  256.                 f.FillCircle( x1 + self.corner, y1 + self.corner, self.corner - self.lineWidth, fg, self.texture, Display.replace );
  257.                 f.FillCircle( x2 - self.corner, y1 + self.corner, self.corner - self.lineWidth, fg, self.texture, Display.replace );
  258.                 f.FillCircle( x2 - self.corner, y2 - self.corner, self.corner - self.lineWidth, fg, self.texture, Display.replace );
  259.                 f.FillCircle( x1 + self.corner, y2 - self.corner, self.corner - self.lineWidth, fg, self.texture, Display.replace )
  260.             END;
  261.             f.FillRect( x1 + self.lineWidth - f.scale, y1 + self.corner, x2 - x1 - 2 * self.lineWidth + 2 * f.scale,
  262.                             y2 - y1 - 2 * self.corner, fg, self.texture, Display.replace );
  263.             f.FillRect( x1 + self.corner, y1 + self.lineWidth - f.scale, x2 - x1 - 2 * self.corner,
  264.                             y2 - y1 - 2 * self.lineWidth + 2 * f.scale, fg, self.texture, Display.replace );
  265.             f.FillRect( x1 + self.corner, y1 - f.scale, x2 - x1 - 2 * self.corner, self.lineWidth + f.scale - 1, fg, 5, Display.replace );
  266.             f.FillRect( x1 + self.corner, y2 - self.lineWidth + f.scale, x2 - x1 - 2 * self.corner, self.lineWidth + f.scale - 1, fg, 5,
  267.                             Display.replace );
  268.             f.FillRect( x1 - f.scale, y1 + self.corner, self.lineWidth + f.scale - 1, y2 - y1 - 2 * self.corner, fg, 5, Display.replace );
  269.             f.FillRect( x2 - self.lineWidth + f.scale, y1 + self.corner, self.lineWidth + f.scale - 1, y2 - y1 - 2 * self.corner, fg, 5,
  270.                             Display.replace );
  271.         ELSE (* sharp edges *)
  272.             f.FillRect( x2, y1 - self.shadowWidth, self.shadowWidth, y2 - y1, fg, self.shadow, Display.replace );
  273.             f.FillRect( x1 + self.shadowWidth, y1 - self.shadowWidth, x2 -x1, self.shadowWidth, fg, self.shadow, Display.replace );
  274.             f.FillRect( x1 + self.lineWidth, y1 + self.lineWidth, x2 - x1 - 2 * self.lineWidth, y2 - y1 - 2 * self.lineWidth,
  275.                             fg, self.texture, Display.replace );
  276.             f.FillRect( x1, y1, x2 - x1, self.lineWidth, fg, 5, Display.replace );
  277.             f.FillRect( x1, y2 - self.lineWidth, x2 - x1, self.lineWidth, fg, 5, Display.replace );
  278.             f.FillRect( x1, y1, self.lineWidth, y2 - y1, fg, 5, Display.replace );
  279.             f.FillRect( x2 - self.lineWidth, y1, self.lineWidth, y2 - y1, fg, 5, Display.replace )
  280.         END
  281.     END Draw;
  282.     PROCEDURE NewAttrRect*;
  283.         VAR new : AttrRect;
  284.                 texture, lineWidth, shadow, shadowWidth, corner : INTEGER;
  285.     BEGIN (* NewAttrRect *)
  286.         IF KeplerFrames.nofpts >= 2 THEN
  287.             NEW( new );
  288.             new.nofpts := 2;
  289.             In.Open; In.Int( texture );
  290.             IF texture < 0 THEN new.texture := 0; ELSE new.texture := texture END;
  291.             In.Int( lineWidth );
  292.             IF lineWidth < 0 THEN new.lineWidth := 0; ELSE new.lineWidth := lineWidth END;
  293.             In.Int( shadow );
  294.             IF shadow < 0 THEN new.shadow := 0; ELSE new.shadow := shadow END;
  295.             In.Int( shadowWidth );
  296.             IF shadowWidth < 0 THEN new.shadowWidth := 0; ELSE new.shadowWidth := shadowWidth END;
  297.             In.Int( corner ); 
  298.             IF corner <= 1 THEN new.corner := 0; ELSE new.corner := corner END;
  299.             IF In.Done THEN
  300.                 KeplerFrames.ConsumePoint( new.p[ 0 ] );
  301.                 KeplerFrames.ConsumePoint( new.p[ 1 ] );
  302.                 KeplerFrames.Focus.Append( new );
  303.             END; (* IF *)
  304.         END; (* IF *)
  305.     END NewAttrRect;
  306. (* --------------------------------------------  FilledCircle  -------------------------------------- *)
  307.     PROCEDURE ( self : FilledCircle ) Read*( VAR r : Files.Rider );
  308.     BEGIN (* Read *)
  309.         Files.ReadInt( r, self.texture );
  310.         self.Read^( r );
  311.     END Read;
  312.     PROCEDURE ( self : FilledCircle ) Write*( VAR r : Files.Rider );
  313.     BEGIN (* Write *)
  314.         Files.WriteInt( r, self.texture );
  315.         self.Write^( r );
  316.     END Write;
  317.     PROCEDURE ( self : FilledCircle ) Draw*( f : KeplerPorts.Port );
  318.         VAR rx, ry : LONGINT;
  319.                 r : INTEGER;
  320.     BEGIN (* Draw *)
  321.         rx := self.p[ 1 ].x - self.p[ 0 ].x;
  322.         ry := self.p[ 1 ].y - self.p[ 0 ].y;
  323.         r := SHORT( ENTIER( Math.sqrt( rx * rx + ry * ry ) ) );
  324.         f.FillCircle( self.p[ 0 ].x, self.p[ 0 ].y, r, fg, self.texture, Display.replace );
  325.     END Draw;
  326.     PROCEDURE NewFilledCircle*;
  327.         VAR new: FilledCircle; texture: INTEGER;
  328.     BEGIN
  329.         IF KeplerFrames.nofpts >= 2 THEN
  330.             NEW( new );
  331.             new.nofpts := 2;
  332.             In.Open; In.Int( texture );
  333.             IF texture < 0 THEN new.texture := 0; ELSE new.texture := texture; END;
  334.             IF In.Done THEN
  335.                 KeplerFrames.ConsumePoint( new.p[ 0 ] );
  336.                 KeplerFrames.ConsumePoint( new.p[ 1 ] );
  337.                 KeplerFrames.Focus.Append( new );
  338.             END
  339.         END
  340.     END NewFilledCircle;
  341. END Kepler8.
  342.