[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]

    {$A-,B-,D+,E-,F-,G+,I-,L+,N-,O-,R-,S-,V-,X+} {TP 6.0 & 286 required!}
    Unit x320x240;

    {
     Sean Palmer, 1993
     released to the Public Domain
     in tweaked modes, each latch/bit plane contains the entire 8-bit pixel.
     the sequencer map mask determines which plane (pixel) to update, and, when
     reading, the read map select reg determines which plane (pixel) to read.
     almost exactly opposite from regular vga 16-color modes which is why I never
     could get my routines to work For BOTH modes. 8)

      # = source screen pixel
      Normal 16-color         Tweaked 256-color

          Bit Mask                Bit Mask
          76543210                33333333
     Map  76543210           Map  22222222
     Mask 76543210           Mask 11111111
          76543210                00000000

      Functional equivalents
          Bit Mask        =       Seq Map Mask
          Seq Map Mask    =       Bit Mask
    }

    Interface

    Var
      color : Byte;

    Const
     xRes    = 320;
     yRes    = 240;   {displayed screen size}
     xMax    = xRes - 1;
     yMax    = yRes - 1;
     xMid    = xMax div 2;
     yMid    = yMax div 2;
     vxRes   = 512;
     vyRes   = $40000 div vxRes; {virtual screen size}
     nColors = 256;
     tsx : Byte = 8;
     tsy : Byte = 8;  {tile size}

    Procedure plot(x, y : Integer);
    Function  scrn(x, y : Integer) : Byte;

    Procedure hLin(x, x2, y : Integer);
    Procedure vLin(x, y, y2 : Integer);
    Procedure rect(x, y, x2, y2 : Integer);
    Procedure pane(x, y, x2, y2 : Integer);

    Procedure line(x, y, x2, y2 : Integer);
    Procedure oval(xc, yc, a, b : Integer);
    Procedure disk(xc, yc, a, b : Integer);
    Procedure fill(x, y : Integer);

    Procedure putTile(x, y : Integer; p : Pointer);
    Procedure overTile(x, y : Integer; p : Pointer);
    Procedure putChar(x, y : Integer; p : Word);

    Procedure setColor(color, r, g, b : Byte);
    {rgb vals are from 0-63}
    Function  getColor(color : Byte) : LongInt;
    {returns $00rrggbb format}
    Procedure setPalette(color : Byte; num : Word; Var rgb);
    {rgb is list of 3-Byte rgb vals}
    Procedure getPalette(color : Byte; num : Word; Var rgb);

    Procedure clearGraph;
    Procedure setWriteMode(f : Byte);
    Procedure waitRetrace;
    Procedure setWindow(x, y : Integer);

    {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}

    Implementation

    Const
      vSeg     = $A000;        {video segment}
      vxBytes  = vxRes div 4;  {Bytes per virtual scan line}
      seqPort  = $3C4;   {Sequencer}
      gcPort   = $3CE;    {Graphics Controller}
      attrPort = $3C0;   {attribute Controller}

      tableReadIndex    = $3C7;
      tableWriteIndex   = $3C8;
      tableDataRegister = $3C9;

      CrtcRegLen   = 10;
      CrtcRegTable : Array [1..CrtcRegLen] of Word =
        ($0D06, $3E07, $4109, $EA10, $AC11, $DF12, $0014, $E715, $0616, $E317);

    Var
      CrtcPort   : Word;  {Crt controller}
      oldMode    : Byte;
      ExitSave   : Pointer;
      input1Port : Word;  {Crtc Input Status Reg #1=CrtcPort+6}
      fillVal    : Byte;

    Type
     tRGB = Record
       r, g, b : Byte;
     end;

    {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}

    Procedure clearGraph; Assembler;
    Asm
      mov ax, vSeg
      mov es, ax
      mov dx, seqPort
      mov ax, $0F02
      out dx, ax {enable whole map mask}
      xor di, di
      mov cx, $8000 {screen size in Words}
      cld
      mov al, color
      mov ah, al
      repz stosw {clear screen}
    end;

    Procedure setWriteMode(f : Byte); Assembler;
    Asm {copy/and/or/xor modes}
      mov ah, f
      shl ah, 3
      mov al, 3
      mov dx, gcPort
      out dx, ax {Function select reg}
    end;

    Procedure waitRetrace; Assembler;
    Asm
      mov  dx, CrtcPort
      add  dx, 6 {find Crt status reg (input port #1)}
     @L1:
      in   al, dx
      test al, 8
      jnz  @L1;  {wait For no v retrace}
     @L2:
      in   al, dx
      test al, 8
      jz   @L2 {wait For v retrace}
     end;

    {
     Since a virtual screen can be larger than the actual screen, scrolling is
     possible.  This routine sets the upper left corner of the screen to the
     specified pixel. Make sure 0 <= x <= vxRes - xRes, 0 <= y <= vyRes - yRes
    }
    Procedure setWindow(x, y : Integer); Assembler;
    Asm
      mov  ax, vxBytes
      mul  y
      mov  bx, x
      mov  cl, bl
      shr  bx, 2
      add  bx, ax     {bx=Ofs of upper left corner}
      mov  dx, input1Port
     @L:
      in   al, dx
      test al, 8
      jnz  @L  {wait For no v retrace}
      sub  dx, 6  {CrtC port}
      mov  al, $D
      mov  ah, bl
      cli {these values are sampled at start of retrace}
      out  dx, ax  {lo Byte of display start addr}
      dec  al
      mov  ah, bh
      out  dx, ax    {hi Byte}
      sti
      add  dx, 6
     @L2:
      in   al, dx
      test al, 8
      jz   @L2  {wait For v retrace}
      {this also resets Attrib flip/flop}
      mov  dx, attrPort
      mov  al, $33
      out  dx, al   {Select Pixel Pan Register}
      and  cl, 3
      mov  al, cl
      shl  al, 1
      out  dx, al   {Shift is For 256 Color Mode}
    end;

    {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}

    Procedure plot(x, y : Integer); Assembler;
    Asm
      mov   ax, vSeg
      mov   es, ax
      mov   di, x
      mov   cx, di
      shr   di, 2
      mov   ax, vxBytes
      mul   y
      add   di, ax
      mov   ax, $0102
      and   cl, 3
      shl   ah, cl
      mov   dx, seqPort
      out   dx, ax {set bit mask}
      mov   al, color
      stosb
    end;

    Function scrn(x, y : Integer) : Byte; Assembler;
    Asm
      mov ax, vSeg
      mov es, ax
      mov di, x
      mov cx, di
      shr di, 2
      mov ax, vxBytes
      mul y
      add di, ax
      and cl, 3
      mov ah, cl
      mov al, 4
      mov dx, gcPort
      out dx, ax      {Read Map Select register}
      mov al, es:[di]  {get the whole plane}
    end;

    Procedure hLin(x, x2, y : Integer); Assembler;
    Asm
      mov   ax, vSeg
      mov   es, ax
      cld
      mov   ax, vxBytes
      mul   y
      mov   di, ax {base of scan line}
      mov   bx, x
      mov   cl, bl
      shr   bx, 2
      mov   dx, x2
      mov   ch, dl
      shr   dx, 2
      and   cx, $0303
      sub   dx, bx     {width in Bytes}
      add   di, bx     {offset into video buffer}
      mov   ax, $FF02
      shl   ah, cl
      and   ah, $0F {left edge mask}
      mov   cl, ch
      mov   bh, $F1
      rol   bh, cl
      and   bh, $0F {right edge mask}
      mov   cx, dx
      or    cx, cx
      jnz   @LEFT
      and   ah, bh                  {combine left & right bitmasks}
     @LEFT:
      mov   dx, seqPort
      out   dx, ax
      inc   dx
      mov   al, color
      stosb
      jcxz  @EXIT
      dec   cx
      jcxz  @RIGHT
      mov   al, $0F
      out   dx, al     {skipped if cx=0,1}
      mov   al, color
      repz  stosb   {fill middle Bytes}
     @RIGHT:
      mov   al, bh
      out   dx, al       {skipped if cx=0}
      mov   al, color
      stosb
     @EXIT:
    end;

    Procedure vLin(x, y, y2 : Integer); Assembler;
    Asm
      mov ax, vSeg
      mov es, ax
      cld
      mov di, x
      mov cx, di
      shr di, 2
      mov ax, vxBytes
      mul y
      add di, ax
      mov ax, $102
      and cl, 3
      shl ah, cl
      mov dx, seqPort
      out dx, ax
      mov cx, y2
      sub cx, y
      inc cx
      mov al, color
     @DOLINE:
      mov bl, es:[di]
      stosb
      add di, vxBytes-1
      loop @DOLINE
    end;

    Procedure rect(x, y, x2, y2 : Integer);
    Var
      i : Word;
    begin
      hlin(x, pred(x2), y);
      hlin(succ(x), x2, y2);
      vlin(x, succ(y), y2);
      vlin(x2, y, pred(y2));
    end;

    Procedure pane(x, y, x2, y2 : Integer);
    Var
      i : Word;
    begin
      For i := y2 downto y do
        hlin(x, x2, i);
    end;

    Procedure line(x, y, x2, y2:Integer);
    Var
      d, dx, dy,
      ai, bi, xi, yi : Integer;
    begin
      if(x < x2) then
      begin
        xi := 1;
        dx := x2 - x;
      end
      else
      begin
        xi := -1;
        dx := x - x2;
      end;
      if (y < y2) then
      begin
        yi := 1;
        dy := y2 - y;
      end
      else
      begin
        yi := -1;
        dy := y - y2;
      end;
      plot(x, y);
      if dx > dy then
      begin
        ai := (dy - dx) * 2;
        bi := dy * 2;
        d  := bi - dx;
        Repeat
          if (d >= 0) then
          begin
            inc(y, yi);
            inc(d, ai);
          end
          else
            inc(d, bi);
          inc(x, xi);
          plot(x, y);
        Until (x = x2);
      end
      else
      begin
        ai := (dx - dy) * 2;
        bi := dx * 2;
        d  := bi - dy;
        Repeat
          if (d >= 0) then
          begin
            inc(x, xi);
            inc(d, ai);
          end
          else
            inc(d, bi);
          inc(y, yi);
          plot(x, y);
        Until (y = y2);
      end;
    end;

    Procedure oval(xc, yc, a, b : Integer);
    Var
      x, y      : Integer;
      aa, aa2,
      bb, bb2,
      d, dx, dy : LongInt;
    begin
      x := 0;
      y := b;
      aa := LongInt(a) * a;
      aa2 := 2 * aa;
      bb := LongInt(b) * b;
      bb2 := 2 * bb;
      d := bb - aa * b + aa div 4;
      dx := 0;
      dy := aa2 * b;
      plot(xc, yc - y);
      plot(xc, yc + y);
      plot(xc - a, yc);
      plot(xc + a, yc);
      While (dx < dy) do
      begin
        if(d > 0) then
        begin
          dec(y);
          dec(dy, aa2);
          dec(d, dy);
        end;
        inc(x);
        inc(dx, bb2);
        inc(d, bb + dx);
        plot(xc + x, yc + y);
        plot(xc - x, yc + y);
        plot(xc + x, yc - y);
        plot(xc - x, yc - y);
      end;

      inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);

      While (y > 0) do
      begin
        if (d < 0) then
        begin
          inc(x);
          inc(dx, bb2);
          inc(d, bb + dx);
        end;
        dec(y);
        dec(dy, aa2);
        inc(d, aa - dy);
        plot(xc + x, yc + y);
        plot(xc - x, yc + y);
        plot(xc + x, yc - y);
        plot(xc - x, yc - y);
      end;
    end;

    Procedure disk(xc, yc, a, b:Integer);
    Var
      x, y      : Integer;
      aa, aa2,
      bb, bb2,
      d, dx, dy : LongInt;
    begin
      x   := 0;
      y   := b;
      aa  := LongInt(a) * a;
      aa2 := 2 * aa;
      bb  := LongInt(b) * b;
      bb2 := 2 * bb;
      d   := bb - aa * b + aa div 4;
      dx  := 0;
      dy  := aa2 * b;

      vLin(xc, yc - y, yc + y);

      While (dx < dy) do
      begin
        if (d > 0) then
        begin
          dec(y);
          dec(dy, aa2);
          dec(d, dy);
        end;
        inc(x);
        inc(dx, bb2);
        inc(d, bb + dx);
        vLin(xc - x, yc - y, yc + y);
        vLin(xc + x, yc - y, yc + y);
      end;

      inc(d, (3 * (aa - bb) div 2 - (dx + dy)) div 2);

      While (y >= 0) do
      begin
        if (d < 0) then
        begin
          inc(x);
          inc(dx, bb2);
          inc(d, bb + dx);
          vLin(xc - x, yc - y, yc + y);
          vLin(xc + x, yc - y, yc + y);
        end;
        dec(y);
        dec(dy, aa2);
        inc(d, aa - dy);
      end;
    end;

    {This routine only called by fill}
    Function lineFill(x, y, d, prevXL, prevXR : Integer) : Integer;
    Var
      xl, xr, i : Integer;
    Label
      _1, _2, _3;
    begin
      xl := x;
      xr := x;

      Repeat
        dec(xl);
      Until (scrn(xl, y) <> fillVal) or (xl < 0);

      inc(xl);

      Repeat
        inc(xr);
      Until (scrn(xr, y) <> fillVal) or (xr > xMax);

      dec(xr);
      hLin(xl, xr, y);
      inc(y, d);

      if Word(y) <= yMax then
      For x := xl to xr do
        if (scrn(x, y) = fillVal) then
        begin
          x := lineFill(x, y, d, xl, xr);
          if Word(x) > xr then
            Goto _1;
        end;

      _1 :

      dec(y, d + d);
      Asm
        neg d;
      end;
      if Word(y) <= yMax then
      begin
      For x := xl to prevXL do
        if (scrn(x, y) = fillVal) then
        begin
          i := lineFill(x, y, d, xl, xr);
          if Word(x) > prevXL then
            Goto _2;
        end;

        _2 :

        for x := prevXR to xr do
          if (scrn(x, y) = fillVal) then
          begin
            i := lineFill(x, y, d, xl, xr);
            if Word(x) > xr then
              Goto _3;
          end;

          _3 :

          end;

      lineFill := xr;
    end;

    Procedure fill(x, y : Integer);
    begin
      fillVal := scrn(x, y);
      if fillVal <> color then
        lineFill(x, y, 1, x, x);
    end;

    {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}

    Procedure putTile(x, y : Integer; p : Pointer); Assembler;
    Asm
      push  ds
      lds   si, p
      mov   ax, vSeg
      mov   es, ax
      mov   di, x
      mov   cx, di
      shr   di, 2
      mov   ax, vxBytes
      mul   y
      add   di, ax
      mov   ax, $102
      and   cl, 3
      shl   ah, cl      {make bit mask}
      mov   dx, seqPort
      mov   bh, tsy
     @DOLINE:
      mov   cl, tsx
      xor   ch, ch
      push  ax
      push  di    {save starting bit mask}
     @LOOP:
      {mov al, 2}
      out   dx, ax
      shl   ah, 1       {give it some time to respond}
      mov   bl, es:[di]
      movsb
      dec   di
      test  ah, $10
      jz    @SAMEByte
      mov   ah, 1
      inc   di
     @SAMEByte:
      loop  @LOOP
      pop   di
      add   di, vxBytes
      pop   ax {start of next line}
      dec   bh
      jnz   @DOLINE
      pop   ds
    end;

    Procedure overTile(x, y : Integer; p : Pointer); Assembler;
    Asm
      push  ds
      lds   si, p
      mov   ax, vSeg
      mov   es, ax
      mov   di, x
      mov   cx, di
      shr   di, 2
      mov   ax, vxBytes
      mul   y
      add   di, ax
      mov   ax, $102
      and   cl, 3
      shl   ah, cl      {make bit mask}
      mov   bh, tsy
      mov   dx, seqPort
     @DOLINE:
      mov   ch, tsx
      push  ax
      push  di    {save starting bit mask}
     @LOOP:
      mov   al, 2
      mov   dx, seqPort
      out   dx, ax
      shl   ah, 1
      xchg  ah, cl
      mov   al, 4
      mov   dl, gcPort and $FF
      out   dx, ax
      xchg  ah, cl
      inc   cl
      and   cl, 3
      lodsb
      or    al, al
      jz    @SKIP
      mov   bl, es:[di]
      cmp   bl, $C0
      jae   @SKIP
      stosb
      dec   di
     @SKIP:
      test  ah, $10
      jz    @SAMEByte
      mov   ah, 1
      inc   di
     @SAMEByte:
      dec   ch
      jnz   @LOOP
      pop   di
      add   di, vxBytes
      pop   ax {start of next line}
      dec   bh
      jnz   @DOLINE
      pop   ds
    end;

    {won't handle Chars wider than 1 Byte}
    Procedure putChar(x, y : Integer; p : Word); Assembler;
    Asm
      mov   si, p  {offset of Char in DS}
      mov   ax, vSeg
      mov   es, ax
      mov   di, x
      mov   cx, di
      shr   di, 2
      mov   ax, vxBytes
      mul   y
      add   di, ax
      mov   ax, $0102
      and   cl, 3
      shl   ah, cl      {make bit mask}
      mov   dx, seqPort
      mov   cl, tsy
      xor   ch, ch
     @DOLINE:
      mov   bl, [si]
      inc   si
      push  ax
      push  di    {save starting bit mask}
     @LOOP:
      mov   al, 2
      out   dx, ax
      shl   ah, 1
      shl   bl, 1
      jnc   @SKIP
      mov   al, color
      mov   es:[di], al
     @SKIP:
      test  ah, $10
      jz    @SAMEByte
      mov   ah, 1
      inc   di
     @SAMEByte:
      or    bl, bl
      jnz   @LOOP
      pop   di
      add   di, vxBytes
      pop   ax {start of next line}
      loop  @DOLINE
    end;

    {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}

    Procedure setColor(color, r, g, b : Byte); Assembler;
    Asm {set DAC color}
      mov  dx, tableWriteIndex
      mov  al, color
      out  dx, al
      inc  dx
      mov  al, r
      out  dx, al
      mov  al, g
      out  dx, al
      mov  al, b
      out  dx, al
    end; {Write index now points to next color}

    Function getColor(color : Byte) : LongInt; Assembler;
    Asm {get DAC color}
      mov  dx, tableReadIndex
      mov  al, color
      out  dx, al
      add  dx, 2
      cld
      xor  bh, bh
      in   al, dx
      mov  bl, al
      in   al, dx
      mov  ah, al
      in   al, dx
      mov  dx, bx
    end; {read index now points to next color}

    Procedure setPalette(color : Byte; num : Word; Var rgb); Assembler;
    Asm
      mov   cx, num
      jcxz  @X
      mov   ax, cx
      shl   cx, 1
      add   cx, ax {mul by 3}
      push  ds
      lds   si, rgb
      cld
      mov   dx, tableWriteIndex
      mov   al, color
      out   dx, al
      inc   dx
     @L:
      lodsb
      out   dx, al
      loop  @L
      pop   ds
     @X:
    end;

    Procedure getPalette(color : Byte; num : Word; Var rgb); Assembler;
    Asm
      mov   cx, num
      jcxz  @X
      mov   ax, cx
      shl   cx, 1
      add   cx, ax {mul by 3}
      les   di, rgb
      cld
      mov   dx, tableReadIndex
      mov   al, color
      out   dx, al
      add   dx, 2
     @L:
      in    al, dx
      stosb
      loop  @L
     @X:
    end;

    {XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX}

    Function vgaPresent : Boolean; Assembler;
    Asm
      mov ah, $F
      int $10
      mov oldMode, al  { save old Gr mode}
      mov ax, $1A00
      int $10          { check For VGA}
      cmp al, $1A
      jne @ERR         { no VGA Bios}
      cmp bl, 7
      jb @ERR          { is VGA or better?}
      cmp bl, $FF
      jnz @OK
     @ERR:
      xor al, al
      jmp @EXIT
     @OK:
      mov al, 1
     @EXIT:
    end;

    Procedure Graphbegin;
    Var
      p     : Array [0..255] of tRGB;
      i, j,
      k, l  : Byte;
    begin
      Asm
        mov ax, $0013
        int $10
      end;   {set BIOS mode}

      l := 0;
      For i := 0 to 5 do
        For j := 0 to 5 do
          For k := 0 to 5 do
          With p[l] do
          begin
            r := (i * 63) div 5;
            g := (j * 63) div 5;
            b := (k * 63) div 5;
            inc(l);
          end;

      For i := 216 to 255 do
      With p[i] do
      begin
        l := ((i - 216) * 63) div 39;
        r := l;
        g := l;
        b := l;
      end;

      setpalette(0, 256, p);
      color := 0;

      Asm
       mov  dx, seqPort
       mov  ax, $0604
       out  dx, ax            { disable chain 4}
       mov  ax, $0100
       out  dx, ax            { synchronous reset asserted}
       dec  dx
       dec  dx
       mov  al, $E3
       out  dx, al            { misc output port at $3C2}
                              { use 25mHz dot clock,  480 lines}
       inc  dx
       inc  dx
       mov  ax, $0300
       out  dx, ax            { restart sequencer}
       mov  dx, CrtcPort
       mov  al, $11
       out  dx, al            { select cr11}
       inc  dx
       in   al, dx
       and  al, $7F
       out  dx, al
       dec  dx                { remove Write protect from cr0-cr7}
       mov  si, offset CrtcRegTable
       mov  cx, CrtcRegLen
       repz outsw             { set Crtc data}
       mov  ax, vxBytes
       shr  ax, 1             { Words per scan line}
       mov  ah, al
       mov  al, $13
       out  dx, ax            { set CrtC offset reg}
      end;

      clearGraph;
    end;

    Procedure Graphend; Far;
    begin
      ExitProc := exitSave;
      Asm
        mov al, oldMode
        mov ah, 0
        int $10
      end;
    end;

    begin
      CrtcPort   := memw[$40 : $63];
      input1Port := CrtcPort + 6;
      if vgaPresent then
      begin
        ExitSave := exitProc;
        ExitProc := @Graphend;
        Graphbegin;
      end
      else
      begin
        Writeln(^G + 'VGA required.');
        halt(1);
      end;
    end.

[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]