home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / das_buch / grafik / mode13h.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-09  |  6.9 KB  |  309 lines
  1. {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X-}
  2. {$M 16384,0,655360}
  3. (*===================================================================*)
  4. (*                            MODE13H.PAS                            *)
  5. (*    Demo- und Grundgerüst für die Programmierung des Modus 13h     *)
  6. (*                    (320 * 200 in 256 Farben)                      *)
  7. (*                    Copyright (C) 1993 te-wi Verlag                *)
  8. (*===================================================================*)
  9.  
  10. PROGRAM Mode13hDemo;
  11.  
  12. USES
  13.   Crt, Dos;
  14.  
  15. CONST
  16.   Black        =   0; Blue           =  1; Green        =  2;
  17.   Cyan         =   3; Red            =  4; Magenta      =  5;
  18.   Brown        =   6; LightGray      =  7; DarkGray     =  8;
  19.   LightBlue    =   9; LightGreen     = 10; LightCyan    = 11;
  20.   LightRed     =  12; LightMagenta   = 13; Yellow       = 14;
  21.   White        =  15; MaxColors      = 256;
  22.  
  23.   GetMaxX      = 319; GetMaxY        = 199;
  24.  
  25.   InitDone     : BOOLEAN = FALSE;
  26.   GraphResult  : INTEGER = 0;
  27.   DisplayColor : BYTE    = 15;
  28.   BackGrndColor: BYTE    = 00;
  29.   LastMode     : BYTE    = $03;
  30.  
  31. VAR
  32.   i, j     : WORD;
  33.   Regs     : Registers;
  34.   (* Im Modus 13h ist der Bildschirm nicht in Bitplanes aufgeteilt *)
  35.   (* sondern direkt als ARRAY[0..199,0..319] adressierbar:         *)
  36.   Screen   : ARRAY[0..GetMaxY, 0..GetMaxX] OF BYTE ABSOLUTE $A000:0;
  37.   GraphMode: INTEGER;
  38.  
  39. FUNCTION GetBkColor: BYTE;
  40. BEGIN
  41.   GetBkColor := BackGrndColor;
  42. END;
  43.  
  44. PROCEDURE SetBkColor(col: BYTE);
  45. BEGIN
  46.   BackGrndColor := col;
  47.   Regs.AH := $0B;
  48.   Regs.BH := $00;
  49.   Regs.BL := col;
  50.   Intr($10, Regs);
  51. END;
  52.  
  53. PROCEDURE ClearDevice;
  54. BEGIN
  55.   Regs.AH := $06;
  56.   Regs.AL := $00;
  57.   Regs.BH := BackGrndColor;
  58.   Regs.CL := 0;
  59.   Regs.CH := 0;
  60.   Regs.DL := 39;
  61.   Regs.DH := 24;
  62.   Intr($10,Regs);
  63. END;
  64.  
  65. PROCEDURE SetGraphMode(VAR Mode: INTEGER);
  66. BEGIN
  67.   IF NOT InitDone THEN BEGIN
  68.     LastMode := Mem[$40:$49];
  69.     Regs.AH := $00;
  70.     Regs.AL := Lo(Mode);
  71.     Intr($10, Regs);
  72.     IF Mem[$40:$49] <> Mode THEN
  73.     BEGIN
  74.       GraphResult := -1;
  75.       Mode        := -1;
  76.     END ELSE InitDone := TRUE;
  77.   END;
  78. END;
  79.  
  80. PROCEDURE OutTextXY(x, y: BYTE; s: STRING);
  81. BEGIN
  82.    Regs.AX := $1300;
  83.    Regs.BH := 0;
  84.    Regs.BL := DisplayColor;
  85.    Regs.DH := y - 1;
  86.    Regs.DL := x - 1;
  87.    Regs.CX := Ord(s[0]);
  88.    Regs.ES := Seg(s);
  89.    Regs.BP := Ofs(s[1]);
  90.    Intr($10, Regs);
  91. END;
  92.  
  93. PROCEDURE PutPixel(x, y: INTEGER; Color: BYTE);
  94. BEGIN
  95.   Screen[y, x] := Color;
  96. END;
  97.  
  98. PROCEDURE RestoreCrtMode;
  99. BEGIN
  100.   Regs.AH := 0;
  101.   Regs.AL := LastMode;
  102.   Intr($10, Regs);
  103.   InitDone := FALSE;
  104. END;
  105.  
  106. PROCEDURE Rectangle(x1, y1, x2, y2: INTEGER);
  107. VAR
  108.   i: INTEGER;
  109. BEGIN
  110.   FOR i := x1 TO x2 DO Screen[y1, i] := DisplayColor;
  111.   FOR i := y1 TO y2 DO Screen[i, x1] := DisplayColor;
  112.   FOR i := x1 TO x2 DO Screen[y2, i] := DisplayColor;
  113.   FOR i := y1 TO y2 DO Screen[i, x2] := DisplayColor;
  114. END;
  115.  
  116. PROCEDURE Line(x1, y1, x2, y2: INTEGER);
  117. VAR
  118.   dx, dy, ex, ey: Integer;
  119.  
  120.   PROCEDURE Swap(VAR i, j: INTEGER);
  121.   VAR
  122.     t: Integer;
  123.   BEGIN
  124.     t := i;
  125.     i := j;
  126.     j := t;
  127.   END;
  128.  
  129. BEGIN
  130.   IF x1 > x2 THEN
  131.   BEGIN
  132.     Swap(x1, x2);
  133.     Swap(y1, y2);
  134.   END;
  135.   ex := x1 - x2;
  136.   ey := -Abs(y2 - y1);
  137.   dx := (-ex) SHL 1;
  138.   dy := (-ey) SHL 1;
  139.   IF y1 <= y2 THEN
  140.   BEGIN
  141.     IF dx >= dy THEN FOR x1 := x1 TO x2 DO
  142.     BEGIN
  143.       PutPixel(x1, y1, DisplayColor);
  144.       Inc(ex, dy);
  145.       IF ex > 0 THEN
  146.       BEGIN
  147.         Dec(ex, dx);
  148.         Inc(y1);
  149.       END;
  150.     END
  151.     ELSE FOR y1 := y1 TO y2 DO
  152.     BEGIN
  153.       PutPixel(x1, y1, DisplayColor);
  154.       Inc(ey, dx);
  155.       IF ey > 0 THEN
  156.       BEGIN
  157.         Dec(ey, dy);
  158.         Inc(x1);
  159.       END;
  160.     END;
  161.   END
  162.   ELSE
  163.   BEGIN
  164.     IF dx >= dy THEN
  165.     BEGIN
  166.       FOR x1 := x1 TO x2 DO
  167.       BEGIN
  168.         PutPixel(x1, y1, DisplayColor);
  169.         Inc(ex, dy);
  170.         IF ex > 0 THEN
  171.         BEGIN
  172.           Dec(ex, dx);
  173.           Dec(y1);
  174.         END;
  175.       END;
  176.     END
  177.     ELSE FOR y1 := y1 DOWNTO y2 DO
  178.     BEGIN
  179.       PutPixel(x1, y1, DisplayColor);
  180.       Inc(ey, dx);
  181.       IF ey > 0 THEN
  182.       BEGIN
  183.         Dec(ey,dy);
  184.         Inc(x1);
  185.       END;
  186.     END;
  187.   END;
  188. END;
  189.  
  190. PROCEDURE EllipseAndCircle(xm, ym: INTEGER; xr,  yr: INTEGER);
  191. VAR
  192.   x, y : INTEGER;
  193.   dx, dy,
  194.   ySub, xAdd,
  195.   r    : LONGINT;
  196. BEGIN
  197.   IF (xr = 0) OR (yr = 0) THEN Exit;
  198.   dx := LONGINT(xr * 2) * LONGINT(xr);
  199.   dy := LONGINT(yr * 2) * LONGINT(yr);
  200.   ySub := 0;
  201.   xAdd := LONGINT(xr) * dy;
  202.   r := xAdd DIV 2;
  203.   x := xr;
  204.   y := 0;
  205.   REPEAT
  206.     PutPixel(xm + x, ym + y, DisplayColor);
  207.     PutPixel(xm + x, ym - y, DisplayColor);
  208.     PutPixel(xm - x, ym - y, DisplayColor);
  209.     PutPixel(xm - x, ym + y, DisplayColor);
  210.     IF r >= 0 THEN
  211.     BEGIN
  212.       Inc(y);
  213.       Inc(ySub,dx);
  214.       Dec(r,ySub);
  215.     END;
  216.     IF r < 0 THEN
  217.     BEGIN
  218.       Dec(x);
  219.       Dec(xAdd, dy);
  220.       Inc(r, xAdd);
  221.     END;
  222.   UNTIL x < 0;
  223. END;
  224.  
  225. PROCEDURE Circle(x, y, r: INTEGER);
  226. BEGIN
  227.   EllipseAndCircle(x, y, Round(r * 5 / 4), r);
  228.   { Die magische Zahl 5 / 4 gleicht die Aspect-Ratio aus }
  229. END;
  230.  
  231. PROCEDURE Ellipse(x, y, rx, ry: INTEGER);
  232. BEGIN
  233.   EllipseAndCircle(x, y, Round(rx * 5 / 4), ry);
  234.   { Die magische Zahl 5 / 4 gleicht die Aspect-Ratio aus }
  235. END;
  236.  
  237. PROCEDURE CloseGraph;
  238. BEGIN
  239.   RestoreCrtMode;
  240. END;
  241.  
  242. PROCEDURE grError(i: INTEGER);
  243. VAR
  244.   ErrMsg: STRING;
  245. BEGIN
  246.   CASE
  247.     i OF
  248.       0: ErrMsg := 'Kein Fehler';
  249.      -1: ErrMsg := 'Grafik konnte nicht initialisiert werden';
  250.     ELSE ErrMsg := 'Allgemeiner Grafikkfehler';
  251.   END;
  252.   Write('Grafikfehler: ', ErrMsg);
  253.   Halt(Abs(i));
  254. END;
  255.  
  256. FUNCTION GetColor: BYTE;
  257. BEGIN
  258.   GetColor := DisplayColor;
  259. END;
  260.  
  261. PROCEDURE SetColor(Color: BYTE);
  262. BEGIN
  263.   DisplayColor := Color;
  264. END;
  265.  
  266. BEGIN
  267.   GraphMode := $13;
  268.   SetGraphMode(GraphMode);
  269.   IF GraphResult < 0 THEN grError(GraphResult);
  270.   Line(0, GetMaxY DIV 2, GetMaxX, GetMaxY DIV 2);
  271.   Line(GetMaxX DIV 2, 0, GetMaxX DIV 2, GetMaxY);
  272.   SetColor(Yellow);
  273.   Line(0, 0, GetMaxX, GetMaxY);
  274.   Line(GetMaxX, 0, 0, GetMaxY);
  275.   Delay(1000);
  276.   SetColor(LightMagenta);
  277.   SetColor(64);
  278.   SetBkColor(Blue);
  279.   Rectangle(0, 0, GetMaxX, GetMaxY);
  280.   Delay(1000);
  281.   REPEAT
  282.     FOR i := 0 TO 100 DO BEGIN
  283.      SetColor(127 - i);
  284.      Delay(10);
  285.      Rectangle(i, i, GetMaxX - i, GetMaxY - i);
  286.     END;
  287.     SetColor(White);
  288.     OutTextXY(15, 10, ' Modus 13h ');
  289.     SetColor(Black);
  290.     FOR i := 0 TO 100 DO BEGIN
  291.       SetColor(i + 15);
  292.       Delay(10);
  293.       Circle(GetMaxX DIV 2, GetMaxY DIV 2, i);
  294.     END;
  295.     FOR i := 200 DOWNTO 0 DO BEGIN
  296.       SetColor(i + 15);
  297.       Delay(10);
  298.       Ellipse(GetMaxX DIV 2, GetMaxY DIV 2, i DIV 4, i DIV 2);
  299.       Ellipse(GetMaxX DIV 2, GetMaxY DIV 2, i DIV 2, i DIV 4);
  300.     END;
  301.     SetColor(Black);
  302.     Line(0, GetMaxY DIV 2, GetMaxX, GetMaxY DIV 2);
  303.     Line(GetMaxX DIV 2, 0, GetMaxX DIV 2, GetMaxY);
  304.   UNTIL KeyPressed;
  305.   CloseGraph;
  306. END.
  307.  
  308. (*===================================================================*)
  309.