Oxygen Basic

Programming => Example Code => Topic started by: Peter on February 26, 2012, 07:50:52 AM

Title: Hellish Experiments
Post by: Peter on February 26, 2012, 07:50:52 AM

Deleted

Title: Re: Hellish Experiments
Post by: Charles Pegge on March 03, 2012, 04:05:13 AM

My attempt to generate a rainbow for the scene.

Code: [Select]

include "window.inc"
Window "Raindrops" ,640,480,2
sys_mode=4

sys x[500], y[500], z[500]
sys i,pic, drop
drop= LoadBmp "bmp/mydrop",0

'Raindrops

For i=0 To 500
x[i] = Rand(0,640)
y[i] = Rand(0,460)
z[i] = Rand(1,3)
Next

'Rainbow

sys rx[5000],ry[5000],rc[5000],ri,rs
ri=1
while ri<5000
rx=rand(-320,320)
ry=rand(-320,320)
rr=hypot(rx,ry)
if rr>260 and rr<300 and ry<0
  rx[ri]=rx+320
  ry[ri]=ry+400
  rs=(rr-260)*6
  r=rs 'red
  g=240-abs(rs-128) 'green
  b=240-rs 'blue
  rc[ri]=r+g*256+b*65536
  ri++
end if
wend

'scene falling raindrops

While Key(27)=0
ClsColor 100,180,180
'ClsColor 0,0,0

for i=1 to 5000
  pixel rx[i]-1,ry[i]-1,rc[i]
  pixel rx[i]+1,ry[i]+1,rc[i]
next

For i=0 To 500
y[i] = y[i] + z[i]
if y[i] >480
   x[i] = Rand(0,649)
   y[i] = Rand(0, 1)
   z[i] = Rand(1,3)
End if
SetBmp drop,x[i],y[i],16,16,0
Next
FlipBuffer
Wend
WinEnd


Charles

Title: Re: Hellish Experiments
Post by: Charles Pegge on March 04, 2012, 07:25:03 AM

A venture into 3d shading starting with pixels.

These sheres use Gouraud shading and the edges are made smooth with simple anti-aliasing.

Code: [Select]

include "win64.inc"
Window "Ray2" ,640,640,2
sys_mode=4

sys x=320, y=320, c=0xffffff


'scene

ClsColor 0,0,0
bg=0


'light
'=====

single lx,ly,lz
lx=.707
ly=.707
lz=0

ambi=31  'light ambient / 255
diff=224 'light diffuse / 255


function color(single li,pr,pg,pb) as sys
'========================================
sys cr,cg,cb
  if li>1 then li=1 'clamp
  if li<0 then li=0 'clamp
  cr=(diff*li+ambi)*pr
  cg=(diff*li+ambi)*pg
  cb=(diff*li+ambi)*pb
  return cb*0x10000+cg*0x100+cr 'composite
end function

function PixelAvg(sys cc,pp) as sys
'==================================
  lea esi,pp
  mov ecx,[cc]
  mov edx,[esi]
  'RED
  xor eax,eax
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  'GREEN
  xor eax,eax
  shr ecx,8
  shr edx,8
  inc esi
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  'BLUE
  xor eax,eax
  shr ecx,8
  shr edx,8
  inc esi
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  return pp
end function


function sphere(sys px,py,ra,single pr,pg,pb)
'============================================
sys x,y,ri,pp,d
single  r,nx,ny,nz
single li
for y=-ra to ra
for x=-ra to ra
r=hypot(x,y)
ri=r
if r<=ra
  nx=x/ra
  ny=y/ra
  nz=sqr(1-nx*nx-ny*ny) 'assume positive
  li=lx*nx+ly*ny+lz*nz
  cc=color li,pr,pg,pb
  pixel px+x,640-py-y,cc
  '
  'ANTIALIAS AVERAGING ON SPHERE EDGES
  '
  if ri=ra
    if x>=0 then d=1 else d=-1
    pp=Getpixel bHdc,px+x+d,640-py-y
    pp=PixelAvg cc,pp
    pixel px+x,640-py-y,pp
  end if
end if
next
next
end function

'objects
'=======

sphere 320,320,200,1,1,.5
sphere 300,200,150,1,.3,.5
sphere 350,200,100,1,1,1

FlipBuffer
'Wend
pause
WinEnd

Charles

Title: Re: Hellish Experiments
Post by: Charles Pegge on March 04, 2012, 12:29:02 PM

Adding pigment texture:

Code: [Select]

include "win64.inc"

Sub Pause()
AscKey=0
While AscKey=0
  Events
  sleep 50
  iF WinExit=1
    WinEnd
    ExitProcess 0
  End iF
Wend
End Sub

sys scr=800
Window "Ray4" ,scr,scr,2
sys_mode=4


Window "Ray3" ,640,640,2
sys_mode=4


ClsColor 32,0,0
FlipBuffer
ClsColor 0,0,0


'light
'=====

single lx,ly,lz

lx=.6933
ly=.6933
lz=.6933

lx=.707
ly=.707
lz=0

ambi=31  'light ambient / 255
diff=224 'light diffuse / 255


Function Noise(sys i) as Single
'==============================
Static As Single f, d=1/0x7fffffff
mov eax,i
xor eax,0x35353535
imul eax,eax
ror eax,17
imul eax,i
ror eax,7
push eax
fild dWord [esp]
add esp,4
fmul dWord d
fstp dWord _return
End Function




function color(single li,pr,pg,pb) as sys
'========================================
sys cr,cg,cb
  if li>1 then li=1 'clamp
  if li<0 then li=0 'clamp
  cr=(diff*li+ambi)*pr
  cg=(diff*li+ambi)*pg
  cb=(diff*li+ambi)*pb
  return cb*0x10000+cg*0x100+cr 'composite
end function

function texture(single li,pr,pg,pb,tx,x,y) as sys
'==============================================
  sys cr,cg,cb,mz,my
  single n
  n=1-tx*3
  mx=x>>2
  my=y>>2
  n+=noise(mx+my*0x7fff)*tx
  mx=x>>1
  my=y>>1
  n+=noise(mx+my*0x7fff)*tx
  mx=x
  my=y
  n+=noise(mx+my*0x7fff)*tx
  '
  if li>1 then li=1 'clamp
  if li<0 then li=0 'clamp
  cr=(n*(diff*li+ambi))*pr
  cg=(n*(diff*li+ambi))*pg
  cb=(n*(diff*li+ambi))*pb
  return cb*0x10000+cg*0x100+cr 'composite
end function


function PixelAvg(sys cc,pp) as sys
'==================================
  lea esi,pp
  mov ecx,[cc]
  mov edx,[esi]
  'RED
  xor eax,eax
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  'GREEN
  xor eax,eax
  shr ecx,8
  shr edx,8
  inc esi
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  'BLUE
  xor eax,eax
  shr ecx,8
  shr edx,8
  inc esi
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  return pp
end function


function sphere(sys px,py,ra,single pr,pg,pb,tx)
'===============================================
sys x,y,ri,pp,d
single  r,nx,ny,nz
single li
for y=-ra to ra
for x=-ra to ra
r=hypot(x,y)
ri=r
if r<=ra
  nx=x/ra
  ny=y/ra
  nz=sqr(1-nx*nx-ny*ny) 'assume positive
  li=lx*nx+ly*ny+lz*nz
  'cc=color li,pr,pg,pb
  cc=Texture li,pr,pg,pb,tx,x,y
  pixel px+x,640-py-y,cc
  '
  'ANTIALIAS AVERAGING ON SPHERE EDGES
  '
  if ri=ra
    if x>=0 then d=1 else d=-1
    pp=Getpixel bHdc,px+x+d,640-py-y
    pp=PixelAvg cc,pp
    pixel px+x,640-py-y,pp
  end if
end if
next
next
end function


'objects
'=======

'sphere posX, posY, radius, red/1, green/1, blue/1, texture/1
sphere 120,520,70,.7,.0,.5,.02
sphere 420,500,80,.5,.0,.7,.1
sphere 320,320,200,1,1,.5,.05
sphere 300,200,150,1,.3,.5,.03
sphere 350,200,100,1,1,1,.07

FlipBuffer
pause
WinEnd

Charles

Title: Re: Hellish Experiments
Post by: Charles Pegge on March 04, 2012, 09:26:05 PM

With ovoids,highlights and background

Code: [Select]


include "win64.inc"

Sub Pause()
AscKey=0
While AscKey=0
  Events
  sleep 50
  iF WinExit=1
    WinEnd
    ExitProcess 0
  End iF
Wend
End Sub

sys scr=800
Window "Ray4" ,scr,scr,2
sys_mode=4


ClsColor 32,0,0
FlipBuffer


'light
'=====

single lx,ly,lz


lx=sqr(1/3)
ly=lx
lz=lx

'lx=sqr(.5)
'ly=lx
'lz=0

ambi=31  'light ambient / 255
diff=224 'light diffuse / 255


Function Noise(sys i) as Single
'==============================
Static As Single f, d=1/0x7fffffff
mov eax,i
xor eax,0x35353535
imul eax,eax
ror eax,17
imul eax,i
ror eax,7
push eax
fild dWord [esp]
add esp,4
fmul dWord d
fstp dWord _return
End Function




function color(single li,pr,pg,pb) as sys
'========================================
sys cr,cg,cb
  if li>1 then li=1 'clamp
  if li<0 then li=0 'clamp
  cr=(diff*li+ambi)*pr
  cg=(diff*li+ambi)*pg
  cb=(diff*li+ambi)*pb
  return cb*0x10000+cg*0x100+cr 'composite
end function

function texture(single li,pr,pg,pb,tx,x,y) as sys
'==============================================
  sys cr,cg,cb,mz,my
  single n,am,di
  n=1-tx*3
  mx=x>>2
  my=y>>2
  n+=noise(mx+my*0x7fff)*tx
  mx=x>>1
  my=y>>1
  n+=noise(mx+my*0x7fff)*tx
  mx=x
  my=y
  n+=noise(mx+my*0x7fff)*tx
  '
  if li>.99 then li=1 'clamp
  if li<0 then li=0 'clamp
  am=ambi
  di=diff*li
  if li>=1 then
    if li>pr then pr=.5*(li+pr)
    if li>pg then pg=.5*(li+pg)
    if li>pb then pb=.5*(li+pb)
    n=.5*(li+n)
  end if
  cr=(n*(di+am))*pr
  cg=(n*(di+am))*pg
  cb=(n*(di+am))*pb
  return cb*0x10000+cg*0x100+cr 'composite
end function


function PixelAvg(sys cc,pp) as sys
'==================================
  lea esi,pp
  mov ecx,[cc]
  mov edx,[esi]
  'RED
  xor eax,eax
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  'GREEN
  xor eax,eax
  shr ecx,8
  shr edx,8
  inc esi
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  'BLUE
  xor eax,eax
  shr ecx,8
  shr edx,8
  inc esi
  mov al,cl
  add al,dl
  jnc fwd nc
  add eax,256
  .nc
  shr eax,1
  mov [esi],al
  return pp
end function


function sphere(sys px,py,ra, single yx,pr,pg,pb,tx)
'===============================================
sys x,y,ri,pp,d
single  r,nx,ny,nz,h
single li,t
single ry=ra*yx
for y=-ry to ry
for x=-ra to ra
r=hypot(x,y/yx)
ri=r
if r<=ra
  nx=x/ra
  ny=y/ry
  nz=sqr(1-nx*nx-ny*ny) 'assume positive
  ny*=yx
  h=1/sqr(nx*nx+ny*ny+nz*nz)
  nx*=h
  ny*=h
  nz*=h
  li=lx*nx+ly*ny+lz*nz
  'cc=color li,pr,pg,pb
  cc=Texture li,pr,pg,pb,tx,x,y
  pixel px+x,scr-py-y,cc
  '
  'ANTIALIAS AVERAGING ON SPHERE EDGES
  '
  if ri=ra
    if x>=0 then d=1 else d=-1
    pp=Getpixel bHdc,px+x+d,scr-py-y
    pp=PixelAvg cc,pp
    pixel px+x,scr-py-y,pp
  end if
end if
next
next
end function


'objects
'=======

'background

single f,i
for x=0 to <scr
i=6
for y=0 to <scr
pixel x,scr-y,i*(1+sin(f))
i+=.1
next
f+=.05
next

'sphere posX, posY, radius, yxRatio, red/1, green/1, blue/1, texture/1
sphere 220,640,70,.75,.7,.0,.5,.02
sphere 520,600,80,1,.5,.0,.7,.1
sphere 320,420,200,1,1,1,.5,.05
sphere 400,250,150,1,1,.3,.5,.03
sphere 550,250,100,1.9,1,1,1,.07
sphere 650,200,100,1.5,1,1,1,.07

FlipBuffer
pause

Charles

Title: Re: Hellish Experiments
Post by: Charles Pegge on March 05, 2012, 02:07:54 PM

120 psychedelic views :)

Code: [Select]


include "win64.inc"

sys scr=800
Window "Ray6" ,scr,scr,2
sys_mode=4


ClsColor 32,0,0
FlipBuffer


sub PsychoSine(single im,ii,st)
'==============================
single fx,fy,i
sys r,g,b,c,x,y
for x=0 to <scr
i=1 '6
fy=0
for y=0 to <scr
c=i*(1+cos(fx))+i*(1+cos(fy))
pixel x,scr-y,c
i=i*im+ii
fy+=st
next
fx+=st
next
end sub

single m,n

m=1.00
n=1
for i=1 to 80
PsychoSine m, n, .01
n+=111
FlipBuffer
next

m=1.0100
n=.4
for i=1 to 40
PsychoSine m, n, .03
m+=.0005
FlipBuffer
next



pause

Charles