PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Try this

https://www.purebasic.fr/english/viewtopic.php?t=25093

Page 1 of 1

Try this

Posted: Fri Dec 22, 2006 12:56 pm
by Derek
Code updated for 5.20+

Code: Select all

;Press escape to exit

f=100
Dim s(f,2)
a$=""
For n=1 To 15
  Read.b b.b
  a$+Chr(b)
Next
DataSection
  Data.b 77,101,114,114,121,32,67,104,114,105,115,116,109,97,115
EndDataSection
InitSprite()
InitKeyboard()
font1=LoadFont(1,"lucida handwriting italic",48)
OpenWindow(0,0,0,800,128,"",#PB_Window_ScreenCentered|#PB_Window_BorderLess)
OpenWindowedScreen(WindowID(0),0,0,800,128,0,0,0)
ClearScreen(RGB(128,128,255))
StartDrawing(ScreenOutput())
  Box(0,100,800,28,RGB(0,255,0))
  BackColor(RGB(128,128,255))
  DrawingFont(font1)
  DrawingMode(#PB_2DDrawing_Transparent)
  tw=TextWidth(a$)
  th=TextHeight(a$)
  xo=(800-tw)/2
  yo=128-th
  For y=yo To yo+2
    For x=xo To xo+2
      DrawText(x,y,a$,0)
    Next
  Next
  DrawText(xo+1,yo+1,a$,RGB(255,0,0))
  For n=1 To f
    s(n,1)=Random(799)
    s(n,2)=0
  Next
StopDrawing()
FlipBuffers()
Repeat
  StartDrawing(ScreenOutput())
    For n=1 To f
      p=Point(s(n,1),s(n,2)+1)
      If p<>RGB(128,128,255)
        s(n,1)=Random(799)
        s(n,2)=0
      Else
        Plot(s(n,1),s(n,2)+1,RGB(255,255,255))
        Plot(s(n,1),s(n,2),RGB(128,128,255))
        s(n,2)+1
      EndIf
    Next
    WindowEvent()
  StopDrawing()
  FlipBuffers()
  ExamineKeyboard()
Until KeyboardPushed(#PB_Key_Escape)

Posted: Fri Dec 22, 2006 2:05 pm
by flaith
nice one, thanks Derek :)

Posted: Fri Dec 22, 2006 2:37 pm
by Tranquil
Nice idea, and looks nice too. But the code is nearly unreadable. :)

Anyway, thanks for sharing.

Posted: Fri Dec 22, 2006 2:56 pm
by remi_meier
Nice!

Here is one that I wrote some time ago. You can draw lines with the
mouse.

Code: Select all

Global Speed.f
Speed = 1.0

Global WX.l, WY.l
WX = GetSystemMetrics_(#SM_CXSCREEN)
WY = GetSystemMetrics_(#SM_CYSCREEN)


Procedure StartBuffered()
	Shared _buf.l, _line.l
	
	_buf  = DrawingBuffer()
	_line = DrawingBufferPitch()
	
	ProcedureReturn _buf
EndProcedure

Procedure BPoint(x, y)
	Shared _buf.l, _line.l

	If x >= 0 And x < WX And y >= 0 And y < WY
		ProcedureReturn PeekL(_buf + y * _line + x * 4)
	EndIf
	
	ProcedureReturn 0
EndProcedure

Structure RAIN
	x.f
	y.f
	Stopped.l
EndStructure
Global NewList rained.RAIN()
#AnzRain = 300
Global Dim rain.RAIN(#AnzRain)

Procedure InitRain()
	Protected z.l

	For z = 0 To #AnzRain
		rain(z)\x = Random(WX - 1)
		rain(z)\y = Random(WY - 1)
		rain(z)\Stopped = #False
	Next
EndProcedure

Procedure UpdateRain()
	Protected ul.l, l.l, u.l, ur.l, r.l, z.l
	
	For z = 0 To #AnzRain
		
		If rain(z)\Stopped Or rain(z)\x > WX - 1 Or rain(z)\x < 0 Or rain(z)\y > WY - 1 Or rain(z)\y < 0
			If rain(z)\Stopped
				AddElement(rained())
				rained()\x = rain(z)\x
				rained()\y = rain(z)\y
			EndIf
			
			rain(z)\x = Random(WX - 1)
			rain(z)\y = 0
			rain(z)\Stopped = #False
			
		Else
			u  = BPoint(rain(z)\x, rain(z)\y + 1)
			ul = BPoint(rain(z)\x - 1, rain(z)\y + 1)
			l  = BPoint(rain(z)\x - 1, rain(z)\y)
			ur = BPoint(rain(z)\x + 1, rain(z)\y + 1)
			r  = BPoint(rain(z)\x + 1, rain(z)\y)
			
			If u = 0 And ul = 0 And ur = 0
				rain(z)\x + Random(2) - 1
				rain(z)\y + Speed
				
			ElseIf u = 0
				rain(z)\y + Speed
				
			ElseIf (ul = 0 And ur = 0)
				If Random(200) & 1
					rain(z)\x - Speed
					rain(z)\y + Speed
				Else
					rain(z)\x + Speed
					rain(z)\y + Speed
				EndIf
				
			ElseIf ul = 0
				;If Random(200) >= 5
					rain(z)\x - Speed
					rain(z)\y + Speed
				;Else
				;	rain(z)\stopped = #True
				;EndIf
				
			ElseIf ur = 0
				;If Random(200) >= 5
					rain(z)\x + Speed
					rain(z)\y + Speed
				;Else
				;	rain(z)\stopped = #True
				;EndIf
				
			Else
				rain(z)\Stopped = #True
				
			EndIf
			
; 			If u = 0
; 				rain()\y + Speed
; 				
; 			ElseIf (l = 0 And r = 0)
; 				If Random(200) & 1
; 					rain()\x - Speed
; 				Else
; 					rain()\x + Speed
; 				EndIf
; 				
; 			ElseIf l = 0
; 				rain()\x - Speed
; 				
; 			ElseIf r = 0
; 				rain()\x + Speed
; 				
; 			Else
; 				rain()\stopped = #True
; 				
; 			EndIf
			
		EndIf
	Next
	
EndProcedure

Procedure DrawRain(circle.l) ;circle or plot?
	Protected z.l

	For z = 0 To #AnzRain
		If rain(z)\Stopped = #False
			If circle
				Circle(rain(z)\x, rain(z)\y, 2, $FFFFFF)
			Else
				If rain(z)\x < WX And rain(z)\x >= 0 And rain(z)\y < WY And rain(z)\y >= 0
					Plot(rain(z)\x, rain(z)\y, $FFFFFF)
				EndIf
			EndIf
		EndIf
	Next
	StopDrawing()
	
	StartDrawing(SpriteOutput(0))
	ForEach rained()
		;If circle
			Circle(rained()\x, rained()\y, 2, $FFFFFF)
		;Else
		;	If rained()\x < 1024 And rained()\x >= 0 And rained()\y < 768 And rained()\y >= 0
		;		Plot(rained()\x, rained()\y, $FFFFFF)
		;	EndIf
		;EndIf
		DeleteElement(rained())
	Next
	StopDrawing()
	StartDrawing(ScreenOutput())
EndProcedure

Procedure DrawBkgSprite()
	LoadFont(0, "Arial", 30, #PB_Font_Bold|#PB_Font_HighQuality)

	StartDrawing(SpriteOutput(0))
		Box(0,0, WX,WY, 0)
		
		DrawingMode(1)
		DrawingFont(FontID(0))
		FrontColor(RGB(255,128,0))
		DrawText(200, 200, "Merry Christmas")
	StopDrawing()
EndProcedure



InitSprite()
InitKeyboard()
InitMouse()

If MessageRequester("Fullscreen?", "Fullscreen?", #PB_MessageRequester_YesNo) = #PB_MessageRequester_Yes
	Windowed.l = #False
Else
	Windowed.l = #True
	WX = 1024
	WY = 768
EndIf


If Windowed
	OpenWindow(0,0,0,WX,WY, "GFX-Demo by Remi",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
	OpenWindowedScreen(WindowID(0), 0,0, WX,WY, 0,0,0)
Else
	OpenScreen(WX, WY, 32, "GFX by Remi")
EndIf

SetFrameRate(60)
SetRefreshRate(60)

CreateSprite(0, WX,WY)
TransparentSpriteColor(0,0)
DrawBkgSprite()


InitRain()

pressed.l = #False
mx.l = 0
my.l = 0
fps.l = 0
FPSt.l = ElapsedMilliseconds()
FPSe.l = 0
released.l = #False
Repeat
	ExamineKeyboard()
	ExamineMouse()
	ClearScreen(0)
	
	If Windowed
		If WindowMouseX(0) < 1 Or WindowMouseX(0) > WX - 2 Or WindowMouseY(0) < 1 Or WindowMouseY(0) > WY - 2 
		  ReleaseMouse(#True)
		  released = #True
		ElseIf released = #True
		  released = #False
		  ReleaseMouse(#False)
		  MouseLocate(WindowMouseX(0), WindowMouseY(0))
		EndIf
	EndIf
	
	If MouseButton(1)
		If pressed = #False
			pressed = #True
			mx = MouseX()
			my = MouseY()
		EndIf
		
	ElseIf MouseButton(2)
		DrawBkgSprite()
	
	ElseIf MouseButton(3)
		StartDrawing(SpriteOutput(0))
			DrawingMode(0)
			Circle(MouseX(), MouseY(), 2, 0)
		StopDrawing()
		
	ElseIf pressed
		StartDrawing(SpriteOutput(0))
			LineXY(mx, my, MouseX(), MouseY(), $FF)
			LineXY(mx, my+1, MouseX(), MouseY()+1, $FF)
			LineXY(mx, my+2, MouseX(), MouseY()+2, $FF)
		StopDrawing()
		pressed = #False
		
	EndIf
	
	
	DisplaySprite(0, 0, 0)
	
	StartDrawing(ScreenOutput())
		DrawRain(0)
		If StartBuffered()
			UpdateRain()
		EndIf
	StopDrawing()
	
	ClearScreen(0)
	DisplaySprite(0, 0, 0)
	
	StartDrawing(ScreenOutput())
		fps + 1
		If ElapsedMilliseconds() - FPSt > 1000
			FPSt + 1000
			FPSe = fps
			fps = 0
		EndIf
		DrawingMode(1)
		FrontColor(RGB(255,128,0))
		DrawText(20, 20, "FPS: " + Str(FPSe))
		
		DrawRain(1)
		Circle(MouseX(), MouseY(), 2, RGB(255,255,0))
		If pressed
			LineXY(mx, my, MouseX(), MouseY(), $FF)
			LineXY(mx, my+1, MouseX(), MouseY()+1, $FF)
			LineXY(mx, my+2, MouseX(), MouseY()+2, $FF)
		EndIf
	StopDrawing()
	
	
	FlipBuffers(0)
	
	If Windowed
		While WindowEvent() : Wend
	EndIf
Until KeyboardPushed(#PB_Key_Escape)

Posted: Fri Dec 22, 2006 3:08 pm
by Derek
Tranquil wrote:Nice idea, and looks nice too. But the code is nearly unreadable. :)

Anyway, thanks for sharing.
Yeah, I didn't want anyone to figure out what it did by reading it, I wanted it to be a surprise. Normally I would indent etc. :evil:

Posted: Fri Dec 22, 2006 3:10 pm
by Derek
@remi_meier, infinitely better than mine. A bit longer as well! Very nice.

Posted: Fri Dec 22, 2006 3:48 pm
by rsts
They're both nice.

And happy holidays to you too :)

cheers
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited