{ ==================================================================== timer-note.f Copyright (C) 2001 FORTH, Inc.
Rick VanNorman rvn@forth.com ==================================================================== } { -------------------------------------------------------------------- Adapted to SwiftForth by Rick VanNorman This sample demonstrates the use of the multi-media timer functions. -------------------------------------------------------------------- } ONLY FORTH ALSO DEFINITIONS VARIABLE STANDALONE LIBRARY WINMM.DLL OPENDLLS 1 IMPORT: timeKillEvent 1 IMPORT: timeBeginPeriod 1 IMPORT: timeEndPeriod 5 IMPORT: timeSetEvent 0 IMPORT: midiOutGetNumDevs 3 IMPORT: midiOutGetDevCaps 5 IMPORT: midiOutOpen 2 IMPORT: midiOutShortMsg 1 IMPORT: midiOutClose WM_USER 100 + CONSTANT WM_BOUNCE 68 CONSTANT SPEED 1 CONSTANT RES 80 CONSTANT MAX-PCH 57 CONSTANT MIN-PCH create moc 52 allot variable hmo variable dev variable last-note variable cur-note variable incr 0 VALUE hBounce 0 VALUE timeID { ------------------------------------------------------------------------ ------------------------------------------------------------------------ } : init-MIDI ( n -- ) dev ! hmo dev @ NULL NULL NULL midiOutOpen drop ; : pack-bytes ( n n n -- n ) 65536 * swap 256 * + + ; : bang hmo @ swap midiOutShortMsg . ; ( n n n -- n ) : alloff 127 0 do 128 i 0 pack-bytes hmo @ swap midiOutShortMsg drop loop ; ( -- ) : cls hmo @ midiOutClose drop ; ( -- ) : BOUNCE-MMTIMER ( -- res ) hBounce WM_BOUNCE 0 0 PostMessage ; ' BOUNCE-MMTIMER 5 CB: &BOUNCE-TIMER : BOUNCE-CREATE ( -- res ) 63 DUP last-note ! cur-note ! 1 incr ! 9 init-MIDI 0 ; : BOUNCE-SIZE ( -- res ) 0 ; : BOUNCE-DEFAULT ( n -- res ) DROP HWND MSG WPARAM LPARAM DefWindowProc ; : BOUNCE-TIMER ( -- res ) 128 last-note @ 0 pack-bytes hmo @ swap midiOutShortMsg drop 144 cur-note @ 100 pack-bytes hmo @ swap midiOutShortMsg drop cur-note @ last-note ! cur-note @ MAX-PCH > if incr @ -1 * incr ! then cur-note @ MIN-PCH < if incr @ -1 * incr ! then cur-note @ incr @ + cur-note ! ; : BOUNCE-CLOSE ( -- res ) timeID timeKillEvent DROP 0 TO timeID SPEED timeEndPeriod DROP hBounce DestroyWindow DROP 0 TO hBounce 0 ; : BOUNCE-DESTROY ( -- res ) 128 last-note @ 0 pack-bytes hmo @ swap midiOutShortMsg drop cls 0 'MAIN @ ?EXIT PostQuitMessage ; : BOUNCE-TURN ( -- res ) WPARAM CASE \ VK_UP OF cxMove ABS 1+ 16 MIN DUP TO cxMove TO cyMove ENDOF \ VK_DOWN OF cxMove ABS 1- 1 MAX DUP TO cxMove TO cyMove ENDOF ENDCASE 0 ; { ------------------------------------------------------------------------ ------------------------------------------------------------------------ } [SWITCH BOUNCE-MESSAGES BOUNCE-DEFAULT WM_CREATE RUNS BOUNCE-CREATE WM_BOUNCE RUNS BOUNCE-TIMER WM_DESTROY RUNS BOUNCE-DESTROY WM_SIZE RUNS BOUNCE-SIZE WM_KEYDOWN RUNS BOUNCE-TURN SWITCH] :NONAME ( -- res ) MSG $FFFF AND BOUNCE-MESSAGES ; 4 CB: BOUNCE-WNDPROC 0 VALUE hClass : AppName Z" Multimedia Timer" ; : CREATE-BOUNCE-WINDOW ( -- hwindow ) 0 \ exended style AppName \ class name Z" Multimedia Timer" \ window title WS_OVERLAPPEDWINDOW \ window style CW_USEDEFAULT CW_USEDEFAULT CW_USEDEFAULT CW_USEDEFAULT 0 \ parent window 0 \ menu HINST \ instance handle 0 \ creation parameters CreateWindowEx ; : start-timer ( -- ) hBounce ABORT" Only one instance at a time, please!" AppName HINST UnregisterClass DROP AppName BOUNCE-WNDPROC DefaultClass TO hClass hClass 0= ABORT" Class is not registered" CREATE-BOUNCE-WINDOW DUP 0= ABORT" create window failed" TO hBounce RES timeBeginPeriod ABORT" Can't set timer" SPEED RES &BOUNCE-TIMER hBounce TIME_PERIODIC timeSetEvent TO timeID hBounce 1 ShowWindow DROP hBounce UpdateWindow DROP ; CR CR .( Type start-timer to start the multimedia timer.) CR CR