Code: Select all
Type d2
As Single mx,my
As Single mw,dy
End Type
Sub throughview(b As d2,a As Single=.5)
#define A_R( c ) ( ( c ) Shr 16 And 255 )
#define A_G( c ) ( ( c ) Shr 8 And 255 )
#define A_B( c ) ( ( c ) And 255 )
Static As Ulong _colour(81,81),clr
Static As Long result
#macro rotate(pivotx,pivoty,px,py,a,scale)
Var Newx=scale*((px-pivotx))+pivotx
Var Newy=scale*((py-pivoty))+pivoty
#endmacro
#macro incircle(cx,cy,r,mx,my,a)
If a<=1 Then
result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= r*r*a*a
Else
result=a*(cx-mx)*a*(cx-mx) +1*(cy-my)*1*(cy-my)<= (r)*(r)
End If
#endmacro
If b.mw=0 Then b.mw=1
b.mw=Abs(b.mw)
For x As Long=b.mx-40 To b.mx+40
For y As Long=b.my-40 To b.my+40
incircle(b.mx,b.my,40,x,y,a)
If result Then
clr=Point(x,y)
_colour(x-b.mx+40,y-b.my+40)=Rgb(A_R(clr)*1,A_G(clr)*1,A_B(clr)*1)
End If
Next y
Next x
Static As Single dil
For x As Long=b.mx-40 To b.mx+40
For y As Long=b.my-40 To b.my+40
incircle(b.mx,b.my,40,x,y,a)
If result Then
rotate(b.mx,b.my,x,y,0,dil)
Var dist=Sqr((b.mx-newx)*(b.mx-newx)+(b.my-newy)*(b.my-newy))
dil=(b.mw+(.5-b.mw)*dist/(40*b.mw))
Line(NewX-dil/2,NewY-dil/2)-(NewX+dil/2,NewY+dil/2),_colour(x-b.mx+40,y-b.my+40),BF
End If
Next y
Next x
End Sub
Sub rotateimage(Byref dest As Any Ptr=0,im As Any Ptr,angle As Single,shiftx As Long=0,shifty As Long=0,sc As Single=1,miss As Ulong=Rgb(255,0,255),fixedpivot As boolean=false)
Static As Integer pitch,pitchs,xres,yres,runflag
Static As Any Ptr row,rows
Static As Integer ddx,ddy,resultx,resulty
Imageinfo im,ddx,ddy,,pitch,row
If dest=0 Then
Screeninfo xres,yres,,,pitchS
rowS=Screenptr
Else
If sc<>1 Then
Dim As Integer x,y
Imageinfo dest,x,y
Imagedestroy dest:dest=0: dest=Imagecreate(x*sc,y*sc)
End If
Imageinfo dest, xres,yres,,pitchS,rows
End If
Dim As Long centreX=ddx\2,centreY=ddy\2
Dim As Single sx=Sin(angle)
Dim As Single cx=Cos(angle)
Dim As Long mx=Iif(ddx>=ddy,ddx,ddy),shftx,shfty
Var fx=sc*.7071067811865476,sc2=1/sc
If fixedpivot=false Then
shiftx+=centreX*sc-centrex
shiftY+=centrey*sc-centrey
End If
For y As Long=centrey-fx*mx+1 To centrey+ fx*mx
Dim As Single sxcy=Sx*(y-centrey),cxcy=Cx*(y-centrey)
shfty=y+shifty
For x As Long=centrex-mx*fx To centrex+mx*fx
If x+shiftx >=0 Then 'on the screen
If x+shiftx <xres Then
If shfty >=0 Then
If shfty<yres Then
resultx=sc2*(Cx*(x-centrex)-Sxcy) +centrex:resulty=sc2*(Sx*(x-centrex)+Cxcy) +centrey
If resultx >=0 Then 'on the image
If resultx<ddx Then
If resulty>=0 Then
If resulty<ddy Then
Dim As Ulong u=*Cast(Ulong Ptr,row+pitch*((resultY))+((resultX)) Shl 2 ) 'point(image)
If u<>miss Then *Cast(Ulong Ptr,rowS+pitchS*(y+shifty)+(x+shiftx) Shl 2)= u 'pset (screen)
End If:End If:End If:End If
End If:End If:End If:End If
Next x
Next y
End Sub
function create as string
#define range(f,l) int(Rnd*((l+1)-(f))+(f))
#define ic imagecreate(20,20)
var ypos=60,x=40
dim as any ptr i(1 to 9)={ic,ic,ic,ic,ic,ic,ic,ic,ic}
dim as string s="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
s+=lcase(s)+"0123456789"
dim as string acc
for n as long=1 to 9
var id=range(0,61)
acc+=chr(s[id])
draw string i(n),(0,0),chr(s[id]),rgb(rnd*255,rnd*255,rnd*255)
next
color ,rgb(255,255,255)
cls
dim as long xpos
for n as long=1 to 9
var s=1.5+(rnd*.5)
var a=(rnd-rnd)/2
rotateimage(,i(n),a,20*n+x,ypos,s,,0)
if n=5 then xpos=20*n+x
next n
dim as d2 b =Type(xpos,ypos+8,1.5,0)
throughview(b)
for n as long=1 to 9
imagedestroy(i(n))
next
return acc
end function
'===============
randomize
screenres 300,200,32
width 300\8,200\16
dim as string key
do
draw string (50,180),create,rgb(0,0,0)
sleep
cls
key=inkey
loop until key= chr(255)+"k" or key=chr(27)
![[img]https://nr100.home.xs4all.nl/badidea/fb_dodicat.png[/img]](https://nr100.home.xs4all.nl/badidea/fb_dodicat.png){kind=link}