home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / pmos2002.zip / DEMO / SRC / GRAFTEST.MOD < prev    next >
Text File  |  1996-11-08  |  6KB  |  185 lines
  1. MODULE GrafTest;
  2.  
  3.         (****************************************************************)
  4.         (*                                                              *)
  5.         (*              Test of music and graphics.                     *)
  6.         (*                                                              *)
  7.         (*  Programmer:         P. Moylan                               *)
  8.         (*  Last edited:        8 November 1996                         *)
  9.         (*  Status:             Working                                 *)
  10.         (*                                                              *)
  11.         (****************************************************************)
  12.  
  13. FROM Timer IMPORT
  14.     (* proc *)  Sleep;
  15.  
  16. (*
  17. FROM MusicDemonstration IMPORT
  18.     (* proc *)  WaitForEndOfMusic;
  19. *)
  20.  
  21. FROM Graphics IMPORT
  22.     (* proc *)  SetMode, PlotMark, PlotLine;
  23.  
  24. FROM MATHLIB IMPORT
  25.     (* proc *)  Sin, Cos, Sqrt, ATan;
  26.  
  27. (************************************************************************)
  28.  
  29. CONST colour = 1;
  30.       stretch = 1.0;
  31.       PI = 3.14159265358979323;
  32.  
  33. (************************************************************************)
  34.  
  35. PROCEDURE PlotScaledLine (x0, y0, x1, y1: LONGREAL);
  36.  
  37.     (* Draws a line from (x0,y0) to (x1,y1), with coordinates scaled to *)
  38.     (* the standards expected by procedure Triangle, below.             *)
  39.  
  40.     CONST xorg = 319.5;  yorg = 174.5;  scale = 174.5;
  41.  
  42.     VAR intx0, inty0, intx1, inty1: CARDINAL;
  43.  
  44.     BEGIN
  45.         intx0 := TRUNC (stretch*(xorg+scale*x0)+0.5);
  46.         inty0 := TRUNC (yorg+scale*y0+0.5);
  47.         intx1 := TRUNC (stretch*(xorg+scale*x1)+0.5);
  48.         inty1 := TRUNC (yorg+scale*y1+0.5);
  49.         PlotLine (intx0,inty0,intx1,inty1,colour);
  50.     END PlotScaledLine;
  51.  
  52. (************************************************************************)
  53.  
  54. PROCEDURE Triangle (x0, y0, side, theta, alpha: LONGREAL);
  55.  
  56.     (* Plots an equilateral triangle, starting at (x0, y0), with each   *)
  57.     (* side being "side" units long, and tilted at angle theta to the   *)
  58.     (* the horizontal.  The units are scaled such that the centre of    *)
  59.     (* the screen is point (0.0,0.0), and side=1.0 gives the biggest    *)
  60.     (* triangle which will fit in the first quadrant.  Part of the      *)
  61.     (* second side is deliberately omitted - only the first "alpha" of  *)
  62.     (* it (0<alpha<1) is plotted.                                       *)
  63.  
  64.     VAR x1, y1, x2, y2: LONGREAL;
  65.  
  66.     BEGIN
  67.         x1 := x0 + side*Cos(theta);  x2 := x0 + side*Cos(theta + PI/3.0);
  68.         y1 := y0 + side*Sin(theta);  y2 := y0 + side*Sin(theta + PI/3.0);
  69.         PlotScaledLine (x0,y0, x1,y1);
  70.         PlotScaledLine (x1,y1,(1.0-alpha)*x1+alpha*x2,(1.0-alpha)*y1+alpha*y2);
  71.         PlotScaledLine (x2,y2, x0,y0);
  72.     END Triangle;
  73.  
  74. (************************************************************************)
  75.  
  76. PROCEDURE FilledTriangle (k: CARDINAL);
  77.  
  78.     (* Plots a sequence of nested triangles, with the outer one         *)
  79.     (* oriented at 60k degrees from the horizontal.                     *)
  80.  
  81.     CONST alpha = 0.1;  small = 0.01;
  82.  
  83.     VAR xorigin, yorigin, side: LONGREAL;
  84.         theta: LONGREAL;
  85.  
  86.     BEGIN
  87.         xorigin := 0.0;  yorigin := 0.0;  side := 1.0;
  88.         theta := VAL(LONGREAL,k)*PI/3.0;
  89.         REPEAT
  90.             Triangle (xorigin, yorigin, side, theta, alpha);
  91.             xorigin := xorigin + alpha*side*Cos(theta);
  92.             yorigin := yorigin + alpha*side*Sin(theta);
  93.             theta := theta + ATan(alpha*Sqrt(3.0)/(2.0-3.0*alpha));
  94.             side := side * Sqrt(1.0 - 3.0*alpha*(1.0-alpha));
  95.         UNTIL side < small;
  96.     END FilledTriangle;
  97.  
  98. (************************************************************************)
  99.  
  100. PROCEDURE Hexagon;
  101.  
  102.     (* Plots an interesting hexagon shape. *)
  103.  
  104.     VAR j: [0..5];
  105.  
  106.     BEGIN
  107.         SetMode (16, TRUE);
  108.         FOR j := 0 TO 5 DO
  109.             FilledTriangle(j);
  110.         END (*FOR*);
  111.         Sleep (3000);
  112.     END Hexagon;
  113.  
  114. (************************************************************************)
  115.  
  116. PROCEDURE Doyley (vertices: CARDINAL);
  117.  
  118.     (* Plots a polygon, with lines between all pairs of vertices.       *)
  119.     (* Assumption: "vertices" is a prime number.  If not, the procedure *)
  120.     (* still does something but the resulting picture is not as         *)
  121.     (* interesting.                                                     *)
  122.  
  123.     CONST colour = 1;
  124.  
  125.     TYPE Subscript = [0..30];
  126.  
  127.     VAR previous, next: Subscript;
  128.         step, j: CARDINAL;
  129.         X, Y: ARRAY Subscript OF CARDINAL;
  130.         xcentre, ycentre, radius, theta, angle: LONGREAL;
  131.  
  132.     BEGIN
  133.         SetMode (16, TRUE);
  134.  
  135.         (* Set up the vertex coordinates in arrays X and Y. *)
  136.  
  137.         xcentre := 319.5;  ycentre := 174.5;  radius := 174.5;
  138.         theta := 2.0*PI/VAL(LONGREAL,vertices);
  139.         FOR j := 0 TO vertices-1 DO
  140.             angle := VAL(LONGREAL,j)*theta;
  141.             X[j] := TRUNC (stretch*(xcentre + radius*Cos(angle) + 0.5));
  142.             Y[j] := TRUNC (ycentre + radius*Sin(angle) + 0.5);
  143.         END (*FOR*);
  144.  
  145.         (* Now the actual plotting. *)
  146.  
  147.         FOR step := 1 TO vertices DIV 2 DO
  148.             previous := 0;
  149.             FOR j := 1 TO vertices DO
  150.                 next := (previous + step) MOD vertices;
  151.                     PlotLine (X[previous], Y[previous], X[next], Y[next],
  152.                                                                 colour);
  153.                 previous := next;
  154.             END (*FOR*)
  155.         END (*FOR*);
  156.  
  157.         Sleep (3000);
  158.     END Doyley;
  159.  
  160. (************************************************************************)
  161.  
  162. PROCEDURE RunGraphicsTest;
  163.  
  164.     (* Runs us through a sequence of graphics tests.    *)
  165.  
  166.     VAR N: [3..23];
  167.  
  168.     BEGIN
  169.         FOR N := 3 TO 23 BY 2 DO
  170.             Doyley (N);
  171.         END (*FOR*);
  172.         Hexagon;
  173.     END RunGraphicsTest;
  174.  
  175. (************************************************************************)
  176. (*                              MAIN PROGRAM                            *)
  177. (************************************************************************)
  178.  
  179. BEGIN
  180.     RunGraphicsTest;
  181.     (*RunGraphicsTest;*)
  182.     (*WaitForEndOfMusic;*)
  183. END GrafTest.
  184.  
  185.