home *** CD-ROM | disk | FTP | other *** search
- {$I SHDEFINE.INC}
-
- {$I SHUNITSW.INC}
-
- {$D-,L-}
- unit ShClrdef;
- {
- ShClrDef
-
- A Screen Color Unit
-
- by
-
- Bill Madison
-
- W. G. Madison and Associates, Ltd.
- 13819 Shavano Downs
- P.O. Box 780956
- San Antonio, TX 78278-0956
- (512)492-2777
- CIS 73240,342
-
- Copyright 1991 Madison & Associates
- All Rights Reserved
-
- This file may be used and distributed only in accord-
- ance with the provisions described on the title page of
- the accompanying documentation file
- SKYHAWK.DOC
- }
-
- Interface
-
- uses
- TpWindow,
- TpCrt;
-
- const
-
- {Color constants:
- Black = 0; Blue = 1; Green = 2; Cyan = 3; Red = 4;
- Magenta = 5; Brown = 6; LtGray = 7;
- DkGray = 8; LtBlue = 9; LtGreen = A; LtCyan = B; LtRed = C;
- LtMagenta = D; Yellow = E; White = F
- }
-
- {Screen color constants}
- {Black text} {Blue text}
- BlackOnBlack = $00; BlueOnBlack = $01;
- BlackOnBlue = $10; BlueOnBlue = $11;
- BlackOnGreen = $20; BlueOnGreen = $21;
- BlackOnCyan = $30; BlueOnCyan = $31;
- BlackOnRed = $40; BlueOnRed = $41;
- BlackOnMagenta = $50; BlueOnMagenta = $51;
- BlackOnBrown = $60; BlueOnBrown = $61;
- BlackOnLtGray = $70; BlueOnLtGray = $71;
-
- {Green text} {Cyan text}
- GreenOnBlack = $02; CyanOnBlack = $03;
- GreenOnBlue = $12; CyanOnBlue = $13;
- GreenOnGreen = $22; CyanOnGreen = $23;
- GreenOnCyan = $32; CyanOnCyan = $33;
- GreenOnRed = $42; CyanOnRed = $43;
- GreenOnMagenta = $52; CyanOnMagenta = $53;
- GreenOnBrown = $62; CyanOnBrown = $63;
- GreenOnLtGray = $72; CyanOnLtGray = $73;
-
- {Red text} {Magenta text}
- RedOnBlack = $04; MagentaOnBlack = $05;
- RedOnBlue = $14; MagentaOnBlue = $15;
- RedOnGreen = $24; MagentaOnGreen = $25;
- RedOnCyan = $34; MagentaOnCyan = $35;
- RedOnRed = $44; MagentaOnRed = $45;
- RedOnMagenta = $54; MagentaOnMagenta = $55;
- RedOnBrown = $64; MagentaOnBrown = $65;
- RedOnLtGray = $74; MagentaOnLtGray = $75;
-
- {Brown text} {Light Gray text}
- BrownOnBlack = $06; LtGrayOnBlack = $07;
- BrownOnBlue = $16; LtGrayOnBlue = $17;
- BrownOnGreen = $26; LtGrayOnGreen = $27;
- BrownOnCyan = $36; LtGrayOnCyan = $37;
- BrownOnRed = $46; LtGrayOnRed = $47;
- BrownOnMagenta = $56; LtGrayOnMagenta = $57;
- BrownOnBrown = $66; LtGrayOnBrown = $67;
- BrownOnLtGray = $76; LtGrayOnLtGray = $77;
-
- {Dark Gray text} {Light Blue text}
- DkGrayOnBlack = $08; LtBlueOnBlack = $09;
- DkGrayOnBlue = $18; LtBlueOnBlue = $19;
- DkGrayOnGreen = $28; LtBlueOnGreen = $29;
- DkGrayOnCyan = $38; LtBlueOnCyan = $39;
- DkGrayOnRed = $48; LtBlueOnRed = $49;
- DkGrayOnMagenta = $58; LtBlueOnMagenta = $59;
- DkGrayOnBrown = $68; LtBlueOnBrown = $69;
- DkGrayOnLtGray = $78; LtBlueOnLtGray = $79;
-
- {Light Green Text} {Light Cyan text}
- LtGreenOnBlack = $0A; LtCyanOnBlack = $0B;
- LtGreenOnBlue = $1A; LtCyanOnBlue = $1B;
- LtGreenOnGreen = $2A; LtCyanOnGreen = $2B;
- LtGreenOnCyan = $3A; LtCyanOnCyan = $3B;
- LtGreenOnRed = $4A; LtCyanOnRed = $4B;
- LtGreenOnMagenta = $5A; LtCyanOnMagenta = $5B;
- LtGreenOnBrown = $6A; LtCyanOnBrown = $6B;
- LtGreenOnLtGray = $7A; LtCyanOnLtGray = $7B;
-
- {Light Red text} {Light Magenta text}
- LtRedOnBlack = $0C; LtMagentaOnBlack = $0D;
- LtRedOnBlue = $1C; LtMagentaOnBlue = $1D;
- LtRedOnGreen = $2C; LtMagentaOnGreen = $2D;
- LtRedOnCyan = $3C; LtMagentaOnCyan = $3D;
- LtRedOnRed = $4C; LtMagentaOnRed = $4D;
- LtRedOnMagenta = $5C; LtMagentaOnMagenta = $5D;
- LtRedOnBrown = $6C; LtMagentaOnBrown = $6D;
- LtRedOnLtGray = $7C; LtMagentaOnLtGray = $7D;
-
- {Yellow text} {White text}
- YellowOnBlack = $0E; WhiteOnBlack = $0F;
- YellowOnBlue = $1E; WhiteOnBlue = $1F;
- YellowOnGreen = $2E; WhiteOnGreen = $2F;
- YellowOnCyan = $3E; WhiteOnCyan = $3F;
- YellowOnRed = $4E; WhiteOnRed = $4F;
- YellowOnMagenta = $5E; WhiteOnMagenta = $5F;
- YellowOnBrown = $6E; WhiteOnBrown = $6F;
- YellowOnLtGray = $7E; WhiteOnLtGray = $7F;
-
- type
- Orientation = (Vertical, Horizontal);
-
- function SelectColors(Row, Col, BegAttr : byte;
- CpFrameChars : FrameArray;
- Orient : Orientation;
- ErasePanelOnExit,
- EraseCursorOnExit,
- WrapCursor : boolean;
- Header : string) : byte;
- {
- * Displays a 16x8 panel of text colors with the window coordinates
- of the upper left corner at coordinates X=Col, Y=Row.
- * The attribute at which the cursor will be initially placed is
- at BegAttr.
- * The color panel will be framed using the characters specified
- in CpFrameChars.
- * Allows the user to navigate the panel with the arrow keys and
- select the desired color combination by pressing <CR>. The user
- can also press <INS>, which will return a function value of $FF,
- and by convention, should be taken to indicate that the currently
- selected attribute value is to be unchanged. Additionally, the
- user can press <ESC>, returning a function value of $FE, which by
- convention should be taken to indicate that the current color
- selection run is completed. Finally, a return of $FD indicates
- that the user has pressed the <F1> key either alone or in com-
- bination with one of the shift-type keys (<L-SHIFT>, <R-SHIFT>,
- <CTRL>, or <ALT>), and by convention indicates that the user is
- requesting help.
- * ErasePanelOnExit determines whether the panel is erased or preserved
- on the screen when SelectColors returns to the caller.
- The panel is always disposed, and its heap space reclaimed.
- * EraseCursorOnExit is only effective if ErasePanelOnExit is false.
- If the panel is to be preserved between calls to SelectColors,
- EraseCursor determines whether the or not the cursor will continue
- to be displayed along with the panel.
- * WrapCursor determines whether the cursor will wrap both horizontally
- and vertically. True allows the cursor to wrap; False inhibits
- further cursor movement when a window edge is reached.
- * Header is the header line which will be displayed on the panel. It
- can be supplied as an empty string (''), in which case no header
- will be displayed.
- * The function returns a normal text attribute byte, but with the
- following exceptions:
-
- Return Explanation
- ------ -----------
- $FF <INS> was pressed by the user. Leave the current value
- unchanged.
- $FE <ESC> was pressed by the user. Accept all current values
- and consider the run completed.
- $FD <F1> was pressed by the user. Provide a HELP screen or
- message.
- $F0 Error in MakeWindow
- $F1 Error in DisplayWindow
-
- }
-
- function ColorName(Attr : byte) : string;
- { Given a text attribute byte, ColorName returns the attribute color
- name as defined above; e.g., ColorName($1E) will return 'YellowOnBlue'.
- If a byte value is passed which does not correspond to a valid text
- attribute, an empty string is returned.
- }
-
- Implementation
-
- function SelectColors(Row, Col, BegAttr : byte;
- CpFrameChars :FrameArray;
- Orient : Orientation;
- ErasePanelOnExit,
- EraseCursorOnExit,
- WrapCursor : boolean;
- Header : string) : byte;
- type
- DirectionType = (Up, Down, Left, Right);
- var
- NCols, NRows,
- ColInc, RowInc: byte;
- T1, T2 : integer;
- C1 : char;
- W1 : word;
- WindowBuf : pointer;
- ColorPanel : WindowPtr;
- SavFrameChars : FrameArray;
- EraseP : boolean;
- procedure MoveCursorBlock(Direction : DirectionType);
- begin
- FastWriteWindow(' X ', WhereY, WhereX, ReadAttrAtCursor);
- case WrapCursor of
- true :
- case Direction of
- Down : GoToXY(WhereX, (WhereY mod NRows) + 1);
- Up : GoToXY(WhereX, NRows - ((RowInc - WhereY) mod NRows));
- Left : GoToXY((WhereX-3 + (3*NCols)) mod (3*NCols), WhereY);
- Right : GoToXY((WhereX+3 + (3*NCols)) mod (3*NCols), WhereY);
- end; {case Direction}
- false :
- case Direction of
- Down : GoToXY(WhereX, WhereY+1);
- Up : GoToXY(WhereX, WhereY-1);
- Left : GoToXY(WhereX-3, WhereY);
- Right : GoToXY(WhereX+3, WhereY);
- end; {case Direction}
- end; {case WrapCursor}
- FastWriteWindow('[X]', WhereY, WhereX, ReadAttrAtCursor);
- end; {MoveCursorBlock}
- begin {SelectColors}
- {Calculate window dimensions based on orientation}
- case Orient of
- Vertical : begin
- NCols := 8;
- NRows := 16;
- end;
- Horizontal : begin
- NCols := 16;
- NRows := 8;
- end;
- end; {case Orient}
- ColInc := 3 * NCols + 1;
- RowInc := NRows + 1;
-
- {Check position parameters}
- if Row = 0 then
- Row := (ScreenHeight - RowInc) shr 1;
- if Col = 0 then
- Col := (ScreenWidth - ColInc) shr 1;
- if (Row+RowInc > ScreenHeight) then
- Row := ScreenHeight - RowInc;
- if (Col+ColInc > ScreenWidth) then
- Col := ScreenWidth - ColInc;
-
- {General housekeeping}
- HiddenCursor;
- SavFrameChars := FrameChars;
-
- {Set frame as specified in call}
- FrameChars := CpFrameChars;
-
- {Build the color panel}
- if not MakeWindow(ColorPanel, Col, Row, Col+ColInc, Row+RowInc,
- true, false, false,
- $07, $07, $07, Header) then begin
- SelectColors := $F0;
- NormalCursor;
- FrameChars := SavFrameChars;
- exit;
- end;
- if not DisplayWindow(ColorPanel) then begin
- SelectColors := $F1;
- NormalCursor;
- FrameChars := SavFrameChars;
- exit;
- end;
- for T1 := 0 to NRows-1 do
- for T2 := 0 to NCols-1 do
- case Orient of
- Vertical : FastWriteWindow
- (' X ', T1+1, 3*T2+1, ((T2 shl 4) + T1));
- Horizontal : FastWriteWindow
- (' X ', T1+1, 3*T2+1, ((T1 shl 4) + T2));
- end; {case Orient}
-
- {Place the cursor as specified in call}
- case Orient of
- Vertical : GoToXY(3*(BegAttr shr 4)+1, (BegAttr and $0F)+1);
- Horizontal : GoToXY(3*(BegAttr and $0F)+1, (BegAttr shr 4)+1);
- end;
- FastWriteWindow('[X]',WhereY, WhereX,ReadAttrAtCursor);
-
- {Select the desired color attribute}
- repeat
- W1 := ReadKeyWord;
- case W1 of
- $4800: begin {UpArrow}
- MoveCursorBlock(Up);
- end;
- $4B00: begin {LtArrow}
- MoveCursorBlock(Left);
- end;
- $4D00: begin {RtArrow}
- MoveCursorBlock(Right);
- end;
- $5000: begin {DnArrow}
- MoveCursorBlock(Down);
- end;
- end; {case}
- until (W1 = $1C0D {<CR >}) or
- (W1 = $5200 {<INS>}) or
- (W1 = $011B {<ESC>}) or
- (W1 = $3B00 {<F1> }) or
- (W1 = $5400 {<#F1>}) or
- (W1 = $5E00 {<^F1>}) or
- (W1 = $6800 {<@F1>});
-
- {Conditionally save the panel}
- case ErasePanelOnExit of
- false :
- {Conditionally clear the cursor block after selection}
- begin
- case EraseCursorOnExit of
- false : {Do nothing} ;
- true :
- begin
- FastWriteWindow(' X ',WhereY, WhereX, ReadAttrAtCursor);
- end;
- end; {case EraseCursorOnExit}
- if SaveWindow
- (Col, Row, Col+ColInc, Row+RowInc, true, WindowBuf) then ;
- end; {false}
- true : {Do nothing} ;
- end; {case ErasePanelOnExit}
-
- {Set up the return}
- case W1 of
- $5200 {<INS>} : SelectColors := $FF;
- $011B {<ESC>} : SelectColors := $FE;
- $3B00,{<F1> }
- $5400,{<#F1>}
- $5E00,{<^F1>}
- $6800 {<@F1>} : SelectColors := $FD;
- else begin
- byte(C1) := ReadAttrAtCursor;
- SelectColors := byte(C1);
- end;
- end; {case W1}
-
- {Dispose of the window and conditionally restore the panel}
- DisposeWindow(EraseTopWindow);
- if not ErasePanelOnExit then
- RestoreWindow(Col, Row, Col+ColInc, Row+RowInc, true, WindowBuf);
-
- {Restore the environment and scram}
- NormalCursor;
- FrameChars := SavFrameChars;
- end;
-
- function ColorName(Attr : byte) : string;
- begin
- case Attr of
-
- {Black text}
- $00 : ColorName := 'BlackOnBlack';
- $10 : ColorName := 'BlackOnBlue';
- $20 : ColorName := 'BlackOnGreen';
- $30 : ColorName := 'BlackOnCyan';
- $40 : ColorName := 'BlackOnRed';
- $50 : ColorName := 'BlackOnMagenta';
- $60 : ColorName := 'BlackOnBrown';
- $70 : ColorName := 'BlackOnLtGray';
-
- {Blue text}
- $01 : ColorName := 'BlueOnBlack';
- $11 : ColorName := 'BlueOnBlue';
- $21 : ColorName := 'BlueOnGreen';
- $31 : ColorName := 'BlueOnCyan';
- $41 : ColorName := 'BlueOnRed';
- $51 : ColorName := 'BlueOnMagenta';
- $61 : ColorName := 'BlueOnBrown';
- $71 : ColorName := 'BlueOnLtGray';
-
- {Green text}
- $02 : ColorName := 'GreenOnBlack';
- $12 : ColorName := 'GreenOnBlue';
- $22 : ColorName := 'GreenOnGreen';
- $32 : ColorName := 'GreenOnCyan';
- $42 : ColorName := 'GreenOnRed';
- $52 : ColorName := 'GreenOnMagenta';
- $62 : ColorName := 'GreenOnBrown';
- $72 : ColorName := 'GreenOnLtGray';
-
- {Cyan text}
- $03 : ColorName := 'CyanOnBlack';
- $13 : ColorName := 'CyanOnBlue';
- $23 : ColorName := 'CyanOnGreen';
- $33 : ColorName := 'CyanOnCyan';
- $43 : ColorName := 'CyanOnRed';
- $53 : ColorName := 'CyanOnMagenta';
- $63 : ColorName := 'CyanOnBrown';
- $73 : ColorName := 'CyanOnLtGray';
-
- {Red text}
- $04 : ColorName := 'RedOnBlack';
- $14 : ColorName := 'RedOnBlue';
- $24 : ColorName := 'RedOnGreen';
- $34 : ColorName := 'RedOnCyan';
- $44 : ColorName := 'RedOnRed';
- $54 : ColorName := 'RedOnMagenta';
- $64 : ColorName := 'RedOnBrown';
- $74 : ColorName := 'RedOnLtGray';
-
- {Magenta text}
- $05 : ColorName := 'MagentaOnBlack';
- $15 : ColorName := 'MagentaOnBlue';
- $25 : ColorName := 'MagentaOnGreen';
- $35 : ColorName := 'MagentaOnCyan';
- $45 : ColorName := 'MagentaOnRed';
- $55 : ColorName := 'MagentaOnMagenta';
- $65 : ColorName := 'MagentaOnBrown';
- $75 : ColorName := 'MagentaOnLtGray';
-
- {Brown text}
- $06 : ColorName := 'BrownOnBlack';
- $16 : ColorName := 'BrownOnBlue';
- $26 : ColorName := 'BrownOnGreen';
- $36 : ColorName := 'BrownOnCyan';
- $46 : ColorName := 'BrownOnRed';
- $56 : ColorName := 'BrownOnMagenta';
- $66 : ColorName := 'BrownOnBrown';
- $76 : ColorName := 'BrownOnLtGray';
-
- {Light Gray text}
- $07 : ColorName := 'LtGrayOnBlack';
- $17 : ColorName := 'LtGrayOnBlue';
- $27 : ColorName := 'LtGrayOnGreen';
- $37 : ColorName := 'LtGrayOnCyan';
- $47 : ColorName := 'LtGrayOnRed';
- $57 : ColorName := 'LtGrayOnMagenta';
- $67 : ColorName := 'LtGrayOnBrown';
- $77 : ColorName := 'LtGrayOnLtGray';
-
- {Dark Gray text}
- $08 : ColorName := 'DkGrayOnBlack';
- $18 : ColorName := 'DkGrayOnBlue';
- $28 : ColorName := 'DkGrayOnGreen';
- $38 : ColorName := 'DkGrayOnCyan';
- $48 : ColorName := 'DkGrayOnRed';
- $58 : ColorName := 'DkGrayOnMagenta';
- $68 : ColorName := 'DkGrayOnBrown';
- $78 : ColorName := 'DkGrayOnLtGray';
-
- {Light Blue text}
- $09 : ColorName := 'LtBlueOnBlack';
- $19 : ColorName := 'LtBlueOnBlue';
- $29 : ColorName := 'LtBlueOnGreen';
- $39 : ColorName := 'LtBlueOnCyan';
- $49 : ColorName := 'LtBlueOnRed';
- $59 : ColorName := 'LtBlueOnMagenta';
- $69 : ColorName := 'LtBlueOnBrown';
- $79 : ColorName := 'LtBlueOnLtGray';
-
- {Light Green Text}
- $0A : ColorName := 'LtGreenOnBlack';
- $1A : ColorName := 'LtGreenOnBlue';
- $2A : ColorName := 'LtGreenOnGreen';
- $3A : ColorName := 'LtGreenOnCyan';
- $4A : ColorName := 'LtGreenOnRed';
- $5A : ColorName := 'LtGreenOnMagenta';
- $6A : ColorName := 'LtGreenOnBrown';
- $7A : ColorName := 'LtGreenOnLtGray';
-
- {Light Cyan text}
- $0B : ColorName := 'LtCyanOnBlack';
- $1B : ColorName := 'LtCyanOnBlue';
- $2B : ColorName := 'LtCyanOnGreen';
- $3B : ColorName := 'LtCyanOnCyan';
- $4B : ColorName := 'LtCyanOnRed';
- $5B : ColorName := 'LtCyanOnMagenta';
- $6B : ColorName := 'LtCyanOnBrown';
- $7B : ColorName := 'LtCyanOnLtGray';
-
- {Light Red text}
- $0C : ColorName := 'LtRedOnBlack';
- $1C : ColorName := 'LtRedOnBlue';
- $2C : ColorName := 'LtRedOnGreen';
- $3C : ColorName := 'LtRedOnCyan';
- $4C : ColorName := 'LtRedOnRed';
- $5C : ColorName := 'LtRedOnMagenta';
- $6C : ColorName := 'LtRedOnBrown';
- $7C : ColorName := 'LtRedOnLtGray';
-
- {Light Magenta text}
- $0D : ColorName := 'LtMagentaOnBlack';
- $1D : ColorName := 'LtMagentaOnBlue';
- $2D : ColorName := 'LtMagentaOnGreen';
- $3D : ColorName := 'LtMagentaOnCyan';
- $4D : ColorName := 'LtMagentaOnRed';
- $5D : ColorName := 'LtMagentaOnMagenta';
- $6D : ColorName := 'LtMagentaOnBrown';
- $7D : ColorName := 'LtMagentaOnLtGray';
-
- {Yellow text}
- $0E : ColorName := 'YellowOnBlack';
- $1E : ColorName := 'YellowOnBlue';
- $2E : ColorName := 'YellowOnGreen';
- $3E : ColorName := 'YellowOnCyan';
- $4E : ColorName := 'YellowOnRed';
- $5E : ColorName := 'YellowOnMagenta';
- $6E : ColorName := 'YellowOnBrown';
- $7E : ColorName := 'YellowOnLtGray';
-
- {White text}
- $0F : ColorName := 'WhiteOnBlack';
- $1F : ColorName := 'WhiteOnBlue';
- $2F : ColorName := 'WhiteOnGreen';
- $3F : ColorName := 'WhiteOnCyan';
- $4F : ColorName := 'WhiteOnRed';
- $5F : ColorName := 'WhiteOnMagenta';
- $6F : ColorName := 'WhiteOnBrown';
- $7F : ColorName := 'WhiteOnLtGray';
-
- else ColorName := '';
- end;
- end;
- end.
-