home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 07 / praxis / wuerfel.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1989-05-02  |  15.8 KB  |  454 lines
  1. (* ------------------------------------------------------ *)
  2. (*                   WUERFEL.PAS                          *)
  3. (*          (c) 1898 Martin Müller & TOOLBOX              *)
  4. (* ------------------------------------------------------ *)
  5. PROGRAM Vier_Dimensionen;
  6.  
  7. USES Graph3, Crt;
  8.  
  9. CONST xpix = 320;         (* Hälfte der Bildschirmgröße   *)
  10.       ypix = 100;                 (* Pixelzahl in Punkten *)
  11.         lx = 1.5;    (* Hälfte der Projektionsschirmgröße *)
  12.         ly = 1.0;
  13.  
  14. TYPE vektor = RECORD          (* vierdimensionaler Vektor *)
  15.                 x, y, z, q : REAL;
  16.               END;
  17.  
  18. VAR ecken                : ARRAY [1..16] OF vektor;
  19.                                      (* Ecken des Würfels *)
  20.     o                    : vektor; (* Ursprung P(0/0/0/0) *)
  21.     position4, position3,
  22.     e4x, e4y, e4z, e4q,
  23.     e3x, e3y, e3z, v     : vektor;
  24.  
  25.      (* Positionen der Beobachter im 3d- und 4d-Raum und  *)
  26.      (* Einheitsvektoren der gedrehten Koordinatensysteme *)
  27.  
  28.     schirmentf4,
  29.     schirmentf3,schrittw : REAL;
  30.     taste, ebene, dim    : CHAR;  (* dient zum Umschalten *)
  31.     bewegen              : BOOLEAN;
  32.  
  33. FUNCTION skprod(v1, v2 : vektor) : REAL;
  34.                              (* ergibt das innere Produkt *)
  35. BEGIN                        (* der Vektoren v1 und v2    *)
  36.   skprod := v1.x*v2.x + v1.y*v2.y + v1.z*v2.z + v1.q*v2.q;
  37. END;
  38.  
  39. FUNCTION L(v : vektor) : REAL;
  40. BEGIN            (* ergibt den Betrag (Länge) des Vektors *)
  41.   L := Sqrt(Sqr(v.x) + Sqr(v.y) + Sqr(v.z) + Sqr(v.q));
  42. END;
  43.  
  44. PROCEDURE plus(v1, v2 : vektor; VAR v : vektor);
  45. BEGIN                            (* Addiert zwei Vektoren *)
  46.   v.x := v2.x + v1.x;
  47.   v.y := v2.y + v1.y;
  48.   v.z := v2.z + v1.z;
  49.   v.q := v2.q + v1.q;
  50. END;
  51.  
  52. PROCEDURE mal(k : REAL; v : vektor; VAR e : vektor);
  53. BEGIN                            (* multipliziert einen   *)
  54.   e.x := k*v.x;                  (* Vektor mit einer Zahl *)
  55.   e.y := k*v.y;
  56.   e.z := k*v.z;
  57.   e.q := k*v.q;
  58. END;
  59.  
  60. PROCEDURE verbinde(p1, p2 : vektor; VAR v : vektor);
  61. BEGIN
  62.   v.x := p2.x - p1.x;           (* ergibt den Vektor von  *)
  63.   v.y := p2.y - p1.y;           (* p1 nach p2 (p1,p2 sind *)
  64.   v.z := p2.z - p1.z;           (* hier Punkte,bzw. Orts- *)
  65.   v.q := p2.q - p1.q;           (* vektoren)              *)
  66. END;
  67.  
  68. PROCEDURE drehe(VAR e1, e2 : vektor);
  69. VAR v, h1, h2 : vektor;
  70. BEGIN
  71.   verbinde(e1, e2, v);
  72.   mal(schrittw, v, v);
  73.   plus(e1, v, h1);
  74.   mal(1/L(h1), h1, h1);
  75.   mal(-1, e1, e1);
  76.   verbinde(e2, e1, v);
  77.   mal(schrittw, v, v);
  78.   plus(e2, v, h2);         (* dreht die Vektoren e1 e2 in *)
  79.   mal(1/L(h2), h2, h2);    (* ihrer Ebene in Abhängigkeit *)
  80.   e1 := h1;                (* von der globalen Variablen  *)
  81.   e2 := h2;                (* Scrittw in Richtung e2.     *)
  82. END;
  83.  
  84. PROCEDURE drehKoord4(VAR p : vektor);
  85. VAR h : vektor;
  86. BEGIN
  87.   h.x := skprod(p, e4x); (* ergibt die Koordinaten von p  *)
  88.   h.y := skprod(p, e4y); (* in einem gedrehtem Koordinaten*)
  89.   h.z := skprod(p, e4z); (* system, das e4x, e3y, e4z e4q *)
  90.   h.q := skprod(p, e4q); (* als Einheitsvektoren hat      *)
  91.   p := h;
  92. END;
  93.  
  94. PROCEDURE drehKoord3(VAR p : vektor);
  95. VAR h : vektor;          (* entspricht drehKoord4 , wobei *)
  96. BEGIN                    (* hier die Einheitsvektoren für *)
  97.   h.x := skprod(p, e3x); (* den Beobachter im dreidimen-  *)
  98.   h.y := skprod(p, e3y); (* sionalen Raum genommen werden *)
  99.   h.z := skprod(p, e3z);
  100.   p := h;
  101. END;
  102.  
  103. PROCEDURE bildeab43(po : vektor; VAR pb : vektor);
  104. VAR k : REAL;                (* Hier wird angenommen, daß *)
  105. BEGIN                        (* der Beobachter auf der q- *)
  106.   k := schirmentf4/(schirmentf4 + po.q);
  107.   pb.x := k*po.x;            (* Achse sitzt, und zwar in  *)
  108.   pb.y := k*po.y;            (* der durch schirmentf4 an- *)
  109.   pb.z := k*po.z;            (* gegebenen Entfernung vom  *)
  110.   pb.q := 0;                 (* Ursprung in negativer     *)
  111. END;                         (* Richtung. x,y und z-Achse *)
  112.                              (* bilden eine 'dreidimen-   *)
  113.                              (* sionale Projetionswand'.  *)
  114.  
  115. PROCEDURE bildeab32(po : vektor; VAR pb : vektor);
  116. VAR k : REAL;
  117. BEGIN
  118.   k := schirmentf3/(schirmentf3 + po.z);
  119.   pb.x := k*po.x;            (* Hier bilden x und y-Achse *)
  120.   pb.y := k*po.y;            (* eine Projektionswand.     *)
  121.   pb.z := 0;                 (* Der Beobachter sitzt auf  *)
  122.   pb.q := 0;                 (* der z-Achse.              *)
  123. END;
  124.  
  125. PROCEDURE Ausgangswerte; (* Berechnung der Koordinaten der*)
  126. VAR i : INTEGER;         (* 16 Ecken des 'Hyperwürfels'   *)
  127. BEGIN
  128.   FOR i := 1 TO 16 DO WITH ecken[i] DO BEGIN
  129.     x := ((i-1) MOD 2)*2-1;
  130.     y := (((i-1) MOD 4) DIV 2)*2 - 1;
  131.     z := (((i-1) MOD 8) DIV 4)*2 - 1;
  132.     q := ((i-1) DIV 8)*2 - 1;
  133.   END;
  134.   WITH e4x DO BEGIN
  135.     x := 1;
  136.     y := 0;       (* Die Einheitsvektoren bekommen hier   *)
  137.     z := 0;       (* die Richtung des zugrundeliegenden   *)
  138.     q := 0;       (* Koordinatensystems. Im Laufe des     *)
  139.   END;            (* Programms können sie verdreht werden.*)
  140.   WITH e4y DO BEGIN
  141.     x := 0;   y := 1;   z := 0;   q := 0;
  142.   END;
  143.   WITH e4z DO BEGIN
  144.     x := 0;   y := 0;   z := 1;   q := 0;
  145.   END;
  146.   WITH e4q DO BEGIN
  147.     x := 0;   y := 0;   z := 0;   q := 1;
  148.   END;
  149.   WITH e3x DO BEGIN
  150.     x := 1;   y := 0;   z := 0;   q := 0;
  151.   END;
  152.   WITH e3y DO BEGIN
  153.     x := 0;   y := 1;   z := 0;   q := 0;
  154.   END;
  155.   WITH e3z DO BEGIN
  156.     x := 0;   y := 0;   z := 1;   q := 0;
  157.   END;
  158.   WITH o DO BEGIN
  159.     x := 0;   y := 0;   z := 0;   q := 0;
  160.   END;
  161.   WITH position3 DO BEGIN
  162.     x := 0;   y := 0;
  163.     z := -5;              (* Die Position des Beobachters *)
  164.     q := 0;               (* im dreidimensionalen         *)
  165.   END;
  166.   WITH position4 DO BEGIN    (* und im 4d- Raum           *)
  167.     x := 0;   y := 0;   z := 0;   q := -5;
  168.   END;
  169.   schirmentf3 := 2;               (* Die Entfernungen     *)
  170.   schirmentf4 := 2;               (* der Projektionswände *)
  171.   dim := 'd';
  172.   ebene := '1';
  173.   schrittw := 1/8;
  174. END;
  175.  
  176. PROCEDURE zeichneLinie(x1, y1, x2, y2 : REAL);
  177. VAR k                  : REAL;
  178.     px1, px2, py1, py2 : INTEGER;
  179. BEGIN
  180.             (* Umrechnung der Ebenenkoordinaten ( 2d Pro- *)
  181.             (* jektionswand) in Bildschirmkoordinaten,    *)
  182.             (* zeichnen der Linie bis zur Bildschirmkante *)
  183.  
  184.   IF ((x1<lx) OR (x2<lx)) AND ((x1>-lx) OR (x2>-lx)) AND
  185.      ((y1<ly) OR (y2<ly)) AND ((y1>-ly) OR (y2>-ly)) THEN
  186.      BEGIN
  187.           (* Soll heißen: Nicht beide zu tief und nicht   *)
  188.           (* beide zu hoch und nicht beide jenseits des   *)
  189.           (* linken und nicht jenseits des rechten Randes *)
  190.     IF x1>lx THEN BEGIN
  191.  
  192.           (* Schnittpunkt der Verbindungsgeraden mit der  *)
  193.           (* rechten  Bildschirmkante                     *)
  194.       k := (lx-x2)/(x1-x2);   y1 := y2+k*(y1-y2);
  195.       x1 := lx;
  196.     END;
  197.     IF x2 > lx THEN BEGIN
  198.       k := (lx-x1)/(x2-x1);   y2 := y1+k*(y2-y1);
  199.       x2 := lx;
  200.     END;
  201.     IF x1 < -lx THEN BEGIN
  202.       k := (-lx-x2)/(x1-x2);  y1 := y2+k*(y1-y2);
  203.       x1 := -lx;
  204.     END;
  205.     IF x2<-lx THEN BEGIN
  206.       k := (-lx-x1)/(x2-x1);  y2 := y1+k*(y2-y1);
  207.       x2 := -lx;
  208.     END;
  209.     IF y1 > ly THEN BEGIN
  210.       k := (ly-y2)/(y1-y2);   x1 := x2+k*(x1-x2);
  211.       y1 := ly;
  212.      END;
  213.      IF y2 > ly THEN BEGIN
  214.        k := (ly-y1)/(y2-y1);   x2 := x1+k*(x2-x1);
  215.        y2 := ly;
  216.      END;
  217.      IF y1 < -ly THEN BEGIN
  218.        k := (-ly-y2)/(y1-y2);  x1 := x2+k*(x1-x2);
  219.        y1 := -ly;
  220.      END;
  221.      IF y2 < -ly THEN BEGIN
  222.        k := (-ly-y1)/(y2-y1);  x2 := x1+k*(x2-x1);
  223.        y2 := -ly;
  224.      END;
  225.      px1 := Trunc(x1/lx*xpix) + xpix;
  226.      px2 := Trunc(x2/lx*xpix) + xpix;
  227.      py1 := ypix - Trunc(y1/ly*ypix);
  228.      py2 := ypix - Trunc(y2/ly*ypix);
  229.      Draw(px1, py1, px2, py2, 1);
  230.   END;
  231. END;
  232.  
  233. PROCEDURE kante(p1, p2 : vektor);
  234. VAR v : vektor;        (* Zeichnet das Bild der Kante von *)
  235.     k : REAL;          (* p1 nach p2.                     *)
  236. BEGIN
  237.   mal(-1, position4, v);  (* Verschiebung der Koordinaten,*)
  238.   plus(p1, v, p1);        (* so daß der Beobachter im Ur- *)
  239.   plus(p2, v, p2);        (* sprung ist.                  *)
  240.   drehKoord4(p1);         (* Umrechnung der Koordinaten in*)
  241.   drehKoord4(p2);         (* ein von der Blickrichtung    *)
  242.   p1.q := p1.q - schirmentf4;  (* normiertes System       *)
  243.   p2.q := p2.q - schirmentf4;  (* Verschieben, Schirm in  *)
  244.                                (* den Ursprung            *)
  245.   IF (p1.q > -schirmentf4*0.99) OR
  246.      (p2.q > -schirmentf4*0.99) THEN BEGIN
  247.  
  248.                (* Wenn ein Punkt vor dem Beobachter liegt *)
  249.                (* wird eine Linie gezeichnet.             *)
  250.  
  251.     IF (p1.q <= -schirmentf4*0.99) THEN BEGIN
  252.  
  253.                (* Wenn p1 hinter dem Beobachter liegt,    *)
  254.                (* also nicht gesehen werden kann, wird ein*)
  255.                (* Punkt auf der Geraden p1 p2 berechnet,  *)
  256.                (* der dicht vor dem Beobachter liegt.     *)
  257.  
  258.       mal(-1, p2, v);
  259.       plus(p1, v, v);
  260.       k := (schirmentf4*0.99 + p2.q)/(-p1.q + p2.q);
  261.       mal(k, v, v);
  262.       plus(p2, v, p1);
  263.     END;
  264.     IF (p2.q <= -schirmentf4*0.99) THEN BEGIN
  265.                         (* Entsprechend wie oben, wenn p2 *)
  266.                         (* hinter dem Beobachter liegt.   *)
  267.       mal(-1, p1, v);
  268.       plus(p2, v, v);
  269.       k := (schirmentf4*0.99 + p1.q)/(-p2.q + p1.q);
  270.       mal(k, v, v);
  271.       plus(p1, v, p2);
  272.     END;
  273.     bildeab43(p1, p1);           (* Berechnung Bildpunkte *)
  274.     bildeab43(p2, p2);
  275.     mal(-1, position3, v);       (* Entsprechend  4-dim   *)
  276.     plus(p1, v, p1);        (* Umrechnung der Koordinaten *)
  277.     plus(p2, v, p2);        (* in ein Koordinatensystem,  *)
  278.     drehKoord3(p1);         (* in dem der Beobachter auf  *)
  279.     drehKoord3(p2);         (* der x-Achse bei            *)
  280.                             (* -schirmentf3 sitzt.        *)
  281.     p1.z := p1.z - schirmentf3;
  282.     p2.z := p2.z - schirmentf3;
  283.     IF (p1.z > -schirmentf3*0.99) OR
  284.        (p2.z > -schirmentf3*0.99) THEN BEGIN
  285.  
  286.     (* Berücksichtigung von Punkten hinter dem Beobachter *)
  287.  
  288.       IF (p1.z <= -schirmentf3*0.99) THEN BEGIN
  289.         mal(-1, p2, v);
  290.         plus(p1, v, v);
  291.         k := (schirmentf3*0.99 + p2.z)/(-p1.z + p2.z);
  292.         mal(k, v, v);
  293.         plus(p2, v, p1);
  294.       END;
  295.       IF (p2.z <= -schirmentf3*0.99) THEN BEGIN
  296.         mal(-1, p1, v);
  297.         plus(p2, v, v);
  298.         k := (schirmentf3*0.99 + p1.z)/(-p2.z + p1.z);
  299.         mal(k, v, v);
  300.         plus(p1, v, p2);
  301.       END;
  302.       bildeab32(p1, p1);
  303.       bildeab32(p2, p2);
  304.       zeichneLinie(p1.x, p1.y, p2.x, p2.y);
  305.     END;
  306.   END;
  307. END;
  308.  
  309.  
  310. PROCEDURE zeichne;    (* Die 32 Kanten des 'Hyperwürfels' *)
  311. BEGIN
  312.   HiRes;
  313.   kante(ecken[ 1], ecken[ 2]); kante(ecken[ 1], ecken[ 3]);
  314.   kante(ecken[ 1], ecken[ 5]); kante(ecken[ 1], ecken[ 9]);
  315.   kante(ecken[ 2], ecken[ 4]); kante(ecken[ 2], ecken[ 6]);
  316.   kante(ecken[ 2], ecken[10]); kante(ecken[ 3], ecken[ 4]);
  317.   kante(ecken[ 3], ecken[ 7]); kante(ecken[ 3], ecken[11]);
  318.   kante(ecken[ 4], ecken[ 8]); kante(ecken[ 4], ecken[12]);
  319.   kante(ecken[ 5], ecken[ 6]); kante(ecken[ 5], ecken[ 7]);
  320.   kante(ecken[ 5], ecken[13]); kante(ecken[ 6], ecken[ 8]);
  321.   kante(ecken[ 6], ecken[14]); kante(ecken[ 7], ecken[ 8]);
  322.   kante(ecken[ 7], ecken[15]); kante(ecken[ 8], ecken[16]);
  323.   kante(ecken[ 9], ecken[10]); kante(ecken[ 9], ecken[11]);
  324.   kante(ecken[ 9], ecken[13]); kante(ecken[10], ecken[12]);
  325.   kante(ecken[10], ecken[14]); kante(ecken[11], ecken[12]);
  326.   kante(ecken[11], ecken[15]); kante(ecken[12], ecken[16]);
  327.   kante(ecken[13], ecken[14]); kante(ecken[13], ecken[15]);
  328.   kante(ecken[14], ecken[16]); kante(ecken[15], ecken[16]);
  329. END;
  330.  
  331.  
  332. BEGIN
  333.   ausgangswerte;
  334.   HiRes;
  335.   REPEAT
  336.     zeichne;
  337.     REPEAT                    (* Änderungen der Parameter *)
  338.       IF dim = 'd' THEN BEGIN
  339.         GotoXY(1,24);
  340.         Write('Position:(',position3.x:4:2,'/',
  341.         position3.y:4:2,'/',position3.z:4:2,')           ');
  342.         GotoXY(1,25);
  343.         Write('Richtung:(',e3z.x:4:2,'/',e3z.y:4:2,
  344.                      '/',e3z.z:4:2,')                    ');
  345.         GotoXY(56,24);
  346.         Write('Schirmentfernung: ', schirmentf3:4:2, '  ');
  347.       END;
  348.       IF dim = 'v' THEN BEGIN
  349.         GotoXY(1,24);
  350.         Write('Position:(',position4.x:4:2,'/',
  351.                position4.y:4:2,'/',position4.z:4:2,
  352.                '/',position4.q:4:2,')   ');
  353.         GotoXY(1,25);
  354.         Write('Richtung:(',e4q.x:4:2,'/',e4q.y:4:2,
  355.                         '/',e4q.z:4:2,'/',e4q.q:4:2,')  ');
  356.         GotoXY(56,24);
  357.         Write('Schirmentfernung: ', schirmentf4:4:2,'   ');
  358.       END;
  359.       GotoXY(34,24);  Write('Schrittweite: ',schrittw:7:3);
  360.       GotoXY(34,25);
  361.       IF bewegen THEN Write('Bewegen  ')
  362.                  ELSE Write('Richtung ');
  363.       taste := ReadKey;
  364.       CASE taste OF
  365.         'd','v'      : dim := taste;
  366.         '1','2','3',
  367.         '4','5','6'  : ebene := taste;
  368.         'g'          : schrittw := schrittw*2;
  369.         'k'          : schrittw := schrittw/2;
  370.         'r'          : bewegen  := FALSE;
  371.         'b'          : bewegen  := TRUE;
  372.         'n'          : IF dim = 'd' THEN
  373.                          schirmentf3:=schirmentf3-schrittw
  374.                        ELSE
  375.                          schirmentf4:=schirmentf4-schrittw;
  376.         'w'          : IF dim = 'd' THEN
  377.                          schirmentf3:=schirmentf3+schrittw
  378.                        ELSE
  379.                          schirmentf4:=schirmentf4+schrittw;
  380.       END;
  381.       IF taste = '+' THEN
  382.         IF bewegen THEN
  383.           IF dim = 'd' THEN BEGIN
  384.             mal(0, v, v);
  385.             CASE ebene OF
  386.               '1': mal(schrittw, e3z, v);
  387.               '2': mal(schrittw, e3x, v);
  388.               '3': mal(schrittw, e3y, v);
  389.             END;
  390.             plus(position3, v, position3);
  391.           END ELSE BEGIN
  392.             mal(0, v, v);
  393.             CASE ebene OF
  394.               '1': mal(schrittw, e4q, v);
  395.               '2': mal(schrittw, e4x, v);
  396.               '3': mal(schrittw, e4y, v);
  397.               '4': mal(schrittw, e4z, v);
  398.             END;
  399.             plus(position4, v, position4);
  400.           END ELSE
  401.             IF dim = 'd' THEN
  402.               CASE ebene OF
  403.                 '1': drehe(e3z, e3x);
  404.                 '2': drehe(e3z, e3y);
  405.                 '3': drehe(e3x, e3y);
  406.             END ELSE
  407.               CASE ebene OF
  408.                 '1': drehe(e4q, e4x);
  409.                 '2': drehe(e4q, e4y);
  410.                 '3': drehe(e4q, e4z);
  411.                 '4': drehe(e4z, e4y);
  412.                 '5': drehe(e4z, e4x);
  413.                 '6': drehe(e4y, e4x);
  414.               END;
  415.        IF taste = '-' THEN
  416.          IF bewegen THEN
  417.            IF dim = 'd' THEN BEGIN
  418.              mal(0, v, v);
  419.              CASE ebene OF
  420.                '1': mal(-schrittw, e3z, v);
  421.                '2': mal(-schrittw, e3x, v);
  422.                '3': mal(-schrittw, e3y, v);
  423.              END;
  424.              plus(position3, v, position3);
  425.            END ELSE BEGIN
  426.              mal(0, v, v);
  427.              CASE ebene OF
  428.                '1': mal(-schrittw, e4q, v);
  429.                '2': mal(-schrittw, e4x, v);
  430.                '3': mal(-schrittw, e4y, v);
  431.                '4': mal(-schrittw, e4z, v);
  432.              END;
  433.              plus(position4, v, position4);
  434.            END ELSE
  435.              IF dim = 'd' THEN
  436.                CASE ebene OF
  437.                  '1': drehe(e3x,e3z);
  438.                  '2': drehe(e3y,e3z);
  439.                  '3': drehe(e3y,e3x);
  440.               END ELSE
  441.                 CASE ebene OF
  442.                   '1': drehe(e4x,e4q);
  443.                   '2': drehe(e4y,e4q);
  444.                   '3': drehe(e4z,e4q);
  445.                   '4': drehe(e4y,e4z);
  446.                   '5': drehe(e4x,e4z);
  447.                   '6': drehe(e4x,e4y);
  448.                 END;
  449.     UNTIL (taste=#13) OR (taste=#27);
  450.   UNTIL taste = #27;
  451. END.
  452. (* ------------------------------------------------------ *)
  453. (*                 Ende von WUERFEL.PAS                   *)
  454.