' ************************************************************** ' * GMT Library * ' * DLL-code * ' * by Prof.Dr.Godfried-Willem RAES * ' * main module is: g_lib.bas * ' * version 11.09 * ' ************************************************************** ' declarations for compiled DLL-file: g_lib.bi (exports only) ' This file contains the source code for the gmt library: ' documentation can be found in the corresponding html files. ' **************************************************************** ' General purpose procedures and macros used and called in * ' **************************************************************** ' declares for non-exported functions in g_lib.bas ' moved to g_lib.inc 'GLOBAL tid() AS DWORD 'if we stick to the queued timers, we'd better make this a field in the task type 'GLOBAL htq AS DWORD FUNCTION GetApplicationIconHandle (BYVAL apid AS LONG) EXPORT AS LONG ' this sets the icon used for the cockpit window LOCAL h AS LONG LOCAL icnr AS DWORD SELECT CASE apid CASE %ID_SONGBOOK99, %ID_BOM99 icnr = %ICO_BOM CASE %ID_COHIBA, %ID_TOVERFLUIT, %ID_PANATELLA icnr = %ICO_COHIBA CASE %ID_OBOTEK icnr = %ICO_OBOTEK CASE %ID_CELLOPI icnr = %ICO_CELLOPI CASE %ID_JUMPYVARIATIONS icnr = %ICO_JUMPY CASE %ID_SHIFTS_INS TO %ID_SHIFTS_DIM icnr = %ICO_SHIFTS CASE %ID_LICKSTICK, %ID_WOODSTOCK icnr = %ICO_LICKSTICK CASE %ID_FIDELC icnr = %ICO_FIDELC CASE %ID_TECHNOFAUSTUS, %ID_EARY, %ID_PARADISO, %ID_TEKNE, %ID_LITHOS, %ID_PROLOGOS icnr = %ICO_FAUST CASE %ID_FALL95, %ID_CHORDCAT, %ID_FUZZYHARM, %ID_SPRING94 icnr = %ICO_NOTE CASE %ID_WSB_SERVER icnr = %ICO_STAR CASE %IDM_KLUNG icnr = %ICO_KLUNG CASE %IDM_TROMS icnr = %ICO_TROMS CASE %IDM_THUNDERWOOD icnr = %ICO_THUNDERWOOD CASE %IDM_SPRINGERS icnr = %ICO_SPRINGERS CASE %IDM_ROTOMOTON icnr = %ICO_ROTOMOTON CASE %IDM_VIBI icnr = %ICO_VIBI CASE %IDM_HARMA icnr = %ICO_HARMA CASE %IDM_BELLY icnr = %ICO_BELLY CASE %IDM_TUBI icnr = %ICO_TUBI CASE %IDM_FLEX icnr = %ICO_FLEX CASE %ID_II_MIM icnr = %ICO_MIM CASE %ID_ZERHACKER icnr = %ICO_SPEAKER CASE %IDM_AUTOSAX icnr = %ICO_AUTOSAX CASE %ID_KLAUWERS TO %ID_KDEBAERDEMACKER -1 icnr = %ICO_KRISTOF CASE %IDM_PLAYERPIANO icnr = %ICO_PIANO CASE %IDM_AKE icnr = %ICO_AKE CASE %IDM_LLOR icnr = %ICO_LLOR CASE %IDM_HURDY icnr = %ICO_HURDY CASE %IDM_BOURDONOLA icnr = %ICO_BOURDONOLA CASE %IDM_PIPEROLA icnr = %ICO_PIPEROLA CASE %IDM_VOXHUMANOLA icnr = %ICO_HUMANOLA CASE %IDM_TRUMP icnr = %ICO_TRUMP CASE %IDM_PUFF icnr = %ICO_PUFF CASE %IDM_SO icnr = %ICO_SO CASE %IDM_SIRE icnr = %ICO_SIRE CASE %IDM_VACCA , %IDM_VITELLO icnr = %ICO_VACCA CASE %IDM_KRUM icnr = %ICO_KRUM CASE %IDM_QT icnr = %ICO_QT CASE %IDM_BAKO icnr = %ICO_BAKO CASE %IDM_SIMBA icnr = %ICO_SIMBA CASE %IDM_BONO icnr = %ICO_BONO CASE %IDM_CASTA icnr = %ICO_CASTA CASE %IDM_PER icnr = %ICO_PER CASE %IDM_TUBO icnr = %ICO_TUBO ' CASE %IDM_PLAYERPIANO TO %IDM_M_ROBOT_LAST ' removed 13.12.2004 ' icnr = %ICO_NOTE CASE ELSE icnr = %ICO_GMT END SELECT FUNCTION = LoadIcon(hInstDLL, BYVAL icnr) END FUNCTION FUNCTION MonitorHandler (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG ' Callback message handler for the default monitor (cfr. example in code. FUNCTION = %False ' this is the default return value for all non handled messages SELECT CASE wMsg CASE %WM_INITDIALOG ' SendMessage hWnd, %WM_SETICON,%ICON_BIG,%Null ' new 12.07.99 - this ought to work... ' CASE %WM_COMMAND ' remmed out 01.12.2002, we should not use Enddialog for ' SELECT CASE LOWRD(wParam) ' non modal dialogs. ' CASE %IDCANCEL ' EndDialog hWnd, 0 ' FUNCTION = %True ' CASE %IDOK ' EndDialog hWnd, 1 ' FUNCTION = %True ' END SELECT CASE %WM_SYSCOMMAND SELECT CASE wParam CASE %SC_CLOSE Destroywindow hWnd FUNCTION = %True END SELECT END SELECT END FUNCTION FUNCTION GetDefaultApp () EXPORT AS LONG IF ISFALSE pApp THEN MSGBOX "No pointer to Application",,FUNCNAME$ : FUNCTION = %False : EXIT FUNCTION @pApp.komposduur = 3600 ' in seconds - one hour default @pApp.tempo = 60 ' in M.M. @pApp.globton = %Null @pApp.DebugTaskNr = %False @pApp.WriteSeqScoreTaskNr = 5 ' dll tasks. @pApp.ReadSeqScoreTaskNr = 10 @pApp.ShowGlobalHarmonyTaskNr = 14 @pApp.GlobalHarmonyTaskNr = 15 @pApp.SampleFileName = "Testwave.wav" @pApp.id = %ID_DEFAULT ' cfr. gmt_glob , g_kons =%ID_DEMO @pApp.audiofilepath = "" @pApp.midifilepath = "" @pApp.datafilepath = "C:\b\pb\gmt\" FUNCTION = %True END FUNCTION FUNCTION ReadMidiFlagsFromFile (f AS STRING) EXPORT AS LONG ' called from getMidiInports in dll LOCAL nr AS LONG LOCAL setting AS LONG LOCAL dum$ LOCAL keyword AS ASCIIZ * 40 FUNCTION = %False IF ISFALSE ExistFile (f) THEN EXIT FUNCTION nr = FREEFILE OPEN f FOR INPUT LOCK SHARED AS #nr ' locate the start of the data block: DO LINE INPUT #nr, keyword keyword = TRIM$(UCASE$(keyword)) IF LEFT$(keyword,1) = "[" THEN IF keyword = TRIM$(UCASE$($Flags_Start)) THEN EXIT LOOP END IF END IF IF EOF(nr) THEN CLOSE #nr MSGBOX "Flags data block for SxThread not found in file " & f,,FUNCNAME$ EXIT FUNCTION END IF LOOP DO IF EOF(nr) THEN EXIT LOOP INPUT #nr, dum$ dum$ = TRIM$(UCASE$(dum$)) SELECT CASE dum$ CASE UCASE$($FlagSysEx) ' = "Receive_Sysex" settable to 0 or 1 INPUT #nr, setting IF setting THEN ' if setting = 1 the sysex must be enabled, so the bit must be reset. BIT RESET SxThread.flags,%SYSEX_BLOCK ELSE 'BIT SET SxThread.flags, %SYSEX_BLOCK ' %sysex_block = 2 , bit 3 SxThread.flags = -1 FUNCTION = %True EXIT FUNCTION END IF ' note: if we set SxThread.flags = -1, the openmidi function will not even start the thread. CASE UCASE$($FlagSysEx2File) INPUT #nr, setting IF setting THEN BIT SET SxThread.flags,%SYSEX_TO_FILE ' bit 0 ELSE BIT RESET SxThread.flags, %SYSEX_TO_FILE END IF CASE UCASE$($FlagSysEx2Array) INPUT #nr, setting IF setting THEN BIT SET SxThread.flags,%SYSEX_TO_SXB ' bit 1 ELSE BIT RESET SxThread.flags, %SYSEX_TO_SXB END IF CASE UCASE$($Flags_End) CLOSE #nr FUNCTION = %True EXIT FUNCTION END SELECT LOOP CLOSE #nr FUNCTION = %False END FUNCTION ' harder to move to g_mus.dll: SUB Iprop2Rit (BYREF H AS HarmType, BYVAL Tasknr AS LONG, BYVAL ritbase AS BYTE) EXPORT ' converts the Iprop field in a Harmony structure to a time-structure ' ritbase? should be 1,2,3,... Optimum values are 2 and 3 ' 29.11.1998 - written for Cohiba ' changed 10.09.1999: now takes pointers to Tasks as parameter, so that we can put it in the DLL. ' changed 23.03.2000: now we have pointers to the task structure in the dll. LOCAL cnt AS BYTE LOCAL i AS BYTE IF ritbase < 1 THEN ritbase = 1 cnt = 0 DO SELECT CASE cnt CASE 0 ' grondtoon/ unisons @pTask(tasknr).Rit.pattern(0)= H.Iprop(0) / (ritbase+0!) @pTask(tasknr).Rit.pattern(1)= -(1- H.Iprop(0)) / (ritbase+ 0!) CASE 1 @pTask(tasknr).Rit.pattern(10)= H.Iprop(1) / (ritbase + 5!) @pTask(tasknr).Rit.pattern(11)= -(1-H.Iprop(1)) / (ritbase + 5!) CASE 2 @pTask(tasknr).Rit.pattern(8)= H.Iprop(2) / (ritbase + 4!) @pTask(tasknr).Rit.pattern(9)= -(1-H.Iprop(2)) / (ritbase + 4!) CASE 3 @pTask(tasknr).Rit.pattern(6) = H.Iprop(3) / (ritbase + 3!) @pTask(tasknr).Rit.pattern(7) = -(1-H.Iprop(3)) / (ritbase + 3!) CASE 4 @pTask(tasknr).Rit.pattern(4) = H.Iprop(4) / (ritbase + 2!) @pTask(tasknr).Rit.pattern(5) = -(1-H.Iprop(4)) / (ritbase + 2!) CASE 5 ' kwart/ kwint: @pTask(tasknr).Rit.pattern(2) = H.Iprop(5) / (ritbase + 1!) @pTask(tasknr).Rit.pattern(3) = -(1- H.Iprop(5))/(ritbase + 1!) CASE 6 ' triton @pTask(tasknr).Rit.pattern(12)= H.Iprop(6) / (ritbase + 6!) @pTask(tasknr).Rit.pattern(13)= -(1-H.Iprop(6)) / (ritbase + 6!) END SELECT INCR cnt IF cnt > 6 THEN EXIT DO LOOP @pTask(tasknr).Rit.pattern(14)= 0 ' remove zero's: FOR cnt = 0 TO 13 IF ISFALSE @pTask(tasknr).Rit.pattern(cnt) THEN FOR i = cnt TO 13 @pTask(tasknr).Rit.pattern(i)=@pTask(tasknr).Rit.pattern(i+1) NEXT i END IF NEXT cnt END SUB SUB ShepChord2Rit (BYREF H AS HarmType, BYVAL nr AS LONG, BYVAL ritbase AS BYTE, BYVAL tc AS INTEGER) EXPORT ' changed 23.03.2000 ' was: SUB ShepChord2Rit (HarTask AS TAAK, Task AS TAAK, BYVAL ritbase?, BYVAL tc%) EXPOR ' returns a rhythm pattern based on the shepard reduction of the harmonic situation passed ' in Task(hartasknr%).Har.C(0 TO 11) ' The result is always a periodic pattern, either binary or ternary, depending on the ' value of ritbase. ' The resulting pattern is returned in Task(tasknr%).Rit.pattern(). ' Other than is the case of Iprop2Rit(), this procedure is sensitive to tonality. ' I-IV-V chords on input will yield rhythms wherein 'on-the-beat' values are stronger. ' Dissonant chords will be characterised by more 'dotted' patterns. LOCAL cnt AS DWORD LOCAL i AS DWORD IF tc < 0 THEN tc = 0 tc = tc MOD 12 IF ritbase? MOD 2 = %False THEN @pTask(nr).Rit.pattern(0) = H.C(tc) * 2 ' 1000 0000 @pTask(nr).Rit.pattern(1) = -(1 - H.C(tc)) * 2 ' F000 0000 @pTask(nr).Rit.pattern(2) = H.C((tc+ 11) MOD 12) * 2 ' 0100 0000 @pTask(nr).Rit.pattern(3) = - (1 - H.C((tc+11) MOD 12)) * 2 ' 0F00 0000 @pTask(nr).Rit.pattern(4) = H.C((tc+4)MOD 12) * 2 ' 0010 0000 @pTask(nr).Rit.pattern(5) = -(1 - H.C((tc+4)MOD 12)) * 2 ' 00F0 0000 @pTask(nr).Rit.pattern(6) = H.C((tc+ 2) MOD 12)+ H.C((tc+ 10) MOD 12) ' 0001 0000 @pTask(nr).Rit.pattern(7) = -((1 - H.C((tc+2) MOD 12)) + (1 - H.C((tc+10) MOD 12))) ' 000F 0000 @pTask(nr).Rit.pattern(8) = H.C((tc+ 5) MOD 12)+ H.C((tc+ 7) MOD 12) ' 0000 1000 @pTask(nr).Rit.pattern(9) = -((1 - H.C((tc+5) MOD 12)) + (1 - H.C((tc+7) MOD 12))) ' 0000 F000 @pTask(nr).Rit.pattern(10) = H.C((tc+ 1) MOD 12) * 2 ' 0000 0100 @pTask(nr).Rit.pattern(11) = -(1 - H.C((tc+1) MOD 12)) * 2 ' 0000 0F00 @pTask(nr).Rit.pattern(12) = H.C((tc+3)MOD 12) * 2 ' 0000 0010 @pTask(nr).Rit.pattern(13) = -(1 - H.C((tc+3)MOD 12)) * 2 ' 0000 00F0 @pTask(nr).Rit.pattern(14) = H.C((tc+11) MOD 12) * 2 ' 0000 0001 @pTask(nr).Rit.pattern(15) = -(1 - H.C((tc+1) MOD 12)) * 2 ' 0000 000F @pTask(nr).Rit.pattern(16) = %False ' remove zero's: FOR cnt = 0 TO 15 IF ISFALSE @pTask(nr).Rit.pattern(cnt) THEN FOR i = cnt TO 15 @pTask(nr).Rit.pattern(i)= @pTask(nr).Rit.pattern(i+1) NEXT i END IF NEXT cnt ELSE ' ternary @pTask(nr).Rit.pattern(0) = H.C(tc) * 2 ' 100 000 000 @pTask(nr).Rit.pattern(1) = -(1 - H.C(tc)) * 2 ' F00 000 000 @pTask(nr).Rit.pattern(2) = H.C((tc+ 4) MOD 12) * 2 ' 010 000 000 @pTask(nr).Rit.pattern(3) = -(1 - H.C((tc+4) MOD 12)) * 2 ' 0F0 000 000 @pTask(nr).Rit.pattern(4) = H.C((tc+ 2) MOD 12) + H.C((tc+ 10) MOD 12) ' 001 000 000 @pTask(nr).Rit.pattern(5) = -(1 - H.C((tc+2)MOD 12)) + (1 - H.C((tc+10) MOD 12)) ' 00F 000 000 @pTask(nr).Rit.pattern(6) = H.C((tc+ 5) MOD 12) * 2 ' 000 100 000 @pTask(nr).Rit.pattern(7) = -(1 - H.C((tc+5) MOD 12)) * 2 ' 000 F00 000 @pTask(nr).Rit.pattern(8) = H.C((tc+ 3) MOD 12) + H.C((tc+ 9) MOD 12) ' 000 010 000 @pTask(nr).Rit.pattern(9) = -(1 - H.C((tc+3) MOD 12)) + (1 - H.C((tc+9) MOD 12)) ' 000 0F0 000 @pTask(nr).Rit.pattern(10) = H.C((tc+ 1) MOD 12) + H.C((tc+ 11) MOD 12) ' 000 001 000 @pTask(nr).Rit.pattern(11) = -(1 - H.C((tc+1) MOD 12)) + (1 - H.C((tc+11) MOD 12)) ' 000 00F 000 @pTask(nr).Rit.pattern(12) = H.C((tc+7)MOD 12) * 2 ' 000 000 100 @pTask(nr).Rit.pattern(13) = -(1 - H.C((tc+7)MOD 12)) * 2 ' 000 000 F00 @pTask(nr).Rit.pattern(14) = H.C((tc+8) MOD 12) * 2 ' 000 000 010 @pTask(nr).Rit.pattern(15) = -(1 - H.C((tc+8) MOD 12)) * 2 ' 000 000 0F0 @pTask(nr).Rit.pattern(16) = H.C((tc+6) MOD 12) * 2 ' 000 000 001 @pTask(nr).Rit.pattern(17) = -(1 - H.C((tc+6) MOD 12)) * 2 ' 000 000 00F @pTask(nr).Rit.pattern(18) = %False ' remove zero's: FOR cnt = 0 TO 17 IF ISFALSE @pTask(nr).Rit.pattern(cnt) THEN FOR i = cnt TO 17 @pTask(nr).Rit.pattern(i)=@pTask(nr).Rit.pattern(i+1) NEXT i END IF NEXT cnt END IF END SUB FUNCTION GetNrTicks (BYVAL tasknr AS LONG) EXPORT AS INTEGER LOCAL noemer! ' bereken de periode-tijd (maatduur) voor de stem-taak die van deze ritmeprocedure ' gebruik maakt. ' Tt! = 1! / Task(tasknr%).freq ' bereken op grond hiervan wat de maximale patroonlengte mag zijn: ' (d.i. de Soll-sigmasom van alle duren in Ritmepatroon!() ) ' nrtiks% = INT(Tt! / Task(tasknr%).Minduur!) ' we now do this in a single step: ' IMPORTANT : minduur must be expressed in seconds!!! 'was: noemer! = Task(tasknr%).tempo * Task(tasknr%).Rit.minduur noemer! = @pTask(tasknr).tempo * @pTask(tasknr).Rit.minduur IF noemer! = 0 THEN FUNCTION = %False ' this is in fact an error condition MSGBOX "Tempo or minduur not set in task " & @pTask(tasknr).naam,,FUNCNAME$ ELSE FUNCTION = INT(60! / noemer!) END IF END FUNCTION SUB ShowNormArray (BYVAL hW AS LONG, Arr!(),OPTIONAL BYVAL flag AS DWORD) EXPORT ' rewritten 20.04.2000 ' optional flag added 11.02.2009. ' if flag is non zero, we can overlay different graphs in the same window. LOCAL oldpoint AS POINTL LOCAL v% LOCAL h!, horstep! LOCAL i AS DWORD LOCAL hDC AS LONG LOCAL Rechthoek AS FourLongs LOCAL ver% ' displays a normalized bipolar array as a graph (normalisation here is -0.5 to +0.5) ' remark gwr 13.06.2009: ? is this true, or is it -1 to +1 ?? ' checked 04.03.2020: indeed it is -0.5 to + 0.5 ' This code adapts size to the window and the length of the array. IF ISFALSE hW THEN EXIT SUB hDC = GetDC(hW) ' hDC = BeginPaint(hW, LpPaint) GetClientRect hW, Rechthoek ver% = Rechthoek.h /2 ' erase previous graph IF ISFALSE flag THEN PatBlt hDC, Rechthoek.x,0,Rechthoek.b,Rechthoek.h,%WHITENESS END IF IF ISFALSE UBOUND(arr!) THEN EXIT SUB horstep! = Rechthoek.b / UBOUND(Arr!) ' draw horizontal zero time-axis: MoveToEx hDC, rechthoek.x,ver%, oldpoint LineTo hDC, rechthoek.x + rechthoek.b,ver% ' draw vertical symmetry axis: MoveToEx hDc, rechthoek.x + rechthoek.b /2,rechthoek.y, oldpoint LineTo hDc, rechthoek.x + rechthoek.b/2, rechthoek.y + rechthoek.h h! = Rechthoek.x FOR i = 0 TO UBOUND(Arr!) v% = ver% - (Arr!(i) * rechthoek.h) IF ISFALSE i THEN MoveToEx hDC, INT(h!),v%, oldpoint ELSE LineTo hDC, INT(h!),v% END IF h! = h! + horstep! NEXT i ' EndPaint hWnd, LpPaint ReleaseDC hW,hDC END SUB SUB ShowPsiChord (Har AS HarmType, BYVAL hor%, BYVAL ver%, BYVAL hsize%, BYVAL vsize%) EXPORT LOCAL hBrush AS LONG LOCAL bw%, Sp%, H1%, H2% LOCAL il AS BYTE LOCAL hDC AS LONG LOCAL hOldBrush AS LONG IF @pgh.HarPsy THEN hDC = GetDC(@pgh.HarPsy) ' graphic display of chordpowerdistribution ' all coordinates are expressed in pixels. FillHarType (Har,%use_velo) 'GetPsiChord Har IF ver% > 460 THEN ver% = 460 IF vsize% > ver% THEN vsize% = ver% IF hor% > 640 - 48 THEN hor% = 640 - 48 IF hsize% > 640 - hor% THEN hsize% = 48 bw% = hsize% / 12 ' width of the bars Sp% = bw% - 1 ' width minus space in between IF Sp% < 0 THEN Sp% = 0 ' blank existing graph: PatBlt hDC, hor%,0,hor%+hsize%,ver%,%WHITENESS FOR il = 0 TO 11 H1% = hor% + (il * bw%) H2% = H1% + Sp% SELECT CASE il CASE 0, 2, 4, 5, 7, 9, 11 hBrush = CreateSolidBrush (%WHITE) CASE ELSE hBrush = CreateSolidBrush (%BLACK) END SELECT hOldBrush = SelectObject(hDC, hBrush) Rectangle hDC,H1%,ver%, H2%, ver% -(Har.c(il)*vsize%) ' draw keyboard reference, for ease of reading: Rectangle hDC,H1%,ver%+2, H2%, ver% +2 + Sp% SelectObject hDc, hOldBrush DeleteObject hBrush NEXT il ReleaseDC @pgh.HarPsy, hDC END IF END SUB SUB DrawBlankBar (staff AS StaffType, BYVAL hDC AS LONG, BYVAL horpos1 AS WORD, BYVAL horpos2 AS WORD) EXPORT LOCAL oldpoint AS POINTL ' used to erase notes in a bar ' we should have 2 nootlijn parameters to set the complete area... PatBlt hDC,INT(horpos1),staff.ver - (staff.lijnafstand * 4),horpos2-horpos1, staff.lijnafstand * 12, %WHITENESS ' redraw the staff-lines now: MoveToEx hDC, horpos1, staff.ver + (staff.lijnafstand * 4), oldpoint LineTo hDC,horpos2 , staff.ver + (staff.lijnafstand * 4) MoveToEx hDC, horpos1 ,staff.ver + (staff.lijnafstand * 3), oldpoint LineTo hDC, horpos2, staff.ver + (staff.lijnafstand * 3) MoveToEx hDC,horpos1 ,staff.ver + (staff.lijnafstand * 2) , oldpoint LineTo hDC,horpos2 , staff.ver + (staff.lijnafstand * 2) MoveToEx hDC,horpos1, staff.ver + staff.lijnafstand, oldpoint LineTo hDC,horpos2 , staff.ver + staff.lijnafstand MoveToEx hDC,horpos1 , staff.ver, oldpoint LineTo hDC,horpos2 ,staff.ver END SUB SUB DrawStaff (staff AS StaffType, BYVAL hDC AS LONG) EXPORT ' this procedure draws a blank staff in the graphics window ' we pass a pointer to the staff structure, a global within GMT, but not shared across the dll LOCAL oldpoint AS POINTL IF hDC = %Null THEN EXIT SUB DrawBlankBar staff, hDC, (staff.hor), staff.hor + staff.length MoveToEx hDC, staff.hor, staff.ver, oldpoint LineTo hDC, staff.hor + staff.length, staff.ver MoveToEx hDC, staff.hor, staff.ver + staff.lijnafstand, oldpoint LineTo hDC, staff.hor + staff.length, staff.ver + staff.lijnafstand MoveToEx hDC, staff.hor, staff.ver + (staff.lijnafstand*2), oldpoint LineTo hDC, staff.hor + staff.length, staff.ver + (staff.lijnafstand *2) MoveToEx hDC, staff.hor, staff.ver+ (staff.lijnafstand*3), oldpoint LineTo hDC, staff.hor + staff.length, staff.ver + (staff.lijnafstand *3) MoveToEx hDC, staff.hor, staff.ver+ (staff.lijnafstand*4), oldpoint LineTo hDC, staff.hor + staff.length, staff.ver + (staff.lijnafstand *4) END SUB SUB DrawBarline (staff AS stafftype, BYVAL hDC AS LONG, BYVAL horpos AS WORD) EXPORT LOCAL oldpoint AS POINTL IF horpos < staff.hor THEN horpos = staff.hor IF horpos > staff.length THEN horpos = staff.length MoveToEx hDC, horpos , staff.ver, oldpoint ' set start coordinates LineTo hDC, horpos , staff.ver + (staff.lijnafstand *4) END SUB SUB DrawNote (staff AS stafftype, BYVAL hDC AS LONG, BYVAL lineposition AS INTEGER, BYVAL horpos AS WORD) EXPORT LOCAL lx AS WORD, ly AS WORD, rx AS WORD, ry AS WORD LOCAL oldpoint AS POINTL ' global variables needed: staff , ' position on the staff is coded as in DARMS coding ' horpos is in absolute window coordinates ' bereken de koordinaten van de linkerbovenhoek en rechteronderhoek waarbinnen de noot elips moet worden ' getekend: lx = horpos ly = staff.ver + (staff.lijnafstand * 4) - ((staff.lijnafstand * lineposition) \ 2) rx = lx + staff.nb ry = ly + staff.nh + 1 ' +1 correction 12.11.1999 ELLIPSE hDC, lx, ly,rx,ry ' now, we redraw the horizontal line, since the ellipse erased it... SELECT CASE lineposition CASE 0,2,4,6,8,10 ' do nothing CASE 1,3,5,7,9 MoveToEx hDC, lx - 1, staff.ver + (staff.lijnafstand * (4-FIX(lineposition/2))), oldpoint LineTo hDC, rx + 1, staff.ver + (staff.lijnafstand * (4-FIX(lineposition/2))) ' gevallen met hulplijntjes naar onder... CASE -1,-2 MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 5), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 5) CASE -3,-4 MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 5), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 5) MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 6), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 6) CASE -5,-6 MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 5), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 5) MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 6), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 6) MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 7), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 7) CASE -7,-8 MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 5), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 5) MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 6), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 6) MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 7), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 7) MoveToEx hDC, lx - (staff.nb/3), staff.ver + (staff.lijnafstand * 8), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver + (staff.lijnafstand * 8) CASE 11, 12 ' hulplijntjes boven de balk... MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 1), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 1) CASE 13, 14 MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 1), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 1) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 2), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 2) CASE 15,16 MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 1), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 1) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 2), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 2) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 3), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 3) CASE 17,18 MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 1), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 1) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 2), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 2) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 3), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 3) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 4), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 4) CASE 19,20 MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 1), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 1) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 2), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 2) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 3), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 3) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 4), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 4) MoveToEx hDC, lx - (staff.nb/3), staff.ver - (staff.lijnafstand * 5), oldpoint LineTo hDC, rx + (staff.nb/3), staff.ver - (staff.lijnafstand * 5) END SELECT END SUB SUB DrawClef (staff AS StaffType, BYVAL hDC AS LONG, BYVAL horpos AS WORD) EXPORT LOCAL oldpoint AS POINTL SELECT CASE staff.clef CASE "G2" ' gewone solsleutel: ' stijgende cirkel vanaf lijn2 Chord hDC, staff.hor + (staff.nb*2),staff.ver + (staff.lijnafstand * 2.5) , _ staff.hor + (staff.nb*3), staff.ver + (staff.lijnafstand * 3.5), _ staff.hor + (staff.nb*3), staff.ver + (staff.lijnafstand * 3), _ staff.hor + (staff.nb*2), staff.ver + (staff.lijnafstand * 3) ' dalende cirkel terug naar begin balk: Chord hDC, staff.hor, staff.ver + (staff.lijnafstand * 2), staff.hor + (staff.nb*3),staff.ver + (staff.lijnafstand * 4),_ staff.hor,staff.ver + (staff.lijnafstand * 3), staff.hor+(staff.nb*3), staff.ver + (staff.lijnafstand * 3) ' schuine lijn tot boven balk MoveToEx hDC, staff.hor,staff.ver + (staff.lijnafstand * 3), oldpoint LineTo hDC, staff.hor + (staff.nb*3),staff.ver - staff.nb*3 ' bovencirkel ARC hDC, staff.hor + (staff.nb*2), staff.ver - staff.nb*4,_ staff.hor + (staff.nb*3), staff.ver - staff.nb*2,_ staff.hor + (staff.nb*3), staff.ver - staff.nb*3,_ staff.hor + (staff.nb*2), staff.ver - staff.nb*3 ' vertikale lijn MoveToEx hDC, staff.hor + (staff.nb*2),staff.ver - (staff.nb*3),oldpoint LineTo hDC, staff.hor + (staff.nb*2), staff.ver + (staff.lijnafstand * 4) + (staff.nb*3) CASE "F4" ' gewone fasleutel 4e lijn ARC hDC, staff.hor, staff.ver,_ staff.hor + (staff.nb*2),staff.ver + (staff.lijnafstand * 2), _ staff.hor + (staff.nb*2), staff.ver + staff.lijnafstand, _ staff.hor, staff.ver + staff.lijnafstand 'schuine staartlijn MoveToEx hDC, staff.hor + (staff.nb*2),staff.ver + staff.lijnafstand, oldpoint LineTo hDC, staff.hor, staff.ver + (staff.lijnafstand * 4) ' bolletjes: ELLIPSE hDC,staff.hor + (staff.nb*2.1), staff.ver + (staff.lijnafstand \ 2),_ staff.hor + (staff.nb*2.4),staff.ver + staff.lijnafstand-3 ELLIPSE hDC,staff.hor + (staff.nb*2.1),staff.ver + (staff.lijnafstand * 1.5),_ staff.hor + (staff.nb*2.4),staff.ver + (staff.lijnafstand * 2)-3 CASE "F3","C5" ' fasleutel 3e lijn ARC hDC, staff.hor, staff.ver + staff.lijnafstand,_ staff.hor + (staff.nb*2),staff.ver + (staff.lijnafstand * 3), _ staff.hor + (staff.nb*2), staff.ver + (staff.lijnafstand * 2), _ staff.hor, staff.ver + (staff.lijnafstand * 2) 'schuine staartlijn MoveToEx hDC, staff.hor + (staff.nb*2), staff.ver + (staff.lijnafstand * 2), oldpoint LineTo hDC, staff.hor, staff.ver + (staff.lijnafstand * 4) + 3 ' bolletjes: ELLIPSE hDC,staff.hor + (staff.nb*2.1),staff.ver + (staff.lijnafstand * 1.5),_ staff.hor + (staff.nb*2.4),staff.ver + (staff.lijnafstand * 2)-3 ELLIPSE hDC,staff.hor + (staff.nb*2.1),staff.ver + (staff.lijnafstand * 2.5),_ staff.hor + (staff.nb*2.4),staff.ver + (staff.lijnafstand * 3)-3 CASE "C1" ' utsleutel 1e lijn MoveToEx hDC, staff.hor, staff.ver + staff.lijnafstand,oldpoint LineTo hDC, staff.hor, staff.ver + (staff.lijnafstand * 4) + staff.lijnafstand *3 MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver + staff.lijnafstand,oldpoint LineTo hDC, staff.hor + (staff.nb/2), staff.ver + (staff.lijnafstand * 3.5) LineTo hDC, staff.hor + 1, staff.ver + (staff.lijnafstand * 3.5) MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver + (staff.lijnafstand * 4) + staff.lijnafstand * 3, oldpoint LineTo hDC, staff.hor + (staff.nb/2),staff.ver + (staff.lijnafstand * 4) + staff.nh/2 LineTo hDC, staff.hor + 1, staff.ver + (staff.lijnafstand * 4) + staff.nh/2 ' bolletjes: ELLIPSE hDC,staff.hor + (staff.nb),staff.ver + (staff.lijnafstand * 3.5),_ staff.hor + (staff.nb*1.3),staff.ver + (staff.lijnafstand * 4)-3 ELLIPSE hDC,staff.hor + (staff.nb),staff.ver + (staff.lijnafstand * 4.5),_ staff.hor + (staff.nb*1.3),staff.ver + (staff.lijnafstand * 4) + staff.lijnafstand -3 CASE "C2" ' utsleutel 2e lijn MoveToEx hDC, staff.hor, staff.ver,oldpoint LineTo hDC, staff.hor, staff.ver + (staff.lijnafstand * 3) + staff.lijnafstand *3 MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver,oldpoint LineTo hDC, staff.hor + (staff.nb/2), staff.ver + (staff.lijnafstand * 2.5) LineTo hDC, staff.hor + 1, staff.ver + (staff.lijnafstand * 2.5) MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver + (staff.lijnafstand * 3) + staff.lijnafstand * 3, oldpoint LineTo hDC, staff.hor + (staff.nb/2),staff.ver + (staff.lijnafstand * 3) + staff.nh/2 LineTo hDC, staff.hor + 1, staff.ver + (staff.lijnafstand * 3) + staff.nh/2 ' bolletjes: ELLIPSE hDC,staff.hor + (staff.nb),staff.ver + (staff.lijnafstand * 2.5),_ staff.hor + (staff.nb*1.3),staff.ver + (staff.lijnafstand * 3)-3 ELLIPSE hDC,staff.hor + (staff.nb),staff.ver + (staff.lijnafstand * 3.5),_ staff.hor + (staff.nb*1.3),staff.ver + (staff.lijnafstand * 3) + staff.lijnafstand -3 CASE "C3" ' utsleutel 3e lijn MoveToEx hDC, staff.hor, staff.ver - staff.lijnafstand,oldpoint LineTo hDC, staff.hor, staff.ver + (staff.lijnafstand * 2) + staff.lijnafstand *3 MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver - staff.lijnafstand,oldpoint LineTo hDC, staff.hor + (staff.nb/2), staff.ver + (staff.lijnafstand * 1.5) LineTo hDC, staff.hor + 1, staff.ver + (staff.lijnafstand * 1.5) MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver + (staff.lijnafstand * 2) + staff.lijnafstand * 3, oldpoint LineTo hDC, staff.hor + (staff.nb/2),staff.ver + (staff.lijnafstand * 2) + staff.nh/2 LineTo hDC, staff.hor + 1, staff.ver + (staff.lijnafstand * 2) + staff.nh/2 ' bolletjes: ELLIPSE hDC,staff.hor + (staff.nb),staff.ver + (staff.lijnafstand * 1.5),_ staff.hor + (staff.nb*1.3),staff.ver + (staff.lijnafstand * 2)-3 ELLIPSE hDC,staff.hor + (staff.nb),staff.ver + (staff.lijnafstand * 2.5),_ staff.hor + (staff.nb*1.3),staff.ver + (staff.lijnafstand * 2) + staff.lijnafstand -3 CASE "C4" ' utsleutel 4e lijn MoveToEx hDC, staff.hor, staff.ver - (staff.lijnafstand*2),oldpoint LineTo hDC, staff.hor, staff.ver + staff.lijnafstand + staff.lijnafstand *3 MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver - staff.lijnafstand*2,oldpoint LineTo hDC, staff.hor + (staff.nb/2), staff.ver + (staff.lijnafstand \ 2) LineTo hDC, staff.hor + 1, staff.ver + (staff.lijnafstand \ 2) MoveToEx hDC, staff.hor + (staff.nb/2), staff.ver + staff.lijnafstand + staff.lijnafstand * 3, oldpoint LineTo hDC, staff.hor + (staff.nb/2),staff.ver + staff.lijnafstand + staff.nh/2 LineTo hDC, staff.hor + 1, staff.ver + staff.lijnafstand + staff.nh/2 ' bolletjes: ELLIPSE hDC,staff.hor + (staff.nb), staff.ver + (staff.lijnafstand \ 2),_ staff.hor + (staff.nb*1.3),staff.ver + staff.lijnafstand-3 ELLIPSE hDC,staff.hor + (staff.nb),staff.ver + (staff.lijnafstand * 1.5),_ staff.hor + (staff.nb*1.3),staff.ver + staff.lijnafstand + staff.lijnafstand -3 CASE "G1" ' stijgende cirkel vanaf lijn1 Chord hDC, staff.hor + (staff.nb*2),staff.ver + (staff.lijnafstand * 3.5), _ staff.hor + (staff.nb*3), staff.ver + (staff.lijnafstand * 4.5) , _ staff.hor + (staff.nb*3), staff.ver + (staff.lijnafstand * 4) , _ staff.hor + (staff.nb*2), staff.ver + (staff.lijnafstand * 4) ' dalende cirkel terug naar begin balk: Chord hDC, staff.hor, staff.ver + (staff.lijnafstand * 3) ,_ staff.hor + (staff.nb*3),staff.ver + (staff.lijnafstand * 5),_ staff.hor,staff.ver + (staff.lijnafstand * 4),_ staff.hor+(staff.nb*3), staff.ver + (staff.lijnafstand * 4) ' schuine lijn tot boven balk MoveToEx hDC, staff.hor, staff.ver + (staff.lijnafstand * 4), oldpoint LineTo hDC, staff.hor + (staff.nb*3),staff.ver - staff.nb*3 + staff.lijnafstand ' bovencirkel ARC hDC, staff.hor + (staff.nb*2), staff.ver - (staff.nb*4) + staff.lijnafstand,_ staff.hor + (staff.nb*3), staff.ver - (staff.nb*2) + staff.lijnafstand,_ staff.hor + (staff.nb*3), staff.ver - (staff.nb*3) + staff.lijnafstand,_ staff.hor + (staff.nb*2), staff.ver - (staff.nb*3) + staff.lijnafstand ' vertikale lijn MoveToEx hDC, staff.hor + (staff.nb*2),staff.ver - (staff.nb*3) + staff.lijnafstand,oldpoint LineTo hDC, staff.hor + (staff.nb*2),staff.ver + (staff.lijnafstand * 5) + (staff.nb*3) END SELECT END SUB SUB DrawFlat (staff AS stafftype, BYVAL hDC AS LONG, BYVAL lineposition AS INTEGER, BYVAL horpos AS WORD) EXPORT ' the data for the staff ought to reside in the global variable Staff (of STAFFTYPE) LOCAL ly AS WORD LOCAL rx AS WORD LOCAL ry AS WORD LOCAL oldpoint AS POINTL ly = staff.ver + (staff.lijnafstand * 4) - ((staff.lijnafstand * lineposition) \ 2) rx = horpos + staff.nb ry = ly + staff.nh ' vertikale lijn: MoveToEx hDC, horpos + (staff.nb/2),ry - (staff.lijnafstand * 2), oldpoint LineTo hDC, horpos + (staff.nb/2), ry ' halve elips: ARC hDC, horpos, ly, rx, ry, horpos+(staff.nb/2),ry, horpos+(staff.nb/2),ly END SUB SUB DrawSharp (staff AS StaffType, BYVAL hDC AS LONG, BYVAL lineposition AS INTEGER, BYVAL horpos AS WORD) EXPORT LOCAL ly AS WORD, rx AS WORD, ry AS WORD LOCAL oldpoint AS POINTL ly = staff.ver + (staff.lijnafstand * 4) - ((staff.lijnafstand * lineposition) \ 2) rx = horpos + staff.nb ry = ly + staff.nh /2 ' vertikale lijntjes MoveToEx hDC, horpos + 2, ry - (staff.nh\2)- 1, oldpoint LineTo hDC, horpos + 2, ry + (staff.nh\2)+ 3 MoveToEx hDC, horpos + 4, ry - (staff.nh\2)-2 , oldpoint LineTo hDC, horpos + 4, ry + (staff.nh\2) +1 ' horizontale lijntjes: MoveToEx hDC, horpos-2, ry,oldpoint LineTo hDC, horpos + staff.nb-1, ry - (staff.nh\2) MoveToEx hDC, horpos-2, ry + (staff.nh\2), oldpoint LineTo hDC, horpos + staff.nb-1, ry END SUB SUB DrawChordNumber (staff AS StaffType, BYVAL hDC AS LONG, BYVAL crd%, BYVAL horpos AS WORD) EXPORT ' horpos should be 1, 2, 3 ... , reflecting a multiple of the chordraster defined in the staff type. ' the zero position for horpos is reserved for drawing the clef. ' Only when horpos is specified as 1, a clef will automatically be drawn. ' The procedure also draws a staff under the notes. IF ISFALSE hDC THEN EXIT SUB LOCAL kol1 AS WORD ' kolommen voor de akkoorden LOCAL kol2 AS WORD LOCAL kol3 AS WORD LOCAL oldpoint AS POINTL STATIC cleffactor AS BYTE, oldclef AS STRING * 2 DIM NoteLine(1 TO 7) AS STATIC INTEGER IF staff.clef <> oldclef THEN LOCAL i AS BYTE oldclef = staff.clef SELECT CASE staff.clef CASE "G2" : cleffactor = 6 CASE "F4", "G1" : cleffactor = 4 CASE "C1" : cleffactor = 1 CASE "C2" : cleffactor = 3 CASE "C3" : cleffactor = 5 CASE "C4" : cleffactor = 7 CASE "C5", "F3" : cleffactor = 2 CASE ELSE : cleffactor = 6 END SELECT ' spitsvondig nootlijnalgoritme...: 'REDIM NoteLine(1 TO 7) ' AS STATIC INTEGER 'default = C1 clef, where the first line is the C-line 'the numeric order is: C1 - F3 - C2 - F4 - C3 - G2 - C4 FOR i = 0 TO 6 NoteLine(i+ 1) = i + cleffactor IF NoteLine(i+1) > 4 THEN NoteLine(i+1) = NoteLine(i+1) -7 NEXT i END IF kol1 = staff.hor + (horpos * staff.akkoordraster) kol2 = kol1 + staff.nb + 1 kol3 = kol2 + staff.nb + 1 ' IF horpos = 1 THEN DrawClef hDC, staff.hor ' may be better not to do this automatically... IF BIT(crd%,0) THEN 'DO DrawNote Staff, hDC, NoteLine(1), kol1 END IF IF BIT(crd%,1) THEN 'Reb / Do# IF BIT(crd%,0) = 0 AND BIT(crd%,2) = 0 THEN DrawNote Staff, hDC, NoteLine(1), kol2 DrawSharp Staff, hDC, NoteLine(1), kol1 ELSE DrawNote Staff, hDC, NoteLine(2), kol3 DrawFlat Staff, hDC, NoteLine(2), kol2 END IF END IF IF BIT(crd%,2) THEN IF BIT(crd%,0) = 0 AND BIT(crd%,1) = 0 AND BIT(crd%,4) = 0 THEN DrawNote Staff, hDc, NoteLine(2), kol1 ELSE DrawNote Staff, hDC, NoteLine(2)+7, kol1 END IF END IF IF BIT(crd%,3) THEN 'Mib / Re# IF BIT(crd%,2) = 0 AND BIT(crd%,4) THEN DrawNote Staff, hDC, NoteLine(2), kol3 DrawSharp Staff, hDC, Noteline(2), kol2 ELSE DrawNote Staff, hDC, NoteLine(3), kol3 DrawFlat Staff, hDC, NoteLine(3), kol2 END IF END IF IF BIT(crd%,4) THEN 'MI DrawNote Staff, hDC, NoteLine(3) , kol1 END IF IF BIT(crd%,5) THEN IF BIT(crd%,4)=0 AND BIT(crd%,7)=0 THEN ' FA 2e kolom, 1e tussenlijn DrawNote Staff, hDC, NoteLine(4) , kol1 ELSE DrawNote Staff, hDC, NoteLine(4)+ 7 , kol1 END IF END IF IF BIT(crd%,6) THEN ' FA# / Solb IF BIT(crd%,5)= 0 THEN DrawNote Staff, hDC, NoteLine(4), kol3 DrawSharp Staff, hDC, NoteLine(4), kol2 ELSE DrawNote Staff, hDC, NoteLine(5), kol3 DrawFlat Staff, hDC, NoteLine(5), kol2 END IF END IF IF BIT(crd%,7) THEN ' SOL 1e kolom 2e lijn DrawNote Staff, hDc, NoteLine(5), kol1 END IF IF BIT(crd%,8) THEN ' SOL# / Lab 3e kolom, 2e lijn IF BIT(crd%,7) = 0 THEN DrawNote Staff, hDC, NoteLine(5), kol3 DrawSharp Staff, hDC, NoteLine(5), kol2 ELSE DrawNote Staff, hDC, NoteLine(6), kol3 DrawFlat Staff, hDC, NoteLine(6), kol2 END IF END IF IF BIT(crd%,9) THEN ' LA IF BIT(crd%,11)= 0 AND BIT(crd%,7) = 0 THEN DrawNote Staff, hDC, NoteLine(6), kol1 ELSE DrawNote Staff, hDC, NoteLine(6) + 7, kol1 END IF END IF IF BIT(crd%,10) THEN 'Sib /La# 3e kolom, 3e lijn IF BIT(crd%,11) = 0 THEN DrawNote Staff, hDC, NoteLine(7), kol3 DrawFlat Staff, hDC, NoteLine(7), kol2 ELSE DrawNote Staff, hDC, NoteLine(6), kol3 DrawSharp Staff, hDC, NoteLine(6), kol2 END IF END IF IF BIT(crd%,11) THEN 'Si 1e kolom, 3e lijn DrawNote Staff, hDC, NoteLine(7), kol1 END IF ' vertical barline: ' DrawBarline hDC, staff.hor + ((horpos+1) * staff.akkoordraster)-3 ' better not automatic ? END SUB FUNCTION ShowNote (staff AS StaffType, BYVAL hDC AS LONG, BYVAL note AS BYTE, BYVAL horpos AS WORD) EXPORT AS WORD ' horpos in horizontal pixels from the start of the staff. ' There is no provision as yet for octave position when notes exceed the range of the staff. IF ISFALSE hDC THEN FUNCTION = horpos : EXIT FUNCTION LOCAL oldpoint AS POINTL LOCAL oktaaf AS INTEGER STATIC cleffactor AS BYTE, oldclef AS STRING * 2 DIM NoteLine(1 TO 7) AS STATIC INTEGER IF staff.clef <> oldclef THEN LOCAL i AS BYTE oldclef = staff.clef SELECT CASE staff.clef CASE "G2" : cleffactor = 6 CASE "F4", "G1" : cleffactor = 4 CASE "C1" : cleffactor = 1 CASE "C2" : cleffactor = 3 CASE "C3" : cleffactor = 5 CASE "C4" : cleffactor = 7 CASE "C5", "F3" : cleffactor = 2 CASE ELSE : cleffactor = 6 END SELECT FOR i = 0 TO 6 NoteLine(i+ 1) = i + cleffactor IF NoteLine(i+1) > 4 THEN NoteLine(i+1) = NoteLine(i+1) -7 NEXT i END IF ' berekening van de oktaafligging: oktaaf = ((note \ 12) - 5 ) * 7 SELECT CASE note MOD 12 CASE 0 'DO DrawNote staff, hDC, NoteLine(1)+ oktaaf, staff.hor + horpos FUNCTION = horpos + staff.nb + 1 CASE 1 'Do# DrawSharp staff, hDC, NoteLine(1)+ oktaaf,staff.hor + horpos DrawNote staff, hDC, NoteLine(1)+ oktaaf ,staff.hor + horpos + staff.nb + 1 FUNCTION = horpos + staff.nb + staff.nb + 2 CASE 2 ' Re DrawNote staff, hDC, NoteLine(2)+ oktaaf,staff.hor + horpos FUNCTION = horpos + staff.nb + 1 CASE 3 'Mib / Re# DrawFlat staff, hDC, NoteLine(3)+ oktaaf,staff.hor + horpos DrawNote staff, hDC, NoteLine(3)+ oktaaf,staff.hor + horpos + staff.nb + 1 FUNCTION = horpos + staff.nb + staff.nb + 2 CASE 4 'MI DrawNote staff, hDC, NoteLine(3)+oktaaf , staff.hor + horpos FUNCTION = horpos + staff.nb + 1 CASE 5 ' FA DrawNote staff, hDC, NoteLine(4)+oktaaf , staff.hor + horpos FUNCTION = horpos + staff.nb + 1 CASE 6 ' FA# / Solb DrawSharp staff, hDC, NoteLine(4)+ oktaaf, staff.hor + horpos DrawNote staff, hDC, NoteLine(4)+ oktaaf, staff.hor + horpos + staff.nb + 1 FUNCTION = horpos + staff.nb + staff.nb + 2 CASE 7 ' SOL DrawNote staff, hDc, NoteLine(5)+ oktaaf,staff.hor + horpos FUNCTION = horpos + staff.nb + 1 CASE 8 ' SOL# / Lab DrawSharp staff, hDC, NoteLine(5)+ oktaaf,staff.hor + horpos DrawNote staff, hDC, NoteLine(5)+ oktaaf,staff.hor + horpos + staff.nb + 1 FUNCTION = horpos + staff.nb + staff.nb + 2 CASE 9 ' LA DrawNote staff, hDC, NoteLine(6)+ oktaaf,staff.hor + horpos FUNCTION = horpos + staff.nb + 1 CASE 10 'Sib /La# DrawFlat staff, hDC, NoteLine(7)+ oktaaf,staff.hor + horpos DrawNote staff, hDC, NoteLine(7)+ oktaaf,staff.hor + horpos + staff.nb + 1 FUNCTION = horpos + staff.nb + staff.nb + 2 CASE 11 'Si DrawNote staff, hDC, NoteLine(7) + oktaaf,staff.hor + horpos FUNCTION = horpos + staff.nb + 1 END SELECT END FUNCTION SUB ShowHar (Har AS HarmType, BYVAL h%, BYVAL v%, BYVAL s!) EXPORT ' s! is the vertical scale ! LOCAL bw%, il%, H1%, H2%, v2%, Sp% LOCAL hBrushBlackKeys AS LONG LOCAL hBrushWhiteKeys AS LONG LOCAL hBrush AS LONG LOCAL hOldBrush AS LONG LOCAL hDC AS LONG IF @pgh.Harvel THEN hDC = GetDC(@pgh.HarVel) hBrushWhiteKeys = CreateSolidBrush (%WHITE) '(&H00F0FFFF) :' light yellow gray... (&H00C1C1C1) hBrushBlackKeys = CreateSolidBrush (%BLACK) ' (&H00000000) :' (&H00FFFFFF) ' graphic display of complete harmonic situation ' display is in piano-key colors IF v% > 480 THEN v% = 480 IF s! > v% / 127 THEN s! = v% / 127 IF h% > 640 - 128 THEN h% = 640 - 128: ' minimum width is 128 pixels SELECT CASE h% CASE < (640 - 512) bw% = 4: Sp% = 2 CASE < 640 - 384 bw% = 3: Sp% = 2 CASE < 640 - 256 bw% = 2: Sp% = 1 CASE ELSE bw% = 1: Sp% = 0 END SELECT ' blank existing graph: PatBlt hDC, h%,0,bw% * (128 + Sp%),v% *s!,%WHITENESS FOR il% = 0 TO 127 H1% = h% + (il% * bw%) H2% = H1% + Sp% + 2 SELECT CASE il% MOD 12 CASE 0, 2, 4, 5, 7, 9, 11 hBrush = hBrushWhiteKeys CASE ELSE hBrush = hBrushBlackKeys END SELECT hOldBrush = SelectObject(hDC, hBrush) Rectangle hDC, H1%, v%, H2%, v% - (ASC(MID$(Har.vel, il% + 1, 1)) * s!) ' draw keyboard reference, for ease of reading: Rectangle hDC,H1%,v%+2, H2%, v% +2 + bw% SelectObject hDC, hOldBrush DeleteObject hBrush NEXT il% ReleaseDC @pgh.HarVel, hDC END IF END SUB SUB ClearScreenBlock (BYVAL hDC AS LONG , BYVAL hor%, BYVAL ver%, BYVAL horpix%, BYVAL verpix%) EXPORT ' New code for Win32Api: PatBlt hDC,hor%,ver%,horpix%,verpix%,%WHITENESS END SUB FUNCTION MakeMelodyPatternWindow () EXPORT AS LONG LOCAL wcs AS WndClassEx LOCAL szClassName AS ASCIIZ * 20 LOCAL dwExStyle AS DWORD szClassName = "GMT melodywindow" wcs.cbSize = SIZEOF(wcs) wcs.style = %CS_HREDRAW OR %CS_VREDRAW wcs.lpfnWndProc = CODEPTR(ProcMelodyPatternWindow) wcs.cbClsExtra = 0 wcs.cbWndExtra = 0 wcs.hInstance = hInstDLL wcs.hIcon = @pApp.hIcon wcs.hCursor = LoadCursor( %NULL, BYVAL %IDC_NO ) wcs.hbrBackground = GetStockObject(%WHITE_BRUSH) wcs.lpszMenuName = %NULL wcs.lpszClassName = VARPTR(szClassName) wcs.hIconSm = @pApp.hIcon RegisterClassEx wcs dwExStyle = %WS_EX_APPWINDOW ' create a window using the registered class: @pgh.MelPat = CreateWindowEx(BYVAL dwExStyle,_ szClassName, _ ' window class name " time proportional melody pattern window ", _ ' window caption %WS_OVERLAPPEDWINDOW, _ ' window style 1, _ ' initial x position GetSystemMetrics(%SM_CYSCREEN)- 160, _ ' initial y position GetSystemMetrics(%SM_CXSCREEN), _ ' initial x size 160, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle %NULL, _ ' window menu handle hInstDLL, _ ' program instance handle BYVAL %NULL) ' creation parameters ' Display the window on the screen ShowWindow @pgh.MelPat, %SW_SHOW CornerWindow @pgh.MelPat, "lo" UpdateWindow @pgh.MelPat FUNCTION = @pgh.MelPat END FUNCTION FUNCTION ProcMelodyPatternWindow (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG ' callback for melody window SELECT CASE wMsg CASE %WM_SIZE InvalidateRect hWnd, BYVAL 0, BYVAL 1 FUNCTION = 0 EXIT FUNCTION CASE ELSE FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END SELECT END FUNCTION FUNCTION MakeGraphWindow () EXPORT AS LONG LOCAL wc AS WndClassEx LOCAL szClassName AS ASCIIZ * 40 LOCAL dwExStyle AS DWORD szClassName = "GMT drawing window" wc.cbSize = SIZEOF(wc) wc.style = %CS_HREDRAW OR %CS_VREDRAW wc.lpfnWndProc = CODEPTR(GraphProc) ' adres of message handler wc.cbClsExtra = 0 wc.cbWndExtra = 0 wc.hInstance = hInstDLL wc.hIcon = @pApp.hIcon wc.hCursor = LoadCursor( %NULL, BYVAL %IDC_NO ) wc.hbrBackground = GetStockObject(%WHITE_BRUSH) ' %LTGRAY_BRUSH) '%NULL_BRUSH) wc.lpszMenuName = %NULL wc.lpszClassName = VARPTR( szClassName ) wc.hIconSm = @pApp.hIcon RegisterClassEx wc dwExStyle = %WS_EX_APPWINDOW ' Now, create a window using the registered class @pgh.Graph = CreateWindowEx(BYVAL dwExStyle,_ szClassName, _ ' window class name " graphics window ", _ ' window caption %WS_OVERLAPPEDWINDOW, _ ' window style 1,_ '%CW_USEDEFAULT, _ ' initial x position 600,_ '%CW_USEDEFAULT, _ ' initial y position 700,_ '%CW_USEDEFAULT, _ ' initial x size 150,_ '%CW_USEDEFAULT, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle %NULL, _ ' window menu handle hInstDll, _ ' program instance handle BYVAL %NULL) ' creation parameters ' Display the window on the screen ShowWindow @pgh.Graph, %SW_SHOW UpdateWindow @pgh.Graph FUNCTION = @pgh.Graph END FUNCTION FUNCTION GraphProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG ' callback function with message loop for graphics window SELECT CASE wMsg CASE %WM_SIZE InvalidateRect hWnd, BYVAL 0,BYVAL 1 FUNCTION = %False EXIT FUNCTION END SELECT ' other msg's handled by the default handler: FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION FUNCTION MakeHarVelWindow () EXPORT AS LONG ' creates a window for displaying har().vel structures LOCAL wc AS WndClassEx LOCAL szClassName AS ASCIIZ * 10 LOCAL dwExStyle AS DWORD szClassName = "GMT-HarVelBox" wc.cbSize = SIZEOF(wc) wc.style = %CS_HREDRAW OR %CS_VREDRAW wc.lpfnWndProc = CODEPTR(HarVelProc) wc.cbClsExtra = 0 wc.cbWndExtra = 0 wc.hInstance = @pgh.Inst wc.hIcon = @pApp.hIcon wc.hCursor = LoadCursor( %NULL, BYVAL %IDC_NO ) wc.hbrBackground = GetStockObject(%LTGRAY_BRUSH) wc.lpszMenuName = %NULL wc.lpszClassName = VARPTR(szClassName) wc.hIconSm = @pApp.hIcon RegisterClassEx wc dwExStyle = %WS_EX_APPWINDOW ' Now, create a window using the registered class ' the handle of this window is a global variable @pgh.HarVel = CreateWindowEx(BYVAL dwExStyle,_ szClassName, _ ' window class name "Harmony Display", _ ' window caption %WS_OVERLAPPEDWINDOW, _ ' window style 1, _ ' initial x position 1, _ ' initial y position 410, _ ' initial x size 180, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle %NULL, _ ' window menu handle @pgh.Inst, _ ' program instance handle BYVAL %NULL) ' creation parameters ' Display the window on the screen ShowWindow @pgh.HarVel, %SW_SHOW UpdateWindow @pgh.HarVel FUNCTION = @pgh.HarVel END FUNCTION FUNCTION HarvelProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG ' callback for Har().vel display window SELECT CASE wMsg CASE %WM_SIZE InvalidateRect hWnd, BYVAL 0,BYVAL 1 FUNCTION = 0 EXIT FUNCTION END SELECT FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION FUNCTION Make_ii_VU_Window (BYVAL resolution AS BYTE) EXPORT AS LONG ' creates a window for displaying 16 channels of ADC input ' we should not waste pixels if they exceed resolution... ' so the vertical size will be a function of the requested resolution. ' Used by ii-sonar, quadrada and Picra devices. LOCAL wc AS WndClassEx LOCAL szClassName AS ASCIIZ * 10 LOCAL dwExStyle AS DWORD LOCAL vsize AS LONG vsize = (2 ^ resolution) + 24 IF vsize > 540 THEN vsize = 540 szClassName = "ADCmonitor" wc.cbSize = SIZEOF(wc) wc.style = %CS_HREDRAW OR %CS_VREDRAW wc.lpfnWndProc = CODEPTR(iiVUProc) ' address of the message handler wc.cbClsExtra = 0 wc.cbWndExtra = 0 wc.hInstance = hInstDLL wc.hIcon = @pApp.hIcon wc.hCursor = LoadCursor( %NULL, BYVAL %IDC_NO ) '%False wc.hbrBackground = GetStockObject(%LTGRAY_BRUSH) wc.lpszMenuName = %NULL wc.lpszClassName = VARPTR(szClassName) wc.hIconSm = @pApp.hIcon RegisterClassEx wc dwExStyle = %WS_EX_TOOLWINDOW '%WS_EX_CLIENTEDGE '%WS_EX_APPWINDOW ' Now, create a window using the registered class @pgh.VU = CreateWindowEx(BYVAL dwExStyle,_ szClassName, _ ' window class name "DAQ monitor", _ ' window caption %WS_CAPTION,_ '%WS_OVERLAPPEDWINDOW, _ ' window style 1, _ ' initial x position 1, _ ' initial y position 120, _ ' initial x size vsize, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle %NULL, _ ' window menu handle hInstDLL, _ ' program instance handle BYVAL %NULL) ' creation parameters ' Display the window on the screen ShowWindow @pgh.VU, %SW_SHOW UpdateWindow @pgh.VU FUNCTION = @pgh.VU END FUNCTION FUNCTION iiVUProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _ BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG ' callback for ii-ADC card VU-display window SELECT CASE wMsg CASE %WM_SIZE InvalidateRect hWnd, BYVAL 0, BYVAL 1 FUNCTION = %False EXIT FUNCTION END SELECT FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION FUNCTION MakeHarPsyWindow () EXPORT AS LONG ' window for displaying har().psy structures LOCAL wc AS WndClassEx LOCAL szClassName AS ASCIIZ * 15 LOCAL dwExStyle AS DWORD szClassName = "PsyChord" wc.cbSize = SIZEOF(wc) wc.style = %CS_HREDRAW OR %CS_VREDRAW wc.lpfnWndProc = CODEPTR(HarPsyProc) wc.cbClsExtra = 0 wc.cbWndExtra = 0 wc.hInstance = hInstDLL wc.hIcon = %False wc.hCursor = LoadCursor( %NULL, BYVAL %IDC_NO ) '%False wc.hbrBackground = GetStockObject(%LTGRAY_BRUSH) wc.lpszMenuName = %NULL wc.lpszClassName = VARPTR( szClassName ) wc.hIconSm = %False RegisterClassEx wc dwExStyle = %WS_EX_TOOLWINDOW '%WS_EX_APPWINDOW @pgh.HarPsy = CreateWindowEx(BYVAL dwExStyle,_ szClassName, _ ' window class name "Chord", _ ' window caption %WS_CAPTION, _ ' window style 1, _ ' initial x position 120, _ ' initial y position 50, _ ' initial x size 116, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle %NULL, _ ' window menu handle hInstDll, _ ' program instance handle BYVAL %NULL) ' creation parameters ShowWindow @pgh.HarPsy, %SW_SHOW UpdateWindow @pgh.HarPsy FUNCTION = @pgh.HarPsy END FUNCTION FUNCTION HarPsyProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG)EXPORT AS LONG ' callback for Har().psy display window SELECT CASE wMsg CASE %WM_SIZE InvalidateRect hWnd, BYVAL 0,BYVAL 1 FUNCTION = %False EXIT FUNCTION END SELECT FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION FUNCTION MakeSpectrumWindow () EXPORT AS LONG ' creates a window for displaying spectral transforms and waveforms LOCAL wc AS WndClassEx LOCAL szClassName AS ASCIIZ * 20 LOCAL dwExStyle AS DWORD szClassName = "GMT-Spectrum Display" wc.cbSize = SIZEOF(wc) wc.style = %CS_HREDRAW OR %CS_VREDRAW wc.lpfnWndProc = CODEPTR(SpectrumProc) ' CODEPTR is used to pass the address of the message handler wc.cbClsExtra = 0 wc.cbWndExtra = 0 wc.hInstance = hInstDLL 'hInst wc.hIcon = @pApp.hIcon wc.hCursor = LoadCursor( %NULL, BYVAL %IDC_NO ) '%False 'LoadCursor( %NULL, BYVAL %IDC_ARROW ) wc.hbrBackground = GetStockObject(%LTGRAY_BRUSH) '%NULL_BRUSH) %WHITE_BRUSH wc.lpszMenuName = %NULL wc.lpszClassName = VARPTR( szClassName ) wc.hIconSm = @pApp.hIcon RegisterClassEx wc dwExStyle = %WS_EX_APPWINDOW ' Now, create a window using the registered class ' the handle of this window is a global variable @pgh.Spec = CreateWindowEx(BYVAL dwExStyle,_ szClassName, _ ' window class name " Spectrum Display ", _ ' window caption %WS_OVERLAPPEDWINDOW, _ ' window style 1, _ ' initial x position 50, _ ' initial y position 280, _ ' initial x size 280, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle %NULL, _ ' window menu handle hInstDll, _ ' program instance handle BYVAL %NULL) ' creation parameters ' Display the window on the screen ShowWindow @pgh.Spec, %SW_SHOW UpdateWindow @pgh.Spec FUNCTION = @pgh.Spec END FUNCTION FUNCTION SpectrumProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG)EXPORT AS LONG ' callback procedure for spectrum display window ' LOCAL Ztext AS ASCIIZ * 100 ' LOCAL hDC AS LONG ' LOCAL LpPaint AS PaintStruct ' LOCAL tRect AS Rect SELECT CASE wMsg 'CASE %WM_CREATE 'CASE %WM_ENTERIDLE CASE %WM_SIZE InvalidateRect hWnd, BYVAL 0,BYVAL 1 FUNCTION = 0 EXIT FUNCTION ' CASE %WM_PAINT ' hDC = BeginPaint(hWnd, LpPaint) ' EndPaint hWnd, LpPaint 'GetClientRect hWnd, tRect 'InvalidateRect hWnd, tRect, 0 ' FUNCTION = 0 ' EXIT FUNCTION ' CASE %WM_DESTROY ' PostQuitMessage 0 ' FUNCTION = 0 ' EXIT FUNCTION END SELECT ' other msg's handled by the default handler: FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam) END FUNCTION SUB wPrint(BYVAL param AS LONG, BYREF glist()AS STRING * 80) EXPORT ' param = %False = destroy listing dialog ' param = %True = create listing dialog STATIC id& STATIC hDlg& LOCAL TXT$ LOCAL i AS LONG SELECT CASE param CASE %False IF hDlg& THEN DIALOG END hDlg& hDlg& = %False EXIT SUB CASE ELSE IF ISFALSE hDlg& THEN id& = 1 DIALOG NEW %HWND_DESKTOP, "GMT",%CW_USEDEFAULT,%CW_USEDEFAULT,_ 250,350,_ %WS_MAXIMIZEBOX OR %WS_MINIMIZEBOX OR %WS_THICKFRAME OR %WS_CAPTION,_ %WS_EX_TOOLWINDOW TO hDlg& CONTROL ADD TEXTBOX, hDlg&,id&,TXT$,0,0,250,350,%ES_MULTILINE OR %ES_READONLY,%WS_EX_WINDOWEDGE DIALOG SHOW MODELESS hDlg& END IF END SELECT TXT$ = "" FOR i = 0 TO UBOUND(glist) TXT$ = TXT$ & RTRIM$(glist(i)) & $CRLF NEXT i CONTROL SET TEXT hDlg&, id&, TXT$ END SUB ' **************************************************** ' * Version 5.0: * ' **************************************************** FUNCTION g_taskProc (BYVAL wTimerID AS LONG, BYVAL msg AS LONG, BYVAL TaskNr AS LONG, BYVAL dw1 AS LONG, BYVAL dw2 AS LONG) AS LONG ' this is the callback function for frequency modulated tasks ' It replaces the MT loop in GMT_MAIN used in prior versions. ' After the doc. in the MSDN SDK , this callback -since it is interrupt driven- should reside in the DLL. ' to implement this, we need a global @pTask() AS GLOBAL Taak PTR in the DLL! (added to g_lib.bas). ' This pointer structure has to be initialized from GMT! The procedure doing this is SetTasks, called from ' gmt on initialisation. LOCAL retval AS LONG ' the tasknr is passed via the parameter TaskNr (0-(%NrOfTasks-1)) , thus there are as many timers as we have tasks. retval = timeKillEvent (BYVAL wTimerID) ' every TimesetEvent must be matched with a timeKillevent... ' call the task-code: IF @pTask(Tasknr).cPtr THEN ' protect against calls to zero pointer land... ' now check the flags in the task: IF BIT (@pTask(Tasknr).swit, %TASK_ONOFF) THEN CALL DWORD @pTask(Tasknr).cPtr ' perform the task code, residing in GMT !!! ' now we check the flag again, since the task might have changed it! IF BIT (@pTask(Tasknr).swit,%TASK_ONOFF) THEN ' we use the rsi field here... @pTask(Tasknr).rsi = MAX(1000! / @pTask(Tasknr).freq,1) ' in ms retval = TimeSetEvent(@pTask(Tasknr).rsi,0,CODEPTR(g_taskProc),Tasknr,%TIME_ONESHOT OR %TIME_CALLBACK_FUNCTION) BIT SET @pTask(TaskNr).swit, %Task_BUSY ELSE BIT RESET @pTask(TaskNr).swit,%TASK_BUSY END IF END IF FUNCTION = %False END FUNCTION FUNCTION g_PerTaskProc (BYVAL wTimerID AS LONG, BYVAL msg AS LONG, BYVAL TaskNr AS LONG, BYVAL dw1 AS LONG, BYVAL dw2 AS LONG) AS LONG ' this is the callback function for periodic tasks - 29.09.2003 - no export. ' After the doc. in the MSDN SDK , this callback -since it is interrupt driven- should reside in the DLL. LOCAL retval AS LONG ' the tasknr is passed via the parameter TaskNr (0-(%NrOfTasks-1)) IF @pTask(Tasknr).cPtr THEN ' protect against calls to zero pointer land... ' now check the flags in the task: IF BIT (@pTask(Tasknr).swit, %TASK_ONOFF) THEN CALL DWORD @pTask(Tasknr).cPtr ' perform the task code, residing in GMT !!! ' now we check the flag again, since the task might have changed it! IF BIT (@pTask(Tasknr).swit,%TASK_ONOFF) THEN BIT SET @pTask(TaskNr).swit, %Task_BUSY ELSE BIT RESET @pTask(TaskNr).swit,%TASK_BUSY retval = timeKillEvent (BYVAL wTimerID) ' every TimesetEvent must be matched with a timeKillevent... END IF END IF FUNCTION = %False END FUNCTION #IF NOT %DEF(%use_queuetimers_allways) #IF NOT %DEF(%choose_timer_mode) 'classical way with timesetevent which we leave untouched SUB StartTask (BYVAL tasknr AS LONG) EXPORT ' here we do everything required to properly start a task. ' We send the tasknumber as a negative value, if called from the cockpit window. ' This way we have a flag in this procedure so that we know a call was a result of a user ' interaction in the cockpit window. LOCAL cockpitflag AS DWORD LOCAL retval AS LONG logfile "classical starttask" + STR$(tasknr) IF tasknr < 0 THEN cockpitflag = %True : tasknr= ABS(tasknr) ' task switched by user, if passed as negative. IF tasknr > UBOUND(pTask) THEN EXIT SUB ' potential bug: we cannot start a task if the timer is already running for it. ' tasks should only be started when in a restartable state... ' so we may have to set a flag in the callback! IF ISFALSE cockpitflag THEN CheckDlgButton @pgh.Cockpit,%GMT_TASK0_ID + tasknr, %BST_CHECKED END IF ' if it is a midi task, we should initialize the equipment with the appropriate data: IF hMidiO(0) THEN ' only if we have a midi handle IF (@pApp.AutoFlags AND %AUTOPATCH) = %AUTOPATCH THEN ' only if the AUTOPATCH flag is set IF (@pTask(tasknr).flags AND %MIDI_TASK) THEN ' only if defined as miditask IF @pTask(tasknr).patch < 128 THEN ProgChange @pTask(tasknr).channel, @pTask(tasknr).patch ELSE ' this would much better be handled in the users own task code... SELECT CASE TRIM$(UCASE$(@pMeq(0).naam)) CASE "PROTEUS2","PROTEUS2XR","PROTEUS3","PROTEUS3XR","PROTEUS2000" ProteusPatch @pMeq(0), @pTask(tasknr).channel, @pTask(tasknr).patch CASE "FB01" ProgChange @pTask(tasknr).channel, @pTask(tasknr).patch CASE "TX81X" ProgChange @pTask(tasknr).channel, @pTask(tasknr).patch CASE "MU100R" ProgChange @pTask(tasknr).channel, @pTask(tasknr).patch CASE ELSE 'ProgChange @pTask(tasknr).channel, @pTask(tasknr).patch ' not yet implemented. Add machine specific code here... END SELECT END IF ModeMess @pTask(tasknr).channel, &H79, 0 ' reset all controllers ModeMess @pTask(tasknr).channel, 7 , @pTask(tasknr).level ModeMess @pTask(tasknr).channel, 10, @pTask(tasknr).pan END IF END IF END IF ' new added 15.10.2000: ' we could change this so that if you have a start-procedure, the flags would be overridden... ' users, let me know what you prefer... IF @pTaskEX(tasknr).StartCptr THEN CALL DWORD @pTaskEx(tasknr).StartCptr '------------------------ BIT SET @pTask(tasknr).swit, %TASK_ONOFF @pTask(tasknr).starttime = GetPromil @pTask(tasknr).rsi = MAX(1000! / @pTask(tasknr).freq,1) ' new MAX 29.09.2003 - divide 0 error if freq=0 SELECT CASE @pTask(tasknr).flags AND %PERTIM_TASK CASE %False IF ISFALSE BIT (@pTask(tasknr).swit, %TASK_BUSY) THEN ' remark: maybe we should first set the timer event, then call the task... [11.09.2000] CALL DWORD @pTask(tasknr).cPtr ' so that we start right away !(ON the beat!) retval = TimeSetEvent(@pTask(tasknr).rsi,0,CODEPTR(g_taskProc),tasknr,%TIME_ONESHOT OR %TIME_CALLBACK_FUNCTION) ' logfile "timesetevent os:" + STR$(retval) IF ISFALSE retval THEN MSGBOX "failed creating timer for task "+ STR$(tasknr) ' ELSE ' the task was already running! - we could crash by starting two instances of the same timertask. END IF CASE ELSE IF ISFALSE BIT (@pTask(tasknr).swit, %TASK_BUSY) THEN CALL DWORD @pTask(tasknr).cptr retval = TimeSetEvent(@pTask(tasknr).rsi,0,CODEPTR(g_perTaskProc),tasknr,%TIME_PERIODIC OR %TIME_CALLBACK_FUNCTION) ' logfile "timesetevent per:" + STR$(retval) IF ISFALSE retval THEN MSGBOX "failed creating timer for task "+ STR$(tasknr) END IF END SELECT END SUB #ENDIF #ENDIF 'in the end we make it work without this function.. ''function ReportTaskcptr(opt byval tasknr as long) EXPORT as long '' this function is here because the starttask function used when compiled with %use_queuetimers_allways sees the pTask(tasknr) as being 0, while this function '' returns the correct number. '' don't ask how this is possible.. '' (originally was a debug function that just logged all tasknrs) '' '' log pTask array.. we made this because codepointers mysteriously got wiped when using queued timers.. '' local i as long '' logfile FUNCNAME$ + str$(tasknr) '' FOR i = lbound(pTask) TO UBOUND (ptask) '' logfile STR$(i) + STR$(pTask(i)) '' NEXT '' logfile "***" '' function = pTask(tasknr) ''END function #IF %DEF(%use_queuetimers_allways) SUB StartTask(BYVAL tasknr AS LONG) EXPORT 'experimental way with timerqueuetimer ' here we do everything required to properly start a task. ' We send the tasknumber as a negative value if called from the cockpit window. ' This way we have a flag in this procedure so that we know a call was a result of a user ' interaction in the cockpit window. ' 20080812 weirdness: pTask(tasknr) is sometimes 0 here, althoug tasknr is valid. ' if we take an indirection and ask ReportTaskCptr for the right value it works.. LOCAL cockpitflag AS DWORD LOCAL retval AS LONG LOCAL cp AS DWORD logfile "queuetimers" IF tasknr < 0 THEN cockpitflag = %True : tasknr= ABS(tasknr) ' task switched by user, if passed as negative. IF tasknr > UBOUND(pTask) THEN EXIT SUB logfile "starttask - allwaysqueued" + STR$(tasknr) ' logfile "ptask:" + STR$(pTask(tasknr)) IF ISFALSE pTask(Tasknr) THEN MSGBOX "no task ptr",,FUNCNAME$ ' dp = reporttaskcptr(tasknr) 'total weirdness.. we get here and it prints the correct pointer nr..!! ' logfile "dp reported:" + str$(dp) EXIT SUB END IF logfile TRIM$(@pTask(tasknr).naam) ' logfile str$(@pTask.freq) ' logfile str$(@pTask.flags) ' static tid() as dword 'this should better become part of the task type.. - global now ' static htq 'global IF ISFALSE(@pTask(tasknr).freq) OR ISFALSE(@pTask(tasknr).cptr) THEN EXIT SUB IF ISFALSE(htq) THEN ' logfile "create qeueu" htq = CreateTimerQueue 'according to the docs we can use the default timer queue, but that doesn't work IF ISFALSE hTq THEN MSGBOX "Failed creating timer qeue!" + $CRLF + "Last error code:" + STR$(ERRCLEAR),,FUNCNAME$: EXIT SUB ' DIM tid(UBOUND(ptask)) as global dword ' kr was de as global dword vergeten!!! ' ' gwr removed here, done on init dll END IF ' logfile "htq:" + STR$(htq) IF ISFALSE cockpitflag THEN CheckDlgButton @pgh.Cockpit,%GMT_TASK0_ID + tasknr, %BST_CHECKED ' logfile "flag checked.. END IF IF hMidiO(0) THEN ' only if we have a midi handle IF (@pApp.AutoFlags AND %AUTOPATCH) = %AUTOPATCH THEN ' only if the AUTOPATCH flag is set IF (@pTask(tasknr).flags AND %MIDI_TASK) THEN ' only if defined as miditask IF @pTask(tasknr).patch < 128 THEN ProgChange @pTask(tasknr).channel, @pTask(tasknr).patch END IF '(left out the stuff that would much better be handled in the users own task code... ) ModeMess @pTask(tasknr).channel, &H79, 0 ' reset all controllers ModeMess @pTask(tasknr).channel, 7 , @pTask(tasknr).level ModeMess @pTask(tasknr).channel, 10, @pTask(tasknr).pan END IF END IF END IF logfile "taskex ptr:" + STR$(pTaskEx(tasknr)) 'note: when we use qeueued timers, the following crashes on function with an optional parameter, 'which does not happen with the old timers.. weirdness.. IF @pTaskEX(tasknr).StartCptr THEN CALL DWORD @pTaskEx(tasknr).StartCptr BIT SET @pTask(tasknr).swit, %TASK_ONOFF @pTask(tasknr).starttime = GetPromil @pTask(tasknr).rsi = MAX(1000! / @pTask(tasknr).freq,1) ' new MAX 29.09.2003 - divide 0 error if freq=0 'as we can update the queuetimers, there's no need anymore to make a distinguishment between %PERTIM and other tasks.. cp = CODEPTR(QTaskCB) retval = CreateTimerQueueTimer(tid(tasknr), hTq, cp, tasknr, @pTask(tasknr).rsi, @pTask(tasknr).rsi, %WT_EXECUTEINPERSISTENTTHREAD ) IF ISFALSE retval THEN MSGBOX "Failed launching task!",,FUNCNAME$ CALL DWORD @pTask(tasknr).cptr 'call it directly right away and schedule it to start after 1 period.. logfile "survived starttask with" + STR$(retval) END SUB #ENDIF #IF %DEF(%choose_timer_mode) SUB StartTask(BYVAL tasknr AS LONG) EXPORT 'timers in modus 1 stay allways in sync.. 'for now (working in winxp) it is recommended to use 0 for fast and/or timing critical tasks (daq etc) and 1 for other ones '2008.08.07 dropped the modus opt param and added a task flag instead: %QUEUE_TASK LOCAL cockpitflag AS DWORD LOCAL retval AS LONG LOCAL cp AS DWORD logfile "choose "+ STR$(@pTask(tasknr).flqgs OR %QUEUE_TQSK) IF tasknr < 0 THEN cockpitflag = %True : tasknr= ABS(tasknr) ' task switched by user, if passed as negative. IF tasknr > UBOUND(pTask) THEN EXIT SUB IF ISFALSE(@pTask(tasknr).freq) OR ISFALSE(@pTask(tasknr).cptr) THEN EXIT SUB ' potential bug: we cannot start a task if the timer is already running for it. ' tasks should only be started when in a restartable state... ' so we may have to set a flag in the callback! IF ((@pTask(tasknr).flags AND %QUEUE_TASK) > 0) AND ISFALSE(htq) THEN htq = CreateTimerQueue 'according to the docs we can use the default timer queue, but that doesn't work logfile "timer queue:" + STR$(htq) IF ISFALSE hTq THEN MSGBOX "Failed creating timer queue!" + $CRLF + "Last error code:" + STR$(ERRCLEAR),,FUNCNAME$: EXIT SUB 'DIM tid(UBOUND(ptask)) as global dword - done on init dll END IF IF ISFALSE cockpitflag THEN CheckDlgButton @pgh.Cockpit,%GMT_TASK0_ID + tasknr, %BST_CHECKED END IF IF hMidiO(0) THEN ' only if we have a midi handle IF (@pApp.AutoFlags AND %AUTOPATCH) = %AUTOPATCH THEN ' only if the AUTOPATCH flag is set IF (@pTask(tasknr).flags AND %MIDI_TASK) THEN ' only if defined as miditask IF @pTask(tasknr).patch < 128 THEN ProgChange @pTask(tasknr).channel, @pTask(tasknr).patch END IF '(left out the stuff that would much better be handled in the users own task code... ) ModeMess @pTask(tasknr).channel, &H79, 0 ' reset all controllers ModeMess @pTask(tasknr).channel, 7 , @pTask(tasknr).level ModeMess @pTask(tasknr).channel, 10, @pTask(tasknr).pan END IF END IF END IF IF @pTaskEX(tasknr).StartCptr THEN CALL DWORD @pTaskEx(tasknr).StartCptr BIT SET @pTask(tasknr).swit, %TASK_ONOFF @pTask(tasknr).starttime = GetPromil @pTask(tasknr).rsi = MAX(1000! / @pTask(tasknr).freq,1) ' new MAX 29.09.2003 SELECT CASE (@pTask(tasknr).flags AND %QUEUE_TASK) CASE 0 'timesetevent SELECT CASE @pTask(tasknr).flags AND %PERTIM_TASK CASE %False IF ISFALSE BIT (@pTask(tasknr).swit, %TASK_BUSY) THEN ' remark: maybe we should first set the timer event, then call the task... [11.09.2000] CALL DWORD @pTask(tasknr).cPtr ' so that we start right away !(ON the beat!) retval = TimeSetEvent(@pTask(tasknr).rsi,0,CODEPTR(g_taskProc),tasknr,%TIME_ONESHOT OR %TIME_CALLBACK_FUNCTION) ' ELSE ' the task was already running! - we could crash by starting two instances of the same timertask. END IF CASE ELSE IF ISFALSE BIT (@pTask(tasknr).swit, %TASK_BUSY) THEN CALL DWORD @pTask(tasknr).cptr retval = TimeSetEvent(@pTask(tasknr).rsi,0,CODEPTR(g_perTaskProc),tasknr,%TIME_PERIODIC OR %TIME_CALLBACK_FUNCTION) END IF END SELECT CASE 1 'queue timers CALL DWORD @pTask(tasknr).cptr 'call it directly right away and schedule it to start after 1 period.. cp = CODEPTR(QTaskCB) retval = CreateTimerQueueTimer(tid(tasknr), hTq, cp, tasknr, @pTask(tasknr).rsi, @pTask(tasknr).rsi, %WT_EXECUTEINPERSISTENTTHREAD ) IF ISFALSE retval THEN MSGBOX "Failed launching task!",,FUNCNAME$ END SELECT END SUB #ENDIF FUNCTION QTaskCB (BYVAL tasknr AS DWORD, BYVAL TimerorWaitFired AS BYTE) AS LONG 'evnt = tasknr @ enumerator in tid 'should call task.cptr, reschedule task if frequency changed '!!!should also check if task is stlll on before and after executing it!! STATIC init AS DWORD STATIC lastfreq()AS SINGLE LOCAL retval AS LONG ' logfile FUNCNAME$ + " " + TRIM$(@pTask(tasknr).naam) IF ISFALSE init THEN init = %True DIM lastfreq(UBOUND(ptask)) 'IF UBOUND(tid)<=0 THEN DIM tid(UBOUND(ptask)) as global dword 'just to make the compiler stop complaining.. dimmed elsewhere when needed.. END IF ' now check the flags in the task: IF BIT (@pTask(Tasknr).swit, %TASK_ONOFF) THEN ' logfile "call" + str$(tasknr) + " " + STR$(@pTask(Tasknr).cPtr) CALL DWORD @pTask(Tasknr).cPtr ' perform the task code, residing in GMT !!! IF ISFALSE lastfreq(tasknr) THEN 'first call to this task lastfreq(tasknr) = @pTask(tasknr).freq ELSEIF lastfreq(tasknr) <> @pTask(tasknr).freq THEN lastfreq(tasknr) = @pTask(tasknr).freq @pTask(tasknr).rsi = MAX(1000! / @pTask(tasknr).freq,1) 'recompute ' logfile "changetimer" + STR$(tasknr) ChangeTimerQueueTimer(htq, tid(tasknr),@pTask(tasknr).rsi, @pTask(tasknr).rsi) 'untested.. END IF BIT SET @pTask(TaskNr).swit, %Task_BUSY ELSE ' logfile "task " + STR$(tasknr) + " stopped - delete timer" '2011.01.06 apparently we get here back still several times after we deleted the timer, in which case we should not delete it again or we get a crash.. IF BIT(@pTask(TaskNr).swit, %TASK_BUSY) THEN BIT RESET @pTask(TaskNr).swit,%TASK_BUSY retval = DeleteTimerQueueTimer(htq, tid(tasknr), 0) logfile "deletetimer retval:"+ STR$(retval) ' else ' logfile funcname$ + "- we shouldn't get here" END IF END IF ' logfile "survived " + FUNCNAME$ END FUNCTION SUB StopTask (BYVAL tasknr AS LONG) EXPORT ' here we do everything required to properly stop a task. ' note that the task will only stop when the callback has returned... ' This can be verified by checking the busy-flag with: ' BIT(Task(nr).swit,%TASK_BUSY = %d1 LOCAL cockpitflag AS BYTE LOCAL i AS WORD LOCAL j AS BYTE ' logfile FUNCNAME$ + STR$(tasknr) IF tasknr < 0 THEN cockpitflag = %True : tasknr= ABS(tasknr) IF tasknr > UBOUND(pTask) THEN EXIT SUB BIT RESET @pTask(tasknr).swit, %TASK_ONOFF 'this stops restarting the timer in the callback. @pTask(tasknr).stoptime = GetPromil ' we also reset the rhythm pattern IF @pTask(tasknr).Rit.pattern(0) THEN FOR i = 0 TO %RitmArraySize ' declared constant = UBOUND(Task(tasknr%).Rit.pattern) @pTask(tasknr).Rit.pattern(i) = %False NEXT i END IF @pTask(tasknr).Har.vel = NUL$(128) ' also for non-midi tasks!!! IF hMidiO(HIBYT(@pTask(tasknr).channel)) THEN IF (@pTask(tasknr).flags AND %MIDI_TASK) = %MIDI_TASK THEN PlayHar @pTask(tasknr).Har, @pTask(tasknr).channel AllNotesOff @pTask(tasknr).channel ' this means a task has to have a unique midi channel... ' since version3 this may go wrong if a timeevent is still running. ' In that case we might encounter stuck notes... ' This can be solved by coding the task-code such that we take into ' account that a task can still run once if the %Task_ONOFF flag is reset, but ' the %Task_busy flag is still set! ' We should exit the taskcode under these conditions. END IF END IF ' used for resetting static vars. in task procedures: @pTask(tasknr).tog = %False IF ISFALSE cockpitflag THEN CheckDlgButton @pgh.Cockpit,%GMT_TASK0_ID + tasknr, %BST_UNCHECKED IF @pTaskEX(tasknr).StopCptr THEN CALL DWORD @pTaskEx(tasknr).StopCptr ' logfile "survived stoptask" + STR$(tasknr) END SUB FUNCTION RunTime (BYVAL onoff AS DWORD) EXPORT AS DWORD 'this is a chronometer. It needs tstart STATIC Tid AS DWORD SELECT CASE onoff CASE %True IF ISFALSE Tid THEN Tid = TimeSetEvent (1000,0,CODEPTR(RunTime_TCB),onoff,%TIME_PERIODIC OR %TIME_CALLBACK_FUNCTION) END IF IF Tid THEN @pApp.RunTimeTog = %True FUNCTION = %True ELSE MSGBOX "Out of timers... Blame MicroSoft!",, FUNCNAME$ FUNCTION = %False END IF CASE %False IF TId THEN TimeKillEvent TId Tid = %False @pApp.RunTimeTog = %False SetDlgItemText @pgh.Cockpit, %GMT_RunTime_ID, "off" END SELECT END FUNCTION FUNCTION RunTime_TCB (BYVAL wTimerID AS LONG, BYVAL msg AS LONG, BYVAL Tstart AS LONG, BYVAL dw1 AS LONG, BYVAL dw2 AS LONG) AS DWORD LOCAL t AS DWORD LOCAL seconds AS DWORD LOCAL minutes AS DWORD LOCAL hours AS DWORD t = timeGetTime seconds = ((t - @pApp.tstart) \ 1000) MOD 60 minutes = ((t - @pApp.tstart) \ 60000) MOD 60 hours = ((t - @pApp.tstart) \ 3600000) MOD 24 SetDlgItemText @pgh.Cockpit, %GMT_RunTime_ID, LTRIM$(STR$(hours) + ":" + STR$(minutes)+":" + STR$(seconds)) END FUNCTION FUNCTION Promil (BYVAL onoff AS DWORD) EXPORT AS DWORD 'this is the promil-counter. It needs @pApp.komposduur ' 1%% duurt (App.komposduur/1000) sekonden ' the duration of 1%% is always (App.komposduur /1000) seconds ' hence the period for the timer should be App.komposduur * 1000/ 1000 or simply App.komposduur STATIC Tid AS DWORD IF ISFALSE @pApp.komposduur THEN EXIT FUNCTION SELECT CASE onoff CASE %True IF ISFALSE Tid THEN Tid = TimeSetEvent (@pApp.komposduur,0,CODEPTR(ShowPromil_TCB),onoff,%TIME_PERIODIC OR %TIME_CALLBACK_FUNCTION) END IF IF Tid THEN @pApp.PromilTog = %True FUNCTION = %True ELSE MSGBOX "Out of timers... Blame MicroSoft!",, FUNCNAME$ FUNCTION = %False END IF CASE %False IF Tid THEN TimeKillEvent TId Tid = %False @pApp.Promiltog = %False SetDlgItemText @pgh.Cockpit, %GMT_Promil_ID, "off" END SELECT END FUNCTION FUNCTION ShowPromil_TCB (BYVAL wTimerID AS LONG, BYVAL msg AS LONG, BYVAL Tstart AS LONG, BYVAL dw1 AS LONG, BYVAL dw2 AS LONG) AS DWORD SetDlgItemText @pgh.Cockpit, %GMT_Promil_ID, LTRIM$(STR$(GetPromil%)) END FUNCTION FUNCTION MTSpeed (BYVAL onoff AS DWORD) AS DWORD ' called from button callback in the cockpit - new 10.10.2003 ' runs at 2Hz frequency '10Hz frequency STATIC Tid AS DWORD STATIC Tstart AS DWORD SELECT CASE onoff CASE %True Tstart = TimeGetTime Tid = TimeSetEvent (500,0,CODEPTR(MTSpeed_TCB),Tstart,%TIME_PERIODIC OR %TIME_CALLBACK_FUNCTION) IF Tid THEN @pApp.MTSpeedTog = %True FUNCTION = %True ELSE MSGBOX "Out of timers... Blame MicroSoft!",, FUNCNAME$ FUNCTION = %False END IF CASE %False IF TId THEN TimeKillEvent TId @pApp.MTSpeedtog = %False Tstart = %False SetDlgItemText @pgh.Cockpit, %GMT_MTSpeed_ID, "off" END SELECT END FUNCTION FUNCTION MTSpeed_TCB (BYVAL wTimerID AS LONG, BYVAL msg AS LONG, BYVAL Tstart AS LONG, BYVAL dw1 AS LONG, BYVAL dw2 AS LONG) AS DWORD LOCAL jitter AS LONG STATIC told AS DWORD STATIC mFreq AS DWORD STATIC tog AS DWORD IF ISFALSE tog THEN tog = %True told = TimeGetTime mFreq = 1000/ 2 ' 2Hz better would be: 1000/ 10 ' 10= frequency, so mFreq = 100 EXIT FUNCTION END IF ' integration time depends on task frequency. ' displays a jittervalue in ms. jitter = (timeGetTime - told) - mFreq IF jitter < %False THEN jitter = %False SetDlgItemText @pgh.Cockpit, %GMT_MTSpeed_ID, FORMAT$(jitter, "###") told = TimeGetTime END FUNCTION SUB GlobHar () EXPORT LOCAL i AS LONG @pTask(@pApp.GlobalHarmonyTaskNr).Har.vel = STRING$(128, 0) FOR i = @pApp.GlobalHarmonyTaskNr+ 1 TO UBOUND(pTask) IF @pTask(i).swit THEN ' both %Task_busy and %Task_onoff flags! 'IF (Task(i).flags AND %HARM_TASK) EQV %HARM_TASK THEN ' %HARM_TASK = bit 1 = 2 IF BIT (@pTask(i).flags,1 ) THEN @pTask(@pApp.GlobalHarmonyTaskNr).Har.vel = SumHar$(@pTask(@pApp.GlobalHarmonyTaskNr).Har, @pTask(i).Har) END IF END IF NEXT i FillHarType @pTask(@pApp.GlobalHarmonyTaskNr).Har END SUB FUNCTION Tprop (BYVAL k AS DWORD) EXPORT AS SINGLE LOCAL a AS LONG LOCAL b AS LONG LOCAL c AS LONG LOCAL Strt AS LONG LOCAL Stp AS LONG ' k = tasknumber ' returns a normalized value (0->1) for the time of the task with the tasknumber passed. a = GetProMil IF a =< %False THEN FUNCTION = %False: EXIT FUNCTION IF a >= 1000 THEN FUNCTION = %True: EXIT FUNCTION Strt = @pTask(k).starttime IF Strt < %False THEN Strt = a: @pTask(k).starttime = a IF a < Strt THEN FUNCTION = %False: EXIT FUNCTION Stp = @pTask(k).stoptime IF Stp <= %False THEN Stp = 1000 IF a >= Stp THEN FUNCTION = %True: EXIT FUNCTION b = a - Strt ' set to 0 c = Stp - Strt ' duration IF c > 0 THEN FUNCTION = b / c ELSE FUNCTION = %False END FUNCTION FUNCTION Tang (BYVAL tasknr AS DWORD) EXPORT AS SINGLE ' returns the angle (in radians) of time passed in tasknr. (0 TO Pi2) FUNCTION = Tprop(tasknr) * Pi2 ' full circle END FUNCTION FUNCTION GetProMil () EXPORT AS INTEGER ' 1%% duurt (App.komposduur/1000) sekonden ' the duration of 1%% is always (App.komposduur /1000) seconds. ' new 23.06.2002: IF @pApp.MTstart THEN FUNCTION = (timeGetTime - @pApp.tstart) / @pApp.komposduur ELSE FUNCTION = -1 END IF END FUNCTION SUB WriteSeqScore () EXPORT ' midi filewriter task for multitaskers ' note that we do not write standard midi files here! ' If you want to convert our format to standard midi file format, use our utility H2M.EXE ' or feed the output to any standard midi sequencing program (CakeWalk). ' Here we stick to centisecond resolution! ' modified 29.06.2001 STATIC initim AS DWORD STATIC oldtick AS DWORD STATIC NrScoreTasks AS LONG LOCAL tick AS DWORD LOCAL i AS DWORD LOCAL strDbg AS STRING IF ISFALSE @pTask(@pApp.WriteSeqScoreTaskNr).tog THEN @pTaskEX(@pApp.WriteSeqScoreTasknr).stopCptr = CODEPTR(WriteSeqScore_Stop) IF @pApp.SeqOutFileNr <=0 THEN IF @pApp.SeqFileOut <> "" THEN @pApp.SeqOutFileNr = FREEFILE OPEN @pApp.SeqFileOut FOR OUTPUT AS @pApp.SeqOutFileNr ' MSGBOX "opened " + @pApp.SeqFileOut + " as " + STR$(@pApp.SeqOutFileNr) ELSE StopTask @pApp.WriteSeqScoreTaskNr EXIT SUB ' cancel if file not open. END IF END IF @pTask(@pApp.WriteSeqScoreTaskNr).tog = %True NrScoreTasks = %False FOR i = LBOUND(pTask) TO UBOUND(pTask) IF (@pTask(i).flags AND %SCORE_TASK) = %SCORE_TASK THEN INCR NrScoreTasks NEXT i IF NrScoreTasks <= %False THEN EXIT SUB END IF DIM old(UBOUND(pTask))AS STATIC STRING * 128 ' copy of previous Task().Har(0).Vel FOR i = LBOUND(old) TO UBOUND(old) old(i) = STRING$(128, 0) NEXT i? initim = timeGetTime END IF tick = timeGetTime tick = (tick - initim)/ 10 ' div ms by ten to get centiseconds IF tick <= oldtick THEN tick = oldtick + 1 oldtick = tick FOR i = LBOUND(pTask) TO UBOUND(pTask) IF (@pTask(i).flags AND %SCORE_TASK)= %SCORE_TASK THEN ' includes only tasks defined for scoring. IF @pTask(i).swit THEN IF @pTask(i).Har.Vel <> old(i) THEN PRINT# @pApp.SeqOutFileNr, @pTask(i).channel; tick; "H"; @pTask(i).Har.Vel ' + CHR$13 + CHR$ 12 old(i) = @pTask(i).Har.Vel END IF END IF END IF NEXT i END SUB SUB WriteSeqScore_Stop () ' no export required IF @pApp.SeqOutFileNr THEN CLOSE @pApp.SeqOutFileNr @pApp.SeqOutFileNr = %False END IF END SUB SUB PlaySeq () EXPORT ' this is a task prototype to play a track from a previously recorded seq file ' the task().freq value should be at least 100Hz ' Of course this code can form the point of departure for multitrack playback as well as for real time ' interactive applications using an 'underlying' music score. LOCAL Track AS BYTE LOCAL Vel AS STRING IF ISFALSE seq.flags THEN StopTask @pApp.ReadSeqScoreTaskNr EXIT SUB END IF IF ISFALSE @pTask(@pApp.ReadSeqScoreTaskNr).tog THEN @pTaskEX(@pApp.ReadSeqScoreTaskNr).StopCptr = CODEPTR(PlaySeq_Stop) IF @pApp.SeqInFileNr <= %False THEN IF @pApp.SeqFileIn <> "" THEN IF Existfile (UCASE$(@pApp.SeqFileIn)) THEN IF UCASE$(RIGHT$(@pApp.SeqFileIn,4))=".SEQ" THEN @pApp.SeqInFileNr = FREEFILE OPEN @pApp.SeqFileIn FOR BINARY AS @pApp.SeqInFileNr BASE = 0 ELSE @pApp.SeqInFileNr = %False MSGBOX "Invalid sequence file passed to sequencing task",,FUNCNAME$ StopTask @pApp.ReadSeqScoreTaskNr EXIT SUB END IF ELSE MSGBOX "Sequence file not found...",,FUNCNAME$ StopTask @pApp.ReadSeqScoreTaskNr EXIT SUB END IF ELSE MSGBOX "No input filename specified...",,FUNCNAME$ StopTask @pApp.ReadSeqScoreTaskNr EXIT SUB END IF END IF @pTask(@pApp.ReadSeqScoreTaskNr).tog = %True IF ISFALSE seq.speedfactor THEN seq.speedfactor = 1 seq.res = 100 ' resolution, for now always centiseconds. @pTask(@pApp.ReadSeqScoreTaskNr).freq = 100 END IF FOR track = 0 TO 63 IF ISFALSE BIT(seq.flags, track) THEN ITERATE FOR Vel = ReadSeqFile$ (track, seq.speedfactor) IF Vel <> "" THEN @pTask(@pApp.ReadSeqScoreTaskNr).Har.vel = Vel PlayHar @pTask(@pApp.ReadSeqScoreTaskNr).Har, seq.map(track) 'note that mapping several tracks to the same channel may cause trouble END IF NEXT END SUB FUNCTION ExportSeqPtr () EXPORT AS DWORD 'publish seq pointer to exe and g_mus.dll FUNCTION = VARPTR(seq) END FUNCTION SUB PlaySeq_Stop () 'not exported LOCAL i AS BYTE IF @pApp.SeqInFileNr > %False THEN CLOSE @pApp.SeqInFileNr @pApp.SeqInFileNr = %False @pApp.SeqFileIn="" END IF FOR i = 0 TO 63 AllNotesOff seq.map(i) NEXT ReadSeqFile$ 0,1 'allow this function to reset its statics END SUB FUNCTION ReadSeqFile$ (BYVAL track%, BYVAL speedfactor!) EXPORT STATIC tog AS DWORD STATIC timepointer AS LONG STATIC testhar() AS HarmType ' needed for redim preserve STATIC playtime() AS DWORD STATIC Play0Har AS QUAD LOCAL tel& IF ISFALSE seq.flags THEN tog = %false FUNCTION = "" EXIT FUNCTION END IF IF tog = %False THEN IF @pApp.SeqInFileNr <= 0 THEN FUNCTION = "" : EXIT FUNCTION ' global vars. - file should already be opened! tog = %True timepointer = timeGetTime \ 10 DIM testhar(63) AS STATIC HarmType DIM playtime(63) AS STATIC DWORD DIM FilePos(63) AS DWORD FOR tel& = 0 TO 63 'track% playtime(tel&) = timepointer testhar(tel&).vel = NUL$(128) NEXT tel& END IF IF track% < 0 OR track% > 63 THEN EXIT FUNCTION IF track% > UBOUND(testhar) THEN REDIM PRESERVE testhar(track%) AS STATIC HarmType REDIM PRESERVE playtime(track%) AS STATIC DWORD END IF ' if there was still a har.vel in the queue, output it now: IF testhar(track%).vel <> NUL$(128) THEN ' at least if its time has come... IF playtime(track%) > (timeGetTime \ 10) THEN 'track% was tel& ' save it for next call FUNCTION = "" EXIT FUNCTION ELSE FUNCTION = testhar(track%).vel testhar(track%).vel = NUL$(128) EXIT FUNCTION END IF ' return it ELSE 'we had no more har buffered anymore OR the har was NUL$(128) 'in this case we set the bit corresponding with the task in Play0Har IF BIT (Play0Har, track%) THEN IF playtime(track%) > (timeGetTime \ 10) THEN 'track% was tel& ' save it for next call FUNCTION = "" EXIT FUNCTION END IF FUNCTION = STRING$(128, 0) BIT RESET Play0Har, track% testhar(track%).vel = NUL$(128) EXIT FUNCTION END IF testhar(track%).vel = STRING$(128, 0) WHILE seq.flags 'NOT EOF(@pApp.SeqInFileNr) tel& = ReadHarFile& (testhar(track%), track%, INT(@pApp.SeqInFileNr)) IF tel& = -1 THEN FUNCTION = "" : EXIT FUNCTION tel& = tel& / speedfactor! IF tel& + timepointer > (timeGetTime \ 10) THEN ' keep the value read for next call... playtime(track%)= tel& + timepointer FUNCTION = "" ' should return a non-value IF testhar(track%).vel = STRING$(128, 0) THEN BIT SET Play0Har, track% EXIT FUNCTION ELSE FUNCTION = testhar(track%).vel testhar(track%).vel = NUL$(128) EXIT FUNCTION END IF WEND END IF END FUNCTION ' [EOF]