\ MIDI Functions - NOT Quite AMPLE but may be workable...

\ TODO:  GM-Style Instrument numbering
1 CONSTANT 'Grand_Piano' 

\ TODO:  GM-Style Drum Mapping....
\ These would be pitch values used by Channel 10.

\ Obtain addresses for relevant functions in WinMM

Z" WINMM.DLL" LoadLibrary ( Load WinMM library )
DUP Z" midiOutOpen" GetProcAddress CONSTANT midiOutOpen
DUP Z" midiOutShortMsg" GetProcAddress CONSTANT midiOutShortMsg
DUP Z" midiOutClose" GetProcAddress CONSTANT midiOutClose
FreeLibrary DROP ( Free WinMM library )

Z" Kernel32.DLL" LoadLibrary ( Load Kernel32 library )
DUP Z" Sleep" GetProcAddress CONSTANT Sleep
FreeLibrary DROP ( Free Kernel32 library )

VARIABLE MidiHandle 

: OpenMidi ( -- )
  0 0 0 -1 MidiHandle midiOutOpen SYSCALL
  IF
    ." Failed to open MIDI output device" CR
    ABORT
  THEN
;

: CloseMidi ( -- )
  MidiHandle @ midiOutClose SYSCALL
  DROP
;

: SendOutShortMsg ( msg -- )
  MidiHandle @ midiOutShortMsg SYSCALL
  DROP
;

: Delay ( ms -- )
  Sleep SYSCALL DROP
;

HEX
: StartNote ( note -- )
  100 * 7F0090 +
  SendOutShortMsg
;
DECIMAL

: StopNote ( note -- )
  256 * 128 +
  SendOutShortMsg
;

: PlayNote ( note time -- )
  SWAP TUCK 
  StartNote
  Delay
  StopNote
; 

HEX
: Instrument ( voice -- )
  100 * 7F00C0 +
  SendOutShortMsg
;
DECIMAL

: CE3K
  OpenMidi
  'Grand_Piano' Instrument
  70 500 PlayNote
  72 500 PlayNote
  68 500 PlayNote
  56 500 PlayNote
  63 1000 PlayNote
  1000 Delay
  CloseMidi
;

CE3K 

BB4Wforth version 0.33 adapted from Jonesforth version 45
Corrections and additions by R.T. Russell, September 2009
244681 cells remaining
OK
S" tester.fr" INCLUDED
S" core.fr" INCLUDED

TESTING CORE WORDS
TESTING BASIC ASSUMPTIONS
TESTING BOOLEANS: INVERT AND OR XOR
TESTING 2* 2/ LSHIFT RSHIFT
TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
TESTING >R R> R@
TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
TESTING MULTIPLY: S>D * M* UM*
TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
TESTING CHAR [CHAR] [ ] BL S"
TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
TESTING EVALUATE
TESTING SOURCE >IN WORD
TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
TESTING FILL MOVE
TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:
 !"#$%&'()*+,-./0123456789:;<=>?@
ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`
abcdefghijklmnopqrstuvwxyz{|}~
YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:
0 1 2 3 4 5 6 7 8 9 
YOU SHOULD SEE 0-9 (WITH NO SPACES):
0123456789
YOU SHOULD SEE A-G SEPARATED BY A SPACE:
A B C D E F G 
YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:
0  1  2  3  4  5  
YOU SHOULD SEE TWO SEPARATE LINES:
LINE 1
LINE 2
YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:
  SIGNED: -80000000 7FFFFFFF 
UNSIGNED: 0 FFFFFFFF 
TESTING INPUT: ACCEPT

PLEASE TYPE UP TO 80 CHARACTERS:
The quick brown fox jumps over the lazy dog.

RECEIVED: "The quick brown fox jumps over the lazy dog."
TESTING DICTIONARY SEARCH RULES

End of Core word set tests 

: ONTIME ." ON TIME!" CR ;
: TEST BEGIN POLL 0 MS AGAIN ;
TEST 

  forth progname.f