Upload

WATER/KOE.PAS

@@ -0,0 +1,66 @@
+uses crt;
+type    pbuf = ^buf;
+        buf = array[0..64000] of byte;
+
+var    r,g,b : pbuf;
+       x,y   : word;
+       f     : file;
+       pal   : array[0..768] of byte;
+       row   : array[0..320*3-1] of byte;
+
+procedure setrgb(c,r,g,b:byte);
+begin
+    port[$3c8] := c;
+    port[$3c9] := r;
+    port[$3c9] := g;
+    port[$3c9] := b;
+end;
+
+procedure waitk;
+var  ch : char;
+begin
+     ch := readkey;
+     if ch = #0 then ch := readkey;
+end;
+
+begin
+     asm
+     mov   ax,$13
+     int   $10
+     end;
+     getmem(r,64000);
+     getmem(g,64000);
+     getmem(b,64000);
+
+     assign(f,'bkg.clx');
+     reset(f,1);
+     seek(f,10);
+     blockread(f,pal,768);
+     for x := 0 to 255 do setrgb(x,pal[x*3+0],pal[x*3+1],pal[x*3+2]);
+     blockread(f,mem[$a000:0],64000);
+     close(f);
+
+
+     assign(f,'o:k1.mtv');
+     reset(f,1);
+     seek(f,8);
+     for y := 0 to 199 do
+     begin
+      blockread(f,row,320*3);
+      for x := 0 to 319 do r^[x+y*320] := row[x*3+0];
+      for x := 0 to 319 do g^[x+y*320] := row[x*3+1];
+      for x := 0 to 319 do b^[x+y*320] := row[x*3+2];
+     end;
+     close(f);
+
+{     move(g^,mem[$a000:0],64000);}
+
+     for y := 250 downto 1 do
+     for x := 0 to 64000 do if (r^[x]  = y) and (g^[x] and 1 = 1) then mem[$a000:x] := 255;
+
+     waitk;
+
+     freemem(r,64000);
+     freemem(g,64000);
+     freemem(b,64000);
+end.