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 >
Pascal/Delphi Source File  |  1985-02-18  |  7KB  |  194 lines
  1. Program SetColor;
  2. type maxstr = string[80];
  3. var line_pos: integer;
  4.     screen_array: Array[1..4000] of byte Absolute $2000:$0000;
  5.     screen_pos: Array[1..4000] of byte absolute $B800:$0000;
  6.     Dos_screen: Array[1..4000] of byte absolute $B800:$2000;
  7.     i,j: Integer;
  8.     extended: boolean;
  9.     ch: char;
  10.  
  11. Procedure set_color(color: integer);
  12. begin
  13.      j:=0;
  14.      for i:=0 to 4000 do begin
  15.                  screen_pos[j]:=color;
  16.                  j:=j+2;
  17.                  end;
  18. end;
  19.  
  20.  
  21. Procedure Writelin(long_string:maxstr; color: integer);
  22.  
  23. var  scr_pos,str_len, real_pos: integer;
  24.  
  25. begin
  26. {$I-}
  27.      str_len:=length(long_string);
  28.      scr_pos:=1;
  29.      for real_pos:=1 to str_len do
  30.                        begin
  31.                             screen_array[line_pos+scr_pos]:=ord(copy(long_string,real_pos,1));
  32.                             screen_array[line_pos+scr_pos+1]:=color;
  33.                             scr_pos:=scr_pos+2;
  34.                        end;
  35.     line_pos:=line_pos+160;
  36.     if line_pos > 3800 then
  37.                        begin
  38.                             clrscr;
  39.                             line_pos:=0;
  40.                        end
  41. {$I+}
  42. end;
  43.  
  44. Procedure Writexy(long_string:maxstr; xcoord,ycoord,color: integer);
  45.  
  46. var scr_pos,str_len, real_pos: integer;
  47.  
  48. begin
  49. {$I-}
  50.      str_len:=length(long_string);
  51.      scr_pos:=0;
  52.      for real_pos:=1 to str_len do
  53.                  if scr_pos < 4001 then
  54.                        begin
  55.                             scr_pos:=((xcoord*2)-1)+(ycoord*160);
  56.                             screen_array[scr_pos]:=ord(copy(long_string,real_pos,1));
  57.                             screen_array[scr_pos+1]:=color;
  58.                             xcoord:=xcoord+1;
  59.                        end
  60. {$I+}
  61. end;
  62.  
  63.  
  64.  
  65.  
  66. Procedure Draw_Screen;
  67. var k,l: integer;
  68. begin
  69.      line_pos:=0;
  70.      clrscr;
  71.      Writelin('                           Select Color Program',15);
  72.      writelin('                                   by',7);
  73.      writelin('                              Jim Everingham',7);
  74.      writelin('                                  1984',7);
  75.      for k:=1 to 127 do writexy(' Color  ',(k*10+403),0,k);
  76.      line_pos:=3680;
  77.      writelin('        Use cursor keys to move pointer to color.  <Return> to select',11);
  78.      writexy('Return',53,23,(15+128));
  79.      move(screen_array,screen_pos,4000);
  80. end;
  81.  
  82. Procedure GetChar(VAR Ch: Char; VAR Extended: Boolean);
  83.  
  84. Type
  85.  Registers = Record
  86.               AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer;
  87.              End;
  88. Var
  89.  Reg: Registers;
  90.  AL:  Integer;
  91. Begin
  92. Ch:=#0; Extended:=False;
  93. If KeyPressed Then
  94.  Begin
  95.  Reg.Ax:=$0800;                { -Set AH as $8 for Dos Function call      }
  96.  Intr($21,Reg);                { -Calls Interupt $21 for Dos Fucntion call}
  97.  AL:=(Reg.AX AND $00FF);       { -Derive AL from AX                       }
  98.  Ch:=Chr(AL);                  { -Set Ch to character to AL               }
  99.  If Ch=#0 then
  100.   Begin                       { Routine to get extended character scan code }
  101.   Reg.Ax:=$0800;
  102.   Intr($21,Reg);
  103.   Ch:=Chr((Reg.AX AND $00FF));
  104.   Extended:=True;
  105.   End;
  106.  End;
  107. End;
  108.  
  109. var col, xpos, ypos: integer;
  110.  
  111. begin
  112.     move(screen_pos,dos_screen,4000);
  113.     Draw_screen;
  114.     xpos:=2;
  115.     ypos:=6;
  116.     gotoxy(xpos,ypos);
  117.     textcolor(white+blink);
  118.     col:=0;
  119.     write(chr(16));
  120.     repeat
  121.           if keypressed then
  122.               begin
  123.               getchar(ch,extended);
  124.               if ch=chr(13) then
  125.                  begin
  126.                       move(dos_screen,screen_pos,4000);
  127.                       set_color(col);
  128.                       gotoxy(1,25);
  129.                       halt;
  130.                  end;
  131.               if extended then
  132.                  begin
  133.                       if ord(ch)=77 then
  134.                             begin
  135.                                  gotoxy(xpos,ypos);
  136.                                  write(' ');
  137.                                  xpos:=xpos+10;
  138.                                  col:=col+1;
  139.                                  if xpos>80 then
  140.                                         begin
  141.                                               xpos:=2;
  142.                                               col:=col-8;
  143.                                         end;
  144.                                  gotoxy(xpos,ypos);
  145.                                  write(chr(16));
  146.                             end;
  147.                       if ord(ch)=75 then
  148.                             begin
  149.                                  gotoxy(xpos,ypos);
  150.                                  write(' ');
  151.                                  col:=col-1;
  152.                                  xpos:=xpos-10;
  153.                                  if xpos<1 then
  154.                                          begin
  155.                                               xpos:=72;
  156.                                               col:=col+8;
  157.                                          end;
  158.                                  gotoxy(xpos,ypos);
  159.                                  write(chr(16));
  160.                             end;
  161.                       if ord(ch)=80 then
  162.                             begin
  163.                                  gotoxy(xpos,ypos);
  164.                                  write(' ');
  165.                                  ypos:=ypos+1;
  166.                                  col:=col+8;
  167.                                  if ypos>21 then
  168.                                          begin
  169.                                                ypos:=6;
  170.                                                col:=col-128;
  171.                                          end;
  172.                                  gotoxy(xpos,ypos);
  173.                                  write(chr(16));
  174.                             end;
  175.                       if ord(ch)=72 then
  176.                             begin
  177.                                  gotoxy(xpos,ypos);
  178.                                  write(' ');
  179.                                  ypos:=ypos-1;
  180.                                  col:=col-8;
  181.                                  if ypos<6 then
  182.                                          begin
  183.                                               ypos:=21;
  184.                                               col:=col+128;
  185.                                          end;
  186.                                  gotoxy(xpos,ypos);
  187.                                  write(chr(16));
  188.                             end;
  189.                  end;
  190.               end;
  191.     until ch='Q';
  192.     move(dos_screen,screen_pos,4000);
  193.     set_color(col);
  194. end.