Tips 'n' Tricks, (code library) Опции

[Guevara-chan]

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

Код

; *=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*
; Untyped stack library v0.71
; Developed in 2009 by Guevara-chan.
; *=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*

Structure StackData
*Base
*TOS
Size.i
Growth.i
EndStructure

; AllocateStack(Size.i, Growth) - creates stack of specifed size with specifed growth rate.
; Set 'Growth' to -1 for unlimited stack expansion.
; Returns point to newborn stack's data if successful.
ProcedureDLL AllocateStack(Size.i = 1, Growth.i = -1)
If Growth < -1 : ProcedureReturn #Null : EndIf
If Size < 0 : ProcedureReturn #Null : EndIf
Define *NewStack.StackData = AllocateMemory(SizeOf(StackData))
With *Newstack
\Base = AllocateMemory(Size)
\TOS = \Base
\Size = Size
\Growth = Growth
EndWith
ProcedureReturn *NewStack
EndProcedure

; FreeStack(*Stack.StackData) - completely disposes all stack's resources.
ProcedureDLL FreeStack(*Stack.StackData)
FreeMemory(*Stack\Base)
FreeMemory(*Stack)
EndProcedure

Macro __StackDepth(Stack); Psedo-procedure
Stack\TOS - Stack\Base
EndMacro

; StackDepth(*Stack.StackData) - returns current depth of stack (in bytes).
ProcedureDLL StackDepth(*Stack.StackData)
ProcedureReturn __StackDepth(*Stack)
EndProcedure

Macro __ResizeStack(Stack, NewSize, NewDepth); Psedo-procedure
Stack\Size = NewSize
Stack\Base = ReAllocateMemory(Stack\Base, Stack\Size)
Stack\TOS = Stack\Base + NewDepth
EndMacro

; ResizeStack(*Stack.StackData, NewSize.i) - reallocates stack to specifed size (in bytes).
; Content is fully preserved, returns new size of stack if successful.
ProcedureDLL ResizeStack(*Stack.StackData, NewSize.i)
If NewSize > 0
Define SDepth = __StackDepth(*Stack)
If SDepth > NewSize : SDepth = NewSize : EndIf
__ResizeStack(*Stack, NewSize, SDepth)
ProcedureReturn NewSize
EndIf
EndProcedure

; SeekStack(*Stack.StackData, NewPos.i = 0) - moves stack's top to specified position (in bytes).
; Returns #True if successful.
ProcedureDLL SeekStack(*Stack.StackData, NewPos.i = 0)
If NewPos => 0
If NewPos <= __StackDepth(*Stack)
*Stack\TOS = *Stack\Base + NewPos
ProcedureReturn #True
EndIf
EndIf
EndProcedure

Macro __CheckSize(Stack, RequestedSize); Partializer
Define SGrowth, SDepth = __StackDepth(Stack), OverHead = SDepth + RequestedSize - Stack\Size
If OverHead > 0; If you need more space...
If Stack\Growth = -1 : SGrowth = OverHead : Else : SGrowth = (OverHead / Stack\Growth + 1) * Stack\Growth : EndIf
If OverHead <= SGrowth; If it's possible to just resize stack...
__ResizeStack(Stack, Stack\Size + SGrowth, SDepth)
Else : ProcedureReturn #False
EndIf
EndIf
EndMacro

Macro __Def_StackProcs(TypeName, TypeLetter)
; PushX(*Stack.StackData, Value.X) - sends value of type X over top of the stack.
; Returns #True if successful.
ProcedureDLL Push#TypeLetter(*Stack.StackData, TypeName.TypeLetter)
__CheckSize(*Stack, SizeOf(TypeName))
Define *NewTOS.TypeName = *Stack\TOS
*NewTOS\TypeLetter = TypeName
*Stack\TOS + SizeOf(TypeName)
ProcedureReturn #True
EndProcedure
; PopX(*Stack.StackData) - receives value of type X from top of the stack.
ProcedureDLL.TypeLetter Pop#TypeLetter(*Stack.StackData)
If __StackDepth(*Stack) >= SizeOf(TypeName)
Define *Value.TypeName = *Stack\TOS - SizeOf(TypeName)
*Stack\TOS = *Value
ProcedureReturn *Value\TypeLetter
EndIf
EndProcedure
EndMacro

; PushData(*Stack.StackData, *Buffer, Length.i) - sends given number of bytes from buffer to stack.
; Returns #True if successful.
ProcedureDLL PushData(*Stack.StackData, *Buffer, Length.i)
If Length > 0 And *Buffer
__CheckSize(*Stack, Length)
With *Stack
CopyMemory(*Buffer, \TOS, Length)
\TOS + Length
EndWith
ProcedureReturn #True
EndIf
EndProcedure

; PopData(*Stack.StackData, *Buffer, Length.i) - receives given number of bytes from top of stack.
; Set '*Buffer' to #Null for restriction of memory copying into it.
; Returns address of result-containing buffer.
ProcedureDLL PopData(*Stack.StackData, *Buffer, Length.i)
If Length > 0
With *Stack
If __StackDepth(*Stack) >= Length : \TOS - Length
If *Buffer : CopyMemory(\TOS, *Buffer, Length)
Else : *Buffer = \TOS
EndIf
ProcedureReturn *Buffer
EndIf
EndWith
EndIf
EndProcedure

; PushS(*Stack.StackData, Text.s) - sends string, followed by integer size counter to top of stack.
; String size + SizeOf(Integer) bytes used, returns #True if successful.
ProcedureDLL PushS(*Stack.StackData, Text.s)
Define *SizeMark.Integer, TSize.i = StringByteLength(Text)
__CheckSize(*Stack, TSize + SizeOf(Integer))
With *Stack
PokeS(\TOS, Text)
*SizeMark = \TOS + TSize
*SizeMark\I = TSize
\TOS = *SizeMark + SizeOf(Integer)
ProcedureReturn #True
EndWith
EndProcedure

; PopS(*Stack.StackData) - receives string from top of stack.
ProcedureDLL.S PopS(*Stack.StackData)
Define SDepth = __StackDepth(*Stack)
If SDepth >= SizeOf(Integer)
With *Stack
Define *TSize.Integer = \TOS - SizeOf(Integer)
If SDepth - SizeOf(Integer) >= *TSize\I : \TOS = *TSize - *TSize\I
CompilerIf SizeOf(Character) = SizeOf(Unicode) : ProcedureReturn PeekS(\TOS, *TSize\I >> 1)
CompilerElse                                   : ProcedureReturn PeekS(\TOS, *TSize\I)
CompilerEndIf
EndIf
EndWith
EndIf
EndProcedure

__Def_StackProcs(Byte, B)
__Def_StackProcs(Word, W)
__Def_StackProcs(Long, L)
__Def_StackProcs(Float, F)
__Def_StackProcs(Quad, Q)
__Def_StackProcs(Double, D)
__Def_StackProcs(Character, C)
__Def_StackProcs(Integer, I)
__Def_StackProcs(Ascii, A)
__Def_StackProcs(Unicode, U)

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

Код

*Ptr = AllocateStack()
PushB(*Ptr, $FF)
PushB(*Ptr, $FF)
PushW(*Ptr, 0)
Debug "Yellow: '" + RSet(Hex(PopL(*Ptr)), 8, "0") + "'"
FreeStack(*Ptr)

[Guevara-chan]

Простейший образец пинга (опять же, PB):

Код

Structure ER
Reply.ICMP_ECHO_REPLY
Buffer.l[20]
EndStructure

Procedure Ping(IP$, Timeout)
hPort = IcmpCreateFile_()
Result = IcmpSendEcho_(hPort, inet_addr_(@IP$), @"Echo This.", Len("Echo This."), 0, @ECHO.ER, SizeOf(ER), Timeout)
IcmpCloseHandle_(hPort)
If Result = 0
ProcedureReturn -1
Else
ProcedureReturn ECHO\Reply\RoundTripTime
EndIf
EndProcedure

P.S. Очистила тему от флуда. Пишите по существу.

[Guevara-chan]

Относительно быстрые процедуры для работы с серой шкалой (PB/Asm):

Код

Procedure RGB2Gray(RGB)
! MOVZX EAX, byte [p.v_RGB]
! MOVZX EBX, byte [p.v_RGB+1]
! MOVZX ECX, byte [p.v_RGB+2]
! XOR DX, DX
! ADD AX, BX
! ADD AX, CX
! MOV CX, 3
! DIV CX
ProcedureReturn
EndProcedure

Procedure Gray2RGB(Level.a)
!XOR EAX, EAX
!MOV byte AH, [p.v_Level]
!MOV byte AL, AH
!SHL EAX, 8
!MOV AL, AH
ProcedureReturn
EndProcedure

[Etoprostoya]

Код

Procedure RGB2Gray(RGB)
! MOVZX EAX, byte [p.v_RGB]
! MOVZX EBX, byte [p.v_RGB+1]
! MOVZX ECX, byte [p.v_RGB+2]
! XOR DX, DX
! ADD AX, BX
! ADD AX, CX
! MOV CX, 21845
! MUL CX
! MOV EAX, EDX
ProcedureReturn
EndProcedure

Procedure Gray2RGB(Level.a)
!MOVD XMM0, [p.v_Level]
!PUNPCKLBW XMM0, XMM0
!PUNPCKLWD XMM0, XMM0
!PSRLDQ XMM0, 1
!MOVD eax, XMM0
ProcedureReturn
EndProcedure

Первая не совсем точная, но быстрее, чем деление (21845=2¹⁶/3). Можно ещё скорректировать, для полной точности, но уже не помню как точно (возможно и здесь чуть напортачил).
Вторая выглядит плохо только для одного пикселя, если обрабатывать по четыре или восемь пикселей за раз, то с незначительными изменениями будет быстрее и проще, особенно, если массив пикселей будет "align(16)".

[Guevara-chan]

Простейший генератор совместимых trip-кодов:

Код

Macro TranslateChar(Char)
Select Char; Обработка символа.
Case ':' To '@' : Char - ':' + 'A'
Case '[' To '`' : Char - '[' + 'a'
Case '.' To 'z'; NOOP
Default         : Char = '.'
EndSelect
EndMacro

Procedure.s Tripcode(Plain.s)
Define Salt.s{2}, *Char.Character = @Salt, *Char2.Character = @Salt + SizeOf(Character)
Define *Reader.Character = @Plain + SizeOf(Character)
Select Len(Plain)
Case 0, 1 : *Char\C = 'H' : *Char2\C = '.'; Пустой заменитель.
Case 2    : *Char\C = *Reader\C : *Char2\C = '.'; Половинная замена.
Default   : *Char\C = *Reader\C : *Reader + SizeOf(Character) : *Char2\C = *Reader\C
EndSelect : TranslateChar(*Char\C) : TranslateChar(*Char2\C); Замена символов.
ProcedureReturn Right(DESFingerprint(Plain, Salt), 10)
EndProcedure

[Guevara-chan]

Все-таки вязалась сегодня и скрепила воедино куски разнородного кода в работоспособный пример записи звука с выходного потока аудиокарты:

Код

; Function set for Input and Output Sound use WinAPI
; Ver 1.0a
; @SAM 2007 Rubtsovsk
; Reconstructed in 2013 by Guevara-chan.

;{ --Librarium--
;-Struct
;-Const
; описание возвращаемых процедурами ошибок
#iosNO_ERR=0; выполнено, ошибок нет
#iosERR=1;невыполнено,какая-то ошибка
#iosBAD_PAR=2; параметр передаваемый в процедуру не верен
#iosABSENT=3; невыполнено, т.к. процесс не запущен
#iosPROCESS=4;невыполнено, т.к. процесс запущен
#iosNO_INIT=5;невыполнено, т.к. не установлены параметры

;-Var
Global iosProcessStart.l; флаг работы процесса
Global ioswo.l,ioswi.l;хендлы события, потока и звук уст-ва.
Global ios.WAVEFORMATEX; структура описания формата
Global Dim iosbufIN.WAVEHDR(8),Dim iosbufOUT.WAVEHDR(8);Описатели для 4-ех буферов (In/Out)
Global iosNBuf.l,iosBufSize.l; кол-во и размер буфера в степени 2
Global Dim OutBuf.l(8), Dim InBuf.l(8); массивы буфферов
Global *iosFunc; указатель внешней функции обработки буферов

;-function

;процедура обновления буферов в режиме сквозного канала, в процессе выполняет внешнюю функцию
Procedure iosInOutProc( hwi.l, uMsg.l, dwInstance.l, dwParam1.l, dwParam2.l)
  If   iosProcessStart=1
   If uMsg=#MM_WIM_DATA
     For i=0 To iosNBuf
       If (iosbufIN(i)\dwFlags & #WHDR_DONE) = #WHDR_DONE                    
        waveInAddBuffer_(ioswi, @iosbufIN(i), SizeOf(WAVEHDR));принять данные с микшера
        CallFunctionFast( *iosFunc,InBuf(i),OutBuf(i),iosBufSize); обработка данных
        waveOutWrite_(ioswo,@iosbufOUT(i), SizeOf(WAVEHDR));воспроизвести        
       EndIf    
     Next    
   EndIf
  Else
   iosProcessStart=-1
  EndIf
EndProcedure

;процедура обновления буферов в режиме вывода звука в процессе выполняет внешнюю функцию
Procedure iosOutProc( hwi.l, uMsg.l, dwInstance.l, dwParam1.l, dwParam2.l)
  If   iosProcessStart=1
   If uMsg=#MM_WIM_DATA
     For i=0 To iosNBuf
       If (iosbufIN(i)\dwFlags & #WHDR_DONE) = #WHDR_DONE                  
        waveInAddBuffer_(ioswi, @iosbufIN(i), SizeOf(WAVEHDR));принять данные с микшера
        CallFunctionFast( *iosFunc,OutBuf(i),iosBufSize); обработка данных
        waveOutWrite_(ioswo,@iosbufOUT(i), SizeOf(WAVEHDR));воспроизвести        
       EndIf    
     Next    
   EndIf
  Else
   iosProcessStart=-1
  EndIf
EndProcedure

;процедура обновления буферов в режиме ввода звука в процессе выполняет внешнюю функцию
Procedure iosInProc( hwi.l, uMsg.l, dwInstance.l, dwParam1.l, dwParam2.l)
  If   iosProcessStart=1
   If uMsg=#MM_WIM_DATA
     For i=0 To iosNBuf
       If (iosbufIN(i)\dwFlags & #WHDR_DONE) = #WHDR_DONE                    
         waveInAddBuffer_(ioswi, @iosbufIN(i), SizeOf(WAVEHDR));принять данные с микшера
         CallFunctionFast( *iosFunc,InBuf(i),iosBufSize); обработка данных
       EndIf    
     Next    
   EndIf
  Else
   iosProcessStart=-1  
  EndIf
EndProcedure

;установка режима
;NBuf кол-во буферов(2-16)
;BufSize размер буфферов степень 2 (8-16)т.е. 256-65536 выборок
;SamplesPerSec частота выборок (из  стандартного ряда от 8000 до 96000)
;BitsPerSample размер выборки в битах(8,16,24,32)
;Channels кол-во каналов (1 или 2)
;возвращает #iosPROCESS-уже процесс запущен,#iosBAD_PAR-парамтры не верены,#iosNO_ERR- пораметры установлены
;но не факт, что с ними звуковая плата заработает
ProcedureDLL.l iosSetFormSound(NBuf.l,BufSize.l,SamplesPerSec.l,BitsPerSample.l,Channels.l)
   Protected i.l
   If iosProcessStart=1
     ProcedureReturn #iosPROCESS
   EndIf
   If BufSize<8 And BufSize>16
     ProcedureReturn #iosBAD_PAR
   EndIf  
   If NBuf<2 And NBuf>8
     ProcedureReturn #iosBAD_PAR
   EndIf
   If BitsPerSample<>8 And BitsPerSample<>16 And BitsPerSample<>24 And BitsPerSample<>32
     ProcedureReturn #iosBAD_PAR
   EndIf
   If Channels<>2 And Channels<>1
     ProcedureReturn #iosBAD_PAR
   EndIf
   If  SamplesPerSec<>24000 And SamplesPerSec<>32000 And SamplesPerSec<>44100 And SamplesPerSec<>48000 And SamplesPerSec<>96000 And SamplesPerSec<>16000 And SamplesPerSec<>22050 And SamplesPerSec<>11025 And SamplesPerSec<>8000
     ProcedureReturn #iosBAD_PAR
   EndIf                  
   iosNBuf=NBuf-1
   iosBufSize=(Channels*Pow(2,BufSize))*(BitsPerSample/8)
   For i=0 To iosNBuf
;   If  OutBuf(i)=0      
       OutBuf(i)=AllocateMemory(iosBufSize)
;   Else
;    ReAllocateMemory(OutBuf(i),iosBufSize)
;   EndIf    
;   If InBuf(i)=0        
       InBuf(i)=AllocateMemory(iosBufSize)
;   Else
;    ReAllocateMemory(InBuf(i),iosBufSize)
;   EndIf    
   Next    
; Определяем формат звука
   ios\wFormatTag= #WAVE_FORMAT_PCM
   ios\nChannels=Channels; кол-во каналов
   ios\nSamplesPerSec=SamplesPerSec;96000, 48000,32000, 22050, 24000, 11025, 8000 частота оцифровки
   ios\wBitsPerSample =BitsPerSample; 8,16,32 bit дискретность
   ios\nBlockAlign     = (ios\nChannels*ios\wBitsPerSample)/8
   ios\nAvgBytesPerSec = ios\nSamplesPerSec*ios\nBlockAlign; сколько байт на одну выборку
   ios\cbSize = 0  
   ProcedureReturn #iosNO_ERR
  EndProcedure

;возвращает число устройств ввода в компьютере
ProcedureDLL.l iosGetNumInDevace()
   ProcedureReturn waveInGetNumDevs_()+1;узнаем сколько устройств есть ввода
EndProcedure

;возвращает число устройств вывода в компьютере
ProcedureDLL.l iosGetNumOutDevace()
   ProcedureReturn waveOutGetNumDevs_()+1;узнаем сколько устройств есть вывода
EndProcedure

;возвращает имя устройства ввода в компьютере под номером Num
ProcedureDLL.s iosGetNameInDevace(Num.l)
     If waveInGetDevCaps_(Num-2,@Caps.WAVEINCAPS,SizeOf(WAVEINCAPS))=#MMSYSERR_NOERROR
      ProcedureReturn PeekS(@Caps\szPname,#MAXPNAMELEN)
     EndIf
EndProcedure

;возвращает имя устройства вывода в компьютере под номером Num
ProcedureDLL.s iosGetNameOutDevace(Num.l)
     If waveOutGetDevCaps_(Num-2,@Caps.WAVEINCAPS,SizeOf(WAVEINCAPS))=#MMSYSERR_NOERROR
       ProcedureReturn PeekS(@Caps\szPname,#MAXPNAMELEN)    
     EndIf
EndProcedure

;возвращает уровень звука воспроизведения главного канала
ProcedureDLL.l iosGetOutVolume()
   Protected  Vol.l
   waveOutGetVolume_(ioswo, @Vol)
   ProcedureReturn Vol
EndProcedure

;устанавливает уровень звука воспроизведения главного канала
ProcedureDLL.l iosSetOutVolume(volume.l)
If iosProcessStart.l=1
   waveOutSetVolume_(ioswo, volume)
Else
   ProcedureReturn #iosABSENT
EndIf    
EndProcedure

;запуск процесса
;NumInDev номер устройства ввода, если 0 то нет и ввода
;NumOutDev номер устройства вывода, если 0 то нет и вывода
;*func укозатель на функцию обработки буфферов
;возвращает #iosPROCESS-уже процесс запущен,#iosERR-ошибка,#iosNO_INIT-не установлен режим, #iosNO_ERR-запущен
ProcedureDLL.l iosStartProcess(NumInDev.l,NumOutDev.l,*func)
   Protected i.l,pri.l  
   If iosProcessStart=1
     ProcedureReturn #iosPROCESS
   EndIf
   If ios\wFormatTag<>1 And iosBifSize=0
     ProcedureReturn #iosNO_INIT
   EndIf
   If NumInDev>0 And NumOutDev>0
     If #MMSYSERR_NOERROR = waveInOpen_(@ioswi,#WAVE_MAPPER+NumInDev-2,@ios,@iosInOutProc(),0,#CALLBACK_FUNCTION|#WAVE_FORMAT_DIRECT)
; готовим буфeры
       For i=0 To iosNBuf
         iosbufIN(i)\lpData = InBuf(i)    
         iosbufIN(i)\dwBufferLength = iosBufSize
         waveInPrepareHeader_(ioswi, @iosbufIN(i), SizeOf(WAVEHDR));подг.  блок
         waveInAddBuffer_(ioswi,iosbufIN(i),SizeOf(WAVEHDR))      
       Next
     Else
       ProcedureReturn #iosERR
     EndIf
     If #MMSYSERR_NOERROR = waveOutOpen_(@ioswo,#WAVE_MAPPER+NumOutDev-2,@ios,0,0,#CALLBACK_NULL|#WAVE_FORMAT_DIRECT)
; готовим буфeры
       For i=0 To iosNBuf
        iosbufOUT(i)\lpData = OutBuf(i)    
        iosbufOUT(i)\dwBufferLength = iosBufSize      
        waveOutPrepareHeader_(ioswo, @iosbufOUT(i), SizeOf(WAVEHDR));подг.  блок      
       Next      
     Else
       ProcedureReturn #iosERR
     EndIf
   EndIf
   If NumInDev>0 And NumOutDev=0
     If #MMSYSERR_NOERROR = waveInOpen_(@ioswi,#WAVE_MAPPER+NumInDev-2,@ios,@iosInProc(),0,#CALLBACK_FUNCTION|#WAVE_FORMAT_DIRECT)
; готовим буфeры
       For i=0 To iosNBuf      
         iosbufIN(i)\lpData = InBuf(i)    
         iosbufIN(i)\dwBufferLength = iosBufSize
         waveInPrepareHeader_(ioswi, @iosbufIN(i), SizeOf(WAVEHDR));подг.  блок
         waveInAddBuffer_(ioswi,iosbufIN(i),SizeOf(WAVEHDR))      
       Next
     Else
       ProcedureReturn #iosERR
     EndIf
   EndIf
   If NumInDev=0 And NumOutDev>0
     If #MMSYSERR_NOERROR = waveInOpen_(@ioswi,#WAVE_MAPPER,@ios,@iosOutProc(),0,#CALLBACK_FUNCTION|#WAVE_FORMAT_DIRECT)
; готовим буфeры
       For i=0 To iosNBuf
         iosbufIN(i)\lpData = InBuf(i)    
         iosbufIN(i)\dwBufferLength = iosBufSize
         waveInPrepareHeader_(ioswi, @iosbufIN(i), SizeOf(WAVEHDR));подг.  блок
         waveInAddBuffer_(ioswi,iosbufIN(i),SizeOf(WAVEHDR))      
       Next
     Else
       ProcedureReturn #iosERR
     EndIf
     If #MMSYSERR_NOERROR = waveOutOpen_(@ioswo,#WAVE_MAPPER+NumOutDev-2,@ios,0,0,#CALLBACK_NULL|#WAVE_FORMAT_DIRECT)
; готовим буфeры
       For i=0 To iosNBuf
        iosbufOUT(i)\lpData = OutBuf(i)    
        iosbufOUT(i)\dwBufferLength = iosBufSize      
        waveOutPrepareHeader_(ioswo, @iosbufOUT(i), SizeOf(WAVEHDR));подг.  блок      
       Next      
     Else
       ProcedureReturn #iosERR
     EndIf
   EndIf        
     If #MMSYSERR_NOERROR <>  waveInStart_(iosWi);запустить запись со входа
       ProcedureReturn #iosERR
     EndIf
   *iosFunc=*func        
   iosProcessStart=1
   ProcedureReturn #iosNO_ERR
EndProcedure

;остановка процесса
;возвращает #iosNO_ERR-остановлен, #iosABSENT-процесс не запущен
ProcedureDLL.l iosStopProcess()
   Protected i.l
   If iosProcessStart.l=1
   iosProcessStart=0
   While iosProcessStart=0
     Delay(1)
   Wend
     waveInStop_(ioswi);остановить    
     waveInReset_(ioswi);остановить
     waveOutReset_(ioswo)              
     For i=0 To iosNBuf
       waveInUnprepareHeader_(ioswi, @iosbufIN(i), SizeOf(WAVEHDR));удалить  блок      
       waveOutUnprepareHeader_(ioswo, @iosbufOUT(i), SizeOf(WAVEHDR));удалить  блок    
     Next    
     waveInClose_(ioswo);
     waveOutClose_(ioswo);освободить звуковуху                      
     iosProcessStart.l=0
     ProcedureReturn #iosNO_ERR
   Else
     ProcedureReturn #iosABSENT  
   EndIf
EndProcedure
;} EndLibrarium

;;;;;;;;;;;;;;;;;;;;; Sampling goes here:;;;;;;;;;;;;;;;;;;;;;
;~ Header structure, to be make things a little easier:
Structure WAVHeader
RiffSig.l
RiffCount.l
WaveSig.l
fmtSig.l
TWaveFormat.l
w.WAVEFORMATEX
DataSig.l
DataCount.l
EndStructure

;~ Sample constant values.
#Samplerate = 44100
#Bitrate = 16
#Channels = 2
#BPS = #channels * #bitrate / 8 * #samplerate
#OutWidth = 640
#OutHeight = 380
#HalfHeight = #OutHeight / 2
#GridSize = 20
#BGWidth = #OutWidth + #GridSize
#BGHeight = #OutHeight + #GridSize
#GridOffset = #GridSize / 2
#SMain = 1
#SBackGround = 2
#SBlur = 3
#PixelSize = 1
#Title = ".[IO:Sound]."
#MaxFeeder = 180

; ~Pre-definitons:
Global StreamSize, FNAme.s = "NewWave.wav"
Define Header.WAVHeader, I
With Header
\RiffSig            = 'FFIR'
\WaveSig            = 'EVAW'
\fmtSig             = ' tmf'
\TWaveFormat        = SizeOf(WAVEFORMATEX)
\w\wFormatTag       =    #WAVE_FORMAT_PCM
\w\nChannels        =    #channels
\w\nSamplesPerSec   =    #samplerate
\w\wBitsPerSample   =    #bitrate
\w\nBlockAlign      =    (\w\nChannels * \w\wBitsPerSample) / 8
\w\nAvgBytesPerSec  =    \w\nSamplesPerSec * \w\nBlockAlign
\DataSig            = 'atad'
EndWith
InitSprite()

;~ Callbac multiprpose proc:
Macro CenterText(Message, X, Y, Color); Pseudo-procedure
DrawText(X - TextWidth(Message) / 2, Y - TextHeight(Message) / 2, Message, Color)
EndMacro

Macro FormatTime(MS); Pseudo-procedure
Str(MS/60000) + ":" + RSet(Str((MS/1000) % 60), 2, "0")
EndMacro

Procedure DataConvertIO(*inData.Word, *outData, bSize); Core
Static BGOffset, Feeder : WriteData(0, *inData, bSize)
If BGOffset = -#GridSize : BGOffset = -1 : Else : BGOffset - 1 : EndIf
If Feeder = #MaxFeeder : Feeder = 0 : Else : Feeder + 9 : EndIf
Define steping = bSize / 2460, y = #HalfHeight, dy, MS, TextColor
Define SinY = Y, DSinY, CosY = Y, DCosY, Power
StartDrawing(ImageOutput(#sMain))
DrawImage(ImageID(#SBackGround), BGOffset, BGOffset)
DrawAlphaImage(ImageID(#SBlur), 0, 0, 100)
DrawingMode(#PB_2DDrawing_Transparent | #PB_2DDrawing_AlphaBlend )
For I = 1 To #OutWidth : dy = y : *InData + 4 * steping
Power = *inData\W / 180 * 1.5
Y = #HalfHeight + Power : LineXY(i - 1, dy, i, y, #Green | $DD000000)
If I % 10 = 0
DSinY = SinY : SinY = #HalfHeight + Sin(Radian(i)) * Power
DCosY = CosY : CosY = #HalfHeight - Cos(Radian(i)) * Power
LineXY(I - 10, DSinY, I, SinY, #Yellow | $AA000000)
LineXY(I - 10, DCosY, I, CosY, #Cyan | $AA000000)
EndIf
Next I
GrabDrawingImage(#SBlur, 0, 0, #OutWidth, #OutHeight) : : MS = StreamSize + ElapsedMilliseconds(); Caching.
TextColor = RGBA(249, 91, 201, 155 + 100 * Abs(Sin(Radian(Feeder))))
CenterText("...Here records '" + FName + "', close to finalize...", #OutWidth / 2, 30, TextColor)
CenterText("-=[" + FormatTime(MS) + "]=-", #OutWidth / 2, #OutHeight - 30, TextColor) : StopDrawing()
StartDrawing(WindowOutput(0)) : DrawImage(ImageID(#SMain), 0, 0) : StopDrawing()
HideWindow(0, #False); Just to show it nice.
EndProcedure

;~ Actual work starts here:
Repeat : FName = Trim(SaveFileRequester("Choose destionation to save sound data:", FName,
"Waveform audio file (*.wav)|*.wav|All files (*.*)|*.*", 0)) : If Fname = "" : End; Exit for null.
ElseIf SelectedFilePattern() = 0 And LCase(GetExtensionPart(FName)) <> "wav" : FName + ".wav" : EndIf
Until CreateFile(0, FName) : Fname = GetFilePart(FName)
WriteData(0, @Header, SizeOf(Header))
OpenWindow(0, 0, 0, #OutWidth, #OutHeight, #Title, #PB_Window_SystemMenu|#PB_Window_ScreenCentered|#PB_Window_Invisible)
CreateImage(#SBackGround, #BGWidth, #BGHeight) : CreateImage(#sMain, #OutWidth, #OutHeight)
CopyImage(#sMain, #sBlur) : StartDrawing(ImageOutput(#SBackGround)) : SetActiveWindow(0)
For I = #GridOffset To #BGHeight Step #GridSize : Line(0, I, #BGWidth, #PixelSize, $4E4B05) : Next I
For I = #GridOffset To #BGWidth Step #GridSize : Line(I, 0, #PixelSize, #BgHeight, $4E4B05) : Next I
StopDrawing()
iosSetFormSound(4,12,#samplerate,#Bitrate,#channels)
StreamSize - ElapsedMilliseconds()
iosStartProcess(2,2,@DataConvertIO())
Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
iosStopProcess()
StreamSize + ElapsedMilliseconds() : StreamSize / 1000 * #BPS
Header\RiffCount = SizeOf(WAVHeader) + StreamSize
Header\DataCount = StreamSize
FileSeek(0, 0)
WriteData(0, @Header, SizeOf(Header))
CloseFile(0) : CloseWindow(0)
MessageRequester(#Title, StrF(StreamSize / 1024, 1) + " KB of data was written into '" + FName + "'.")

...Да, тут общая библиотека и пример ее работы. Даже, вот, вольная фантазия на тему осциллографа в комплекте имеется:

[Эроласт]

А что за язык?

[tolich]

Это DarkBASIC...

То есть, PureBasic, вечно я их путаю...

[Guevara-chan]

Как по мне, надо бы не путать, а допилить уже спец. флаги в тег "code". Оно ведь явно не PHP, согласитесь ?

[Guevara-chan]

Оптимизированное преобразование длинного слова (dword, да) в строку. Напомните мне на досуге допилить поддержку основ счисления больше 36:

Код

Procedure.s LongToStr(Val.l, Base.a = 10)
#MaxBase = 36; So far.
Define Sign.a, Accum.s{33}
If Base > 1 And Base <= #MaxBase; If operation ever applicable...
If Val < 0 : Val = -Val : Sign = '-' : EndIf
EnableASM
MOV EAX, Val
MOVZX EBX, Base
LEA ECX, Accum
DivMore:
SUB EDX, EDX  : DIV EBX
MOV DL, byte [EDX+l___ctable]
MOV [ECX], DL : INC ECX
CompilerIf #PB_Compiler_Unicode
INC ECX; One more.
CompilerEndIf
And EAX, EAX
JNZ l_longtostr_divmore; Спасибо Фреду за наше счастливое детство.
MOV DL, Sign : MOV [ECX], DL
DisableASM
ProcedureReturn ReverseString(Accum)
EndIf; Modulus-to-char conversion table:
DataSection : __CTable: : Data.a '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z' : EndDataSection
EndProcedure

[Guevara-chan]

Считаем длину строки (в символах) по указателю. Скорости сравнимы со стандартом:

Код

Procedure GageShortStr(*Ptr)
EnableASM
MOV EBX, *Ptr
MOV EAX, EBX
SUB ECX, ECX
CountMore:
CompilerIf #PB_Compiler_Unicode  
ADD EAX, 2
CMP word [EAX-2], CX
CompilerElse
INC EAX
CMP byte [EAX-1], CH
CompilerEndIf
JNZ l_asmgagestring_countmore
SUB EAX, EBX
CompilerIf #PB_Compiler_Unicode
SHR EAX, 1
CompilerEndIf
DEC EAX
ProcedureReturn
DisableASM
EndProcedure

Procedure GageLongStr(*Ptr)
EnableASM
CLD
MOV ECX, -1
MOV EDI, *Ptr
SUB EAX, EAX
CompilerIf #PB_Compiler_Unicode  
Repnz Scasw
CompilerElse
Repnz Scasb
CompilerEndIf
MOV EAX, -2
SUB EAX, ECX
ProcedureReturn
DisableASM
EndProcedure

[tolich]

Возможно я слегка отсталый в плане оптимизации кота, но почему не SCASB/SCASW?

[Guevara-chan]

Все просто - достаточно замерить скорости:

Код

Procedure AsmGageString(*Ptr.Character)
#CharSize = SizeOf(Character)
EnableASM
MOV EBX, *Ptr
MOV EAX, EBX
SUB ECX, ECX
CountMore:
CompilerIf #PB_Compiler_Unicode  
ADD EAX, #CharSize
CMP word [EAX-2], CX
CompilerElse
INC EAX
CMP byte [EAX-1], CH
CompilerEndIf
JNZ l_asmgagestring_countmore
SUB EAX, EBX
CompilerIf #PB_Compiler_Unicode
SHR EAX, 1
CompilerEndIf
DEC EAX
ProcedureReturn
DisableASM
EndProcedure

Procedure GageSCASX(*Ptr)
EnableASM
CLD
MOV ECX, -1
MOV EDI, *Ptr
SUB EAX, EAX
CompilerIf #PB_Compiler_Unicode  
Repnz Scasw
CompilerElse
Repnz Scasb
CompilerEndIf
MOV EAX, -2
SUB EAX, ECX
ProcedureReturn
DisableASM
EndProcedure

;{
Macro TestProc(TVal, Action)
Define TVal = -ElapsedMilliseconds()
For I = 1 To #Times : Action : Next I
TVal + ElapsedMilliseconds()
EndMacro

Macro FormatResult(ResultName, TAccum)
#CR$ + ResultName + " = " + TAccum + " ms."
EndMacro
;}

#Times = 10000000 : Define Test.s = "Thy hallo there."
TestProc(LTime , Len(Test))
TestProc(GSTime, GageSCASX(@Test))
TestProc(AGSTime, AsmGageString(@Test))

MessageRequester("[Resultae]:", "For " + #Times + " iterations..." +
FormatResult("Len(X)", LTime) + FormatResult("GageSCASX(X)", GSTime) + FormatResult("AsmGageString(X)", AGSTime))

...Итого, имеем (для ASCII):
Стандарт - 350 ms.
SCASB - 351 ms.
Мой вариант - 327 ms.

[tolich]

Для коротких строк понятно. Как для строк в пару килобайт или мегабайт?

Причём, вроде, в одном источнике я читал, что строковые команды тормозные, а в другом, что они работают через ПДП.

[Guevara-chan]

Хм, а вот тут твой вариант становится быстрее. Если, допустим, поставить:

Код

#Times = 10000000 : Define Test.s = "Thy hallo there."
For I = 1 To 5 : Test + Test : Next I

Стандарт - 5871 ms.
SCASB - 5871 ms.
Мой вариант - 8709 ms.
...И отставание, как я понимаю, будет только нарастать. Хм...

[Guevara-chan]

Тренируюсь в укрощении CoffeeScript. Сходу вот - определение дня недели для любой валидной даты:

Код

day_of_week = (day, month, year) ->
    month_len = [0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]    # 0 ? Because jan.
    month_len[2] += 1 unless year % 4 or year % 1000 == 0            # 29th february, you know.
    unless 0 < month <= 12                                            # Month boundary check.
        throw new RangeError("Month index outside of [1..12] range !")  
    unless 0 < day <= month_len[month]                                # Day index boundary check.
        throw new RangeError("Day index outside of [1..#{month_len[month]}] range !")
    #.---Finally some actual calculations:
    dayz = day +                                            # Amount of days passed.
           month_len[...month].reduce((a, b) -> a + b) +    # Sum(days_in_jan..prev_month) + 1
           --year * 365 + year // 4 - year // 1000            # Leap years correction.
    return dayz %% 7

date2day = (args...) ->
    ['mon', 'tue', 'wed', 'thu', 'fri', 'sat', 'sun'][day_of_week args...]

## Example...
console.log date2day(3, 12, 2014) # => 'wed'