MODE8:GCOL2:OFF:x=0:y=0:FORI=1TO80000:r=RND(1):s=r>.1:t=r>.86:u=r>.93:A=-.86*s+.65*t+.35*u:B=-.04*s+.3*t-.54*u:C=.04*s-.27*t-.01*u:D=.16-.69*s+.63*t-.02*u:F=-1.6*s+1.16*u:z=A*x+B*y:y=C*x+D*y+F:x=z:LINE600+96*x,32+96*y,600+96*x,32+96*y:NEXT 

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

S" WINMM.DLL" LoadLibrary CONSTANT WinMM \Load WinMM  Library


\ Obtain addresses for relevant functions in WinMM

WinMM S" midiOutOpen" GetProcedureAddress CONSTANT midiOpenOut
WinMM S" midiOutShortMsg" GetProcedureAddress CONSTANT midiOutShortMsg
WinMM S" midiOutClose" GetProcedureAddress CONSTANT midiOutClose


VARIABLE MidiHandle
0 MidiHandle ! \Variable Initialisation
\ Is this correct way  to set up variable to hold midichannels?


\ Per MIDITEST.BBC
:GetMidi
0 0 0 -1  \ Params in order on stack needed.
MidiHandle \
\ Probably need to test return value here...
;

:_SendShortMsg
MidiHandle @    \ Contents NOT address...
midiOutShortMsg SYSCALL
;

:PlayNote (note --)  \ Based on PlayNewNote in MIDITEST.BBC
256 * 144 +  
127 16 LSHIFT  + \ dwmsg
_SendShortMsg
;


:StopNote  \ (note  --) StopNoteBased on StopPlay in MIDITEST.BBC
256 * 128 + 
_SendShortMsg
;


:Insturment (voice --) \ Change Instrument
1 -  256 *  192 + \ Setup voice change.
127 16 LSHIFT + \ Question do we have LSHIFT/ RSHIFT?
_SendShortMsg
;

:CloseMidi
MidiHandle @
DUP \ Because we need it for closing the midi device
IF    \ I.E Non Zero handle
 midiOutClose SYSCALL \  Close the device using it.
THEN ;
DROP \Drop duplicate param...
;

 

\ 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