home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 03 / ldm / demo2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-01-11  |  3.6 KB  |  125 lines
  1. (* ------------------------------------------------------ *)
  2. (*                   WRLDDEMO.PAS                         *)
  3. (*           Demonstration der Unit WORLD.PAS             *)
  4. (*           (C) 1991 Hagen Lehmann & TOOLBOX             *)
  5. (* ------------------------------------------------------ *)
  6. PROGRAM WrldDemo;
  7.  
  8. USES Crt, Graph, World, Dos;             { Reihenfolge !!! }
  9.  
  10. VAR
  11.   Driver, Mode : INTEGER;
  12.   Loop, Worlds : WORD;
  13.   Key          : CHAR;
  14.   DriverPath   : STRING;
  15.  
  16.  
  17.  
  18.   PROCEDURE DrawLines;
  19.   BEGIN
  20.     Rectangle(0, 0, 719, 347);
  21.   END;
  22.  
  23.  
  24.  
  25.   VAR
  26.   Gd, Gm, LochStep, LochStart,
  27.   LochEnde, X0, Y0, ZRing, ZRad : INTEGER;
  28.   RRing, RRad, WRing, WRad,
  29.   StepRing, StepRad, ZwoPi,
  30.   XStart, YStart, XP, YP        : REAL;
  31.   ch                            : CHAR;
  32.  
  33. PROCEDURE Input;                 { Eingabe aller Parameter }
  34. BEGIN
  35.   X0 := GetMaxX DIV 2;
  36.   Y0 := GetMaxY DIV 2;
  37.   RRing := GetMaxY DIV 2;
  38.   LochStep := 2;
  39.   ZRing := 100;
  40.   ZRad  := 66;
  41.   LochStart := 4;
  42.   LochEnde  := 9;
  43. END;
  44.  
  45. PROCEDURE Zeichnen;
  46. VAR
  47.   AnzStepRing, c, d, x: INTEGER;
  48.   PRadX, PRadY        : REAL;
  49.   XAsp, YAsp          : WORD;
  50.   RUmX, RUmY          : REAL;
  51. BEGIN
  52.   SetBkColor(0);
  53.  
  54.   GetAspectRatio(XAsp, YAsp);     { Verzerrung ausgleichen }
  55.  
  56. (*  XAsp := 347;  YAsp:= 719; *)
  57.   RRad := RRing * ZRad / ZRing;
  58.   RUmY := RRing - RRad;
  59.   RUmX := RUmY * YAsp / XAsp;
  60.   AnzStepRing := 5 * ((2 * ZRing) DIV ZRad);
  61.   StepRing := Pi / AnzStepRing;    { Winkelschritt im Ring }
  62.   StepRad := -StepRing * (ZRing / ZRad - 1);  { Winkel Rad }
  63.   FOR x := LochStart TO LochEnde DO BEGIN
  64.     SetColor(1 + x MOD GetMaxColor);
  65.     PRadY := RRad - LochStep * 2 * x - 8;    { Mittelpunkt }
  66.     PRadX := PRadY *YAsp / XAsp;             { des Rads    }
  67.     IF PRadX < 0 THEN Exit;
  68.     XStart := X0 + RUmX * Sin(0) + PRadX * Sin(0); { Start }
  69.     YStart := Y0 - RUmY * Cos(0) - PRadY * Cos(0);
  70.     MoveTo(Round(XStart), Round(YStart));
  71.     WRing := 0;
  72.     WRad := 0;
  73.     d := 0;
  74.     REPEAT                       { einzelne Kurve zeichnen }
  75.       FOR c := 1 TO 2 * AnzStepRing DO BEGIN  { ein Umlauf }
  76.         Inc(d);
  77.         WRad := StepRad * d;                  { Winkel Rad }
  78.         WRing := StepRing * c;            { Winkel im Ring }
  79.         XP := X0 + RUmX * Sin(WRing) + PRadX * Sin(WRad);
  80.         YP := Y0 - RUmY * Cos(WRing) - PRadY * Cos(WRad);
  81.         LineTo(Round(XP), Round(YP));
  82.       END;
  83.     UNTIL (Abs(XStart-XP) < 0.01) AND         { Startpunkt }
  84.           (Abs(YStart-YP) < 0.01);            {  erreicht? }
  85.   END;
  86. END;
  87.  
  88. PROCEDURE DrawWorld;
  89. BEGIN
  90.   ZwoPi := 2 * Pi;
  91.   Input;
  92.   Zeichnen;
  93. END;
  94.  
  95.  
  96. BEGIN
  97.   ClrScr;
  98.   DriverPath := GetEnv('BGIPATH');
  99.   Driver     := Detect;
  100.   InitGraph(Driver, Mode, DriverPath);
  101.  
  102.   SetBkColor(1);
  103.   SetColor(14);
  104.  
  105.   GivenWorld(719, 347);    { Koordinaten sind von HERCULES }
  106.  
  107.   DefineWorld(1, 0, 0, GetMaxX,       GetMaxY,       TRUE);
  108.   DefineWorld(2, 0, 0, GetMaxX DIV 2, GetMaxY DIV 2, TRUE);
  109.   DefineWorld(3, GetMaxX DIV 2, 0, GetMaxX,
  110.                  GetMaxY DIV 2,TRUE);
  111.   DefineWorld(4, 0, GetMaxY DIV 2, GetMaxX, GetMaxY, TRUE);
  112.  
  113.   FOR Worlds := 1 TO 4 DO BEGIN
  114.                                { alle Welten durchspielen  }
  115.     SelectWorld(Worlds);       { jeweilige Welt übernehmen }
  116.     ClearWorld;                { Weltinhalt löschen        }
  117.     DrawLines;  { Linien mit Herculeskoordinaten zeichnen  }
  118.     DrawWorld;  { "WORLD" mit Herculeskoordinaten zeichnen }
  119.     Key := ReadKey;
  120.   END;
  121.   CloseGraph;
  122. END.
  123. (* ------------------------------------------------------ *)
  124. (*                Ende von WRLDDEMO.PAS                   *)
  125.