Важная информация
Показано с 1 по 1 из 1

Тема: ScreenSaver

  1. #1 ScreenSaver 
    Разбирающийся
    Регистрация
    13.10.2013
    Сообщений
    53
    Сказал(а) спасибо
    52
    Поблагодарили 34 раз(а) в 22 сообщениях
    И снова здравствуйте.

    Давно уже хотел написать скринсейвер и таки написал. Код оказался сложнее, чем я предполагал... особенно, если учитывать "функционал" данного приложения: хаотичное перемещение квадратов на экране.
    Сейчас работает, почему-то, через раз. Чистое везение: может зависнуть, а может еще поработать. В чем дело, ума не приложу; может, кто и знает...

    Прилагаю код и .exe. Извините за корявость кода
    Код (1920х1080)
    [Ссылки могут видеть только зарегистрированные пользователи. ]
    Код :
    ScreenRes 1920, 1080, 24, 1, 8
     
    Declare Sub moveb(param As Integer)
    Declare Function nstep (x As Integer, y As Integer) As String
    Declare function stack OverLoad (st As String) As Integer
    Declare Function stack OverLoad (i As Integer)As String
    Declare Function bita(dat As string) As Integer
    Declare Function bitb(dat As string) As Integer
    Declare Function bits(x As Integer, y As Integer) As String
     
    Randomize Timer
    Const br=255
    Const wb=300
    Const wl=20
    Const lb=250
    Const ll=20
     
    Dim Shared stackd (1 To 16) As String
    Dim Shared c (1 To 2, 1 To 12) As Integer
    Dim Shared sh (1 To 25) As Single
    Dim Shared a (-3 To 8, -3 To 6) As Integer
    Dim Shared As Double col (0 To 5)={RGB(0,0,0), RGB(br,0,0), RGB(0,br,0), RGB(0,0,br), RGB(br, br, 0), RGB(br, 0, br)}
     
    Dim As Integer i, j, t, tt
    Dim As String temp
    Dim handle (1 To 12) As Integer 
     
    For i=1 To 25
    	sh(i)=12.8
    Next
    For i=-3 To 8
    	For j=-3 To 6
    		a(i, j)=Int(Rnd*5+1)
    	Next
    Next
    For i=2 To 3
    	For j=1 To 2
    	a(i, j)=0: t=t+1:c(1, t)=i: c(2, t)=j
    	Next j
    Next
     
    For i=0 To 5
    	For j=0 To 3
    		Line (i*(wb+wl),j*(lb+ll))-(i*(wb+wl)+wb,j*(lb+ll)+lb), col(a(i, j)), BF
    	Next
    Next
    Do While InKey$=""
    	For i=1 To 4
    		temp=nstep(c(1, i), c(2, i))
    		If temp<>"stand" Then c(1, i)=bita(temp): c(2, i)=bitb(temp)
    		handle(i)=ThreadCreate(@moveb, stack(temp))
    		Sleep 5
    	Next i
    	For i=1 To 4	
    		ThreadWait(handle(i))
    	Next i
    Loop
    End
     
    Function nstep (x As Integer, y As Integer) As String
    	Dim act (1 To 2, 1 To 4) As Integer
    	Dim As Integer i, action
    	If a(x+1, y)>0 and a(x+2, y)>0 And a(x+1, y+1)>0 And a(x+1, y-1)>0 And x<5 Then i=i+1: act(1, i)=x+1: act(2, i)=y
    	If a(x, y-1)>0 And a(x, y-2)>0 And a(x+1, y-1)>0 And a(x-1, y-1)>0 And y>-1 Then i=i+1: act(1, i)=x: act(2, i)=y-1
    	If a(x-1, y)>0 And a(x-2, y)>0 And a(x-1, y+1)>0 And a(x-1, y-1)>0 And x>-1 Then i=i+1: act(1, i)=x-1: act(2, i)=y
    	If a(x, y+1)>0 And a(x, y+2)>0 And a(x+1, y+1)>0 And a(x-1, y+1)>0 And y<3  Then i=i+1: act(1, i)=x: act(2, i)=y+1
    	If i=0 Then Return "stand"
    	action=Int(Rnd*i)+1
    	nstep=bits(act(1, action), act(2, action))
    End Function
     
    Sub moveb (param As Integer)
    	Dim As Integer com, i, t1, t2, x, y
    	Dim As Single shift0, shift1
    	Dim As String st
    	st=stack(param)
    	If st="stand" Then Sleep 1000: Exit Sub
    	x=bita(st): y=bitb(st)
    	If a(x-1, y)=0 Then com=1: t1=-1
    	If a(x+1, y)=0 Then com=2: t1=1
    	If a(x, y+1)=0 Then com=3: t2=1
    	If a(x, y-1)=0 Then com=4: t2=-1
    	'If com=0 Then Cls: Print "error": Sleep: End
    	For i=1 To 25
    		shift0=shift1
    		If t1 Then shift1=shift0+12.8 Else shift1=shift0+10.8
    		If com=1 Then Line (x*(wb+wl)+wb-shift0, y*(lb+ll))-(x*(wb+wl)+wb-shift1, y*(lb+ll)+lb),0,bf: Line(x*(wb+wl)-shift0, y*(lb+ll))-(x*(wb+wl)-shift1, y*(lb+ll)+lb), col(a(x, y)),bf
    		If com=2 Then Line (x*(wb+wl)+shift0,y*(lb+ll))-(x*(wb+wl)+shift1, y*(lb+ll)+lb),0,bf: Line(x*(wb+wl)+wb+shift0, y*(lb+ll))-(x*(wb+wl)+wb+shift1, y*(lb+ll)+lb), col(a(x, y)), bf
    		If com=3 Then Line (x*(wb+wl), y*(lb+ll)+shift0)-(x*(wb+wl)+wb, y*(lb+ll)+shift1), 0, bf: Line (x*(wb+wl), y*(lb+ll)+lb+shift0)-(x*(wb+wl)+wb, y*(lb+ll)+lb+shift1), col(a(x, y)), bf
    		If com=4 Then Line (x*(wb+wl), y*(lb+ll)+lb-shift0)-(x*(wb+wl)+wb, y*(lb+ll)+lb-shift1), 0, bf: Line (x*(wb+wl), y*(lb+ll)-shift0)-(x*(wb+wl)+wb, y*(lb+ll)-shift1), col(a(x, y)), bf
    		Sleep 40
    	Next 
    	Swap a(x, y), a(x+t1, y+t2)
    End Sub
     
    function stack OverLoad (st As String) As Integer
    	Dim As Integer i
    	For i=1 To 16
    		If stackd(i)="" Then stackd(i)=st: stack=i: Exit For
    	Next i
    	If i=17 Then Cls: Print "stack overloaded": Sleep: End
    End Function
     
    Function stack OverLoad (i As Integer) As String
    	stack=stackd(i): stackd(i)=""
    End Function
     
    Function bita(dat As string) As Integer
    	bita=Val(Left$(dat, 4))
    End Function
     
    Function bitb(dat As string) As Integer
    	bitb=Val(Right$(dat, 4))
    End Function
     
    Function bits(x As Integer, y As Integer) As String
    	bits=Space(4-Len(Str(x)))&Str(x)&Space(4-Len(Str(y)))&Str(y)
    End Function

    Код (1024х576)
    [Ссылки могут видеть только зарегистрированные пользователи. ]
    Код :
    ScreenRes 1024, 576, 24, 1, 8
     
    Declare Sub moveb(param As Integer)
    Declare Function nstep (x As Integer, y As Integer) As String
    Declare function stack OverLoad (st As String) As Integer
    Declare Function stack OverLoad (i As Integer)As String
    Declare Function bita(dat As string) As Integer
    Declare Function bitb(dat As string) As Integer
    Declare Function bits(x As Integer, y As Integer) As String
     
    Randomize Timer
    Const br=255
    Const wb=160
    Const wl=11
    Const lb=133
    Const ll=11
     
    Dim Shared stackd (1 To 16) As String
    Dim Shared c (1 To 2, 1 To 12) As Integer
    Dim Shared sh (1 To 25) As Single
    Dim Shared a (-3 To 8, -3 To 6) As Integer
    Dim Shared As Double col (0 To 5)={RGB(0,0,0), RGB(br,0,0), RGB(0,br,0), RGB(0,0,br), RGB(br, br, 0), RGB(br, 0, br)}
     
    Dim As Integer i, j, t, tt
    Dim As String temp
    Dim handle (1 To 12) As Integer 
     
    For i=1 To 25
    	sh(i)=12.8
    Next
    For i=-3 To 8
    	For j=-3 To 6
    		a(i, j)=Int(Rnd*5+1)
    	Next
    Next
    For i=2 To 3
    	For j=1 To 2
    	a(i, j)=0: t=t+1:c(1, t)=i: c(2, t)=j
    	Next j
    Next
     
    For i=0 To 5
    	For j=0 To 3
    		Line (i*(wb+wl),j*(lb+ll))-(i*(wb+wl)+wb,j*(lb+ll)+lb), col(a(i, j)), BF
    	Next
    Next
    Do While InKey$=""
    	For i=1 To 4
    		temp=nstep(c(1, i), c(2, i))
    		If temp<>"stand" Then c(1, i)=bita(temp): c(2, i)=bitb(temp)
    		handle(i)=ThreadCreate(@moveb, stack(temp))
    		Sleep 5
    	Next i
    	For i=1 To 4	
    		ThreadWait(handle(i))
    	Next i
    Loop
    'ThreadWait(1)
     
    Function nstep (x As Integer, y As Integer) As String
    	Dim act (1 To 2, 1 To 4) As Integer
    	Dim As Integer i, action
    	If a(x+1, y)>0 and a(x+2, y)>0 And a(x+1, y+1)>0 And a(x+1, y-1)>0 And x<5 Then i=i+1: act(1, i)=x+1: act(2, i)=y
    	If a(x, y-1)>0 And a(x, y-2)>0 And a(x+1, y-1)>0 And a(x-1, y-1)>0 And y>-1 Then i=i+1: act(1, i)=x: act(2, i)=y-1
    	If a(x-1, y)>0 And a(x-2, y)>0 And a(x-1, y+1)>0 And a(x-1, y-1)>0 And x>-1 Then i=i+1: act(1, i)=x-1: act(2, i)=y
    	If a(x, y+1)>0 And a(x, y+2)>0 And a(x+1, y+1)>0 And a(x-1, y+1)>0 And y<3  Then i=i+1: act(1, i)=x: act(2, i)=y+1
    	If i=0 Then Return "stand"
    	action=Int(Rnd*i)+1
    	nstep=bits(act(1, action), act(2, action))
    End Function
     
    Sub moveb (param As Integer)
    	Dim As Integer com, i, t1, t2, x, y
    	Dim As Single shift0, shift1
    	Dim As String st
    	st=stack(param)
    	If st="stand" Then Sleep 1000: Exit Sub
    	x=bita(st): y=bitb(st)
    	If a(x-1, y)=0 Then com=1: t1=-1
    	If a(x+1, y)=0 Then com=2: t1=1
    	If a(x, y+1)=0 Then com=3: t2=1
    	If a(x, y-1)=0 Then com=4: t2=-1
    	'If com=0 Then Cls: Print "error": Sleep: End
    	For i=1 To 25
    		shift0=shift1
    		If t1 Then shift1=shift0+6.84 Else shift1=shift0+5.77
    		If com=1 Then Line (x*(wb+wl)+wb-shift0, y*(lb+ll))-(x*(wb+wl)+wb-shift1, y*(lb+ll)+lb),0,bf: Line(x*(wb+wl)-shift0, y*(lb+ll))-(x*(wb+wl)-shift1, y*(lb+ll)+lb), col(a(x, y)),bf
    		If com=2 Then Line (x*(wb+wl)+shift0,y*(lb+ll))-(x*(wb+wl)+shift1, y*(lb+ll)+lb),0,bf: Line(x*(wb+wl)+wb+shift0, y*(lb+ll))-(x*(wb+wl)+wb+shift1, y*(lb+ll)+lb), col(a(x, y)), bf
    		If com=3 Then Line (x*(wb+wl), y*(lb+ll)+shift0)-(x*(wb+wl)+wb, y*(lb+ll)+shift1), 0, bf: Line (x*(wb+wl), y*(lb+ll)+lb+shift0)-(x*(wb+wl)+wb, y*(lb+ll)+lb+shift1), col(a(x, y)), bf
    		If com=4 Then Line (x*(wb+wl), y*(lb+ll)+lb-shift0)-(x*(wb+wl)+wb, y*(lb+ll)+lb-shift1), 0, bf: Line (x*(wb+wl), y*(lb+ll)-shift0)-(x*(wb+wl)+wb, y*(lb+ll)-shift1), col(a(x, y)), bf
    		Sleep 40
    	Next 
    	Swap a(x, y), a(x+t1, y+t2)
    End Sub
     
    function stack OverLoad (st As String) As Integer
    	Dim As Integer i
    	For i=1 To 16
    		If stackd(i)="" Then stackd(i)=st: stack=i: Exit For
    	Next i
    	If i=17 Then Cls: Print "stack overloaded": Sleep: End
    End Function
     
    Function stack OverLoad (i As Integer) As String
    	stack=stackd(i): stackd(i)=""
    End Function
     
    Function bita(dat As string) As Integer
    	bita=Val(Left$(dat, 4))
    End Function
     
    Function bitb(dat As string) As Integer
    	bitb=Val(Right$(dat, 4))
    End Function
     
    Function bits(x As Integer, y As Integer) As String
    	bits=Space(4-Len(Str(x)))&Str(x)&Space(4-Len(Str(y)))&Str(y)
    End Function

    За последним кодом зависаний пока не замечено.
    Останавливается сейчас через нажатие любой клавиши (или через кликание мышью по зависнувшему окну (которое, надо сказать, иногда отвисает) и последующее аварийное завершение).
    Ответить с цитированием  
     

  2. Пользователь сказал cпасибо:

    >Quiet Snow< (26.05.2014)

Информация о теме
Пользователи, просматривающие эту тему

Эту тему просматривают: 1 (пользователей: 0 , гостей: 1)

Похожие темы

  1. ScreenSaver
    от Good.Morning в разделе Общие вопросы программирования
    Ответов: 6
    Последнее сообщение: 19.05.2014, 04:23
Ваши права
  • Вы не можете создавать новые темы
  • Вы не можете отвечать в темах
  • Вы не можете прикреплять вложения
  • Вы не можете редактировать свои сообщения
  •