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

Spiderman · 12.03.2009, 17:44

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

Прошу выкладывать только код, т.е. эта тема посвящена только исходному коду и не затрагивает библиотеки

Spiderman · 12.03.2009, 17:48

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

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

Spiderman · 13.03.2009, 17:04

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

Вычисление расстояния до объекта:

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 ...

Randomize · 29.06.2010, 18:14

Сегодня понадобилась функция разбиения строки:
Например имеем: 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 = Mid( delimiter, 1, 1)

    

    For t=1 To StrLen

        If Mid(mystring$,t,1)=delimiter Or Mid(mystring$,t,1)="" Then

            SplitResult(SplitCount)=Trim( Mid( mystring$, start, t-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 i = 0 To SplitCount

    Print SplitResult(i)

Next

WaitKey

End

impersonalis · 29.06.2010, 18:19

http://forum.boolean.name/showthread.php?t=47

Randomize · 29.06.2010, 18:37

Рекурсивный пробег по чилдам:


			
Function SeekChilds(ent) 

    Local i, child

    

    For i=1 To CountChildren(ent) 

        child=GetChild(ent,i) 

        If child<>0 

            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 i, child

    

    For i=1 To CountChildren(ent) 

        child=GetChild(ent,i) 

        If child<>0 

            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 моделирования как игровой редактор карт.

Randomize · 29.06.2010, 18:50

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


			
Dim IMMouseUP  (3)

Dim IMMouseDown(3)

Dim IMMouseHit (3)



Function IMUpdate()

    Local i

    For i=1 To 3

        IMMouseUP( i )   = IMMouseDown( i )

        IMMouseHit( i )  = (MouseHit( i ) > 0)

        IMMouseDown( i ) = MouseDown( i )

    

        If(IMMouseUP( i ) = True And IMMouseDown( i ) = False)

            IMMouseUP( i ) = True

        Else

            IMMouseUP( i ) = False

        EndIf

    Next

End Function

В начало игрового цикла вставляем IMUpdate().
Приставка IM - Input manager (Менеджер ввода)
Вместо MouseDown пишем IMMouseDown
Вместо IMMouseHit пишем IMMouseHit
И конечно IMMouseUP, которая возвращаят True при отпускании кнопки.

Это решает сразу 2 беды.
1) Нет MouseUP
2) Как вы наверное заметили, при повторном вызывании ф-ции MouseHit или MouseDown в цикле функция возвращает False, хотя при первом вызове True. Чтобы этого избежать приходилось заводить глобальные переменные. Теперь это в прошлом.

baton4ik · 07.07.2010, 16:00

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

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. Если кому-то надо, могу выложить вариант с типами вместо массивов

Tadeus · 08.07.2010, 03:13

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

Функции для работы с 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

Вот вроде бы и всё, если откопаю среди своего го.. добра еще что-нибудь - выложу

impersonalis · 09.07.2010, 11:46

Преобразование 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...

И тогда, наверняка, вдруг запашет прога та

Randomize · 31.08.2010, 08:48

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

Чётность:


			
Function IsOdd( value )

    If value =0 Then Return 0

    

    If Float( value Mod 2 ) <>0 Then Return 1 Else Return 0

End Function

HEX в INT:


			
Function Hex2Int%(h$)

    Local z,i

    

    Local t2$= Upper$(Trim$(h$))

    Local d% = 0

    

    For z = 1 To Len(t2$)

        i = Instr("0123456789ABCDEF",Mid$(t2$,z,1))

        If (i > 0) Then d = d * 16 + i - 1

    Next

    Return d

End Function

Узнать размер куба, в который вписан меш.
Когда пользовался PhysX`ом функция была дико полезна.


			
Global EntityBoxX#, EntityBoxY#, EntityBoxZ#

Function GetEntityBox(ent, recursive = True, root = 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 s = 1 To cnt_surf

    surf = GetSurface(ent, s)

    cnt_verts = CountVertices(surf) - 1

    For v = 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 i = 1 To cnt_children

        GetEntityBox(GetChild(ent, i), True, root)

    Next

EndIf

End Function

impersonalis · 31.08.2010, 12:39

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

А так - занятные фунЕции

impersonalis · 13.10.2010, 12:55

Порт (реализация средствами б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)

impersonalis · 20.10.2010, 13:50

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)

impersonalis · 12.11.2010, 11:50