PureBasic Forums - English

Code: Select all

; Original version by dobro
; Optimized version by 'thorsten will' aka 'mr.vain of secretly!' 
; 
InitSprite():w=640:Dim D(w,480):OpenScreen(w,480,32,""):Repeat:d=ScreenOutput()
StartDrawing(d):h=480:If i=0:For i=1 To w<<4:a=Random(w-1):b=Random(h-1)
Circle(a,b,5,Random(4096)):Next:For x=0 To w-1:For y=0 To h-1:d(x,y)=Point(x,y)
Next:Next:EndIf:For x=1 To w-2:For y=1 To h-2:t=D(x-1,y-1)+D(x+1,y+1)+D(x,y-1)
t+D(x,y+1)+D(x+1,y)+D(x-1,y)+D(x-1,y+1)+D(x+1,y-1):t/8:Plot(x,y,t):D(x,y)=t:Next
Next:StopDrawing():FlipBuffers():Until GetAsyncKeyState_(27)

Code: Select all

 
;*****************************************************************************
;*
;* Name   :Cam Mover or the ugly Window Test:
;* Author :idle - andrew ferguson
;* Date   :24/06/2009
;* Notes  :windows 32bit only
;*        :hit esc To quit 
;*        :If the webcam isn't set at 320 x 240 remove the comment on line 9
;*        :Don't set it less than 320 x 240  
;*        ;If your system can't find avicap32.dll add this string to the openlibary command  
;*        :system drive "C:\Windows\system32\avicap32.dll"  
;*****************************************************************************
OpenLibrary(1,"avicap32.dll"):*p=GetFunction(1,"capCreateCaptureWindowW")
ExamineDesktops():Global q=DesktopWidth(0),z=DesktopHeight(0),w=320,h=240,t,n,e
Macro sm(b,c,d):SendMessage_(n,b,c,d):EndMacro:Global lx.f,ly.f,dx,dy,f=z/2-h/2
Procedure FC(j,*v.long):*r.long=*v\l+3:sx.f:sy.f:a.f:While d<230400:y=d%w:x=d/w
c=*r\l:sx+x*c:sy+y*c:a+c:d+3:*r+3:Wend:If t>20:dx=(sx/a)-lx:dy=(sy/a)-ly:Else
lx=(sx/a):ly=(sy/a):t+1:EndIf:e+dx:f+dy:If e<0:e=0:ElseIf e>q-w:e=q-w:EndIf
If f<0:f=0:ElseIf f>z-h:f=z-h:EndIf:ResizeWindow(0,e,f,w,h):EndProcedure:s.s  
u=OpenWindow(0,0,0,w,h,s,$CA0001):n=CallFunctionFast(*p,s,1<<28*5,0,0,w,h,u,0)
e=q/2-w/2:Sm(1034,0,0):sm(1076,60,0):sm(1074,1,0):sm(1029,0,@FC());sm(1065,0,0)
Repeat:Until WaitWindowEvent()=16 Or GetAsyncKeyState_(#VK_ESCAPE)&$1

Code: Select all

;*****************************************************************************
;*
;* Name   : Toile Denim (Lewis Strauss 501)
;* Author : Dobro
;* Date   : 24/Juin/2009
;* Notes  : -exit white mouse right button
;*
;***************************************************************************** 
t$="-1,-1,0,-1,+1,-1,-1,0,+1,0,-1,+1,0,+1,+1,+1,0,0,0,0"
xp=2:yp=2:EX=640:Ey=480:InitSprite():InitMouse():OpenScreen(EX,Ey,32,"")
CreateImage(1,EX,Ey,32):StartDrawing(ImageOutput(1)):For t= 1 To 4096
Circle(Random(EX-1),Random(Ey-1),5,Random (255)):Next:StopDrawing():Repeat 
 If oo=0:For xp =2 To EX-2:StartDrawing(ImageOutput(1)):For yp=2 To Ey-2
 For x=1 To 4 Step 2:a1=Val(StringField(t$,x,",")):
a2=Val(StringField(t$,x+1,",")):p=p+(Point(xp+a1,yp+a2)):Next:p=p/2:
Circle(xp,yp,2,p):Next:StopDrawing():StartDrawing(ScreenOutput()):
DrawImage(ImageID(1),0,0):StopDrawing():FlipBuffers():Next:oo=1:EndIf
ExamineMouse():If MouseButton(2):End:EndIf:ForEver

Code: Select all

;***************************************************************************** 
;* 
;* Name   : Tower of Hanoi 
;* Author : nase09 
;* Date   : 23 June 2009 
;* Notes  : s=Number of Stones (up to 60 recommended, solves only <64!)  
;*          p=moving speed (e.g. set to 600 for slow,150 For fast,0 for fun)
;*
;***************************************************************************** 
s=12 :p=300 :InitSprite():OpenWindow(0,0,0,800,680,""):Dim t(2):Dim h(2):h(0)=s
OpenWindowedScreen(WindowID(0),0,0,800,680,0,0,0):Dim b(s):Dim p(s):Dim i(2,s-1)
Dim y(s):For d=0 To s-1:i(0,d)=d+1:b(d+1)=d*(124/s):y(d+1)=d:k=30:Next:If s%2=0
t(1)=2:t(2)=1:Else:t(1)=1:t(2)=2:EndIf:f=$4646:x.q=1:If s>20:k=640/s:EndIf
Repeat:q=t((x&(x-1))%3):z=t((x|(x-1)+1)%3):d=h(z):i(z,d)=i(q,h(q)-1):p(i(z,d))=z
y(i(z,d))=d:h(q)-1:h(z)+1:r=260:ClearScreen(0):StartDrawing(ScreenOutput())
For d=0 To 2:Box(6+d*r,672,257,4,f):Box(134+d*r,672,2,-k*s-4,f+23)
Next:For d=1 To s:u=b(d):Box(10+p(d)*r+u,671-y(d)*k,250-u-u,-k+1,182)
Box(12+p(d)*r+u,669-y(d)*k,246-u-u,-k+5,234):Next:StopDrawing():FlipBuffers()
Delay(p):x+1:Until WindowEvent()=16 Or x>1<<s-1

Code: Select all

;*****************************************************************************
;*
;* Name   : HTTPGet
;* Author : Infratec
;* Date   : 27.06.2009
;* Notes  : compile it for the console
;*
;***************************************************************************** 
InitNetwork():ReceiveHTTPFile(ProgramParameter(0), "HTTPGet.out")

Code: Select all

;*****************************************************************************
;*
;* Name   : iFX - Simple tool to adjust RGB channel-values of an image (Win32)
;* Author : Thorsten Will - aka 'Mr.Vain of Secretly!'
;* Date   : 28.06.2009
;* Notes  : Entry for the PurePunch Contest #2
;*          The rule is to code something in max 10 lines, each row max 80 chars!
;*          This time i tried to code a simple graphic tool for this contest!  
;*          Win32 API has been used - so it works on Windows only - Sorry!.
;*
;*          I M P O R T A N T :
;*          ~~~~~~~~~~~~~~~~~~~
;*          Please load ONLY BITMAP (*.bmp) IMAGES in 32Bit format, else
;*          this application does not works or may crash, because their was
;*          not enough space for error-handling nor supporting 24 bit bitmaps!
;*
;*          P L E A S E   D I S A B L E   T H E   D E B U G G E R  !!!
;*
;***************************************************************************** 
MessageBox_(0,"Entry by Thorsten Will aka va!n '2009","PureContest #2 - iFX",64)
w=800:Macro m(t,d):Macro t:d:EndMacr:EndMacro:m(C,Gadget)o:m(L,For i=0 To 2)o
OpenWindow(0,0,0,w,400,"iFX",$C80001):h=600:z=13100:w=600:n=255:Dim c(3):z=13100
UseJPEGImageDecoder():t$="Load":L:TrackBar#C(i,w+120-(i*30),95,20,n,1,n,2):Next
Button#C(3,w+50,40,100,20,t$):Repeat:e=WindowEvent():If e=z:t=Event#C():If t=3
f$=OpenFileRequester("BMP Image","","",0):m(P,etGadgetState)o:If LoadImage(0,f$)
v=ResizeImage(0,h,400,1):Image#C(5,0,0,h,w,v):EndIf:Else:L:c(i)=G#P(i):Dim R(3)
Next:d=CopyImage(0,1):GetObject_(d,SizeOf(BITMAP),m.BITMAP):*p.point=m\bmBits
s=*p+$EA5FC:Repeat:c=*p\x:j=0:L:R(i)=c>>(i*8)&n:u.f=(R(i)/n)*c(i):R(i)=u:q=i<<3
j+(R(i)<<q):Next:*p\x=j:*p+4:Until *p>s:S#P(5,d):EndIf:EndIf:Until e=16:End

Code: Select all

;*****************************************************************************
;*
;* Name   : iFX v2 - Simple tool to adjust RGB channel-values of an image (Win32)
;* Author : Thorsten Will - aka 'Mr.Vain of Secretly!'
;* Date   : 28.06.2009
;* Notes  : Entry for the PurePunch Contest #2
;*          The rule is to code something in max 10 lines, each row max 80 chars!
;*          This time i tried to code a simple graphic tool for this contest!  
;*          Win32 API has been used - so it works on Windows only - Sorry!.
;*
;*          F I X E D   v 2 :
;*          ~~~~~~~~~~~~~~~~~
;*          + Should work now with all BMP and JPG images (8,16,24,32 bit) 
;*          + Does not crash when moving slider before loaded an image.
;*          + Fixed problem when loading a new image and aborted the requester.
;*          - On 24 bit images the BLUE channel adjustment dont work atm! But 
;*            i will try to find the bug and fix it if possible. Any idea? ^^
;*
;*          P L E A S E   D I S A B L E   T H E   D E B U G G E R  !!!
;*
;***************************************************************************** 
w=800:Macro m(t,d):Macro t:d:EndMacr:EndMacro:m(C,Gadget)o:m(L,For i=0 To 2)o
OpenWindow(0,0,0,w,400,"iFX v2",$C80001):z=13100:w=600:n=255:Dim c(3):x=m.BITMAP
UseJPEGImageDecoder():t$="Load":L:TrackBar#C(i,w+120-(i*30),95,20,n,1,n,2):Next
Button#C(3,w+50,40,100,20,t$):Repeat:e=WindowEvent():If e=z:t=Event#C():If t=3
f$=OpenFileRequester("Load Img","","",0):m(P,etGadgetState)o:Dim R(3):If f$<>""
If LoadImage(0,f$):v=ResizeImage(0,w,400,1):Image#C(5,0,0,w,w,v):EndIf:a=1:EndIf
ElseIf a:L:c(i)=G#P(i):Next:d=CopyImage(0,1):GetObject_(d,SizeOf(BITMAP),x)
*p.point=m\bmBits:f=m\bmBitsPixel/8:s=*p+$3A980*f-r:Repeat:c=*p\x:j=0:L:o=(i<<3)
R(i)=c>>o&n:u.f=(R(i)/n)*c(i):R(i)=u:q=i<<3:j+(R(i)<<q):Next:*p\x=j:*p+f
Until *p>s:S#P(5,d):EndIf:EndIf:Until e=16:End

Code: Select all

;*******************************************************************************
;*
;* Name   : PIXEL REFRESH TIMING visual test.
;* Author : Psychophanta
;* Date   : 2009/06/28
;* Notes  : WIN32 Entry for the PurePunch Contest #2
;*          Visual test for your display (aka monitor) pixel refresh timing.
;*          Pixel refresh timing is higher as you see your display blinks
;*          on black.
;*          Only a display with an acceptable almost "null" time
;*          will show no black blinking to your eyes.
;*******************************************************************************
R=ColorRequester():H=800:V=600
InitSprite():InitKeyboard():OpenScreen(H,V,32,"fs"):Macro s(a,b,c,d,e,f)
ClearScreen(0):StartDrawing(ScreenOutput()):For t=e To d Step 2
Line(a,b,c,f,R):Next:StopDrawing():EndMacro:Macro f(a,b,c,d,f)
s(a,b,c,d,0,f):FlipBuffers(0):s(a,b,c,d,1,f):EndMacro:f(0,t,H,V,0):Repeat
ExamineKeyboard():If KeyboardReleased(#PB_Key_Space):If a:f(0,t,H,V,0):Else
f(t,0,0,H,V):EndIf:a!1:EndIf:FlipBuffers():Delay(100)
Until KeyboardPushed(1)