Извините, ничего не найдено.

Не расстраивайся! Лучше выпей чайку!
Регистрация
Справка
Календарь

Вернуться   forum.boolean.name > Программирование игр для компьютеров > Blitz3D > Полезные функции

Полезные функции Выкладываем полезные функции, чтоб не изобретать велосипед заново...

Ответ
 
Опции темы
Старый 12.03.2009, 17:44   #1
Spiderman
Знающий
 
Аватар для Spiderman
 
Регистрация: 28.07.2008
Адрес: Киев
Сообщений: 228
Написано 61 полезных сообщений
(для 191 пользователей)
Смех Исходница

В этой теме предлагаю выкладывать полезные функции, куски кода, математические формулы, которые будут полезны каждому и упростят жизнь среднестатистическому прогеру.

Прошу выкладывать только код, т.е. эта тема посвящена только исходному коду и не затрагивает библиотеки
__________________
Тяжела жизнь программиста: радость находки своего бага всегда омрачает осознание собственной тупости...
(Offline)
 
Ответить с цитированием
Старый 12.03.2009, 17:48   #2
Spiderman
Знающий
 
Аватар для Spiderman
 
Регистрация: 28.07.2008
Адрес: Киев
Сообщений: 228
Написано 61 полезных сообщений
(для 191 пользователей)
Ответ: Исходница

Эта функция позволяет манипулировать размером изображения в реальном времени без большой нагрузки на систему

Global scratch%=CreateImage(100,100)          ;картинка для DrawSize

Function DrawSizeImage(image,x%,y%,w%,h%)
	 
     Local ih%=ImageHeight(image)
     Local iw%=ImageWidth(image)

     Local sw%=Abs(w)
     Local sh%=Abs(h)
     
     Local xr#=(Float(iw)/Float(sw))
     Local yr#=(Float(ih)/Float(sh))
     
     fromimg=ImageBuffer(image)
     toimg=ImageBuffer(scratch)
     
     Local vf=-1+((h>0)*2)
     
     Local fw=(w<0)*w
     Local fh=(h<0)*h

     If w>=0
          For ix=0 To sw		       
               CopyRect ix*xr,0,1,ih,ix,0,fromimg,toimg
          Next
     Else
          For ix=0 To sw
		       CopyRect ix*xr,0,1,ih,sw-ix,0,fromimg,toimg
          Next
     EndIf
     

     For iy=0 To sh
          CopyRect 0,iy*yr,sw,1,x+fw,y+(iy*vf),toimg
     Next

End Function
__________________
Тяжела жизнь программиста: радость находки своего бага всегда омрачает осознание собственной тупости...
(Offline)
 
Ответить с цитированием
Старый 13.03.2009, 17:04   #3
Spiderman
Знающий
 
Аватар для Spiderman
 
Регистрация: 28.07.2008
Адрес: Киев
Сообщений: 228
Написано 61 полезных сообщений
(для 191 пользователей)
Ответ: Исходница

Несколько полезных математических формул

Вычисление расстояния до объекта:
2D    Sqr((x1-x2)^2+(y1-y2)^2)
3D    Sqr((x1-x2)^2+(y1-y2)^2+(z1-z2)^2)
Движение одного объекта на другой по прямой траектории (градусы)

coef=1.4
angle = ATan2(x1,y1) //x1 и y1 -коорд. первого объекта 
x2 = Sin(angle)*coef  
y2 = Cos(angle)*coef
Если нужно переключить переменную типа булеан, но не известно в данный момент значение TRUE или FALSE
boolvar = 1 - boolvar
Как сделать так чтобы часть кода выполнялась с определенной задержкой т.е. не каждый проход цикла

zaderjka = 5
if (MilliSecs() /  zaderjka) Mod 2 then ...
__________________
Тяжела жизнь программиста: радость находки своего бага всегда омрачает осознание собственной тупости...
(Offline)
 
Ответить с цитированием
Эти 3 пользователя(ей) сказали Спасибо Spiderman за это полезное сообщение:
Arton (30.06.2010), PackegerX (04.09.2011), Randomize (23.03.2009)
Старый 29.06.2010, 18:14   #4
Randomize
[object Object]
 
Аватар для Randomize
 
Регистрация: 01.08.2008
Адрес: В России
Сообщений: 4,354
Написано 2,470 полезных сообщений
(для 6,850 пользователей)
Ответ: Исходница

Сегодня понадобилась функция разбиения строки:
Например имеем: 1,2,3,4,5,6,7,8,9,10
Нужно разбить по символу запятой и соответственно поместить всё в массив.
Function Split(mystring$, delimiter$)
    
Local StrLen Len(mystring$)+1
    Local start 
1
    Local t
    
    mystring 
Trim(mystring)
    
delimiter Middelimiter11)
    
    For 
t=1 To StrLen
        
If Mid(mystring$,t,1)=delimiter Or Mid(mystring$,t,1)="" Then
            SplitResult
(SplitCount)=TrimMidmystring$, startt-start ) )
            
SplitCount SplitCount 1            
            start
=t+1
        
EndIf
    
Next
End 
Function 
SplitResult - массив с результатами
SplitCount - количество результатов

Простенький примерчик:
test$="0,1,2,3,4,5,6,7,8,9,10,11,12,13"

Split(test$,", ")

Print 
SplitCount 
For 0 To SplitCount
    
Print SplitResult(i)
Next
WaitKey
End 
Если появится флуд на тему: зачем, почему, b3d гавно. Буду карать. Я выкладываю потому, что нахожу это полезным.
__________________
Retry, Abort, Ignore? █
Intel Core i7-9700 4.70 Ghz; 64Gb; Nvidia RTX 3070
AMD Ryzen 7 3800X 4.3Ghz; 64Gb; Nvidia 1070Ti
AMD Ryzen 7 1700X 3.4Ghz; 8Gb; AMD RX 570
AMD Athlon II 2.6Ghz; 8Gb; Nvidia GTX 750 Ti
(Offline)
 
Ответить с цитированием
Эти 5 пользователя(ей) сказали Спасибо Randomize за это полезное сообщение:
Crayzi (21.11.2010), Egor Rezenov (31.03.2011), Leowey (06.04.2011), PackegerX (04.09.2011), St_AnGer (29.06.2010)
Старый 29.06.2010, 18:19   #5
impersonalis
Зануда с интернетом
 
Аватар для impersonalis
 
Регистрация: 04.09.2005
Сообщений: 14,014
Написано 6,798 полезных сообщений
(для 20,935 пользователей)
Ответ: Исходница

http://forum.boolean.name/showthread.php?t=47
__________________
http://nabatchikov.com
Мир нужно делать лучше и чище. Иначе, зачем мы живем? tormoz
А я растила сына на преданьях
о принцах, троллях, потайных свиданьях,
погонях, похищениях невест.
Да кто же знал, что сказка душу съест?
(Offline)
 
Ответить с цитированием
Сообщение было полезно следующим пользователям:
Randomize (29.06.2010)
Старый 29.06.2010, 18:37   #6
Randomize
[object Object]
 
Аватар для Randomize
 
Регистрация: 01.08.2008
Адрес: В России
Сообщений: 4,354
Написано 2,470 полезных сообщений
(для 6,850 пользователей)
Ответ: Исходница

Рекурсивный пробег по чилдам:
Function SeekChilds(ent
    
Local ichild
    
    
For i=1 To CountChildren(ent
        
child=GetChild(ent,i
        If 
child<>
            
If CountChildren(child)>0 Then SeekChilds(child)
     ;---> 
Put code here <---;        
        EndIf 
    
Next 
End 
Function 
У чилдов тоже есть чилды. Данная ф-ция прбегает по всей иерархии.
Не раз писалось, но думаю пусть будет и тут тоже.

Область применения:
Например у вас вся игровая локация сделана одной сценой в формате B3d.
Вы хотите поставить точку старта в особом месте или расставить NPC прямо в 3dsmax (или другом пакете 3d моделирования)
Имя каждого чилда вполне подходит для хранения такой информации.
Для обработки каждого чилда можно завести вспомогательную ф-цию:
допустим ApplyChild(child)
где child - хендл чилда.
;---> Put code here <---; в ф-ции SeekChilds(ent) заменим на ApplyChild(child)
У нас получился такой код:


Local LevelMesh LoadAnimMesh("Level.B3D") ; Загружаем уровень
SeekChilds
(LevelMesh)

Function 
SeekChilds(ent
    
Local ichild
    
    
For i=1 To CountChildren(ent
        
child=GetChild(ent,i
        If 
child<>
            
If CountChildren(child)>0 Then SeekChilds(child)
     
ApplyChild(child)        
        EndIf 
    
Next 
End 
Function


Function 
ApplyChild(child)
    
Local name$=Lower(EntityName(child))
    
    If 
Instr(name$,"start")>0 Then 
        
Перемещаем игрока в точку старта
    
EndIf
    
    If 
Instr(name$,"shield")>0 Then 
        
ставим броню в месте этого чилда
    
EndIf
    
    
    If 
Instr(name$,"enemy")>0 Then 
        
ставим врага в месте этого чилда
    
EndIf
End Function 
Позволяет секономить время и использовать пакет 3d моделирования как игровой редактор карт.
(Offline)
 
Ответить с цитированием
Сообщение было полезно следующим пользователям:
LLI.T.A.L.K.E.R. (11.10.2011)
Старый 29.06.2010, 18:50   #7
Randomize
[object Object]
 
Аватар для Randomize
 
Регистрация: 01.08.2008
Адрес: В России
Сообщений: 4,354
Написано 2,470 полезных сообщений
(для 6,850 пользователей)
Ответ: Исходница

Мышь.
Все знают, что в интерфейсе Windows (да и не только) срабатывание щелчка по кнопке срабатывает в момент отпускания клавиши мыши.
Вот скромная реализация подобного на Blitz3D:

Dim IMMouseUP  (3)
Dim IMMouseDown(3)
Dim IMMouseHit (3)

Function 
IMUpdate()
    
Local i
    
For i=1 To 3
        IMMouseUP
)   = IMMouseDown)
        
IMMouseHit)  = (MouseHit) > 0)
        
IMMouseDown) = MouseDown)
    
        If(
IMMouseUP) = True And IMMouseDown) = False)
            
IMMouseUP) = True
        
Else
            
IMMouseUP) = False
        
EndIf
    
Next
End 
Function 
В начало игрового цикла вставляем IMUpdate().
Приставка IM - Input manager (Менеджер ввода)
Вместо MouseDown пишем IMMouseDown
Вместо IMMouseHit пишем IMMouseHit
И конечно IMMouseUP, которая возвращаят True при отпускании кнопки.

Это решает сразу 2 беды.
1) Нет MouseUP
2) Как вы наверное заметили, при повторном вызывании ф-ции MouseHit или MouseDown в цикле функция возвращает False, хотя при первом вызове True. Чтобы этого избежать приходилось заводить глобальные переменные. Теперь это в прошлом.
(Offline)
 
Ответить с цитированием
Сообщение было полезно следующим пользователям:
PackegerX (04.09.2011)
Старый 07.07.2010, 16:00   #8
baton4ik
Дэвелопер
 
Аватар для baton4ik
 
Регистрация: 21.11.2009
Адрес: Киев
Сообщений: 1,699
Написано 657 полезных сообщений
(для 1,962 пользователей)
Ответ: Исходница

Функция выводит текст по буквам (написана для проекта "Часовёнок")

Dim currenttext$(99)
Dim position(99)
Dim oldtexttime(99)

;...

Function writetext(id,txt$,x,y,delayt)
If position(id)=0 position(id)=1
	If position(id)<=Len(txt) And MilliSecs()-oldtexttime(id)>delayt
		currenttext(id)=currenttext(id)+Mid(txt,position(id),1)
		position(id)=position(id)+1
		oldtexttime(id)=MilliSecs()
	EndIf
	Text(x,y,currenttext(id))
	If position(id)>Len(txt) Return 1
End Function
txt - текст, id - id текста, x,y - координаты, delayt - задержка между выводом букв. Функция возвращает 1, если тект выведен полностью

Пример использования:

Dim currenttext$(99)
Dim position(99)
Dim oldtexttime(99)

Repeat
	writetext(1,"Привет! :)",20,20,100)
	writetext(2,"Этот текст ниже",20,40,100)
	If writetext(3,"После того, как выведется этот текст",20,60,100)
		writetext(4,"Будет выведен этот",250,60,100)
	EndIf
Until KeyHit(1)

Function writetext(id,txt$,x,y,delayt)
If position(id)=0 position(id)=1
	If position(id)<=Len(txt) And MilliSecs()-oldtexttime(id)>delayt
		currenttext(id)=currenttext(id)+Mid(txt,position(id),1)
		position(id)=position(id)+1
		oldtexttime(id)=MilliSecs()
	EndIf
	Text(x,y,currenttext(id))
	If position(id)>Len(txt) Return 1
End Function
P.S. Если кому-то надо, могу выложить вариант с типами вместо массивов
(Offline)
 
Ответить с цитированием
Сообщение было полезно следующим пользователям:
Randomize (07.07.2010)
Старый 08.07.2010, 03:13   #9
Tadeus
Троллота
 
Регистрация: 09.07.2007
Сообщений: 1,829
Написано 554 полезных сообщений
(для 1,772 пользователей)
Ответ: Исходница

Понеслась. Тут функции почти все мои, некоторые переделаны с других языков

Функции для работы с base64
Function base64_encode$(msg$)
    Local alph$="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    Local i=1
    While i<=Len(msg$)
        If i<=Len(msg$)-2
            c1=Asc(Mid$(msg$,i,1))
            c2=Asc(Mid$(msg$,i+1,1))
            c3=Asc(Mid$(msg$,i+2,1))
            e1=c1 Shr 2
            e2=((c1 And 3) Shl 4) Or (c2 Shr 4)
            e3=((c2 And 15) Shl 2) Or (c3 Shr 6)
            e4=c3 And 63
        Else
            If i=Len(i)-1 Then
                e3=64
                e4=63
            Else 
                e4=64
            EndIf 
        EndIf
        i=i+3
        r$=r$+Mid$(alph$,e1+1,1)+Mid$(alph$,e2+1,1)+Mid$(alph$,e3+1,1)+Mid$(alph$,e4+1,1)
    Wend
    Return r$
End Function 

Function base64_decode$(msg$)
    Local alph$="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    Local i=1
    While i<=Len(msg$)
        e1=Instr(alph$,Mid$(msg$,i,1))-1
        e2=Instr(alph$,Mid$(msg$,i+1,1))-1
        e3=Instr(alph$,Mid$(msg$,i+2,1))-1
        e4=Instr(alph$,Mid$(msg$,i+3,1))-1
        c1=(e1 Shl 2) Or (e2 Shr 4)
        c2=((e2 And 15) Shl 4) Or (e3 Shr 2)
        c3=((e3 And 3) Shl 6) Or e4
        r$=r$+Chr$(c1)
        If e3<>64 Then
            r$=r$+Chr$(c2)
        EndIf
        If e4<>64 Then
            r$=r$+Chr$(c3)
        EndIf 
        i=i+4
    Wend
    Return r$
End Function
Проверка года на высокосность
Function isLeapYear(year)
    Local a=year Mod 4
    Local b=year Mod 100
    Local c=year Mod 400
    If (a=0 And b<>0) Or c=0 Then
        Return True
    EndIf 
End Function
Номер дня в году (требует наличия предыдущей функции)
Function yearDay(day,month,year)
    Local temp#
    If month>2 Then
        temp=month+1
        temp=temp*30.6
        temp=temp-(temp Mod 1)
        temp=temp-(63-isLeapYear(year))
    Else
        temp=month-1
        temp=temp*(63-isLeapYear(year))
        temp=temp/2
        temp=temp-(temp Mod 1)
    EndIf
    temp=temp+day
    Return temp
End Function
Получаем данные максимально поддерживаемого графического режима
Function maxWidth()
    Return GfxModeWidth(CountGfxModes())
End Function

Function maxHeight()
    Return GfxModeHeight(CountGfxModes())
End Function

Function maxDepth()
    Return GfxModeDepth(CountGfxModes())
End Function
Перевод в юлианские дни
Function toJulian(day%,month%,year%)
    Local a%,y%,m%
    a=(14-month)/12
    y=year+4800-a
    m=month+12*a-3
    Return day+(153*m+2)/5+365*y+y/4-y/100+y/400-32045
End Function
Функции, возвращающие соответственно день, месяц и год из юлианских дней
Function julianDay(jd%)
    l=jd+68569
    n=(4*l)/146097
    l=l-(146097*n+3)/4
    i=(4000*(l+1))/1461001
    l=l-(1461*i)/4+31
    j=(80*l)/2447
    d=l-(2447*j)/80
    Return d
End Function

Function julianMonth(jd%)
    l=jd+68569
    n=(4*l)/146097
    l=l-(146097*n+3)/4
    i=(4000*(l+1))/1461001
    l=l-(1461*i)/4+31
    j=(80*l)/2447
    l=j/11
    m=j+2-(12*l)
    Return m
End Function

Function julianYear(jd%)
    l=jd+68569
    n=(4*l)/146097
    l=l-(146097*n+3)/4
    i=(4000*(l+1))/1461001
    l=l-(1461*i)/4+31
    j=(80*l)/2447
    d=l-(2447*j)/80
    l=j/11
    y=100*(n-49)+i+l
    Return y
End Function
RYB -> RGB. Правда, задаёт цвет, а не меняет его. Пригодится, если вы делаете программу, где необходимо смешение цветов как в красках.
Function setRYB(iR#,iY#,iB#)
    Local x0#,x1#,x2#,x3#,y0#,y1#

    x0=cubicInt(iB,1.0,0.163)
    x1=cubicInt(iB,1.0,0.0)
    x2=cubicInt(iB,1.0,0.5)
    x3=cubicInt(iB,1.0,0.2)
    y0=cubicInt(iY,x0,x1)
    y1=cubicInt(iR,x2,x3)
    red=cubicInt(iR,y0,y1)*255

    x0=cubicInt(iB,1.0,0.373)
    x1=cubicInt(iB,1.0,0.66)
    x2=cubicInt(iB,0.0,0.0)
    x3=cubicInt(iB,0.5,0.094)
    y0=cubicInt(iY,x0,x1)
    y1=cubicInt(iY,x2,x3)
    green=cubicInt(iR,y0,y1)*255

    x0=cubicInt(iB,1.0,0.6)
    x1=cubicInt(iB,0.0,0.2)
    x2=cubicInt(iB,0.0,0.5)
    x3=cubicInt(iB,0.0,0.0)
    y0=cubicInt(iY,x0,x1)
    y1=cubicInt(iY,x2,x3)
    blue=cubicInt(iR,y0,y1)*255

    Color red,green,blue
End Function

Function cubicInt#(t#,a#,b#)
    weight#=t#*t#*(3-2*t#)
    Return a#+weight#*(b#-a#)
End Function
Читаем ID3-теги (первой версии) из MP3
Function ID3_GetInfo(file$)
    FMusic=ReadFile(file$)
    BInfo=CreateBank(127)
    If Not FMusic Then
        FreeBank BInfo
        Return 0
    EndIf
    If Left$(ReadLine$(FMusic),3)<>"ID3" Then
        CloseFile FMusic
        FreeBank BInfo
        Return 0
    EndIf
    SeekFile FMusic,FileSize(file$)-128
    For i=0 To 126
        PokeByte BInfo,i,ReadByte(FMusic)
    Next
    For i=0 To 2
        STag$=STag$+Chr$(PeekByte(BInfo,i))
    Next
    If STag$<>"TAG" Then
        CloseFile FMusic
        FreeBank BInfo
        Return 0
    EndIf
    CloseFile FMusic
    Return BInfo
End Function

Function ID3_GetTitle$(BInfo)
    For i=3 To 30
        IByte=PeekByte(BInfo,i)
        If IByte<>0 Then
            STitle$=STitle$+Chr$(IByte)
        Else
            If Len(STitle$)>0 Then
                Return STitle$
            Else
                Return 0
            EndIf 
        EndIf 
    Next 
End Function

Function ID3_GetInterpreter$(BInfo)
    For i=33 To 63
        IByte=PeekByte(BInfo,i)
        If IByte<>0 Then
            SInterpreter$=SInterpreter$+Chr$(IByte)
        Else
            If Len(SInterpreter$)>0 Then
                Return SInterpreter$
            Else
                Return 0
            EndIf 
        EndIf 
    Next 
End Function

Function ID3_GetAlbum$(BInfo)
    For i=63 To 93
        IByte=PeekByte(BInfo,i)
        If IByte<>0 Then
            SAlbum$=SAlbum$+Chr$(IByte)
        Else
            If Len(SAlbum$)>0 Then
                Return SAlbum$
            Else
                Return 0
            EndIf 
        EndIf 
    Next 
End Function

Function ID3_GetYear$(BInfo)
    For i=93 To 96
        IByte=PeekByte(BInfo,i)
        If IByte>=48 And IByte<=57 Then 
            SYear$=SYear$+Chr$(IByte)
        Else
            Return 0
        EndIf 
    Next
    Return SYear$
End Function

Function ID3_GetComment$(BInfo)
    For i=97 To 127
        IByte=PeekByte(BInfo,i)
        If IByte<>0 Then
            SComment$=SComment$+Chr$(IByte)
        Else
            If Len(SComment$)>0 Then
                Return SComment$
            Else
                Return 0
            EndIf 
        EndIf 
    Next 
End Function
HTTP-запрос. Поддерживает перенаправления
Function httpGetRequest$(http_url$)
    If Left$(http_url$,7)="http://" Then
        http_url$=Mid$(http_url$,8)
    EndIf
    If Instr(http_url$,"/") Then
        http_host$=Left$(http_url$,Instr(http_url$,"/")-1)
        http_file$=Mid$(http_url$,Instr(http_url$,"/"))
    Else
        http_host$=http_url$
        http_file$="/"
    EndIf
    http_stream=OpenTCPStream(http_host$,80)
    If Not http_stream Then Return 0
    WriteLine http_stream,"GET "+http_file$+" HTTP/1.1"
    WriteLine http_stream,"Host: "+http_host$
    WriteLine http_stream,"Connection: close"
    WriteLine http_stream,""
    Repeat
        Delay 1
    Until ReadAvail(http_stream)<>0
    
    Repeat
        http_header$=ReadLine(http_stream)
        If Left(http_header$,9)="Location:"
            If Mid(http_header$,11,4)="http" Then
                Return httpGetRequest(Mid$(http_header$,11))
            Else
                Return httpGetRequest("http://"+http_host$+Mid$(http_header$,11))
            EndIf 
        EndIf 
    Until http_header$=""
    While Not Eof(http_stream)
        http_res$=http_res$+Chr$(ReadByte(http_stream))
    Wend
    
    res$=http_res$
    Return res$
End Function
Скачивание файла по HTTP. Также поддерживает перенаправление
Function httpGetFile(http_url$,savename$)
    If Left$(http_url$,7)="http://" Then
        http_url$=Mid$(http_url$,8)
    EndIf
    If Instr(http_url$,"/") Then
        http_host$=Left$(http_url$,Instr(http_url$,"/")-1)
        http_file$=Mid$(http_url$,Instr(http_url$,"/"))
    Else
        http_host$=http_url$
        http_file$="/"
    EndIf
    http_stream=OpenTCPStream(http_host$,80)
    If Not http_stream Then Return 0
    WriteLine http_stream,"GET "+http_file$+" HTTP/1.1"
    WriteLine http_stream,"Host: "+http_host$
    WriteLine http_stream,"Connection: close"
    WriteLine http_stream,""
    Repeat
        Delay 1
    Until ReadAvail(http_stream)<>0
    
    Repeat
        http_header$=ReadLine(http_stream)
        If Left(http_header$,9)="Location:"
            If Mid(http_header$,11,4)="http" Then
                Return httpGetFile(Mid$(http_header$,11),savename$)
            Else
                Return httpGetFile("http://"+http_host$+Mid$(http_header$,11),savename$)
            EndIf 
        EndIf 
    Until http_header$=""
    
    http_result=WriteFile(savename$)
    
    While Not Eof(http_stream)
        WriteByte http_result,ReadByte(http_stream)
    Wend

    CloseFile http_result
End Function
Получение unixtime из текущего и заданого времени:
Function unixtime()
    day=Int(CurrentDate$())
    year=Int(Right$(CurrentDate$(),4))
    Select Mid$(CurrentDate$(),4,3)
        Case "Jan"
            month=1
        Case "Feb"
            month=2
        Case "Mar"
            month=3
        Case "Apr"
            month=4
        Case "May"
            month=5
        Case "Jun"
            month=6
        Case "Jul"
            month=7
        Case "Aug"
            month=8
        Case "Sep"
            month=9
        Case "Oct"
            month=10
        Case "Nov"
            month=11
        Case "Dec"
            month=12
    End Select
    hour=Int(CurrentTime$())
    minute=Int(Mid(CurrentTime$(),4,2))
    second=Int(Right(CurrentTime$(),2))
    a=(14-month)/12
    y=year+4800-a
    m=month+12*a-3
    temp=day+(153*m+2)/5+365*y+y/4-y/100+y/400-32045
    temp=(temp-2440588)*24*60*60
    temp=temp+60*60*hour+60*minute+second
    Return temp
End Function

Function time(day,month,year,hour=0,minute=0,second=0)
    a=(14-month)/12
    y=year+4800-a
    m=month+12*a-3
    temp=day+(153*m+2)/5+365*y+y/4-y/100+y/400-32045
    temp=(temp-2440588)*24*60*60
    temp=temp+60*60*hour+60*minute+second
    Return temp
End Function
Создаёт квадратное поле размера w на h с шириной квадратной ячейки в sz
Function createField(w%,h%,sz#=1.0)
    m=CreateMesh()
    s=CreateSurface(m)
    For i=-h/2 To h/2
        For j=-h/2 To w/2
            sv#=(1/Float(w))*Float(i)
            su#=(1/Float(h))*Float(j)
            v=AddVertex(s,i*sz#,0,j*sz#,su#,sv#)
        Next 
    Next
    For i=0 To h-1
        For j=0 To w-1
            v1=i*(w+1)+j
            v2=i*(w+1)+j+1
            v3=i*(w+1)+j+w+1
            v4=i*(w+1)+j+w+2
            t1=AddTriangle(s,v1,v2,v3)
            t2=AddTriangle(s,v3,v2,v4)
        Next 
    Next
    UpdateNormals m
    Return m
End Function
Вот вроде бы и всё, если откопаю среди своего го.. добра еще что-нибудь - выложу
(Offline)
 
Ответить с цитированием
Эти 14 пользователя(ей) сказали Спасибо Tadeus за это полезное сообщение:
Arton (09.07.2010), baton4ik (08.07.2010), DStalk (23.10.2010), Egor Rezenov (01.11.2010), genroelgvozo (12.11.2010), impersonalis (08.07.2010), is.SarCasm (08.07.2010), MadMedic (13.10.2010), MisterAlex (27.08.2010), PackegerX (04.09.2011), Randomize (08.07.2010), Reks888 (09.07.2010), SBJoker (08.07.2010), viper86 (20.10.2010)
Старый 09.07.2010, 11:46   #10
impersonalis
Зануда с интернетом
 
Аватар для impersonalis
 
Регистрация: 04.09.2005
Сообщений: 14,014
Написано 6,798 полезных сообщений
(для 20,935 пользователей)
Ответ: Исходница

Преобразование short (2байта), засейвенного в 4-байтовом блитцевском int-е, в адекватный 4-байтовый блитцевский же инт.
Function Short2Int%(a%)
	Local M1%=%00000000000000001000000000000000
	Local M2%=%11111111111111110000000000000000
	Local D%=a And M1
	If D
		a = a Xor M2
	EndIf
	Return a
End Function
Например вы получили от DLL банку с шортами, и делаете что-то типа:
PeekShort...
в инт. И на выходе - дурь, а надо делать особую магию:
Short2Int(PeekShort...
И тогда, наверняка, вдруг запашет прога та
__________________
http://nabatchikov.com
Мир нужно делать лучше и чище. Иначе, зачем мы живем? tormoz
А я растила сына на преданьях
о принцах, троллях, потайных свиданьях,
погонях, похищениях невест.
Да кто же знал, что сказка душу съест?
(Offline)
 
Ответить с цитированием
Эти 4 пользователя(ей) сказали Спасибо impersonalis за это полезное сообщение:
baton4ik (09.07.2010), is.SarCasm (09.07.2010), Randomize (14.07.2010), Reks888 (09.07.2010)
Старый 31.08.2010, 08:48   #11
Randomize
[object Object]
 
Аватар для Randomize
 
Регистрация: 01.08.2008
Адрес: В России
Сообщений: 4,354
Написано 2,470 полезных сообщений
(для 6,850 пользователей)
Ответ: Исходница

Ну чочо, продолжим:

Чётность:
Function IsOddvalue )
    If 
value =0 Then Return 0
    
    
If Floatvalue Mod 2 ) <>0 Then Return Else Return 0
End 
Function 
HEX в INT:
Function Hex2Int%(h$)
    
Local z,i
    
    Local t2
$= Upper$(Trim$(h$))
    
Local d% = 0
    
    
For 1 To Len(t2$)
        
Instr("0123456789ABCDEF",Mid$(t2$,z,1))
        If (
0Then d 16 1
    Next
    
Return d
End 
Function 

Узнать размер куба, в который вписан меш.
Когда пользовался PhysX`ом функция была дико полезна.
Global EntityBoxX#, EntityBoxY#, EntityBoxZ#
Function GetEntityBox(entrecursive Trueroot 0)
If 
root 0 Then
    EntityBoxX
# = 0
    
EntityBoxY# = 0
    
EntityBoxZ# = 0
Else
    
ox# = EntityX(ent, True) - EntityX(root, True)
    
oy# = EntityY(ent, True) - EntityY(root, True)
    
oz# = EntityZ(ent, True) - EntityZ(root, True)
EndIf
cnt_surf CountSurfaces(ent)
For 
1 To cnt_surf
    surf 
GetSurface(ents)
    
cnt_verts CountVertices(surf) - 1
    
For 0 To cnt_verts
        vx
# = Abs(VertexX(surf, v) + ox#)
        
vy# = Abs(VertexY(surf, v) + oy#)
        
vz# = Abs(VertexZ(surf, v) + oz#)
        
If (vx# > EntityBoxX#) Then EntityBoxX# = vx#
        
If (vy# > EntityBoxY#) Then EntityBoxY# = vy#
        
If (vz# > EntityBoxZ#) Then EntityBoxZ# = vz#
    
Next
Next
If recursive Then
    
If root 0 Then root ent
    cnt_children 
CountChildren(ent)
    For 
1 To cnt_children
        GetEntityBox
(GetChild(enti), Trueroot)
    
Next
EndIf
End Function 
(Offline)
 
Ответить с цитированием
Эти 3 пользователя(ей) сказали Спасибо Randomize за это полезное сообщение:
Arles (31.08.2010), baton4ik (31.08.2010), impersonalis (31.08.2010)
Старый 31.08.2010, 12:39   #12
impersonalis
Зануда с интернетом
 
Аватар для impersonalis
 
Регистрация: 04.09.2005
Сообщений: 14,014
Написано 6,798 полезных сообщений
(для 20,935 пользователей)
Ответ: Исходница

Позвольте не согласиться с первой реализацией: чётность проверяется сравнением последнего бита с 0.
Нужно битово домножить число на маску 00000000 00000000 00000000 00000001 а затем результат сравнить с 0. Если =0, то число чётное (т.е. можно сразу return (value and mask) ).
В этой реализации нет долгих арифметических операций (тем паче деления!) и не надо реализовывать отдельную проверку для 0.
(б3д под рукой нет)

А так - занятные фунЕции
__________________
http://nabatchikov.com
Мир нужно делать лучше и чище. Иначе, зачем мы живем? tormoz
А я растила сына на преданьях
о принцах, троллях, потайных свиданьях,
погонях, похищениях невест.
Да кто же знал, что сказка душу съест?
(Offline)
 
Ответить с цитированием
Эти 3 пользователя(ей) сказали Спасибо impersonalis за это полезное сообщение:
ABTOMAT (31.08.2010), Randomize (31.08.2010), SBJoker (31.08.2010)
Старый 13.10.2010, 12:55   #13
impersonalis
Зануда с интернетом
 
Аватар для impersonalis
 
Регистрация: 04.09.2005
Сообщений: 14,014
Написано 6,798 полезных сообщений
(для 20,935 пользователей)
Ответ: Исходница

Порт (реализация средствами б3д) функции из темы http://forum.boolean.name/showthread.php?t=9230 ( www.boolean.name > Программирование игр для компьютеров > C++ : Проверка: является ли строка числом?)
Проверка: является ли текст в строке числом.
Function CheckIsNum%(S$)
	Local sDIGIT%=1
	Local sEXP%=2
	Local sSEP%=3
	Local sSIGN%=4
	Local sETC%=5
	Local Key%
	Local i%
	Local b%
	Local Epos%=-1
	Local Spos%=-1
	Local ExitFlag%=True
	Local cLEN%=Len(S)
	For i=1 To cLEN
		If Not ExitFlag
			Exit
		EndIf
		b=Asc(Mid(S,i,1))
		If b>=Asc("0") And b<=Asc("9")
			Key=sDIGIT
		ElseIf b=Asc("E") Or b=Asc("e")
			Key=sEXP
		ElseIf b=Asc(".") Or b=Asc(",")
			Key=sSEP
		ElseIf b=Asc("+") Or b=Asc("-")
			Key=sSIGN
		Else
			Key=sETC
		EndIf
		Select Key
			Case sDIGIT
				;
			Case sEXP
				If Epos<>-1
					ExitFlag=False
				Else
					Epos=i
				EndIf
			Case sSEP
				If Spos<>-1
					ExitFlag=False
				Else
					Spos=i
				EndIf
			Case sSIGN
				If i<>1 And Epos<>i-1
					ExitFlag=False
				EndIf
			Case sETC
				ExitFlag=False
		End Select
	Next
	Return ExitFlag
End Function

Q$="ололо"
DebugLog Q+" "+CheckIsNum(Q)
Q$="15445.1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="12БЛДЖАД!"
DebugLog Q+" "+CheckIsNum(Q)
Q$="123.345E-12"
DebugLog Q+" "+CheckIsNum(Q)
Q$="23.2gh465E-1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="23.2465E-1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="sdgf23.2465E-1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="1+1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="+.12E-008"
DebugLog Q+" "+CheckIsNum(Q)
Q$="+.12E-008.1"
DebugLog Q+" "+CheckIsNum(Q)
__________________
http://nabatchikov.com
Мир нужно делать лучше и чище. Иначе, зачем мы живем? tormoz
А я растила сына на преданьях
о принцах, троллях, потайных свиданьях,
погонях, похищениях невест.
Да кто же знал, что сказка душу съест?
(Offline)
 
Ответить с цитированием
Сообщение было полезно следующим пользователям:
Randomize (13.10.2010)
Старый 20.10.2010, 13:50   #14
impersonalis
Зануда с интернетом
 
Аватар для impersonalis
 
Регистрация: 04.09.2005
Сообщений: 14,014
Написано 6,798 полезных сообщений
(для 20,935 пользователей)
Ответ: Исходница

UPD функции, согласно посту №28 из темы
http://forum.boolean.name/showthread.php?t=9230 ( www.boolean.name > Программирование игр для компьютеров > C++ : Проверка: является ли строка числом?)
Проверка: является ли текст в строке числом.
http://forum.boolean.name/showpost.p...2&postcount=28
Function CheckIsNum%(S$)
	Local sDIGIT%=1
	Local sEXP%=2
	Local sSEP%=3
	Local sSIGN%=4
	Local sETC%=5
	Local Key%
	Local i%
	Local b%
	Local Epos%=-1
	Local Spos%=-1
	Local ExitFlag%=True
	Local IsClose%=False
	Local cLEN%=Len(S)
	For i=1 To cLEN
		If Not ExitFlag
			Exit
		EndIf
		b=Asc(Mid(S,i,1))
		If b>=Asc("0") And b<=Asc("9")
			Key=sDIGIT
		ElseIf b=Asc("E") Or b=Asc("e")
			Key=sEXP
		ElseIf b=Asc(".") Or b=Asc(",")
			Key=sSEP
		ElseIf b=Asc("+") Or b=Asc("-")
			Key=sSIGN
		Else
			Key=sETC
		EndIf
		IsClose=False
		Select Key
			Case sDIGIT
				IsClose=True
			Case sEXP
				If Epos<>-1
					ExitFlag=False
				Else
					Epos=i
				EndIf
			Case sSEP
				If Spos<>-1
					ExitFlag=False
				Else
					Spos=i
				EndIf
			Case sSIGN
				If i<>1 And Epos<>i-1
					ExitFlag=False
				EndIf
			Case sETC
				ExitFlag=False
		End Select
	Next
	If Not IsClose
		ExitFlag=False
	EndIf
	Return ExitFlag
End Function

Q$="ололо"
DebugLog Q+" "+CheckIsNum(Q)
Q$="15445.1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="12БЛДЖАД!"
DebugLog Q+" "+CheckIsNum(Q)
Q$="123.345E-12"
DebugLog Q+" "+CheckIsNum(Q)
Q$="23.2gh465E-1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="23.2465E-1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="sdgf23.2465E-1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="1+1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="+.12E-008"
DebugLog Q+" "+CheckIsNum(Q)
Q$="+.12E-008.1"
DebugLog Q+" "+CheckIsNum(Q)
Q$="E"
DebugLog Q+" "+CheckIsNum(Q)
Q$=""
DebugLog Q+" "+CheckIsNum(Q)
Q$="+"
DebugLog Q+" "+CheckIsNum(Q)
Q$="-"
DebugLog Q+" "+CheckIsNum(Q)
Q$="."
DebugLog Q+" "+CheckIsNum(Q)

ВОТ БЛИН РЕАЛЬНО - куда девается кнопка "правка" под постом. Убирается от времени?
Ответ самому себе (тему создавать опасно: опять процитируют 12 стульев, обматерят в асе и надуютцо как фифы) - http://forum.boolean.name/showpost.p...5&postcount=15
__________________
http://nabatchikov.com
Мир нужно делать лучше и чище. Иначе, зачем мы живем? tormoz
А я растила сына на преданьях
о принцах, троллях, потайных свиданьях,
погонях, похищениях невест.
Да кто же знал, что сказка душу съест?
(Offline)
 
Ответить с цитированием
Эти 3 пользователя(ей) сказали Спасибо impersonalis за это полезное сообщение:
Colossus (20.10.2010), Kudesnic (20.10.2010), Randomize (21.10.2010)
Старый 12.11.2010, 11:50   #15
impersonalis
Зануда с интернетом
 
Аватар для impersonalis
 
Регистрация: 04.09.2005
Сообщений: 14,014
Написано 6,798 полезных сообщений
(для 20,935 пользователей)
Ответ: Исходница

Сообщение от Tadeus Посмотреть сообщение
Понеслась. Тут функции почти все мои, некоторые переделаны с других языков



HTTP-запрос. Поддерживает перенаправления
Function httpGetRequest$(http_url$)
    If Left$(http_url$,7)="http://" Then
        http_url$=Mid$(http_url$,8)
    EndIf
    If Instr(http_url$,"/") Then
        http_host$=Left$(http_url$,Instr(http_url$,"/")-1)
        http_file$=Mid$(http_url$,Instr(http_url$,"/"))
    Else
        http_host$=http_url$
        http_file$="/"
    EndIf
    http_stream=OpenTCPStream(http_host$,80)
    If Not http_stream Then Return 0
    WriteLine http_stream,"GET "+http_file$+" HTTP/1.1"
    WriteLine http_stream,"Host: "+http_host$
    WriteLine http_stream,"Connection: close"
    WriteLine http_stream,""
    Repeat
        Delay 1
    Until ReadAvail(http_stream)<>0
    
    Repeat
        http_header$=ReadLine(http_stream)
        If Left(http_header$,9)="Location:"
            If Mid(http_header$,11,4)="http" Then
                Return httpGetRequest(Mid$(http_header$,11))
            Else
                Return httpGetRequest("http://"+http_host$+Mid$(http_header$,11))
            EndIf 
        EndIf 
    Until http_header$=""
    While Not Eof(http_stream)
        http_res$=http_res$+Chr$(ReadByte(http_stream))
    Wend
    
    res$=http_res$
    Return res$
End Function
Вот вроде бы и всё, если откопаю среди своего го.. добра еще что-нибудь - выложу
ну а закрывать соединение кто будет?
__________________
http://nabatchikov.com
Мир нужно делать лучше и чище. Иначе, зачем мы живем? tormoz
А я растила сына на преданьях
о принцах, троллях, потайных свиданьях,
погонях, похищениях невест.
Да кто же знал, что сказка душу съест?
(Offline)
 
Ответить с цитированием
Ответ


Опции темы

Ваши права в разделе
Вы не можете создавать темы
Вы не можете отвечать на сообщения
Вы не можете прикреплять файлы
Вы не можете редактировать сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.


Часовой пояс GMT +4, время: 01:10.


vBulletin® Version 3.6.5.
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Перевод: zCarot
Style crйe par Allan - vBulletin-Ressources.com