[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
Unit X3840;
{=========================================
= 320X200 3840 color, 2 page Mode X =
= by David Dahl @ 1:272/85 =
=========================================}
(* PUBLIC DOMAIN *)
Interface
Uses CRT, DOS;
Procedure PutPixel (XCoord, YCoord : Word;
Red, Green, Blue : Byte);
Procedure InitializeGraphics;
Procedure EnableScreen;
Procedure SetActivePage (PageNo : Word);
Procedure SetDisplayPage (PageNo : Word);
Implementation
Const SC_INDEX = $3C4; SC_MEM_MODE = 4;
GC_INDEX = $3CE; GC_GRAPH_MODE = 5; GC_MISCELL = 6;
CRTC_INDEX = $3D4; CC_UNDERLINE = $14; CC_MODE_CTRL = $17;
DAC_WRITE_ADR = $3C8; DAC_DATA = $3C9;
SeqCtrlIndex = $3C4;
AttrCtrlWrite = $3C0;
INPUT_STATUS_1 = $3DA;
Type PageOfsArray = Array[0..3] of Word;
CRTCPageRec = Record High:Word; Low:Word; End;
CRTCPageArray = Array[0..3] of CRTCPageRec;
PaletteRec = Record Red:Byte; Green:Byte; Blue:Byte; End;
PaletteArray = Array [0..255] of PaletteRec;
Const PageOfs : PageOfsArray = ($0000,$4000,$8000,$C000);
Var CRTCPage : CRTCPageArray;
Palette : PaletteArray;
InGraphics : Boolean;
SaveExit : Pointer;
DisplayPage : Word;
ActivePage : Word;
PageNum : Word;
{-[ Initialize Variables ]------------------------------------------------}
Procedure InitializeVariables;
Var Index : Integer;
RedCount,
GreenCount,
BlueCount : Integer;
Begin
PageNum := 0;
DisplayPage := 0;
ActivePage := 0;
{ Calculate CRTC Page Offsets }
For Index := 0 to 3 do
Begin
CRTCPage[Index].High := (Word(Hi(PageOfs[Index])) SHL 8) OR $0C;
CRTCPage[Index].Low := (Word(Lo(PageOfs[Index])) SHL 8) OR $0D;
End;
{ Calculate Palette }
Index := 0;
For BlueCount := 0 to 14 do
For RedCount := 0 to 15 do
Begin
Palette[Index].Red := (RedCount * 63) DIV 15;
Palette[Index].Green := 0;
Palette[Index].Blue := (BlueCount * 63) DIV 14;
Inc(Index)
End;
For GreenCount := 0 to 15 do
Begin
Palette[Index].Red := 0;
Palette[Index].Green := (GreenCount * 63) DIV 15;
Palette[Index].Blue := 0;
Inc(Index);
End;
End;
{-[ Put Pixel To Screen ]-------------------------------------------------}
Procedure PutPixel (XCoord, YCoord : Word;
Red, Green, Blue : Byte); Assembler;
ASM
MOV AX, SegA000; MOV ES, AX
MOV DI, ActivePage; SHL DI, 1; MOV BX, XCoord;
MOV CX, BX; AND CX, $03; MOV AX, 1; SHL AX, CL
MOV DX, SeqCtrlIndex; MOV AH, AL; MOV AL, 2; OUT DX, AX
ADD BX, YCoord; MOV CX, BX; AND BX, 1; SHL BX, 1
MOV SI, Word(PageOfs[DI+BX])
MOV BX, CX; INC BX; AND BX, 1; SHL BX, 1
MOV DI, Word(PageOfs[DI+BX])
MOV AX, YCoord; MOV BX, AX; SHL AX, 4; SHL BX, 6; ADD AX, BX
MOV BX, XCoord; SHR BX, 2; ADD BX, AX
MOV AL, Blue; SHL AL, 4; ADD AL, Red
MOV AH, Green; ADD AH, 15 * 16
MOV ES:[DI+BX], AH; MOV ES:[SI+BX], AL
End;
{-[ Set VGA DAC ]---------------------------------------------------------}
Procedure SetPalette (Pal : Pointer); Assembler;
ASM
LES DI, Pal; MOV DX, DAC_WRITE_ADR; XOR AL, AL; OUT DX, AL
MOV DX, DAC_DATA; MOV CX, 256 * 3
@PalOut:; MOV AL, Byte(ES:[DI]); INC DI; OUT DX, AL; LOOP @PalOut
END;
{-[ Initialize 3840 Color Mode X ]----------------------------------------}
Procedure InitializeGraphics;
Begin
InGraphics := True;
ASM
MOV AX, $12; INT $10; MOV AX, $13; INT $10
MOV DX, GC_INDEX; MOV AL, GC_GRAPH_MODE; OUT DX, AL; INC DX
IN AL, DX; AND AL, 11101111b; OUT DX, AL; DEC DX
MOV AL, GC_MISCELL; OUT DX, AL; INC DX; IN AL, DX
AND AL, 11111101b; OUT DX, AL
MOV DX, SC_INDEX; MOV AL, SC_MEM_MODE; OUT DX, AL; INC DX
IN AL, DX; AND AL, 11110111b; OR AL, 4; OUT DX, AL
MOV DX, CRTC_INDEX; MOV AL, CC_UNDERLINE; OUT DX, AL; INC DX
IN AL, DX; AND AL, 10111111b; OR AL, 4; OUT DX, AL; DEC DX
MOV AL, CC_MODE_CTRL; OUT DX, AL; INC DX; IN AL, DX
OR AL, 01000000b; OUT DX, AL
END;
PortW[CRTC_INDEX] := $4218;
Port[CRTC_INDEX] := $07;
Port[CRTC_INDEX+1] := Port[CRTC_INDEX+1] OR $10;
Port[CRTC_INDEX] := $09;
Port[CRTC_INDEX+1] := Port[CRTC_INDEX+1] AND Not($20);
Port[AttrCtrlWrite] := $10 OR $20;
Port[AttrCtrlWrite] := $61; {01100001b;}
SetPalette (Addr(Palette));
End;
{-[ Ping-Pong Screen To Enable 3840 Colors ]------------------------------}
Procedure EnableScreen;
Begin
PageNum := (PageNum + 1) AND 1;
Repeat Until (Port[Input_Status_1] AND 8) = 0;
PortW[CRTC_INDEX] := CRTCPage[PageNum OR DisplayPage].High;
PortW[CRTC_INDEX] := CRTCPage[PageNum OR DisplayPage].Low;
Repeat Until (Port[Input_Status_1] AND 8) <> 0;
End;
{-[ Set Active Page # ]---------------------------------------------------}
Procedure SetActivePage (PageNo : Word);
Begin ActivePage := (PageNo AND 1) SHL 1; End;
{-[ Set Display Page # ]--------------------------------------------------}
Procedure SetDisplayPage (PageNo : Word);
Begin DisplayPage := (PageNo AND 1) SHL 1; End;
{-[ Exit Code ]-----------------------------------------------------------}
{$F+}
Procedure GpxExit;
Begin
ExitProc := SaveExit;
If InGraphics
Then
TextMode(C80);
End;
{$F-}
{=[ Unit Init Code ]======================================================}
Begin
InGraphics := False;
SaveExit := ExitProc;
ExitProc := Addr(GpxExit);
InitializeVariables;
End.
{ ------------------- DEMO PROGRAMS ------------------ }
{$Q-,A+,S-,R-}
Program DisplayTGA;
{====================================
= Display TGA in 3840 color Mode X =
= by David Dahl @ 1:272/85 =
====================================}
(* Public Domain *)
Uses CRT, X3840;
Type TGAHeaderRec = Record
IDLen : Byte;
ColMapType : Byte; ImageType : Byte;
CMOrg : Word; CMLen : Word; CMBits : Byte;
XOfs : Word; YOfs : Word;
XSize : Word; YSize : Word;
BPix : Byte;
ImageDesc : Byte;
End;
TGAHeaderPtr = ^TGAHeaderRec;
Buffer32Array = Array [0 .. (127 * 4)] of Byte;
Buffer32Ptr = ^Buffer32Array;
Var Header : TGAHeaderPtr;
Fin : File;
YPos, XPos : LongInt;
XSize, YSize : Integer;
CodeByte : Byte;
Count : Byte;
Index : Word;
ColorBuffer : Buffer32Ptr;
PixelSize : Word;
Done : Boolean;
FileName : String;
Begin
New (ColorBuffer); New (Header);
If ParamCount = 1
Then
FileName := ParamStr(1)
Else
Begin
Writeln ('Enter Filename of Targa File to View');
Readln (FileName);
End;
If Pos('.',FileName) = 0
Then
FileName := FileName + '.TGA';
Assign (Fin, FileName); Reset (Fin,1);
BlockRead (Fin, Header^, SizeOf(Header^));
If Header^.ImageDesc = 0
Then
Begin
With Header^ do
Begin
Writeln ('XSize, YSize :',XSize:6,YSize:6);
Writeln ('Image Type :',ImageType:6);
Writeln ('Bits/Pixel :',BPix:6);
End;
If ((Header^.BPix = 16)OR(Header^.BPix = 24)OR(Header^.BPix = 32)) AND
(Header^.ImageType >= 8)
Then
Begin
Writeln ('Press Any Key To View Image.');
While Keypressed do Readkey;
Repeat Until Keypressed;
While Keypressed do Readkey;
InitializeGraphics;
XSize := Header^.XSize;
YSize := Header^.YSize;
XPos := 0;
YPos := Header^.YSize-1;
PixelSize := (Header^.BPix SHR 3);
Done := False;
Repeat
BlockRead (Fin, CodeByte, SizeOf(CodeByte));
Count := (CodeByte AND 127) + 1;
CodeByte := CodeByte SHR 7;
If CodeByte = 0
Then { Output Count Colors }
Begin
BlockRead (Fin, ColorBuffer^, Count * PixelSize);
Index := 0;
While (Count > 0) AND Not(Done) do
Begin
If PixelSize > 2
Then
PutPixel ((XPos * 319) DIV XSize,
(YPos * 199) DIV YSize,
ColorBuffer^[Index+2] SHR 4, { Red }
ColorBuffer^[Index+1] SHR 4, { Green }
(ColorBuffer^[Index] * 14) DIV 255) { Blue }
Else
PutPixel ((XPos * 319) DIV XSize,
(YPos * 199) DIV YSize,
(ColorBuffer^[Index+1] SHR 3) AND 15, { Red }
((ColorBuffer^[Index] SHR 6) OR
(ColorBuffer^[Index+1] SHL 2)) AND 15, { Green }
(ColorBuffer^[Index] SHR 1) AND 15); { Blue }
Inc(Index, PixelSize);
Dec(Count);
Inc(XPos,1);
If XPos >= XSize
Then
Begin
XPos := 0; Dec (YPos);
If YPos < 0
Then
Done := True;
End;
If KeyPressed
Then
Done := ReadKey = #27;
End;
End
Else
Begin { Output Color Count Times }
BlockRead (Fin, ColorBuffer^, PixelSize);
While (Count > 0) AND Not(Done) do
Begin
If PixelSize > 2
Then
PutPixel ((XPos * 319) DIV XSize,
(YPos * 199) DIV YSize,
ColorBuffer^[2] SHR 4, { Red }
ColorBuffer^[1] SHR 4, { Green }
(ColorBuffer^[0] * 14) DIV 255) { Blue }
Else
PutPixel ((XPos * 319) DIV XSize,
(YPos * 199) DIV YSize,
(ColorBuffer^[1] SHR 3) AND 15, { Red }
((ColorBuffer^[0] SHR 6) OR
(ColorBuffer^[1] SHL 2)) AND 15, { Green }
(ColorBuffer^[0] SHR 1) AND 15); { Blue }
Dec(Count);
Inc(XPos,1);
If XPos >= XSize
Then
Begin
XPos := 0; Dec (YPos);
If YPos < 0
Then
Done := True;
End;
If KeyPressed
Then
Done := ReadKey = #27;
End;
End;
Until Done;
While Keypressed do Readkey;
Repeat EnableScreen Until Keypressed;
While Keypressed do Readkey;
TextMode (C80);
End
Else
Writeln ('Cannot view this picture.');
End
Else
Writeln ('Not a TGA File.');
Close (Fin); Dispose (Header); Dispose (ColorBuffer);
End.
{ --------------------------- CUT -------------- }
Program TestX3840;
{=============================
= Display All 3840 Colors =
= by David Dahl @ 1:272/85 =
=============================}
(* PUBLIC DOMAIN *)
Uses CRT, X3840;
Var Red, Green, Blue : Integer;
Begin
InitializeGraphics; { Initialize 3840 Color Mode X }
For Red := 0 to 15 do
For Green := 0 to 15 do
For Blue := 0 to 14 do
PutPixel (Red+(Blue*16), Green, { X, Y }
Red, Green, Blue); { Color }
Repeat EnableScreen Until Keypressed; { Enable 3840 Colors }
While Keypressed do Readkey;
TextMode(C80);
End.
----------------------------[ CUT HERE ]------------------------
Message 1 contains a unit to display a pseudo 3840
color Mode X on a standard VGA. Message 2 contains a bare-bone
Targa viewer. Message 3 contains a program to display all 3840
colors to the screen and this short text description.
A brief description of the procedures in the X3840 unit
follow:
InitializeGraphics;
Initializes the 3840 color graphic mode. EnableScreen must be
called to view the 3840 colors.
EnableScreen;
Enables 3840 colors. This procedure should be called in a
tight loop in order to properly display the colors. See included
programs for example.
Putpixel (XCoord, YCoord : Integer; Red, Green, Blue : Byte);
XCoord is an integer in the set 0 .. 319. YCoord is an integer
in the set 0 .. 199. Red, Green, and Blue specify the
corresponding color components of the pixel. Red and Green
must be in the set 0 .. 15, but Blue must be in the set 0 ..
14. No range checking is performed so you must make sure the
values do not stray outside these sets or unexpected results
will occur.
SetActivePage (PageNumber : Integer);
Sets the page to be written to. There are 2 pages (0 and 1)
for use.
SetDisplayPage (PageNumber : Integer);
Sets the page to be displayed. There are 2 pages (0 and 1) for
use.
How 3840 color works:
This mode is really just a 256 color mode in which the
palette has been carefully selected to give 16 intensities of red
and green, and 15 intensities of blue. The red and blue colors
are mixed in the palette as indices 0 .. 239, and green as
indices 240 .. 255. To get an effective 3840 colors, the
red/blue mix of a pixel is placed on one page and the green is
placed on another page and the screen is flipped quickly between
the two pages. If the pages are flipped quick enough, your eye
blends he colors together and sees 3840 colors (16R * 16G * 15B)
instead of just 256.
The bare-bone targa file viewer will only view 16, 24, or
32-bit color RLE compressed files. 8-Bit Grey scale and raw
image files are not supported. I only tested it on a 24-bit
image, but I believe 16 and 32-bit should work alright also.
Dave
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]