home *** CD-ROM | disk | FTP | other *** search
/ RBBS in a Box Volume 1 #3.1 / RBBSIABOX31.cdr / dosc / dither.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-09-29  |  2.8 KB  |  124 lines
  1. program dither;
  2.  
  3. {$I S400.INT}
  4.  
  5. const c2a: array[0..6] of integer = (0,8,0,8,7,15,15);
  6.       c2b: array[0..6] of integer = (8,8,0,0,0,8,0);
  7.       c1a: array[0..15] of integer = (4,6,2,1,5,3,0,7,
  8.                                      12,14,10,9,13,11,8,15);
  9.       xa: array [0..15] of integer = (0,224,
  10.                                      0,192,
  11.                                      0,144,144,288,
  12.                                      0,144,256,352,
  13.                                      368,
  14.                                      0,0,0);
  15.       ya: array [0..15] of integer = (0,0,
  16.                                      1,1,
  17.                                      2,2,2,2,
  18.                                      3,3,3,3,
  19.                                      1,
  20.                                      4,4,4);
  21.  
  22. var x, y, i, color, color2, c1, c2: integer;
  23.  
  24. procedure pointc (x,y,color: integer);
  25.  
  26.   begin
  27.   if (color and 1) <> 0 then
  28.     begin
  29.     plansl (0);
  30.     pointon (x,y);
  31.     end;
  32.   if (color and 2) <> 0 then
  33.     begin
  34.     plansl (1);
  35.     pointon (x,y);
  36.     end;
  37.   if (color and 4) <> 0 then
  38.     begin
  39.     plansl (2);
  40.     pointon (x,y);
  41.     end;
  42.   if (color and 8) <> 0 then
  43.     begin
  44.     plansl (3);
  45.     pointon (x,y);
  46.     end;
  47.   end;
  48.  
  49. procedure block (ulx,uly,color: integer);
  50.  
  51.   var i,j :integer;
  52.  
  53.   begin
  54.   for i := 1 to 15 do
  55.     for j := 1 to 15 do
  56.       pointc (ulx+j,uly+i,color);
  57.   end;
  58.  
  59. procedure diblock (ulx,uly,c1,c2: integer);
  60.  
  61.   var i,j: integer;
  62.  
  63.   begin
  64.   for i := 1 to 15 do
  65.     for j := 1 to 15 do
  66.       if ((i+j) mod 2) = 0 then
  67.         pointc (ulx+j,uly+i,c1)
  68.       else
  69.         pointc (ulx+j,uly+i,c2);
  70.   end;
  71.  
  72. begin
  73. vhr;
  74.   for c1 := 8 to 15 do
  75.   begin
  76.   color := c1a[c1];
  77.   y := 16 + (32 * (c1 - 8));
  78.   block (16,y,color);
  79.   for i := 0 to 6 do
  80.     begin
  81.     x := 48 + (16 * i);
  82.     diblock (x,y,color-c2b[i],c2a[i]);
  83.     end;
  84.   end;
  85. i := 0;
  86. for c1 := 0 to 15 do
  87.   begin
  88.   x := 192 + xa[c1];
  89.   y := 16 + (64 * ya[c1]);
  90.   color := c1a[c1];
  91.   if not (color in [0,15]) then
  92.     for c2 := (c1+1) to 15 do
  93.       begin
  94.       if c2 = 7 then x := x + 16;
  95.       color2 := c1a[c2];
  96.       if ((not (color2 in [0,7,8,15])) and (color2 <> (color + 8))) then
  97.         begin
  98.         x := x + 16;
  99.         block (x,y,color);
  100.         diblock (x,y+16,color,color2);
  101.         block (x,y+32,color2);
  102.         i := i + 1;
  103.         end;  { if }
  104.       end;  { for c2... }
  105.   i := i + 1;
  106.   end;  { for c1... }
  107. for i := 0 to 3 do
  108.   begin
  109.   plansl (i);
  110.   lineon (8,8,168,8);
  111.   lineon (168,8,168,264);
  112.   lineon (168,264,8,264);
  113.   lineon (8,264,8,8);
  114.   lineon (200,8,600,8);
  115.   lineon (600,8,600,264);
  116.   lineon (600,264,200,264);
  117.   lineon (200,264,200,8);
  118.   end;
  119. gotoxy(10,24);
  120. write('Press SPACE to continue...');
  121. repeat until keypressed;
  122. textmode (c80);
  123. end
  124.