Squares
Re: Squares
( !!~~OFF TOPIC~~!! )
I got another song demo'd
That makes 4 songs so far...
Cost like $1,400 to get 4 songs demo'd ( $350 a piece )
I got like , 25 more songs to get demo'd ( like $9,000 dollars worth )
It will take several years to get them all done...unless i come into some money along the way..
Listen to my songs: https://soundcloud.com/user-704620747
I got another song demo'd
That makes 4 songs so far...
Cost like $1,400 to get 4 songs demo'd ( $350 a piece )
I got like , 25 more songs to get demo'd ( like $9,000 dollars worth )
It will take several years to get them all done...unless i come into some money along the way..
Listen to my songs: https://soundcloud.com/user-704620747
Re: Squares
FreeBASIC art:
Code: Select all
const SCREEN_W = 640, SCREEN_H = 480
const IMG_SIZE = 400
const IMG_XO = (SCREEN_W - IMG_SIZE) \ 2 '120
const IMG_YO = (SCREEN_H - IMG_SIZE) \ 2 '40
const as ulong WHITE = rgb(255, 255, 255)
const as ulong GREEN = rgb(0, 200, 0)
const as ulong RED = rgb(255, 0, 0)
const as ulong YELLOW = rgb(255, 255, 0)
const as ulong BLUE = rgb(0, 0, 255)
const as ulong BROWN = rgb(150, 75, 0)
const as single PI = atn(1) * 4
'-------------------------------------------------------------------------------
type int2d
dim as integer x, y
end type
operator + (a as int2d, b as int2d) as int2d
return type(a.x + b.x, a.y + b.y)
end operator
sub tline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
line pTarget, (p1.x, p1.y)-(p2.x, p2.y), c
end sub
sub dline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
line pTarget, (p1.x, p1.y)-step(p2.x, p2.y), c
end sub
sub thickline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
for x as integer = -1 to +1
for y as integer = -1 to +1
line pTarget, (p1.x + x, p1.y + y)-step(p2.x, p2.y), c
next
next
end sub
sub pointyline(pTarget as any ptr, p1 as int2d, p2 as int2d, c as ulong)
for x as integer = -1 to +1
for y as integer = -1 to +1
line pTarget, (p1.x + x, p1.y + y)-(p1.x + p2.x, p1.y + p2.y), c
next
next
end sub
sub drawLeaf(pTarget as any ptr, p0 as int2d, dp1 as int2d, dp2 as int2d, c as ulong)
thickline(pTarget, p0, dp1, c)
pointyline(pTarget, p0 + dp1, dp2, c)
end sub
sub tcircle(pTarget as any ptr, p as int2d, r as single, c as ulong)
circle pTarget, (p.x, p.y), r, c, ,,,f
end sub
'-------------------------------------------------------------------------------
screenres SCREEN_W, SCREEN_H, 32
width SCREEN_W \ 8, SCREEN_H \ 16
dim as integer i, x, y, r
dim as ulong c, f
dim as int2d root, dp1, dp2, flower
const NUM_LEAVES = 6, NUM_STEMS = 5
root = type(IMG_SIZE \ 2, IMG_SIZE - 20)
dim as int2d leafNodes(NUM_LEAVES - 1, 0 to 1) = { _
{ type(80, -30), type(70, +20) }, _
{ type(60, -40), type(60, +40) }, _
{ type(20, -30), type(20, -10) }, _
{ type(-70, -40), type(-90, +30) }, _
{ type(-40, -30), type(-100, +30) }, _
{ type(-30, -10), type(-20, +10) }}
dim as int2d stemNodes(NUM_STEMS - 1, 0 to 1) = { _
{ type(-20, -70), type(-50, -140) }, _
{ type(-40, -80), type(-50, -70) }, _
{ type(-10, -150), type(-20, -120) }, _
{ type(+20, -140), type(+20, -90) }, _
{ type(+30, -80), type(+40, -50) } }
dim as any ptr pImg = imagecreate(IMG_SIZE, IMG_SIZE)
'blue sky
line pImg, (0, 0)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(70, 70, 255), bf
line pImg, (0, 80)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(50, 50, 255), bf
line pImg, (0, 110)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(0, 0, 255), bf
line pImg, (0, 200)-step(IMG_SIZE - 1, IMG_SIZE - 1), rgb(40, 40, 255), bf
'mountains
for i = 0 to 2
circle pImg, (IMG_SIZE \ 2 - 300 - i * 10, IMG_SIZE + 70 + i * 10), 500, rgb(180 - i * 10, 170 - i * 10, 180 - i * 20),,, 0.6 , f
next
for i = 0 to 2
circle pImg, (IMG_SIZE \ 2 + 350 + i * 30, IMG_SIZE + 100 + i * 20), 500, rgb(127 - i * 10, 127 - i * 20, 127 - i * 20),,, 0.7, f
next
for i = 0 to 2
circle pImg, (IMG_SIZE \ 2 - 350 - i * 30, IMG_SIZE + 100 + i * 20), 500, rgb(127 - i * 10, 127 - i * 10, 80 - i * 20),,, 0.6 , f
next
'brown ground
for i = 0 to 2
circle pImg, (root.x, root.y + i * 10), 400 - i * 40, rgb(150 - i * 20, 75 - i * 10, 0),,, 0.2 + i / 40, f
next
'ground leaves
for i = 0 to NUM_LEAVES - 1
drawLeaf(pImg, root, leafNodes(i, 0), leafNodes(i, 1), GREEN)
next
'flower stems
for i = 0 to NUM_STEMS - 1
drawLeaf(pImg, root, stemNodes(i, 0), stemNodes(i, 1), GREEN)
flower = root + stemNodes(i, 0) + stemNodes(i, 1)
for j as integer = 0 to 6
x = cos((j / 7) * PI * 2) * 25
y = sin((j / 7) * PI * 2) * 25
pointyline(pImg, flower, type(x, y), rgb(255, 200, 0))
tcircle(pImg, flower + type(x, y), 10, RED)
next
tcircle(pImg, flower, 10, YELLOW)
next
'clouds
randomize 123
for i = 0 to 19
x = rnd * IMG_SIZE
y = rnd * 20
r = rnd * (40 - i) + 40
f = rnd* 50 + 200
c = rgb(f, f, f)
circle pImg, (x, y), r, c, ,, rnd / 2 + 0.3, f
next
'show image
put (IMG_XO, IMG_YO), pImg
sleep
Re: Squares
@badidea
Nice Doodle!!
Nice Doodle!!
Re: Squares
A doodle a day, keeps the insanity away :-)
Re: Squares
Time Rhyme!!
3:35 = bee dirty hive
3:35 = bee dirty hive
Re: Take a break
Summer is here.
Code: Select all
Type Point
As Single x,y,z
As Ulong col
End Type
Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
Static As Double timervalue,_lastsleeptime,t3,frames
Var t=Timer
frames+=1
If (t-t3)>=1 Then t3=t:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=T
Return sleeptime
End Function
Sub drawpolygon(p() As Point, col As Ulong,im As Any Ptr=0)
Dim k As Long=Ubound(p)+1
Dim As Long index,nextindex
Dim As Single cx,cy,counter
For n As Long=1 To Ubound(p)
counter+=1
index=n Mod k:nextindex=(n+1) Mod k
If nextindex=0 Then nextindex=1
cx+=p(index).x:cy+=p(index).y
Line im,(p(index).x,p(index).y)-(p(nextindex).x,p(nextindex).y),col
Next
cx=cx/counter:cy=cy/counter
p(0)=Type<Point>(cx,cy)
Line im,(p(4).x,p(4).y)-(p(36).x,p(36).y),col
Paint im,((p(1).x+p(4).x)\2,p(1).y),Rgb(0,0,0),col'prop
Paint im,(cx,cy),col,col
For n As Long=8 To 10
Line im,(p(n).x,p(n).y)-(p(n+1).x,p(n+1).y),Rgb(200,0,0)
Next n
Line im,(p(11).x,p(11).y)-(p(8).x,p(8).y),Rgb(200,0,0)
Paint im,((p(8).x+p(10).x)/2,(p(8).y+p(10).y)/2),Rgb(100,100,255),Rgb(200,0,0)
for n as long=-1 to 1
line(p(16).x,p(16).y+n)-(p(21).x,p(21).y+n),rgb(0,0,0)
next
End Sub
Function RotatePoint(c As Point,p As Point,angle As Point,scale As Point=Type<Point>(1,1,1)) As Point
Dim As Single sx=Sin(angle.x),sy=Sin(angle.y),sz=Sin(angle.z)
Dim As Single cx=Cos(angle.x),cy=Cos(angle.y),cz=Cos(angle.z)
Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
Return Type<Point>((scale.x)*((cy*cz)*dx+(-cx*sz+sx*sy*cz)*dy+(sx*sz+cx*sy*cz)*dz)+c.x,_
(scale.y)*((cy*sz)*dx+(cx*cz+sx*sy*sz)*dy+(-sx*cz+cx*sy*sz)*dz)+c.y,_
(scale.z)*((-sy)*dx+(sx*cy)*dy+(cx*cy)*dz)+c.z,p.col)
End Function
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
Sub cloud(x As Long, y As Long,length As Long=100,Alpha As Long=105, Zoom As Single = 0,im As Any Ptr=0)
Static As Long r=255,b=255,g=255
Dim As Double pi=3.14159
Static As Long cl,p
cl=cl+1
If cl Mod 100000=0 Then
p=p+1
Draw String(x/50+8*p,400),"_____",Rgb(255,255,255)
End If
If Length<=1 Or Alpha<=1 Then Exit Sub
Dim As Single rnded = -pi+Rnd*1*pi*3
Dim As Single rnded2 = -pi+Rnd*-3*pi*3
If Alpha<15 Then
For i As long = 0 To 255-Alpha Step 100
Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded*PI/3),y+Length/6+length*Sin(-pi/2+rnded*PI/3)),Rgba(R,G,B,Alpha)
Line im,(-(Zoom/2)+x-length/2,y)-((Zoom/2)+x+Length/6+length*Cos(-pi/2+rnded2*PI/3),y+Length/6+length*Sin(pi/2+rnded2*PI/3)),Rgba(R,G,B,Alpha)
Next
End If
cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded*PI/3),(Zoom/2)+y+length*Sin(-pi/2+rnded*PI/3),length/1.4,Alpha/1.2,Zoom,im)
cloud(-(Zoom/2)+x+length*Cos(-pi/2+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi/2+rnded2*PI/3),length/1.4,Alpha/1.2,Zoom,im)
cloud(-(Zoom/2)+x+length*Cos(pi/3+rnded2*PI/3),(Zoom/2)+y+length*Sin(pi+rnded2*PI/3),length/1.4,Alpha/2,Zoom,im)
End Sub
Sub Tree(i As Any Ptr=0,x1 As Single,y1 As Single,size As Single,angle As Single,depth As Single,colb As Ulong=0,colL As Ulong=0)
Dim As Single spread,scale,x2,y2
spread=25
scale=.76
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
x2=x1-.25*size*Cos(angle*.01745329)
y2=y1-.25*size*Sin(angle*.01745329)
Static As long count,fx,fy,sz,z
If count=0 Then fx=x1:fy=y1:sz=size:z=2^(depth+1)-1
Line i,(x1,y1)-(x2,y2),colb
If count=0 Then fx=x2:fy=y2:sz=size
count=count+1
If count>z Then count=0
If incircle(fx,fy,(.45*sz),x2,y2)=0 Then Circle i,(x2,y2),.01*sz,colL
If depth>0 Then
Tree(i,x2, y2, size * Scale, angle - Spread, depth - 1,colB,colL)
Tree(i,x2, y2, size * Scale, angle + Spread, depth - 1,colB,colL)
End If
End Sub
Function Filter(Byref tim As Ulong Pointer,_
Byval rad As Single,_
Byval destroy As long=1,_
Byval fade As long=0) As Ulong Pointer
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
If fade<0 Then fade=0:If fade>100 Then fade=100
Type p2
As Long x,y
As Ulong col
End Type
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As long=-ymin To ymax
For x1 As long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
If fade=0 Then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
Else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
End If
#endmacro
Dim As Single fd=map(0,100,fade,1,0)
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As Ulong col
Dim As p2 NewPoints(_x-1,_y-1)
For y As long=0 To (_y)-1
For x As long=0 To (_x)-1
col=Point(x,y,tim)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As long ar,ag,ab
Dim As long xmin,xmax,ymin,ymax,inc
For y As long=0 To _y-1
For x As long=0 To _x-1
average()
Pset im,((NewPoints(x,y).x),(NewPoints(x,y).y)),averagecolour
Next x
Next y
If destroy Then Imagedestroy tim: tim = 0
Function= im
End Function
Function range(f As Long,l As Long) As Long
Return Int(Rnd*((l+1)-(f)))+f
End Function
Function go As Long
#macro backdrop()
Scope
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
Dim As Single minx,maxx,miny,maxy,lasty,grad
Dim As Long ctr
#macro paintsketch(_function,r,g,b,im,sz,set)
Randomize 1
ctr=0
For x As Double=minx To maxx Step (maxx-minx)/5000
ctr+=1
If ctr=4500 Then Randomize 1
Dim As Double x1=(xres)*(x-minx)/(maxx-minx)
Dim As Double y1=(yres)*(_function-maxy)/(miny-maxy)
If ctr Mod set=0 Then
Var xx=x1+Rnd*5-Rnd*5,yy=y1+Rnd*set/4
tree(im,xx,yy,sz,90+(Rnd*10-Rnd*10),12,Rgb(100,10+Rnd*50,0),Rgb(Rnd*50,100+Rnd*100,0))
End If
grad=y1-lasty
lasty=y1
grad=grad*250
Line im,(x1,yres)-(x1,y1),Rgb(r+grad,g+grad,b)
Next x
#endmacro
#macro _window(topleftX,topleftY,bottomrightX,bottomrightY)
minx=topleftX
maxx=bottomrightX
miny=bottomrightY
maxy=topleftY
#endmacro
#macro sea
For z As Long=0 To .7*yres
Var r=map(0,(.7*yres),z,0,250)
Var g=map(0,(.7*yres),z,0,250)
Var b=map(0,(.7*yres),z,200,250)
Line im2,(0,z)-(xres,z),Rgb(r,g,b)
Next z
#endmacro
sea
Dim As Single pi=4*Atn(1)
_window(-4*pi,3,4*pi,-1.2)
paintsketch(.05*Sin(x)+.05*Sin(2*x),50,100,50,imgs(1),15,100)
_window(-3*pi,2,3*pi,-.8)
paintsketch(.1*Sin(x),50,120,0,imgs(2),25,100)
_window(-2*pi,2,2*pi,-.6)
paintsketch(.1*Sin(x),50,150,0,imgs(3),30,150)
_window(-pi,2,pi,-.5)
paintsketch(.2*Sin(x),50,170,0,imgs(4),55,150)
Var x=xres,y=yres
Randomize 2
For a As Long = 1 To 7
If a<=5 Then
cloud(x*1.5/a, y*1/a, Range(60,80)/2, Range(40,60),5,im2)
cloud(x*1.4/a, y*2/a, range(60,80)/2, range(40,60),2,im2)
End If
If a=6 Then cloud(x/2,y/4,150,250,1,im2)
If a=7 Then cloud(.8*x,.1*y,100,80,5,im2)
Next
im2=filter(im2,2)
Line im2,(0,.7*yres)-(xres,.9*yres),Rgb(0,50,200),bf
End Scope
#endmacro
#macro Sweep(p,_step,sz)
For z As Long=0 To (sz)\4 -_step
Swap p[z],p[z+_step]
Next z
#endmacro
Dim As Integer xres,yres
Screenres 1024,768,32,,64
Screeninfo xres,yres
Width xres\8,yres\16
Dim As Any Ptr sim=Imagecreate(150,25)
Draw String sim,(5,10),"D-CAT",Rgb(0,0,0)
Draw String sim,(129,10),"|||",Rgb(0,0,0)
Circle sim,(90,15),35,Rgb(0,10,0),,,.1,f
Dim As Any Ptr im2=Imagecreate(xres,yres)
Dim As Any Ptr imgs(1 To 4)={Imagecreate(xres,yres),Imagecreate(xres,yres),Imagecreate(xres,yres),Imagecreate(xres,yres)}
Draw String(20,406),"[",Rgb(255,255,255)
Draw String(690,406),"]",Rgb(255,255,255)
backdrop()
Dim As Ulong Ptr p(1 To 4),p2
Dim As Integer size,size2
For n As Long=1 To 4
Imageinfo imgs(n),,,,,p(n),size
Next n
Imageinfo im2,,,,,p2,size2
Dim As Point pt(0 To 38),rot(0 To 38)
For n As Long=1 To 38: Read pt(n).x:pt(n).x+=410: Next
For n As Long=1 To 38: Read pt(n).y:pt(n).y+=350: Next
drawpolygon(pt(),Rgb(0,0,0))
Dim As Point ctr=pt(0)
Dim As Single pi=4*Atn(1)
Dim As Single a
Dim As Long k2=1.5
Dim As String i
Dim As String s="Going on holiday"
Dim As Any Ptr im(1 To Len(s))
Dim As Long sz=10,fps
For n As Long=1 To Len(s)
im(n)=Imagecreate(sz*3,sz*3)
Draw String im(n),(10,5),Chr(s[n-1]),Rgb(255,Rnd*255,Rnd*255)
Put(n*sz,400),im(n),trans
Next
Dim As Single angl,d=50
Dim As Single x1,y1,x2,y2
Dim As Single x3,y3,x4,y4,yy=100
Do
i=Inkey
For n As Long=1 To 4
sweep(p(n),k2*n,size) 'hills
Next n
sweep(p2,1,size2) 'sky
angl+=.1
a=.1*Sin(angl)
Screenlock
Cls
Put(0,0),im2,Pset
For n As Long=1 To 3
Put(0,0),imgs(n),trans
Next n
For n As Long=1 To 38
pt(n).y+=a*5
rot(n)= rotatepoint(ctr,pt(n),Type<Point>(0,0,a),Type<Point>(.8,.8,.8))
Next n
drawpolygon(rot(),Rgb(88,73,00))
Circle(rot(22).x,rot(22).y),3,0,,,,f
rotateimage(,sim,-a,rot(0).x-75,rot(0).y-12.5,1,,true)
For n As Long=1 To Ubound(im)
Var k=n+2,k1=k+1
If n=1 Then
x1=k*3*sz-d:y1=400+30*Sin(angl+n/2)-20
x2=k*3*sz-d:y2=400+30*Sin(angl+n/2)+40
End If
If n=Ubound(im) Then
x3=k1*3*sz-d:y3=400+30*Sin(angl+(n+1)/2)-20
x4=k1*3*sz-d:y4=400+30*Sin(angl+(n+1)/2)+40
End If
Pset(k*3*sz-d,400+30*Sin(angl+n/2)-20+yy),Rgb(200,0,1)
Line -((k+1)*3*sz-d,400+30*Sin(angl+(n+1)/2)-20+yy),Rgb(200,0,1)
Pset(k*3*sz-d,400+30*Sin(angl+n/2)+40+yy),Rgb(0,0,1)
Line -((k+1)*3*sz-d,400+30*Sin(angl+(n+1)/2)+40+yy),Rgb(200,0,1)
Next
Line(x1,y1+yy)-(x2,y2+yy),Rgb(200,0,1)
Line(x3,y3+yy)-(x4,y4+yy),Rgb(200,0,1)
Paint(100,400+30*Sin(angl+(1)/2)+10+yy),Rgb(0,100,200),Rgb(200,0,1)
For n As Long=1 To Ubound(im)
Var k=n+2
rotateimage(,im(n),(Sin((angl+n/2)))/4-0,k*3*sz-d-15,400+30*Sin(angl+n/2)+yy-20,2)
Next n
Line(x3,y3+yy)-(rot(22).x,rot(22).y),Rgb(0,0,0)
Line(x4,y4+yy)-(rot(22).x,rot(22).y),Rgb(0,0,0)
Put(0,0),imgs(4),trans
Line(0,750)-(xres,768),Rgb(200,200,200),bf
Draw String(400,755),"Framerate = "&fps,Rgb(200,0,0)
Screenunlock
Sleep regulate(30,fps),1
Loop Until i=Chr(27)
For n As Long=Lbound(im) To Ubound(im)
Imagedestroy im(n)
Next
Imagedestroy im2
Imagedestroy sim
For n As Long=1 To 4
Imagedestroy(imgs(n))
Next n
Sleep
Return 0
End Function
Data _
498, 489, 487, 481, 454, 420, 399, 390, 381, 369, 359, 331, 297, 272, 255, 247, 237, 228, 217, 205, 202, 205, 219, 228, 251, 288, 319, 347, 359, 401, 418, 440, 440, 457, 471, 480, 486, 488
Data _
165, 158, 116, 157, 153, 152, 151, 151, 144, 143, 146, 145, 148, 151, 151, 149, 134, 124, 120, 133, 152, 167, 174, 174, 178, 184, 189, 191, 193, 196, 195, 200, 193, 190, 182, 174, 218, 177
End go
Re: Take a break
Very nice dodicat. Cool parallax scrolling.dodicat wrote:Summer is here.
...
Re: Take a break
Fractal trees?dodicat wrote:Summer is here.
Re: Squares
Dodicat , It's amazing how much action you get , out of so little code!!
Love the clouds!!
Love the clouds!!
-
- Posts: 8586
- Joined: May 28, 2005 3:28
- Contact:
Re: Squares
dodicat good job I like it :-)
The fractal tree's and the cloud stuff isn't new for me
but I played around with your rotateimage code and optimized the inner loop only for fun.
It's faster as before but slower than MultiPut may be your solution is more accurate as MultiPut.
How ever here are the result and it was fun for me.
Joshy A short test compare
The fractal tree's and the cloud stuff isn't new for me
but I played around with your rotateimage code and optimized the inner loop only for fun.
It's faster as before but slower than MultiPut may be your solution is more accurate as MultiPut.
How ever here are the result and it was fun for me.
Joshy
Code: Select all
' !!! inner loop !!!
' old new diff
' 9 times + 6 times + +3
' 3 times - 2 times - +1
' 6 times * 3 times * +3
' 4 times > 2 times > +2
' 4 times < 2 times < +2
' 2 times shift 0 times shift +2
' 4 times if 2 times if +2 (both plus 1 color compare)
' -----------------------------------
' 30 17 15
Code: Select all
Sub rotateimage_old(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
' !!! inner loop !!!
If x+shiftx >=0 andalso x+shiftx <xres Then
If shfty >=0 andalso shfty<yres Then
resultx=sc2*(Cx*(x-centrex)-Sxcy)+centrex
resulty=sc2*(Sx*(x-centrex)+Cxcy)+centrey
If resultx >=0 andalso resultx<ddx Then
If resulty>=0 andalso 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
Next x
Next y
End Sub
Sub rotateimage_new(byref dstImage As Any Ptr =0 , _ ' 0 = screen
byval srcImage As Any Ptr , _
byval rotAngle As single , _
byval rotCenterX As integer = 0 , _
byval rotCenterY As integer = 0 , _
byval scaleFactor As single = 1.0, _
byval maskColor As Ulong = Rgb(255,0,255), _
byval fixedPivot As boolean = false)
dim as Integer srcWidth=any,srcHeight=any,srcBytes=any,srcPitch=any
dim as Integer dstWidth=any,dstHeight=any,dstBytes=any,dstPitch=any
dim as integer dstX=any,dstY=any,srcX=any,srcY=any
dim as single dx=any,dy=any,sidy=any,cody=any
dim as ulong srcColor=any
dim as ulong ptr srcPixels=any,dstP,dstPixels=Screenptr()
' no active screen
if dstPixels=0 then exit sub
' no legal source image
if Imageinfo(srcImage,srcWidth,srcHeight,srcBytes,srcPitch,srcPixels) then exit sub
If dstImage=0 Then
Screeninfo dstWidth,dstHeight,,dstBytes,dstPitch
Else
If scaleFactor<>1.0 Then
if scaleFactor<0.01 then scaleFactor=0.01
dim as integer oldWidth,oldHeight
' no legal destinantion image
if Imageinfo(dstImage,dstWidth,dstHeight) then exit sub
' destroy destination and create new scaled image
Imagedestroy(dstImage)
dstWidth = oldWidth *scaleFactor
dstHeight = oldHeight*scaleFactor
' more safe
while dstWidth<2 or dstHeight<2
scaleFactor += 0.01
dstWidth *= oldWidth *scaleFactor
dstHeight *= oldHeight*scaleFactor
wend
' create scaled image
dstImage=Imagecreate(dstWidth,dstHeight)
End If
if Imageinfo(dstImage,dstWidth,dstHeight,dstBytes,dstPitch,dstPixels) then exit sub
End If
' not the same color depth
if srcBytes<>dstBytes then exit sub
' it's an RGB (ulong) rotater only
if dstBytes<=2 then exit sub
' pitch in bytes to pitch in ulong
srcPitch shr=2 : dstPitch shr=2
Dim As integer srcCenterX=srcWidth \2
dim as integer srcCenterY=srcHeight\2
Dim As single si=Sin(rotAngle), co=cos(rotAngle)
Dim As integer mx=Iif(srcWidth>=srcHeight,srcWidth,srcHeight)
' isn't as magic number it's sqr(0.5)
dim as single fx=scaleFactor*.7071067811865476
dim as single invScale=1.0/scaleFactor
If fixedPivot=false Then
rotCenterX+=srcCenterX*scaleFactor-srcCenterX
rotCenterY+=srcCenterY*scaleFactor-srcCenterY
End If
dim as single fxmx=fx*mx
dim as integer yS=srcCenterY-fxmx ' Y start
dim as integer yE=srcCenterY+fxmx ' Y end
dim as integer xS=srcCenterX-fxmx ' X start
dim as integer xE=srcCenterX+fxmx ' X end
dim as integer Rows=any,xSize=any,Columns=any,dstRow=any
dstY=rotCenterY+yS : if dstY>=dstHeight then exit sub
if dstY<0 then yS=0-rotCenterY
dstY=yE+rotCenterY : if dstY<1 then exit sub
if dstY>=dstHeight then yE=dstHeight-rotCenterY-1
Rows = yE-yS : if Rows<1 then exit sub
dstX=xS+rotCenterX : if dstX>=dstWidth then exit sub
if dstX<0 then xS=0-rotCenterX
dstX=xE+rotCenterX : if dstX<1 then exit sub
if dstX>=dstWidth then xE=dstWidth-rotCenterX-1
xSize = xE-xS : if xSize<1 then exit sub
dstY=yS+rotCenterY : dy =yS-srcCenterY
dstX=xS+rotCenterX : dstRow=dstPitch*dstY+dstX
while Rows
sidy=si*dy : cody=co*dy
dx=xS-srcCenterX : dstP=dstPixels+dstRow
Columns=xSize
while Columns
' !!! inner loop !!!
srcX=srcCenterX + invScale*(co*dx-sidy)
' is srcX inside source ?
If srcX>-1 andalso srcX<srcWidth Then
srcY=srcCenterY + invScale*(si*dx+cody)
' is srcY inside source
If srcY>-1 andalso srcY<srcHeight Then
srcColor = srcPixels[srcPitch*srcY+srcX]
If srcColor<>maskColor Then *dstP = srcColor
End If
End If
dx+=1 : dstP+=1 : Columns-=1
wend
dstRow+=dstPitch : dy+=1 : Rows-=1
wend
End Sub
const as single PI=4*ATN(1)
const as single DEG2RAD = PI/180.0 '0.01745329
dim as integer scrW,scrH
screeninfo scrW,scrH
scrW*=0.7:scrH*=0.7
screenres scrW,scrH,32,2,64
screenset 1,0
var img = ImageCreate(512,512)
line img,(0,0)-step(511,511),rgb(128,128,128),BF
line img,(0,0)-step(511,511),rgb(255,255,255),B
for i as integer = 0 to 511 step 32
line img,(0,i)-step(511,0),rgb(255,255,255)
line img,(i,0)-step(0,511),rgb(255,255,255)
next
windowtitle "old code please wait ..."
dim as single w
dim as double t1=timer()
for i as integer=0 to 360*2
var x=scrW/2-256+cos(w*0.5)*256
var y=scrH/2-256+sin(w)*scrH
cls
rotateimage_old(,img,w,x,y,2.1+sin(w*0.5)*2)
flip
w+=0.01
'sleep 10
next
t1=timer()-t1
w=0
windowtitle "new code please wait ..."
dim as double t2=timer()
for i as integer=0 to 360*2
var x=scrW/2-256+cos(w*0.5)*256
var y=scrH/2-256+sin(w)*scrH
cls
rotateimage_new(,img,w,x,y,2.1+sin(w*0.5)*2)
flip
w+=0.01
'sleep 10
next
t2=timer()-t2
print "old: " & t1 & " new: " & t2
flip
sleep
Re: Squares
@Dodicat
@Richard
I'm trying to get the right value , using only 1 or 2 decimal digits..
Can someone help?
@Richard
I'm trying to get the right value , using only 1 or 2 decimal digits..
Can someone help?
Code: Select all
screen 19
dim as ulongint v1
dim as single v2
dim as string n , v
do
dim as longint n1 = int( rnd * 65536 )
v1 = n1
v2 = v1 / 256
v = str(int(v2))
n = str(frac(v2))
n = mid(n,3)
n = left(n,2) ' trying to get right answer with only 1 or two decimal digits
print n1 , int( (val( v + "." + n )+.005) * 256)
sleep
loop until inkey = chr(27)
sleep
end
Re: Squares
What are you trying to do.
Code: Select all
print " >>> "; Cint( 2.56 * Int( v1 / 2.56 ) )
Re: Squares
Code: Select all
screen 19
do
const as integer n = 2 '' 2: for displaying 2 decimal digits at most
const as integer c = 10 ^ n
dim as double d
dim as string s
dim as integer i
d = int( rnd * 65536 ) / 256 '' decimal number to round to 'n' decimal digits at most
s = str( clngint( d * c ) / c ) '' to round the 'n'th decimal digit
i = instr( 1, s, "." )
if i > 0 then
s = left( s, i + n ) '' to keep 'n' decimal digits at most
end if
print d,, s
loop until getkey = 27
sleep
Code: Select all
declare function roundToDecimalDigits (byval d as double, byval n as uinteger) as string
screen 19
do
const as integer n = 2 '' 2: for displaying 2 decimal digits at most
dim as double d
d = int( rnd * 65536 ) / 256 '' decimal number to round to 'n' decimal digits at most
print d,, roundToDecimalDigits(d, n)
loop until getkey = 27
sleep
Function roundToDecimalDigits (byval d as double, byval n as uinteger) as string
dim as integer c = 1
for k as integer = 1 to n
c = c * 10
next k
dim as string s
dim as integer i
s = str( clngint( d * c ) / c ) '' to round the 'n'th decimal digit
i = instr( 1, s, "." )
if i > 0 then
s = left( s, i + n ) '' to keep 'n' decimal digits at most
end if
return s
end function
Re: Squares
You guys;
I'm trying to round the 16 bit input ( 0 to 65535) to 1 or 2 decimal digits , and then try to recreate the input with just those 2 digit places.
v = int( input / 256 )
n = str( frac( input / 256) )
n = mid(n,3)
n = left(n,2) ' truncate to 2 decimal places
now , try to recreate the input , using just v and n..
I'm trying to round the 16 bit input ( 0 to 65535) to 1 or 2 decimal digits , and then try to recreate the input with just those 2 digit places.
v = int( input / 256 )
n = str( frac( input / 256) )
n = mid(n,3)
n = left(n,2) ' truncate to 2 decimal places
now , try to recreate the input , using just v and n..
Re: Squares
Code: Select all
screen 19
dim as longint v1 , v2 , v3 , v4
do
dim as longint n1 = int( rnd * 65536 )
v1 = n1 mod 256
v2 = n1 \ 256
print
print n1 , v1 , v2
' for b as longint = 0 to 65535 step 1
' if b mod 256 = v1 and b \ 256 = v2 then print b : exit for
' next
print v2 * 256 + v1
sleep
loop until inkey = chr(27)
sleep
end