home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / Plot3D.p < prev    next >
Encoding:
Text File  |  1994-07-23  |  7.1 KB  |  297 lines
  1. Program Plot_3D;
  2.  
  3. { PLOT 3-D
  4.  
  5.   Ein Programm von Jens Gelhar, (c) Himpelsoft 1990.
  6.  
  7.   MaxonPascal3-Anpassung / Test:  Falk Zühlsdorff (PackMAN) 1994
  8.  
  9.   Unter Benutzung einiger Ideen (mein Programm kommt aber OHNE
  10.   Quasi-Raytracing aus!) von Michael Aumer (KICKSTART 9/90, S.72)
  11.  
  12.   Dieses Programm plottet dreidimensionale Funktionen (z = f(x,y)).
  13.   Dabei werden aber nicht irgendwelche häßliche Drahtgitter erzeugt
  14.   (womöglich gar ohne Hidden Lines), sondern der Graph wird als
  15.   plastischer Körper einschließlich Schatten dargestellt.
  16.  
  17.   Der Funktionsterm und einige Parameter müssen im Quelltext
  18.   angegeben werden.
  19.  
  20.   Viel Spaß beim Ausprobieren!
  21.  
  22. }
  23.  
  24. {$opt q }
  25.  
  26. Uses Intuition, Graphics;
  27.  
  28. {
  29. Durch Definition eines Bezeichners "test" wird die "Preview"-
  30. Version des Plotters definiert, d. h. die Grafik wird erheblich
  31. schneller, aber sehr grob erstellt:
  32.  
  33. Const test=1;
  34.  
  35. }
  36.  
  37. Const
  38.   ScrH = 256;
  39.   WinH = ScrH;
  40.   ScrB = 640;
  41.   WinB = ScrB;
  42.   MinY = 80;
  43.   MaxY = WinH-8;
  44.  
  45.   Schattenlänge = 4.5;   { größerer Wert -> längere Schatten }
  46.   Schattenhärte = 20;    { größerer Wert -> weichere Schatten }
  47.  
  48.   {$if def test }
  49.     Step = 15;
  50.   {$endif }
  51.  
  52. Var scr: ^Screen;
  53.     win: ^Window;
  54.     ras: ^RastPort;
  55.     vp : ^ViewPort;
  56.     Msg : Ptr;
  57.     xi, zi : integer;
  58.     yi : real;
  59.     YStep : real;
  60.     x, y, z : real;
  61.     i, pen : integer;
  62.     xd, yd, maxYd : real;
  63.     xu, yu: integer;
  64.     v0, v1, v2 : real;
  65.     cosA : real;
  66.     lastZ : real;
  67.     Schatten, Schattenlinie : integer;
  68.     Txt: String;
  69.     tf: real;
  70.     max : Array[0..WinB] of integer;
  71.     plotIt : Boolean;
  72.     SL2 : Real;
  73.     xj : integer;
  74.  
  75.     Gfx : long;
  76.  
  77. { Der folgende Text wird über die fertige Grafik geschrieben: }
  78.  
  79. Const Funktion = 'z = cos(c*r) / (r^2+1)';
  80.  
  81.  
  82. Function f(x, y: real): real;
  83.   { Diese Function repräsentiert die dargestellte Funktion.
  84.     Wertebereich von x und y: -1 bis +1, wenn man andere Ausschnitte
  85.     darstellen will, sind die Werte innerhalb der Function
  86.     entsprechend zu normieren.
  87.     Der von "f" zurückgegebene Wert muß der gewünschten Höhe in
  88.     Bildpunkten (!) entsprechen. Die meisten Funktionen wird man also
  89.     mit einem Faktor (z. B. 50) multiplizieren müssen, sonst wird das
  90.     Bild zu "flach".
  91.   }
  92.   Var r : real;
  93.   Begin
  94.     r := sqr(x) + sqr(y);
  95.     f := 50 * (1+cos(20*sqrt(r))) / (20*r+0.5);
  96.   End;
  97.  
  98.  
  99. (******************* andere schöne Funktionen: ******************]
  100.  
  101.   { Kreis mit Mittelpunkt: }
  102.   Var r : real;
  103.   Begin f := 0;
  104.     r := sqr(x) + sqr(y);
  105.     If r < 0.1 Then
  106.       f := 80 * cos(5*r*pi)
  107.     Else
  108.     If abs(r-0.9) < 0.1 Then
  109.       Begin
  110.         r := r-0.9;
  111.         f := 25 * cos(5*r*pi)
  112.       End
  113.     Else f := 0;
  114.   End;
  115.  
  116.   { Überlagerung zweier gedämpfter Schwingungen: }
  117.   Var r1, r2: Real;
  118.   Begin
  119.     r1 := 3*(sqr(x+0.5) + sqr(y+0.2));
  120.     r2 := 3*(sqr(x-0.6) + sqr(y-0.5));
  121.     f := 10 *(cos (8*r1) / (r1 + 0.05) + cos(8*r2) / (r2+0.05) );
  122.   End;
  123.  
  124.   { "Chaotische" Wellen: }
  125.   Begin
  126.     f := 50 * ( sin (3*x+4*y) * abs(cos (3*y-2*x))) + 20 * (sqr(x) + 1-sqr(y) );
  127.   End;
  128.  
  129.   { total "hohl": }
  130.   Var r : real;
  131.   Begin
  132.     r := sqr(x) + sqr(y);
  133.     If r < 0.9 Then f := -100*cos(r*pi/1.8)
  134.              Else f := 0
  135.   End;
  136.  
  137. [****************************************************************)
  138.  
  139.  
  140. Function Tiefenfaktor (y: real): real;
  141.   { perspektivische Verkleinerung, 0 < y < 1, normiert auf tf(0)=1 }
  142.   Begin
  143.     Tiefenfaktor := 2 / (y+2)
  144.   End;
  145.  
  146.  
  147. Begin
  148.   {$opt b+ - Abbruch möglich }
  149.   scr := Open_Screen(0, 0, ScrB, ScrH, 4, 0, 15, HIRES, 'Plot');
  150.   win := Open_Window(0, 0, WinB, WinH, 1, MOUSEBUTTONS, BORDERLESS, Nil, scr,
  151.                      0, 0, WinB, WinH);
  152.   ras := win^.RPort;
  153.   vp := ^scr^.ViewPort;
  154.  
  155.   For i:= 0 to 15 Do
  156.     SetRGB4(vp, i, i, i, i);
  157.   For i:= 0 to WinB do
  158.     max[i] := MaxY;
  159.  
  160.   YStep := 2 / (MaxY-MinY);
  161.   SL2 := Schattenlänge/2;
  162.  
  163.   yi := MaxY;
  164.   While yi >= MinY Do
  165.     Begin
  166.  
  167.       yu := Round(yi);
  168.  
  169.       y := (MaxY - yi) / (MaxY-MinY);       { [0..1] }
  170.       y := 2*(exp(y)-1) / (exp(1)-1) - 1;   { [-1..+1] }
  171.  
  172.       tf := Tiefenfaktor( (MaxY-yi) / (MaxY-MinY) );
  173.  
  174.       Txt := IntStr(Round(50*y)+50) + '%';
  175.       Move (ras, 1, 10);
  176.       SetAPen (ras, 12);
  177.       Gfx:=_Text (ras, Txt, Length(Txt))
  178.  
  179.       Schatten := -MaxInt;
  180.       lastZ := f(-1-YStep, y);
  181.       maxYD := 0;
  182.  
  183.       xi := 0;
  184.       While xi < WinB Do
  185.         Begin
  186.           x := (2*xi - WinB) / WinB;
  187.           xu := (WinB +Round( WinB * x * tf) )div 2;
  188.           z := f(x,y);
  189.           zi := yu - round( z*tf );
  190.  
  191.           plotIt := zi < max[xu];
  192.  
  193.           If plotIt Then
  194.             Begin
  195.               xd := (z - lastZ) {$if def test} / step {$endif} ;
  196.               yd := z - f(x, y-YStep);
  197.  
  198.               { Vektorprodukt:  V := (yStep, 0, xd) X (0, yStep, yd) }
  199.               v0 := -xd * YStep;
  200.               v1 := -yd * YStep;
  201.               v2 := sqr(YStep);
  202.  
  203.               { A = (-SL2, 0, 1),
  204.                 cos alpha = (A*V) / (abs(A) * abs(V)) }
  205.  
  206.               cosA := (v2 - SL2*v0) / (sqrt(1+sqr(SL2)) * sqrt(sqr(v0)+sqr(v1)+sqr(v2)));
  207.  
  208.               pen := round((14*16 div 2) * (cosA+1));
  209.  
  210.             End;
  211.  
  212.       Schattenlinie := xu + Round( (yu-zi) * Schattenlänge );
  213.       If (Schattenlinie < Schatten) and plotIt Then
  214.         Begin
  215.           If Schatten-Schattenlinie < Schattenhärte Then
  216.             pen := round(pen / (1+2*(Schatten-Schattenlinie)/Schattenhärte))
  217.           Else
  218.             pen := pen div 3
  219.         End
  220.       Else
  221.         If Schattenlinie >= Schatten Then
  222.           Schatten := Schattenlinie;
  223.  
  224.       If plotIt Then
  225.         Begin
  226.  
  227.           {$if def test }
  228.             pen := pen shr 4;
  229.           {$else }
  230.             If random(16) < pen and 15 Then
  231.               pen := (pen shr 4) + 1
  232.             Else
  233.               pen := pen shr 4;
  234.           {$endif }
  235.  
  236.             If yi = MaxY Then pen := 10;
  237.           SetAPen (ras, pen);
  238.  
  239.           {$if def test }
  240.             For i := 0 to Step-1 Do
  241.               Begin
  242.                 xj := xu + round(tf*i);
  243.                 Move (ras, xj, zi+round((Step-i)/Step * (z-lastZ) * tf ));
  244.                 Draw (ras, xj, max[xj]-1);
  245.               End;
  246.             For i := 0 to Step-1 Do
  247.               Begin
  248.                 xj := xu + round(tf*i);
  249.                 max[xj-1] := zi + round((Step-i)/Step * (z-lastZ) * tf )
  250.               End;
  251.           {$else }
  252.             Move(ras, xu, zi);
  253.             Draw(ras, xu, max[xu]-1);
  254.             max[xu] := zi;
  255.             If yd > maxYD Then maxYD := yd;
  256.           {$endif }
  257.  
  258.         End;
  259.  
  260.           LastZ := z;
  261.  
  262.           xi := xi + {$if def test} step {$else} 1 {$endif} ;
  263.  
  264.         End;
  265.  
  266.      {$if def test}
  267.        yi := yi - 1 - step div 2;
  268.      {$else }
  269.        If maxYd*tf > 3 Then             { bei starken Gefällen zum }
  270.          yi := yi - 0.1 - 2/maxYd/tf    { Betrachter hin um weniger }
  271.        Else                             { als eine Zeile springen }
  272.          yi := yi - 1
  273.      {$endif}
  274.  
  275.     End;
  276.  
  277.   Txt := Funktion;
  278.   Move (ras, 1, 10);
  279.   SetAPen (ras, 12);
  280.   Gfx:=_Text (ras, Txt, Length(Txt))
  281.  
  282.   Repeat
  283.     { alle bisherigen Events überlesen }
  284.     msg := Get_Msg(win^.UserPort);
  285.   Until msg = nil;
  286.  
  287.   Repeat
  288.     { Programm mit linker Maustaste beenden }
  289.     msg := Wait_Port(win^.UserPort);
  290.   Until msg <> nil;
  291.  
  292.   { Fenster + Screen schließen sich autmatisch }
  293.  
  294. End.
  295.  
  296.  
  297.