home *** CD-ROM | disk | FTP | other *** search
/ Die ASC Mega 2 / ASC-Mega2-CD-ROM.iso / SPIELE / KAISER / PALETTE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-08-26  |  4.1 KB  |  154 lines
  1. program palette;
  2.  
  3. uses  crt,dos,screen;
  4.  
  5. const daten:           array[0..16] of byte =
  6. {              (0,1,2,3,4,5,20,7,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F,0);}
  7.                          (0,1,2,$26,4,$38,$14,7,$27,9,$12,$3B,$24,$3D,$36,$3F,0);
  8.       value:           array[0..3] of byte = (0,8,1,9);
  9.       att_backgr     = brown*16+lightgray;
  10.  
  11. type  control_typ    = (li,re,auf,ab,bauf,bab,pos1,end_,key,ext);
  12.  
  13.  
  14. var   farbe,r,g,b,neu: shortint;
  15.       control:         control_typ;
  16.       taste:           char;
  17.       ende:            boolean;
  18.  
  19. procedure install_palette;
  20. var regs: registers;
  21. begin
  22.   with regs do begin
  23.     ax:=$1002;
  24.     dx:=ofs(daten);
  25.     es:=seg(daten);
  26.     intr($10,regs);
  27.   end;
  28. end;   (* install_palette *)
  29.  
  30.  
  31. procedure bildschirm;
  32. var lauf,x,y: byte;
  33. begin
  34.   box(all_double_box,0,0,78,23,att_backgr,att_backgr); 
  35.   box(all_single_box,7,1,64,3,att_backgr,att_backgr);
  36.   for lauf:=0 to 15 do for y:=2 to 4 do for x:=8+lauf*4 to 11+lauf*4 do begin
  37.     crt_screen^[y,x,0]:='█'; crt_screen^[y,x,1]:=chr(lauf);
  38.   end;
  39. end;   (* bildschirm *)
  40.  
  41.  
  42. procedure fill_rgb;
  43. var wert: byte;
  44. begin
  45.   r:=0; g:=0; b:=0; wert:=daten[farbe];
  46.   if (wert and 1)>0 then inc(b,2);
  47.   if (wert and 2)>0 then inc(g,2);
  48.   if (wert and 4)>0 then inc(r,2);
  49.   if (wert and 8)>0 then inc(b,1);
  50.   if (wert and 16)>0 then inc(g,1);
  51.   if (wert and 32)>0 then inc(r,1);
  52.   wr(6,9+farbe*4,att_backgr,#24#24); gotoxy(12+farbe*4,7);
  53. end;   (* fill_rgb *)
  54.  
  55.  
  56. procedure back_rgb;
  57. begin
  58.   daten[farbe]:=value[b]+value[g]*2+value[r]*4;
  59.   wr(6,9+farbe*4,att_backgr,'  ');
  60. end;   (* back_rgb *)
  61.  
  62.  
  63. procedure zeige_rgb;
  64. var x,wert: byte;
  65.  
  66. function strr (zahl: longint; stellen: byte): string;
  67. var s: string;
  68. begin
  69.   str(zahl,s); while length(s)<stellen do s:='0'+s;
  70.   strr:=s;
  71. end;  (* strr *)
  72.  
  73. function hex (zahl: byte): string;
  74. const hexchars: array[0..$F] of char = '0123456789ABCDEF';
  75. begin
  76.   hex:=hexchars[(zahl and $F0) shr 4]+hexchars[zahl and $F];
  77. end;  (* hex *)
  78.  
  79. procedure rgb_box (oben,unten: char; wert,att: byte);
  80. begin
  81.   box(all_single_box,x,17,2,4,att*16+white,att*16+white);
  82.   wr(17,succ(x),att*16+white,oben); wr(22,x+2,att*16+white,unten);
  83.   wr(21-wert,succ(x),att*16+white,'██');
  84.   inc(x,4);
  85. end;   (* rgb_box *)
  86.  
  87. begin  (* zeige_rgb *)
  88.   x:=34; wert:=value[b]+value[g]*2+value[r]*4;
  89.   box(all_double_box,33,15,12,7,att_backgr,att_backgr);
  90.   wr(16,37,att_backgr,'$'+hex(wert)+'/'+strr(wert,2));
  91.   rgb_box ('Q','A',r,red); rgb_box('W','S',g,green); rgb_box('E','D',b,blue);
  92. end;   (* zeige_rgb *)
  93.  
  94.  
  95. procedure lies (var control: control_typ; var taste: char; num_pad: boolean);
  96. begin
  97.   taste:=readkey;
  98.   if taste=#0
  99.     then begin
  100.       taste:=readkey;
  101.       case ord(taste) of
  102.         72:  control:=auf;
  103.         80:  control:=ab;
  104.         75:  control:=li;
  105.         77:  control:=re;
  106.         73:  control:=bauf;
  107.         81:  control:=bab;
  108.         71:  control:=pos1;
  109.         79:  control:=end_;
  110.         else control:=ext;
  111.       end;
  112.     end else
  113.       if num_pad
  114.         then case taste of
  115.                '8': control:=auf;
  116.                '2': control:=ab;
  117.                '4': control:=li;
  118.                '6': control:=re;
  119.                '9': control:=bauf;
  120.                '3': control:=bab;
  121.                '7': control:=pos1;
  122.                '1': control:=end_;
  123.                else control:=key;
  124.              end
  125.         else control:=key;
  126. end;   (* lies *)
  127.  
  128.  
  129. begin (* palette *)
  130.   bildschirm; farbe:=0;
  131.   repeat
  132.     install_palette;
  133.     fill_rgb; neu:=farbe;
  134.     repeat
  135.       zeige_rgb;
  136.       lies (control,taste,true);
  137.       case control of
  138.         li:  begin dec(neu); ende:=true; end;
  139.         re:  begin inc(neu); ende:=true; end;
  140.         key: case upcase(taste) of
  141.                'Q': if r<3 then inc(r);
  142.                'W': if g<3 then inc(g);
  143.                'E': if b<3 then inc(b);
  144.                'A': if r>0 then dec(r);
  145.                'S': if g>0 then dec(g);
  146.                'D': if b>0 then dec(b);
  147.                #27: ende:=true;
  148.              end;
  149.       end;
  150.     until ende;
  151.     back_rgb; farbe:=neu and 15;
  152.   until taste=#27;
  153. end.
  154.