Subversion Repositories Kolibri OS

Rev

Go to most recent revision | Blame | Last modification | View Log | Download | RSS feed

  1.  
  2. { В FreePascal 2.2.0 кодировка cp866 не реализована. }
  3. {-$codepage cp866}
  4.  
  5. {$mode objfpc}
  6. {$apptype gui}
  7. {$r-}
  8.  
  9. program Ray;
  10.  
  11. const
  12.   MSG_PRESSKEY = 'Нажми на кнопку...';
  13.   MSG_USAGE    = 'Для перемешения и врашения используй стрелки';
  14.  
  15.   WIDTH  = 320;
  16.   HEIGHT = 200;
  17.   COLORS = 128;
  18.  
  19.   FlatPalette: array[1..COLORS * 3] of Byte = (
  20.     0,10,20,48,48,48,1,0,43,1,3,43,2,5,44,2,7,44,3,9,45,4,11,46,5,13,47,6,15,48,
  21.     7,17,49,8,19,50,9,21,51,10,22,52,11,24,52,12,26,54,13,28,54,14,30,56,15,32,
  22.     56,16,34,58,17,34,58,17,36,58,18,38,60,19,40,60,20,42,62,21,44,62,10,31,0,
  23.     11,31,0,11,31,1,11,32,1,12,32,1,12,32,2,12,33,2,13,33,2,14,33,3,15,33,3,15,
  24.     34,3,15,34,4,15,35,4,16,35,4,16,35,5,16,36,5,17,36,5,17,36,6,18,37,6,18,38,
  25.     7,19,38,8,20,39,8,20,40,9,21,40,10,22,41,10,22,42,11,23,42,12,24,43,12,24,
  26.     44,13,25,44,14,25,45,14,26,46,15,27,46,16,27,47,17,28,47,18,28,48,19,29,49,
  27.     19,30,49,20,30,50,21,31,51,21,32,51,22,32,52,23,33,53,23,34,53,24,34,54,25,
  28.     35,55,25,36,55,26,36,56,27,37,57,27,38,57,27,39,57,27,41,57,27,42,57,27,43,
  29.     57,27,44,57,27,45,57,27,46,57,27,47,57,27,49,57,27,50,57,27,51,57,27,52,57,
  30.     27,53,57,27,55,57,27,56,57,27,57,57,27,58,57,27,58,57,26,58,57,25,58,57,24,
  31.     58,56,23,58,55,22,58,54,20,58,53,19,58,51,18,58,50,17,58,50,16,58,49,15,58,
  32.     48,14,58,47,13,58,46,12,58,45,11,58,44,11,58,44,10,58,43,10,58,42,9,57,41,
  33.     8,57,40,8,56,39,7,56,38,6,55,37,5,55,35,4,54,33,4,54,31,2,32,32,32,63,63,63,
  34.     63,63,63,63,63,63,63,63,63,48,48,48,63,63,63,63,63,63);
  35.  
  36. type
  37.   TRGBColor = packed record
  38.     R, G, B: Byte;
  39.   end;
  40.  
  41.   PRGBPalette = ^TRGBPalette;
  42.   TRGBPalette = array[0..COLORS - 1] of TRGBColor;
  43.  
  44.   PRGBBuffer = ^TRGBBuffer;
  45.   TRGBBuffer = array[0..HEIGHT - 1, 0..WIDTH - 1] of TRGBColor;
  46.  
  47.   lrgarr = array[Word] of Byte;
  48.   sq     = array[0..254, 0..255] of Byte;
  49.  
  50.  
  51. var
  52.   mp: ^lrgarr;
  53.   rng: array[0..320] of Byte;
  54.   fcos, fsin: array[0..359] of Integer;
  55.  
  56.   RGBBuffer : PRGBBuffer;
  57.   RGBPalette: TRGBPalette absolute FlatPalette;
  58.  
  59.   Message: String = '';
  60.  
  61.  
  62. function NCol(mc, n, dvd: Longint): Byte;
  63. var
  64.   loc: Byte;
  65. begin
  66.   loc := Byte((mc + n - Random(2 * n)) div dvd);
  67.   if loc > 100 then Result := 100 else
  68.   if loc < 5   then Result := 5   else
  69.                     Result := loc;
  70. end;
  71.  
  72.  
  73. procedure Plasma(x1, y1, x2, y2: Word);
  74. var
  75.   xn, yn, dxy   : Word;
  76.   p1, p2, p3, p4: Word;
  77. begin
  78.   if (x2 - x1 > 1) or (y2 - y1 > 1) then
  79.   begin
  80.     p1 := mp^[Word(y1 shl 8 + x1)];
  81.     p2 := mp^[Word(y2 shl 8 + x1)];
  82.     p3 := mp^[Word(y1 shl 8 + x2)];
  83.     p4 := mp^[Word(y2 shl 8 + x2)];
  84.     xn := (x2 + x1) shr 1;
  85.     yn := (y2 + y1) shr 1;
  86.     dxy:= 5 * (x2 - x1 + y2 - y1) div 3;
  87.  
  88.     if mp^[y1 shl 8 + xn] = 0 then mp^[Word(y1 shl 8 + xn)] := NCol(p1 + p3, dxy, 2);
  89.     if mp^[yn shl 8 + x1] = 0 then mp^[Word(yn shl 8 + x1)] := NCol(p1 + p2, dxy, 2);
  90.     if mp^[yn shl 8 + x2] = 0 then mp^[Word(yn shl 8 + x2)] := NCol(p3 + p4, dxy, 2);
  91.     if mp^[y2 shl 8 + xn] = 0 then mp^[Word(y2 shl 8 + xn)] := NCol(p2 + p4, dxy, 2);
  92.     mp^[Word(yn shl 8 + xn)] := NCol(p1 + p2 + p3 + p4, dxy, 4);
  93.  
  94.     Plasma(x1, y1, xn, yn);
  95.     Plasma(xn, y1, x2, yn);
  96.     Plasma(x1, yn, xn, y2);
  97.     Plasma(xn, yn, x2, y2);
  98.   end;
  99. end;
  100.  
  101.  
  102. procedure Draw(xp, yp, dir: Integer);
  103. var
  104.   z, zobs               : Integer;
  105.   ix, iy, iy1, iyp, ixp : Integer;
  106.   x, y                  : Integer;
  107.   s, csf, snf, mpc, i, j: Integer;
  108. begin
  109.   while dir <  0            do Inc(dir, SizeOf(fcos));
  110.   while dir >= SizeOf(fcos) do Dec(dir, SizeOf(fcos));
  111.  
  112.   FillChar(rng, SizeOf(rng), 200);
  113.   FillChar(RGBBuffer^, SizeOf(RGBBuffer^), 0);
  114.  
  115.   zobs := 300 + mp^[Word(yp shl 8 + xp)];
  116.  
  117.   csf := fcos[dir];
  118.   snf := fsin[dir];
  119.  
  120.   for iy := yp to yp+150 do
  121.   begin
  122.     iy1 := 1 + 2 * (iy - yp);
  123.     s   := 4 + 300 div iy1;
  124.  
  125.     for ix := xp + yp - iy to xp - yp + iy do
  126.     begin
  127.       ixp := xp + ((ix - xp) * csf + (iy - yp) * snf) shr 8;
  128.       iyp := yp + ((iy - yp) * csf - (ix - xp) * snf) shr 8;
  129.       x := 160 + 360 * (ix - xp) div iy1;
  130.  
  131.       if (x >= 0) and (x + s < 319) then
  132.       begin
  133.         z   := mp^[Word(iyp shl 8 + ixp)];
  134.         mpc := z shr 1;
  135.  
  136.         if z < 40 then z := 40;
  137.         y := 100 + (zobs - z) * 30 div iy1;
  138.  
  139.         if (y < 200) and (y >= 0) then
  140.         for j := x to x + s do
  141.         if y < rng[j] then
  142.         begin
  143.           for i := y to rng[j] do
  144.             RGBBuffer^[i - 1, j] := RGBPalette[mpc];
  145.           rng[j] := y;
  146.         end;
  147.       end;
  148.     end;
  149.   end;
  150. end;
  151.  
  152.  
  153. procedure Paint;
  154. begin
  155.   kos_begindraw();
  156.   kos_definewindow(100, 100, WIDTH - 1, HEIGHT - 1, $01000000);
  157.   kos_drawimage24(0, 0, WIDTH, HEIGHT, RGBBuffer);
  158.   if Message <> '' then
  159.     kos_drawtext(12, HEIGHT - 12 - 9, Message, $00FF00, $FF000000);
  160.   kos_enddraw();
  161. end;
  162.  
  163.  
  164. function ReadKey: Char;
  165. var
  166.   Event: Word;
  167. begin
  168.   kos_maskevents(ME_PAINT or ME_KEYBOARD);
  169.   repeat
  170.     Event := kos_getevent();
  171.     if Event = SE_PAINT then Paint;
  172.   until Event = SE_KEYBOARD;
  173.   Result := Chr(kos_getkey() shr 8);
  174. end;
  175.  
  176.  
  177. procedure Pause;
  178. begin
  179.   kos_maskevents(ME_PAINT or ME_KEYBOARD);
  180.   Message := MSG_PRESSKEY;
  181.   Paint;
  182.   ReadKey;
  183. end;
  184.  
  185.  
  186. var
  187.   dir, i, j, x, y: Longint;
  188.   C: Char;
  189.   B: Byte;
  190.   Terminate: Boolean;
  191.  
  192. begin
  193.   { таблицы значений синуса и косинуса }
  194.   for i := 0 to 359 do
  195.   begin
  196.     fcos[i] := Trunc(256 * Cos(i / 180 * Pi));
  197.     fsin[i] := Trunc(256 * Sin(i / 180 * Pi));
  198.   end;
  199.  
  200.   { создаем буфер с эффектом "плазма" }
  201.   New(mp);
  202.   FillChar(mp^, SizeOf(mp^), 0);
  203.   mp^[$0000] := 128;
  204.   Plasma(0, 0, 256, 256);
  205.  
  206.   { создаем "пустой" буфер кадра }
  207.   New(RGBBuffer);
  208.   FillChar(RGBBuffer^, SizeOf(RGBBuffer^), 0);
  209.  
  210.   { преобразование палитры из 63 в 255 }
  211.  
  212.   for i := 0 to COLORS - 1 do
  213.   begin
  214.     B := Round(RGBPalette[i].R / 63 * 255);
  215.     RGBPalette[i].R := Round(RGBPalette[i].B / 63 * 255);
  216.     RGBPalette[i].G := Round(RGBPalette[i].G / 63 * 255);
  217.     RGBPalette[i].B := B;
  218.   end;
  219.  
  220.   for j := 0 to 199 do
  221.     for i := 0 to 255 do
  222.       RGBBuffer^[j, i + (WIDTH - 256) shr 1] := RGBPalette[sq(Pointer(mp)^)[j, i]];
  223.  
  224.   Pause;
  225.  
  226.   x   := 0;
  227.   y   := 0;
  228.   dir := 0;
  229.  
  230.   Message := MSG_USAGE;
  231.  
  232.   Terminate := False;
  233.   while not Terminate do
  234.   begin
  235.     dir := dir mod 360;
  236.     if dir < 0 then dir := 360 + dir;
  237.  
  238.     Draw(x, y, dir);
  239.     Paint;
  240.  
  241.     C := ReadKey;
  242.     if C = #$B0 then Dec(dir, 13) else
  243.     if C = #$B3 then Inc(dir, 13) else
  244.     if C = #$B2 then
  245.     begin
  246.       y := y + fcos[dir] shr 6;
  247.       x := x + fsin[dir] shr 6;
  248.     end else
  249.     if C = #$B1 then
  250.     begin
  251.       y := y - fcos[dir] shr 6;
  252.       x := x - fsin[dir] shr 6;
  253.     end;
  254.     if C = #27 then Terminate := True;
  255.   end;
  256. end.
  257.