home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / 3D.p < prev    next >
Encoding:
Text File  |  1994-07-23  |  15.6 KB  |  401 lines
  1. PROGRAM _3D;
  2. USES Intuition,Graphics;
  3.  
  4. { geschrieben von:         Michael Janich 1989             }
  5. { bearbeitet von:          Jens "Himpelsoft" Gelhar        }
  6. { ALL RIGHTS REVERSED.                                     }
  7.  
  8. { MaxonPascal3-Anpassung:  Falk Zühlsdorff (PackMAN) 1994  }
  9.  
  10. { Programm wird mit ESC beendet.                           }
  11. { Mit den Cursortasten kann man die Rotationsrichtung des  }
  12. { Objekts ändern, mit einigen Tasten des Ziffernblocks     }
  13. { den Standpunkt des Betrachters.                          }
  14. { In der vorliegenden Version gibt es noch Fehler, wenn    }
  15. { Linien den Bildschirmrand überschreiten.                 }
  16.  
  17. CONST width=640;
  18.       height=256; { Screen }
  19.  
  20.       file_name = 'MPascal3:Demo/3D_coords/coords.haus';
  21.       { Aus dieser Datei werden die Koordinaten gelesen }
  22.  
  23.       rot_angle=0.12; { rotation in one step }
  24.  
  25. TYPE Point = REAL;
  26.      Ptr2Point_3d = ^Point_3d;
  27.      Point_3d = RECORD x, y, z: Point;
  28.                 END; { Rec Point_3d }
  29.      Ptr2Point_2d = ^Point_2d;
  30.      Point_2d = RECORD x, y: Point;
  31.                 END; { Rec Point_2d }
  32.      Ptr2Coords = ^Coords;
  33.      Coords = RECORD c: Point_3d;
  34.          next: Ptr2Coords;
  35.      END;
  36.  
  37. VAR  fin,helpscreen : BOOLEAN;
  38.      FP             : Point_3d;
  39.      chain          : Ptr2Coords;
  40.      W1,W2          :^Window;
  41.      Rast1          :^RastPort;
  42.      MyScreen1      : ^Screen;
  43.      Rast2          :^RastPort;
  44.      Rast           : ^RastPort;
  45.      MyScreen2      : ^Screen;
  46.      t1             : IntuiText;
  47.      sin_rot_angle,
  48.      cos_rot_angle  : REAL;
  49.      act_pos        : STRING[99];
  50.      Pointer        : ^Byte; { Requiered for key-codes }
  51.      LastKey        : Byte;
  52.      i              : INTEGER;
  53.      pro_Res,last   : Point_2d; { Result of projetion-function }
  54.      rot_res        : Point_3d; { Result of rotation-func }
  55.      rot,scr_no     : INTEGER;
  56.  
  57. (************************************************************************)
  58. (* Function:                                                            *)
  59. (*                                                                      *)
  60. (* Open Screen                                                          *)
  61. (************************************************************************)
  62.  
  63. PROCEDURE Init;
  64. VAR i: INTEGER;
  65.  
  66.    BEGIN { Init }
  67.       fin := FALSE;
  68.       Pointer := Ptr($bfec01);
  69.       LastKey := 0;
  70.       MyScreen1:=Open_Screen(0, 0, width, height, 1, 0, 1, HIRES or GENLOCK_VIDEO,'3d-Haus');
  71.       MyScreen2:=Open_Screen(0, 0, width, height, 1, 0, 1, HIRES or GENLOCK_VIDEO,'3d-Haus');
  72.       W1:=Open_Window(0,0,width,height,1,0,$0800,Nil,MyScreen1,width,height,width,height);
  73.       W2:=Open_Window(0,0,width,height,1,0,$0800,Nil,MyScreen2,width,height,width,height);
  74.       Rast1:=W1^.RPort;
  75.       Rast2:=W2^.RPort;
  76.       Rast := Rast1;
  77.       SetRGB4(^MyScreen1^.ViewPort,0,1,1,1); { almost black }
  78.       SetRGB4(^MyScreen2^.ViewPort,0,1,1,1);
  79.       SetRGB4(^MyScreen1^.ViewPort,1,14,14,14); { almost withe }
  80.       SetRGB4(^MyScreen2^.ViewPort,1,14,14,14);
  81.       FP.x := -40; { Point of eye }
  82.       FP.y := -40;
  83.       FP.z := -40;
  84.       sin_rot_angle := sin(rot_angle);
  85.       cos_rot_angle := cos(rot_angle);
  86.       last.x := width div 2; { else undefinded }
  87.       last.y := height div 2;
  88.       scr_no := 1; { screen_number toggles between 1 and 2 }
  89.       rot := 2;    { rotation axis 1,2,3 }
  90.    END; { Proc Init }
  91.  
  92. (************************************************************************)
  93. (* Input:                                                               *)
  94. (*                                                                      *)
  95. (* 3d-Point; call by reference                                          *)
  96. (************************************************************************)
  97. (* Output:                                                              *)
  98. (*                                                                      *)
  99. (* 3d-Point                                                             *)
  100. (************************************************************************)
  101. (* Function:                                                            *)
  102. (*                                                                      *)
  103. (* rotate point by the rot_angle                                        *)
  104. (************************************************************************)
  105.  
  106. PROCEDURE Rotate_alfa (VAR a: Point_3d); { We change the original point }
  107. BEGIN
  108.    a.y := a.y * cos_rot_angle - a.z * sin_rot_angle;
  109.    a.z := a.y * sin_rot_angle + a.z * cos_rot_angle;
  110. END; { Proc Rotate_alfa }
  111.  
  112. PROCEDURE Rotate_beta (VAR a: Point_3d); { We change the original point }
  113. BEGIN
  114.    a.x := a.x * cos_rot_angle + a.z * sin_rot_angle;
  115.    a.z := a.z * cos_rot_angle - a.x * sin_rot_angle ;
  116. END; { Proc Rotate_beta }
  117.  
  118. PROCEDURE Rotate_gamma (VAR a: Point_3d); { We change the original point }
  119. BEGIN
  120.    a.x := a.x * cos_rot_angle - a.y * sin_rot_angle;
  121.    a.y := a.x * sin_rot_angle + a.y * cos_rot_angle;
  122. END; { Proc Rotate_gamma }
  123.  
  124. { please verify the +- in r_gamma }
  125.  
  126. (************************************************************************)
  127. (* Input:                                                               *)
  128. (*                                                                      *)
  129. (* 3d-Point                                                             *)
  130. (************************************************************************)
  131. (* Output:                                                              *)
  132. (*                                                                      *)
  133. (* 2d-Point                                                             *)
  134. (************************************************************************)
  135. (* Function:                                                            *)
  136. (*                                                                      *)
  137. (* Convert py central-perspectiv                                        *)
  138. (************************************************************************)
  139.  
  140. PROCEDURE Projection (a: Point_3d); { result in global Pro_res }
  141. VAR t: Point;
  142.  
  143.    BEGIN { Func Projection }
  144.       {$if def debug}
  145.          WriteLn("Projection: Eingabe: (",a.x,",",a.y,",",a.z,").");
  146.       {$endif debug}
  147.       IF abs(a.y - FP.y) <1e-3
  148.          THEN t := 0
  149.          ELSE t := a.y / (2*(a.y - FP.y));
  150.       pro_res.x := 2*(a.x - t*(a.x - FP.x))+width/2;
  151.       pro_res.y :=   (a.z - t*(a.z - FP.z))+height/2;
  152.       {$if def debug}
  153.          WriteLn("----------- Ausgabe: (",pro_res.x,",",pro_res.y,").");
  154.       {$endif debug}
  155.  END; { Func Projection }
  156.  
  157. (************************************************************************)
  158. (* Input:                                                               *)
  159. (*                                                                      *)
  160. (* 2d-Points                                                            *)
  161. (************************************************************************)
  162. (* Function:                                                            *)
  163. (*                                                                      *)
  164. (* Check Point for screen-dimens. cut, if neccessary                    *)
  165. (************************************************************************)
  166.  
  167. PROCEDURE Check (VAR a: Point_2d);
  168. VAR temp: Point_2d;
  169.  
  170. BEGIN
  171.    temp := a;
  172.    IF a.x < 0 THEN { right of screen }
  173.       IF (last.x-a.x)=0 THEN a.x := -1 ELSE BEGIN { check for division by 0 }
  174.          a.y := last.y - (last.y-a.y)*last.x/(last.x-a.x); a.x := 0;
  175.       END;
  176.    IF a.y >= height THEN
  177.       IF (last.y-a.y)=0 THEN a.x := -1 ELSE BEGIN
  178.          a.x := a.x - (a.x-last.x)*(last.y-height)/(a.y-last.y); a.y := height-1;
  179.       END;
  180.    IF a.x >= width THEN BEGIN
  181.       {$if def debug}
  182.          WriteLn("a.x ist zu gross: ",a.x," >= ",width);
  183.       {$endif}
  184.       IF (a.x-last.x)=0 THEN a.x := -1 ELSE BEGIN
  185.          a.y := last.y - (last.y-a.y)*(last.x-width)/(a.x-last.x); { an dieser Stelle gabs immer den /0-error }
  186.          a.x := width-1;
  187.       END;
  188.    END;
  189.    IF a.y < 0 THEN
  190.       IF (last.y-a.y)=0 THEN a.x := -1 ELSE BEGIN
  191.          a.x := a.x - (a.x-last.x)*last.y/(last.y-a.y); a.y :=  0;
  192.       END; { letztes ist noch zu überprüfen }
  193.    {$if def debug}
  194.       IF(a.x <> temp.x) OR (a.y <> temp.y) THEN
  195.          WriteLn("Changes in Check-Procedure.");
  196.    {$endif debug}
  197.    last := temp;
  198.  
  199. END; { Proc Check }
  200. (************************************************************************)
  201. (* Input:                                                               *)
  202. (*                                                                      *)
  203. (* Two 2d-Points (from-Coord, to-Coord)                                 *)
  204. (************************************************************************)
  205. (* Function:                                                            *)
  206. (*                                                                      *)
  207. (* Draw Line on Screen                                                  *)
  208. (************************************************************************)
  209.  
  210. PROCEDURE Draw_line(a: Point_2d);
  211.    BEGIN
  212.       Check (a);
  213.       {$if def debug}
  214.           WriteLn("Linie nach (",a.x,",",a.y,").");
  215.       {$endif}
  216.       IF a.x <> -1 THEN Draw (Rast, round(a.x), round(a.y));
  217.    END; { Proc Draw }
  218.  
  219. (************************************************************************)
  220. (* Input:                                                               *)
  221. (*                                                                      *)
  222. (* 2d-Point (to-Coord)                                                  *)
  223. (************************************************************************)
  224. (* Function:                                                            *)
  225. (*                                                                      *)
  226. (* Move Grafik-Cursor                                                   *)
  227. (************************************************************************)
  228.  
  229. PROCEDURE Move_Line(a: Point_2d);
  230.    BEGIN
  231.       Check (a);
  232.         {$if def debug}
  233.            WriteLn("Bewegen nach (",a.x,",",a.y,").");
  234.         {$endif}
  235.       IF a.x <> -1 THEN Move(Rast, round(a.x), round(a.y));
  236.    END; { Proc Move_line }
  237.  
  238. (************************************************************************)
  239. (* Input:                                                               *)
  240. (*                                                                      *)
  241. (* Keyboard                                                             *)
  242. (************************************************************************)
  243. (* Function:                                                            *)
  244. (*                                                                      *)
  245. (* change point of eye                                                  *)
  246. (************************************************************************)
  247.  
  248. PROCEDURE Read_Change;
  249.    BEGIN
  250.      LastKey := Pointer^;
  251.      CASE LastKey OF
  252.        133: FP.x := FP.x + 1;
  253.        197: FP.x := FP.x - 1;
  254.        131: FP.y := FP.y + 1;
  255.        195: FP.y := FP.y - 1;
  256.        129: FP.z := FP.z + 1;
  257.        193: FP.z := FP.z - 1;
  258.        103: rot := 1;
  259.        101: rot := 1;
  260.        097: rot := 2;
  261.        099: rot := 2;
  262.        139: rot := 3;
  263.        201: rot := 3;
  264.        127, 117, 119: fin := TRUE;
  265.        Otherwise
  266.      END; { CASE }
  267.  
  268.      CASE scr_no OF
  269.       1: BEGIN Rast:=Rast2; ScreenToFront(MyScreen1) END;
  270.       2: BEGIN Rast:=Rast1; ScreenToFront(MyScreen2) END
  271.      END;
  272.  
  273.      scr_no := 3-scr_no;
  274.      SetAPen(Rast,0);
  275.      RectFill(Rast,0,0,Width-1,Height-1);
  276.      SetAPen(Rast,1);
  277.    END; { Proc Read_Changes }
  278.  
  279. (************************************************************************)
  280. (* Input:                                                               *)
  281. (*                                                                      *)
  282. (* Chain of 3d-points                                                   *)
  283. (************************************************************************)
  284. (* Function:                                                            *)
  285. (*                                                                      *)
  286. (* Calculate and Draw 3d-points                                         *)
  287. (************************************************************************)
  288.  
  289. PROCEDURE Calc_Draw (root: Ptr2Coords);
  290.  
  291.    BEGIN
  292.       WHILE root <> NIL DO
  293.       BEGIN
  294.         IF root^.c.x = -1 THEN
  295.            BEGIN
  296.               root := root^.next;
  297.               CASE rot OF
  298.                  1: Rotate_alfa (root^.c);
  299.                  2: Rotate_beta (root^.c);
  300.                  3: Rotate_gamma(root^.c);
  301.               ELSE; END; { case }
  302.               Projection (root^.c);
  303.               Move_Line(pro_res);
  304.            END
  305.            ELSE BEGIN
  306.               CASE rot OF
  307.                  1: Rotate_alfa (root^.c);
  308.                  2: Rotate_beta (root^.c);
  309.                  3: Rotate_gamma(root^.c);
  310.               ELSE; END; { case }
  311.               Projection(root^.c);
  312.               Draw_Line(pro_res);
  313.            END;
  314.         root := root^.next;
  315.      END; { WHILE }
  316.    END; { Proc Calc_Draw }
  317.  
  318. (************************************************************************)
  319. (* Input:                                                               *)
  320. (*                                                                      *)
  321. (* File of coords of object                                             *)
  322. (************************************************************************)
  323. (* Output:                                                              *)
  324. (*                                                                      *)
  325. (* Root of chain                                                        *)
  326. (************************************************************************)
  327. (* Function:                                                            *)
  328. (*                                                                      *)
  329. (* read  file  from extern device                                       *)
  330. (************************************************************************)
  331.  
  332. FUNCTION Read_Coords: Ptr2Coords;
  333. VAR  f: FILE OF CHAR;
  334.      old_coord, result, temp: Ptr2Coords;
  335.  
  336.    BEGIN
  337.       New (result);
  338.       WITH result^.c DO
  339.       BEGIN
  340.          x := -1;
  341.          y := 0;
  342.          z := 0;
  343.       END; { WITH }
  344.       old_coord := result;
  345.       Reset (f, file_Name);
  346.       IF EoF(f) THEN Error ("File not Found.");
  347.       WHILE NOT EoF(f) DO
  348.       BEGIN
  349.          New (temp);
  350.          WITH temp^.c DO
  351.          BEGIN
  352.             ReadLn (f, x, y, z);
  353.             {$if def debug}
  354.                WriteLn("Gelesene Coordinaten: (",x,",",y,",",z,").");
  355.             {$endif}
  356.          END; { WITH }
  357.          old_coord^.next := temp;
  358.          old_coord := temp;
  359.       END; { WHILE }
  360.       temp^.next := NIL; { End of chain }
  361.       Read_Coords := result;
  362.    END; { Func Read_Coords }
  363.  
  364.  
  365. (************************************************************************)
  366. (* Function:                                                            *)
  367. (*                                                                      *)
  368. (* Close libraries and screen                                           *)
  369. (************************************************************************)
  370.  
  371.  
  372. PROCEDURE Close_(list:Ptr2Coords);
  373. VAR temp: Ptr2Coords;
  374.    BEGIN
  375.       WHILE (list <> NIL) DO
  376.       BEGIN
  377.          temp := list^.next;
  378.          dispose (list);
  379.          list := temp;
  380.       END; { WHILE }
  381.       helpscreen:=CloseScreen(MyScreen1);
  382.       helpscreen:=CloseScreen(MyScreen2);
  383.       CloseLib(intuitionbase);
  384.       CloseLib(GfxBase);
  385.    END;
  386.  
  387. BEGIN { Main }
  388.    Init;
  389.    chain := Read_Coords;
  390.    REPEAT
  391.       Calc_Draw (chain);
  392.       Read_Change;
  393.       act_pos := '('+RealStr(FP.x,0)+','+RealStr(FP.y,0)+','+RealStr(Fp.z,0)+')';
  394.       t1:=IntuiText(1,0,1,0,0,Nil,act_pos,Nil);
  395.       PrintIText (Rast1, ^t1, 10,190);
  396.       PrintIText (Rast2, ^t1, 10,190);
  397.    UNTIL fin;
  398.    Close_(chain);
  399. END.
  400.  
  401.