home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
30TURUTL
/
SETCOLOR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-02-18
|
7KB
|
194 lines
Program SetColor;
type maxstr = string[80];
var line_pos: integer;
screen_array: Array[1..4000] of byte Absolute $2000:$0000;
screen_pos: Array[1..4000] of byte absolute $B800:$0000;
Dos_screen: Array[1..4000] of byte absolute $B800:$2000;
i,j: Integer;
extended: boolean;
ch: char;
Procedure set_color(color: integer);
begin
j:=0;
for i:=0 to 4000 do begin
screen_pos[j]:=color;
j:=j+2;
end;
end;
Procedure Writelin(long_string:maxstr; color: integer);
var scr_pos,str_len, real_pos: integer;
begin
{$I-}
str_len:=length(long_string);
scr_pos:=1;
for real_pos:=1 to str_len do
begin
screen_array[line_pos+scr_pos]:=ord(copy(long_string,real_pos,1));
screen_array[line_pos+scr_pos+1]:=color;
scr_pos:=scr_pos+2;
end;
line_pos:=line_pos+160;
if line_pos > 3800 then
begin
clrscr;
line_pos:=0;
end
{$I+}
end;
Procedure Writexy(long_string:maxstr; xcoord,ycoord,color: integer);
var scr_pos,str_len, real_pos: integer;
begin
{$I-}
str_len:=length(long_string);
scr_pos:=0;
for real_pos:=1 to str_len do
if scr_pos < 4001 then
begin
scr_pos:=((xcoord*2)-1)+(ycoord*160);
screen_array[scr_pos]:=ord(copy(long_string,real_pos,1));
screen_array[scr_pos+1]:=color;
xcoord:=xcoord+1;
end
{$I+}
end;
Procedure Draw_Screen;
var k,l: integer;
begin
line_pos:=0;
clrscr;
Writelin(' Select Color Program',15);
writelin(' by',7);
writelin(' Jim Everingham',7);
writelin(' 1984',7);
for k:=1 to 127 do writexy(' Color ',(k*10+403),0,k);
line_pos:=3680;
writelin(' Use cursor keys to move pointer to color. <Return> to select',11);
writexy('Return',53,23,(15+128));
move(screen_array,screen_pos,4000);
end;
Procedure GetChar(VAR Ch: Char; VAR Extended: Boolean);
Type
Registers = Record
AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer;
End;
Var
Reg: Registers;
AL: Integer;
Begin
Ch:=#0; Extended:=False;
If KeyPressed Then
Begin
Reg.Ax:=$0800; { -Set AH as $8 for Dos Function call }
Intr($21,Reg); { -Calls Interupt $21 for Dos Fucntion call}
AL:=(Reg.AX AND $00FF); { -Derive AL from AX }
Ch:=Chr(AL); { -Set Ch to character to AL }
If Ch=#0 then
Begin { Routine to get extended character scan code }
Reg.Ax:=$0800;
Intr($21,Reg);
Ch:=Chr((Reg.AX AND $00FF));
Extended:=True;
End;
End;
End;
var col, xpos, ypos: integer;
begin
move(screen_pos,dos_screen,4000);
Draw_screen;
xpos:=2;
ypos:=6;
gotoxy(xpos,ypos);
textcolor(white+blink);
col:=0;
write(chr(16));
repeat
if keypressed then
begin
getchar(ch,extended);
if ch=chr(13) then
begin
move(dos_screen,screen_pos,4000);
set_color(col);
gotoxy(1,25);
halt;
end;
if extended then
begin
if ord(ch)=77 then
begin
gotoxy(xpos,ypos);
write(' ');
xpos:=xpos+10;
col:=col+1;
if xpos>80 then
begin
xpos:=2;
col:=col-8;
end;
gotoxy(xpos,ypos);
write(chr(16));
end;
if ord(ch)=75 then
begin
gotoxy(xpos,ypos);
write(' ');
col:=col-1;
xpos:=xpos-10;
if xpos<1 then
begin
xpos:=72;
col:=col+8;
end;
gotoxy(xpos,ypos);
write(chr(16));
end;
if ord(ch)=80 then
begin
gotoxy(xpos,ypos);
write(' ');
ypos:=ypos+1;
col:=col+8;
if ypos>21 then
begin
ypos:=6;
col:=col-128;
end;
gotoxy(xpos,ypos);
write(chr(16));
end;
if ord(ch)=72 then
begin
gotoxy(xpos,ypos);
write(' ');
ypos:=ypos-1;
col:=col-8;
if ypos<6 then
begin
ypos:=21;
col:=col+128;
end;
gotoxy(xpos,ypos);
write(chr(16));
end;
end;
end;
until ch='Q';
move(dos_screen,screen_pos,4000);
set_color(col);
end.