home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GET10.ZIP / GETCOLOR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-09  |  3.7 KB  |  141 lines
  1. Program GetColor; {test program for getattr procedure}
  2. Uses Crt, Qwik, wndwvars, Wndw, Getvars, Get, Fns;
  3.  
  4. var
  5.    testchar: char;
  6.    I:        byte;
  7.  
  8.  
  9. procedure getattr(var selattr: byte; display_value: boolean);
  10. {
  11.   This procedure displays a palette of attributes similar to that used by
  12.   Turbo Pascal's TINST program and allows the user to select one. The
  13.   parameter display_value controls whether or not the decimal value of the
  14.   attribute is displayed at the bottom of the window.
  15.  
  16.   <Ret> selects a foreground and background colour combination (attribute)
  17.   <Esc> aborts leaving the attribute variable passed unchanged
  18.  
  19.   NOTE:
  20.  
  21.   The procedure InitWindow in WNDW40 should be run BEFORE this procedure
  22.   is executed, preferably at the start of the program within which this
  23.   procedure is used.
  24. }
  25.  
  26. var row, col:     integer;
  27.     strattr:      string[3];
  28.     color_window: array[1..864] of byte;  {18 * 24 * 2 bytes}
  29.  
  30.  
  31. procedure display_colors;
  32. var fg,bg: byte;
  33. begin
  34.   Qfill(3,4,1,24,7,' '); {clears space for boxtop}
  35.   for fg := 0 to 15 do
  36.     for bg := 0 to 7 do
  37.       Qwrite(succ(fg) + 3, succ(bg * 3) + 3, ord(bg * 16 + fg), ' x ');
  38.   Qfill(20,4,1,24,7,' '); {clears space for box bottom}
  39.   QStoreToMem(3,4,18,24,color_window);
  40. end;
  41.  
  42.  
  43. procedure moveto (var r,c: integer);
  44. var x,y:    integer;
  45.    attr,
  46.    attrs,
  47.    attrt,
  48.    attrb:  byte;  {box attributes, side, top and bottom}
  49.  
  50. begin
  51.   r := r and $0F; {equivalent to r := r mod 16. See Turbo Tutor manual p316}
  52.   if r = 0 then
  53.     r := 16;
  54.  
  55.   c := c and $07;  {equivalent to c := mod 8}
  56.   if c = 0 then
  57.     c := 8;
  58.  
  59.   QStoreToScr(3,4,18,24,color_window); {restore window contents}
  60.  
  61.   x := pred(c * 3) + 3;
  62.   y := r + 3;
  63.   attrs := (pred(c) * 16 + 15);
  64.   attrb := attrs;
  65.   attrt := attrs;
  66. {
  67.   The top or bottom of the box may stick into space. White on black is 15
  68. }
  69.   case r of
  70.     1: attrt := 15;
  71.    16: attrb := 15;
  72.   end;
  73.  
  74.   Qwrite(pred(y),pred(x),attrt,'┌─┐'); { chr(218) + chr(196) + chr(191) }
  75.   Qwrite(y,pred(x),      attrs,'│')  ; { chr(179) }
  76.   Qwrite(y,succ(x),      attrs,'│')  ; { chr(179) }
  77.   Qwrite(succ(y),pred(x),attrb,'└─┘'); { chr(192) + chr(196) + chr(217) };
  78.  
  79.   if display_value then
  80.     begin
  81.       str((pred(col) * 16 + pred(row)),strattr);
  82.       while length(strattr) < 3 do
  83.         strattr := '─' + strattr;
  84.       titlewindow(bottom,right,strattr);
  85.     end;
  86.  
  87. end; {moveto}
  88.  
  89.  
  90. begin {get_colors}
  91.  SetWindowModes(ShadowRight);
  92.  MakeWindow(2,3,20,26,32,15,vdoublebrdr,window1);
  93.  titlewindow(top,left,'Attributes');
  94.  ModCursor(CursorOff);
  95.  escaped := false;
  96.  row := 1;
  97.  col := 1;
  98.  display_colors;
  99.  
  100.   repeat
  101.     moveto(row,col);
  102.     command := extendkey;
  103.     action := get_edit(command);
  104.     case action of
  105.       upchar:          dec(row);
  106.       downchar:        inc(row);
  107.       rightchar:       inc(col);
  108.       leftchar:        dec(col);
  109.       goto_start:      col := 1;
  110.       goto_end:        col := 8;
  111.       goto_top:        begin
  112.                          row := 1;
  113.                          col := 1;
  114.                        end;
  115.       goto_bottom:     begin
  116.                          row := 16;
  117.                          col := 8;
  118.                        end;
  119.       pageup:          row := 1;
  120.       pagedown:        row := 16;
  121.       escapefrom:      escaped := true;
  122.       carriage_return: selattr := pred(col) * 16 + pred(row);
  123.     end;
  124.  
  125.   until (action = carriage_return) or escaped;
  126.  
  127.   ModCursor(CursorOn);
  128.   removewindow;
  129. end;
  130.  
  131.  
  132. begin
  133.   initWindow(7,true);
  134.   getattr(I,true);
  135.   textbackground(0); textcolor(7);
  136.   if not escaped then
  137.     write('Attribute selected was ',I)
  138.   else write('No attribute selected');
  139. end.
  140.  
  141.