Информационный сервер для программистов: Исходники со всего света. Паскальные исходники со всего света
  Powered by Поисковый сервер Яndex: Найдется ВСЁ!
На Главную Исходники Форум Информер Страны мира
   Demo Making    >>    plasmat
   
 
 Plasma Textured Tunnel Effect [320x200x256]  Unknown 15.11.97

Эффект туннеля, текстурированного плазмой. Предусмотрено управление клавиатурой - движение вперед и назад, а также вращение по (или против) часовой стрелке.
This is a very cool plasma tunnel which you can "walk" around in with the keyboard.



2k 
 

  {> Cut here. FileName= PLASMAT.PAS } {$N+,X+,R-,S-,I-,G+,E+,Q-} program plasma_tunnel; uses crt,dos; const segA000 : word = $A000; biosseg : word = $0040; var v,pic : pointer; addr,x,y : word; i,r,d : byte; ds,rs : shortint; len : real; warp,interactive : boolean; keys : array[0..127] of boolean; oldint9h : procedure; key : char; stab : array[0..255] of byte; procedure newint9h;interrupt;assembler; asm xor bh,bh in al,60h mov bl,al and bl,01111111b xor al,10000000b shr al,7 mov byte ptr keys[bx],al pushf call oldint9h cli mov es,biosseg mov ax,es:[1Ah] mov es:[1Ch],ax sti end; function vinkel(x,y : real) : byte; var v : integer; begin if (x = 0) and (y > 0) then vinkel := 64 else if (x = 0) and (y <= 0) then vinkel := 192 else begin v := round(arctan(y/x)/pi*128); if (x < 0) and (y < 0) then vinkel := v+128 else if (x < 0) and (y >= 0) then vinkel := 128+v else vinkel := v; end; end; function max(a,b : integer) : integer; inline($58/$5B/$3B/$C3/$7F/$01/$93); function min(a,b : integer) : integer; inline($58/$5B/$3B/$C3/$7C/$01/$93); procedure plasma(x1,y1,x2,y2 : longint); var nx,ny : word; c : integer; function cc(c,n : integer) : byte; var d : integer; begin d := ((x2-x1+y2-y1)*5) div 3; cc := min(max((c+d-random(d+d)) div n,1),255); end; procedure putpixel(x,y : byte;c : byte);assembler; asm mov es,word ptr [pic+2] mov bl,x mov bh,y mov al,c mov es:[bx],al end; function getpixel(x,y : byte) : byte;assembler; asm mov es,word ptr [pic+2] mov bl,x mov bh,y mov al,es:[bx] end; begin if ((x2-x1) < 2) and ((y2-y1) < 2) then exit; nx := x1+(x2-x1) shr 1; ny := y1+(y2-y1) shr 1; if getpixel(nx,y1) = 0 then putpixel(nx,y1,cc(getpixel(x1,y1)+getpixel(x2,y1),2)); if getpixel(nx,y2) = 0 then putpixel(nx,y2,cc(getpixel(x1,y2)+getpixel(x2,y2),2)); if getpixel(x1,ny) = 0 then putpixel(x1,ny,cc(getpixel(x1,y1)+getpixel(x1,y2),2)); if getpixel(x2,ny) = 0 then putpixel(x2,ny,cc(getpixel(x2,y1)+getpixel(x2,y2),2)); if getpixel(nx,ny) = 0 then putpixel(nx,ny,cc(getpixel(x1,y1)+getpixel(x2,y2)+ getpixel(x1,y2)+getpixel(x2,y1),4)); plasma(x1,y1,nx,ny); plasma(nx,y1,x2,ny); plasma(x1,ny,nx,y2); plasma(nx,ny,x2,y2); end; procedure retrace;assembler; asm mov dx,3DAh @loop: in al,dx test al,8 jnz @loop @loop2: in al,dx test al,8 jz @loop2 end; procedure setp(c,r,g,b : byte);assembler; asm mov dx,3C8h mov al,c out dx,al inc dx mov al,r out dx,al mov al,g out dx,al mov al,b out dx,al end; function test8086 : byte;assembler; asm xor dl,dl push sp pop ax cmp sp,ax jne @out inc dl pushf pop ax or ax,4000h push ax popf pushf pop ax test ax,4000h je @out inc dl @out: mov al,dl end; begin randomize; if test8086 < 2 then begin writeln('Sorry, you need a 386 or better to run this program.',#7); halt; end; interactive := false; write('Do you want to control? '); repeat key := readkey; until (upcase(key) in ['Y','N']); writeln(key); if upcase(key) = 'Y' then interactive := true; write('Wait while calculating tunnel data...'); for i := 0 to 127 do keys[i] := false; for i := 0 to 255 do stab[i] := round(sin(i*pi/128)*127.5+127.5); getmem(v,64000); addr := 0; for y := 0 to 99 do for x := 0 to 319 do begin len := sqrt((x-159.5)*(x-159.5)+(y-99.5)*(y-99.5))+1; memw[seg(v^):addr] := vinkel(x-159.5,y-99.5)+ (round(4000/len) and 255) shl 8; inc(addr,2); end; getmem(pic,$FFFF); asm mov es,word ptr [pic+2] xor di,di mov cx,0FFFFh/4+1 db 66h;xor ax,ax db 66h;rep stosw end; plasma(0,0,256,256); addr := 0; for y := 0 to 255 do for x := 0 to 255 do begin mem[seg(pic^):addr] := (mem[seg(pic^):addr+256]+mem[seg(pic^):addr+256]+ mem[seg(pic^):addr-256]+mem[seg(pic^):addr+1]+ mem[seg(pic^):addr-1]) div 5; inc(addr); end; asm mov ax,13h int 10h end; for i := 1 to 63 do setp(i,i,32,32+i div 2); for i := 0 to 63 do setp(i+64,63-i,32+i div 2,63); for i := 0 to 63 do setp(i+128,i div 2,63-i,63-i); for i := 0 to 63 do setp(i+192,32+i div 2,0,i); getintvec($09,@oldint9h); setintvec($09,@newint9h); asm mov ax,word ptr [v+2] db 8Eh;db 0E0h {mov fs,ax} mov ax,word ptr [pic+2] db 8Eh;db 0E8h {mov gs,ax} mov es,segA000 end; rs := 0; if not interactive then ds := 8; repeat if interactive and not warp then begin if keys[$48] then begin if ds < 10 then inc(ds); end else if ds > 0 then dec(ds); if keys[$50] then begin if ds > -10 then dec(ds); end else if ds < 0 then inc(ds); if keys[$4D] then begin if rs < 10 then inc(rs); end else if rs > 0 then dec(rs); if keys[$4B] then begin if rs > -10 then dec(rs); end else if rs < 0 then inc(rs); end else begin if not warp then r := stab[i]; inc(i); end; inc(d,ds shr 1); inc(r,rs shr 1); if keys[1] then warp := true; if warp then begin inc(ds,2); inc(rs,1); end; retrace; asm push bp xor di,di xor bx,bx mov cl,r mov ch,d mov bp,8000 @dloop: db 64h;mov dx,[bx] add dl,cl add dh,ch mov si,dx db 65h;mov al,[si] db 64h;mov dx,[bx+2] add dl,cl add dh,ch mov si,dx db 65h;mov ah,[si] db 66h;shl ax,16 db 64h;mov dx,[bx+4] add dl,cl add dh,ch mov si,dx db 65h;mov al,[si] db 64h;mov dx,[bx+6] add dl,cl add dh,ch mov si,dx db 65h;mov ah,[si] db 66h;rol ax,16 db 66h;stosw add bx,8 dec bp jnz @dloop mov bp,8000 sub bx,2 add cl,128 @dloop2: db 64h;mov dx,[bx] add dl,cl add dh,ch mov si,dx db 65h;mov al,[si] db 64h;mov dx,[bx-2] add dl,cl add dh,ch mov si,dx db 65h;mov ah,[si] db 66h;shl ax,16 db 64h;mov dx,[bx-4] add dl,cl add dh,ch mov si,dx db 65h;mov al,[si] db 64h;mov dx,[bx-6] add dl,cl add dh,ch mov si,dx db 65h;mov ah,[si] db 66h;rol ax,16 db 66h;stosw sub bx,8 dec bp jnz @dloop2 pop bp end; until ds >= 120; asm mov ax,3h int 10h end; setintvec($09,@oldint9h); end.