home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / dtx9302 / grafik / hi_res.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-06  |  13.3 KB  |  560 lines
  1. (* ------------------------------------------------------ *)
  2. (*                     HI_RES.PAS                         *)
  3. (*   Schnelle Grafiken für 16 Bit VGA mit Trident-Chips   *)
  4. (*        (c) 1992,93 Arno Bücken & DMV-Verlag            *)
  5. (* ------------------------------------------------------ *)
  6. UNIT Hi_Res;
  7.  
  8. INTERFACE
  9.  
  10. VAR
  11.   GraphicError : BYTE;
  12.  
  13.   PROCEDURE GraphMode;
  14.   PROCEDURE TextModus;
  15.   PROCEDURE PutPixel(x, y, c : WORD);
  16.   PROCEDURE Line(x, y, x2, y2, c : INTEGER);
  17.   PROCEDURE Circle(xm, ym, r, c : INTEGER);
  18.   PROCEDURE Ellipse(xm, ym, rx, ry, c : INTEGER);
  19.   PROCEDURE Quad(x1, y1, x2, y2, c1, c2 : INTEGER);
  20.   PROCEDURE Rec(x1, y1, x2, y2, c : INTEGER);
  21.   PROCEDURE Paint(x, y, c : WORD);
  22.   PROCEDURE PrintScreen;
  23. { PROCEDURE PrintScreen9;   --> vgl. Listing 2 }
  24.   PROCEDURE SetColorToPrint(b : BYTE);
  25.   PROCEDURE ClearColorToPrint(b : BYTE);
  26.   PROCEDURE hLine(x1, x2, y, c : WORD);
  27.   PROCEDURE WrChar(ch : CHAR; c : WORD);
  28.   PROCEDURE SetPos(x, y : WORD);
  29.   PROCEDURE WrStr(VAR Str; c : WORD);
  30.   PROCEDURE SavePalette;
  31.   PROCEDURE RestorePalette;
  32.   PROCEDURE SetColor(n, r, g, b : BYTE);
  33.   FUNCTION  GetPixel(x, y : WORD) : WORD;
  34.  
  35. IMPLEMENTATION
  36.  
  37. USES Printer, Dos;
  38.  
  39. TYPE
  40.   PixelP = ^Pixel;
  41.   Pixel  = RECORD
  42.              x, y : WORD;
  43.              Next : PixelP;
  44.            END;
  45.  
  46. CONST
  47.   Index = $03ce;
  48.   Daten = $03cf;
  49.   br    : ARRAY [0..7] OF BYTE = (128, 64, 32, 16, 8, 4, 2, 1);
  50.  
  51. VAR
  52.   Regs    : Registers;
  53.   Modus   : BYTE;
  54.   i       : WORD;
  55.   Drucken : ARRAY [0..16] OF BYTE;
  56.   Palette : ARRAY [0..16] OF BYTE;
  57.   Color   : ARRAY [0..48] OF BYTE;
  58.  
  59.   PROCEDURE GraphMode;
  60.   BEGIN
  61.     Regs.ah := $0F;
  62.     Intr($10, Regs);
  63.     Modus   := Regs.al;
  64.     Regs.al := $00;
  65.     Regs.ah := $1a;
  66.     Intr($10, Regs);
  67.     IF (Regs.al <> $1A) OR (Regs.bl <> 8) THEN BEGIN
  68.       GraphicError := 1;
  69.       Exit;
  70.     END ELSE BEGIN
  71.       Regs.ah := 0;
  72.       Regs.al := $5F;
  73.       Intr($10, Regs);
  74.     END;
  75.   END;
  76.  
  77.   PROCEDURE TextModus;
  78.   BEGIN
  79.     Regs.ah := 0;
  80.     Regs.al := Modus;
  81.     Intr($10, Regs);
  82.   END;
  83.  
  84.   PROCEDURE PutPixel(x, y, c : WORD);
  85.   VAR
  86.     a, AdrA   : BYTE;
  87.     AdrB, Seg : WORD;
  88.   BEGIN
  89.     IF (c < 0) OR (c > 15) THEN BEGIN
  90.       GraphicError := 2;
  91.       Exit;
  92.     END;
  93.     IF (x < 0) OR (y < 0) OR (x > 1023) OR
  94.        (y>767) THEN BEGIN
  95.       GraphicError := 3;
  96.       Exit;
  97.     END;
  98.     AdrA := x MOD 8;
  99.     AdrB := x DIV 8;
  100.     Seg  := $A000+y * 8;
  101.     a    := Mem[Seg:AdrB];
  102.     Port[Index]   := 1;
  103.     Port[Daten]   := $0F;
  104.     Port[Index]   := 8;
  105.     Port[Daten]   := Br[AdrA];
  106.     Port[Index]   := 0;
  107.     Port[Daten]   := c;
  108.     Mem[Seg:AdrB] := a;
  109.     Port[Index]   := 1;
  110.     Port[Daten]   := 0;
  111.     Port[Index]   := 8;
  112.     Port[Daten]   := 0;
  113.   END;
  114.  
  115.   FUNCTION GetPixel(x, y : WORD) : WORD;
  116.   VAR
  117.     AdrB       : WORD;
  118.     AdrA       : BYTE;
  119.     a, b, c, d : BYTE;
  120.     Seg, g     : WORD;
  121.   BEGIN
  122.     IF (x < 0) OR (x > 1023) OR (y < 0) OR
  123.        (y > 767) THEN BEGIN
  124.       GraphicError := 3;
  125.       Exit;
  126.     END;
  127.     AdrA := x MOD 8;
  128.     AdrB := x DIV 8;
  129.     seg  := $A000+y * 8;
  130.     a    := Mem[Seg:AdrB];
  131.     Port[Index] := 4;
  132.     Port[Daten] := 1;
  133.     b := Mem[Seg:AdrB];
  134.     Port[Daten] := 2;
  135.     c := Mem[Seg:AdrB];
  136.     Port[Daten] := 3;
  137.     d := Mem[Seg:AdrB];
  138.     Port[Daten] := 0;
  139.     g := 0;
  140.     IF (a AND Br[AdrA]) <> 0 THEN Inc(g, 1);
  141.     IF (b AND Br[AdrA]) <> 0 THEN Inc(g, 2);
  142.     IF (c AND Br[AdrA]) <> 0 THEN Inc(g, 4);
  143.     IF (d AND Br[AdrA]) <> 0 THEN Inc(g, 8);
  144.     GetPixel := g;
  145.   END;
  146.  
  147.   PROCEDURE hLine(x1, x2, y, c : WORD);
  148.   VAR
  149.     Seg, Counter, AdrA, AdrB : WORD;
  150.   BEGIN
  151.     WHILE (x1 < x2) AND (x1 MOD 8 <> 0) DO BEGIN
  152.       PutPixel(x1, y, c);
  153.       Inc(x1);
  154.     END;
  155.     WHILE (x2 > x1) AND (x2 MOD 8 <> 7) DO BEGIN
  156.       PutPixel(x2, y, c);
  157.       Dec(x2);
  158.     END;
  159.     IF x1 = x2 THEN Exit;
  160.     Port[Index] := 1;
  161.     Port[Daten] := $0F;
  162.     Port[Index] := 8;
  163.     Port[Daten] := 255;
  164.     Port[Index] := 0;
  165.     Port[Daten] := c;
  166.     Seg  := $A000+y * 8;
  167.     AdrA := x1 DIV 8;
  168.     AdrB := x2 DIV 8;
  169.     FOR Counter := AdrA TO AdrB DO
  170.       Mem[Seg:Counter] := 255;
  171.     Port[Index] := 1;
  172.     Port[Daten] := 0;
  173.     Port[Index] := 8;
  174.     Port[Daten] := 0;
  175.   END;
  176.  
  177.   FUNCTION Sgn(i : INTEGER) : INTEGER;
  178.   BEGIN
  179.     IF i = 0 THEN
  180.       Sgn := 0
  181.     ELSE IF i < 0 THEN
  182.       Sgn := -1
  183.     ELSE Sgn := 1;
  184.   END;
  185.  
  186.   PROCEDURE Line(x, y, x2, y2 : INTEGER; c : INTEGER);
  187.   VAR
  188.     i1, i2, i, d, s1, s2, dx, dy : INTEGER;
  189.     t                            : BOOLEAN;
  190.   BEGIN
  191.     dx := Abs(x2-x);
  192.     dy := Abs(y2-y);
  193.     s1 := Sgn(x2-x);
  194.     s2 := Sgn(y2-y);
  195.     IF dx < dy THEN BEGIN
  196.       d  := dx;
  197.       dx := dy;
  198.       dy := d;
  199.       t  := TRUE;
  200.     END ELSE
  201.       t  := FALSE;
  202.     d  := 2 * dy-dx;
  203.     i1 := 2 * dy;
  204.     i2 := 2 * dx;
  205.     FOR i := 1 TO dx DO BEGIN
  206.       PutPixel(x, y, c);
  207.       IF d >= 0 THEN BEGIN
  208.         IF t THEN Inc(x, s1) ELSE Inc(y, s2);
  209.         Dec(d,i2);
  210.       END;
  211.       IF t THEN Inc(y, s2) ELSE Inc (x, s1);
  212.       Inc(d, i1);
  213.     END;
  214.   END;
  215.  
  216.   PROCEDURE Circle(xm, ym, r : INTEGER; c : INTEGER);
  217.   VAR
  218.     x, y, d : INTEGER;
  219.   BEGIN
  220.     x := 0;
  221.     y := r;
  222.     d := r-1;
  223.     REPEAT
  224.       IF d < 0 THEN BEGIN
  225.         Dec(y);
  226.         Inc(d, y);
  227.         Inc(d, y);
  228.       END;
  229.       PutPixel(xm+x, ym+y, c);
  230.       PutPixel(xm-x, ym+y, c);
  231.       PutPixel(xm+x, ym-y, c);
  232.       PutPixel(xm-x, ym-y, c);
  233.       PutPixel(xm+y, ym+x, c);
  234.       PutPixel(xm-y, ym+x, c);
  235.       PutPixel(xm+y, ym-x, c);
  236.       PutPixel(xm-y, ym-x, c);
  237.       Dec(d,x);
  238.       Dec(d,x);
  239.       Dec(d);
  240.       Inc(x);
  241.     UNTIL y < x;
  242.   END;
  243.  
  244.   PROCEDURE Ellipse(xm, ym, rx, ry, c : INTEGER);
  245.   VAR
  246.     r, x, y, d : INTEGER;
  247.     fx, fy     : REAL;
  248.   BEGIN
  249.     IF rx = ry THEN BEGIN
  250.       Circle(xm, ym, rx, c);
  251.       Exit;
  252.     END;
  253.     IF rx > ry THEN BEGIN
  254.       r  := rx;
  255.       fx := 1.0;
  256.       fy := ry/rx;
  257.     END ELSE BEGIN
  258.       r  := ry;
  259.       fy := 1.0;
  260.       fx := rx/ry;
  261.     END;
  262.     x := 0;
  263.     y := r;
  264.     d := r-1;
  265.     REPEAT
  266.       IF d < 0 THEN BEGIN
  267.         Dec(y);
  268.         Inc(d, y);
  269.         Inc(d, y);
  270.       END;
  271.       PutPixel(Round(xm+fx*x), Round(ym+fy*y), c);
  272.       PutPixel(Round(xm-fx*x), Round(ym+fy*y), c);
  273.       PutPixel(Round(xm+fx*x), Round(ym-fy*y), c);
  274.       PutPixel(Round(xm-fx*x), Round(ym-fy*y), c);
  275.       PutPixel(Round(xm+fx*y), Round(ym+fy*x), c);
  276.       PutPixel(Round(xm-fx*y), Round(ym+fy*x), c);
  277.       PutPixel(Round(xm+fx*y), Round(ym-fy*x), c);
  278.       PutPixel(Round(xm-fx*y), Round(ym-fy*x), c);
  279.       Dec(d, x);
  280.       Dec(d, x);
  281.       Dec(d);
  282.       Inc(x);
  283.     UNTIL y < x;
  284.   END;
  285.  
  286.   PROCEDURE Quad(x1, y1, x2, y2, c1, c2 : INTEGER);
  287.   VAR
  288.     Counter : INTEGER;
  289.   BEGIN
  290.     IF Abs(x1-x2) = 1 THEN BEGIN
  291.       Rec(x1, y1, x2, y2, c1);
  292.       Exit;
  293.     END;
  294.     hLine(x1, x2, y1, c1);
  295.     hLine(x1, x2, y2, c1);
  296.     FOR Counter := y1 TO y2 DO BEGIN
  297.       PutPixel(x1, Counter, c1);
  298.       PutPixel(x2, Counter, c1);
  299.     END;
  300.     FOR Counter := y1+1 TO y2-1 DO
  301.       hLine(x1+1, x1-1, Counter, c2);
  302.   END;
  303.  
  304.   PROCEDURE Rec(x1, y1, x2, y2, c : INTEGER);
  305.   VAR
  306.     i : INTEGER;
  307.   BEGIN
  308.     hLine(x1, x2, y1, c);
  309.     hLine(x1, x2, y2, c);
  310.     FOR i := y1 TO y2 DO BEGIN
  311.       PutPixel(x1, i, c);
  312.       PutPixel(x2, i, c);
  313.     END;
  314.   END;
  315.  
  316.   PROCEDURE Paint(x, y, c : WORD);
  317.   VAR
  318.     p, p2                  : PixelP;
  319.     DownFlag, UpFlag, Flag : BOOLEAN;
  320.     xMin, xMax             : WORD;
  321.  
  322.     PROCEDURE Heap(hx, hy : WORD);
  323.     VAR
  324.       pi : PixelP;
  325.     BEGIN
  326.       IF Maxavail < 8 THEN Exit;
  327.       New(Pi);
  328.       pi^.x    := hx;
  329.       pi^.y    := hy;
  330.       pi^.Next := p^.Next;
  331.       p^.Next  := pi;
  332.     END;
  333.  
  334.     FUNCTION SearchLeft(x, y : WORD) : WORD;
  335.     BEGIN
  336.       IF GetPixel(x, y) = c THEN BEGIN
  337.         SearchLeft := x;
  338.         Exit;
  339.       END;
  340.       DownFlag := (GetPixel(x, y+1) = c);
  341.       UpFlag   := (GetPixel(x, y-1) = c);
  342.       Dec(x);
  343.       WHILE (GetPixel(x, y) <> c) AND (GraphicError <> 3) DO BEGIN
  344.         Flag := (GetPixel(x, y+1) = c);
  345.         IF Flag <> DownFlag THEN BEGIN
  346.           DownFlag := Flag;
  347.           Heap(x, y+1);
  348.         END;
  349.         Flag := (GetPixel(x, y-1) = c);
  350.         IF Flag <> UpFlag THEN BEGIN
  351.           UpFlag := Flag;
  352.           Heap(x, y-1);
  353.         END;
  354.         Dec(x);
  355.       END;
  356.       Inc(x);
  357.       GraphicError := 0;
  358.       SearchLeft   := x;
  359.     END;
  360.  
  361.     FUNCTION SearchRight(x, y : WORD) : WORD;
  362.     BEGIN
  363.       IF GetPixel(x, y) = c THEN BEGIN
  364.         SearchRight := x;
  365.         Exit;
  366.       END;
  367.       DownFlag := (GetPixel(x, y+1) = c);
  368.       IF NOT DownFlag THEN Heap(x, y+1);
  369.       UpFlag := (GetPixel(x, y-1) = c);
  370.       IF NOT UpFlag THEN Heap(x, y-1);
  371.       Inc(x);
  372.       WHILE (GetPixel(x, y) <> c) AND (GraphicError <> 3) DO BEGIN
  373.         Flag := (GetPixel(x, y+1) = c);
  374.         IF Flag <> DownFlag THEN BEGIN
  375.           DownFlag := Flag;
  376.           Heap(x, y+1);
  377.         END;
  378.         Flag := (GetPixel(x, y-1) = c);
  379.         IF Flag <> UpFlag THEN BEGIN
  380.           UpFlag := Flag;
  381.           Heap(x, y-1);
  382.         END;
  383.         Inc(x);
  384.       END;
  385.       Dec(x);
  386.       GraphicError := 0;
  387.       SearchRight  := x;
  388.     END;
  389.  
  390.   BEGIN
  391.     New(p);
  392.     p^.x    := x;
  393.     p^.y    := y;
  394.     p^.next := NIL;
  395.     WHILE p <> NIL DO BEGIN
  396.       p2   := p;
  397.       x    := p^.x;
  398.       y    := p^.y;
  399.       xmin := SearchLeft(x, y);
  400.       xmax := SearchRight(x, y);
  401.       hLine(xMin, xMax, y, c);
  402.       p := p^.Next;
  403.       Dispose(p2);
  404.     END;
  405.   END;
  406.  
  407.   PROCEDURE PrintScreen;
  408.   CONST
  409.     Line = 45;
  410.   VAR
  411.     x, y    : WORD;
  412.     a, b, c : BYTE;
  413.  
  414.     PROCEDURE MakeByte(x, y : WORD; VAR a, b, c : BYTE);
  415.     BEGIN
  416.       a := 0;  b := 0;  c := 0;
  417.       Inc(a, Drucken[GetPixel(x, y   )] * 128);
  418.       Inc(a, Drucken[GetPixel(x, y+ 2)] *  64);
  419.       Inc(a, Drucken[GetPixel(x, y+ 4)] *  32);
  420.       Inc(a, Drucken[GetPixel(x, y+ 6)] *  16);
  421.       Inc(a, Drucken[GetPixel(x, y+ 8)] *   8);
  422.       Inc(a, Drucken[GetPixel(x, y+10)] *   4);
  423.       Inc(a, Drucken[GetPixel(x, y+12)] *   2);
  424.       Inc(a, Drucken[GetPixel(x, y+14)]);
  425.       Inc(b, Drucken[GetPixel(x, y+16)] * 128);
  426.       Inc(b, Drucken[GetPixel(x, y+18)] *  64);
  427.       Inc(b, Drucken[GetPixel(x, y+20)] *  32);
  428.       Inc(b, Drucken[GetPixel(x, y+22)] *  16);
  429.       Inc(b, Drucken[GetPixel(x, y+24)] *   8);
  430.       Inc(b, Drucken[GetPixel(x, y+26)] *   4);
  431.       Inc(b, Drucken[GetPixel(x, y+28)] *   2);
  432.       Inc(b, Drucken[GetPixel(x, y+30)]);
  433.       Inc(c, Drucken[GetPixel(x, y+32)] * 128);
  434.       Inc(c, Drucken[GetPixel(x, y+34)] *  64);
  435.       Inc(c, Drucken[GetPixel(x, y+36)] *  32);
  436.       Inc(c, Drucken[GetPixel(x, y+38)] *  16);
  437.       Inc(c, Drucken[GetPixel(x, y+40)] *   8);
  438.       Inc(c, Drucken[GetPixel(x, y+42)] *   4);
  439.       Inc(c, Drucken[GetPixel(x, y+44)] *   2);
  440.       Inc(c, Drucken[GetPixel(x, y+46)]);
  441.     END;
  442.  
  443.   BEGIN
  444.   {$I-}
  445.     y := 0;
  446.     Write(LST, #0);
  447.     IF IoReSult <> 0 THEN BEGIN
  448.       GraphicError := 4;
  449.       Exit;
  450.     END;
  451.     WHILE y < 768 DO BEGIN
  452.       Write(LST, #28, #90, #0, #4);
  453.       FOR x := 0 TO 1023 DO BEGIN
  454.         MakeByte(x, y, a, b, c);
  455.         Write(LST, Chr(a), Chr(b), Chr(c));
  456.       END;
  457.       Write(LST, #28, #51, #1, #13, #10);
  458.       Write(LST, #28, #90, #0, #4);
  459.       FOR x := 0 TO 1023 DO BEGIN
  460.         MakeByte(x, y+1, a, b, c);
  461.         Write(LST, Chr(a), Chr(b), Chr(c));
  462.       END;
  463.       Write(LST, #28, #51,Chr(Line), #13, #10);
  464.       Inc(y, 48);
  465.     END;
  466.   {$I+}
  467.   END;
  468.  
  469.   PROCEDURE SetColorToPrint(b : BYTE);
  470.   BEGIN
  471.     IF (b < 0) OR (b > 15) THEN BEGIN
  472.       GraphicError:=5;
  473.       Exit;
  474.     END;
  475.     Drucken[b] := 1;
  476.   END;
  477.  
  478.   PROCEDURE ClearColorToPrint(b : BYTE);
  479.   BEGIN
  480.     IF (b < 0) OR (b > 15) THEN BEGIN
  481.       GraphicError := 5;
  482.       Exit;
  483.     END;
  484.     Drucken[b] := 0;
  485.   END;
  486.  
  487.   PROCEDURE WrChar(ch : CHAR; c : WORD);
  488.   BEGIN
  489.     Regs.ah := 14;
  490.     Regs.al := Ord(ch);
  491.     Regs.bx := c;
  492.     Intr($10, Regs);
  493.   END;
  494.  
  495.   PROCEDURE SetPos(x, y : WORD);
  496.   BEGIN
  497.     Regs.ah := 2;
  498.     Regs.dl := x;
  499.     Regs.dh := y;
  500.     Intr($10, Regs);
  501.   END;
  502.  
  503.   PROCEDURE WrStr(VAR Str; c : WORD);
  504.   VAR
  505.     st2     : STRING [255] ABSOLUTE Str;
  506.     Counter : BYTE;
  507.   BEGIN
  508.     FOR Counter := 1 TO Ord(st2[0]) DO
  509.       WrChar(st2[i], c);
  510.   END;
  511.  
  512.   PROCEDURE SavePalette;
  513.   BEGIN
  514.     Regs.ax := $1009;
  515.     Regs.dx := Ofs(Palette);
  516.     Regs.es := Seg(Palette);
  517.     Intr($10, Regs);
  518.     Regs.ax := $1017;
  519.     Regs.cx := 16;    { Anzahl Register}
  520.     Regs.bx := 0;     { Register 0 als erstes}
  521.     Regs.dx := Ofs(Color);
  522.     Regs.es := Seg(Color);
  523.   END;
  524.  
  525.   PROCEDURE RestorePalette;
  526.   BEGIN
  527.     Regs.ax := $1002;
  528.     Regs.dx := Ofs(Palette);
  529.     Regs.es := Seg(Palette);
  530.     Intr($10, Regs);
  531.     Regs.ax := $1012;
  532.     Regs.cx := 16;
  533.     Regs.bx := 0;
  534.     Regs.dx := Ofs(Color);
  535.     Regs.es := Seg(Color);
  536.     Intr($10, Regs);
  537.   END;
  538.  
  539.   PROCEDURE SetColor(n, r, g, b : BYTE);
  540.   BEGIN
  541.     Regs.ax := $1000;
  542.     Regs.bl := n;
  543.     Regs.bh := n;
  544.     Intr($10, Regs);
  545.     Regs.ax := $1010;
  546.     Regs.bx := n;
  547.     Regs.dh := r;
  548.     Regs.ch := g;
  549.     Regs.cl := b;
  550.     Intr($10, Regs);
  551.   END;
  552.  
  553. BEGIN
  554.   GraphicError := 0;
  555.   Drucken[0]   := 0;
  556.   FOR i := 1 TO 15 DO Drucken[i] := 1;
  557. END.
  558. (* ------------------------------------------------------ *)
  559. (*                Ende von HI_RES.PAS                     *)
  560.