|
|
|
S" GetTickCount" S" kernel32" SYSADDR
S" GetTickCount" S" kernel32" SYSADDR CONSTANT GetTickCount
|
|
|
|
|
|
|
|
GetTickCount SYSCALL
|
|
|
|
|
Z" kernel32.dll" LoadLibrary DUP Z" GetTickCount" GetProcAddress CONSTANT GetTickCount GetTickCount SYSCALL . 6491875 GetTickCount SYSCALL . 6499843 FreeLibrary
|
\ 'Fake' fractal fern \ Original QBASIC program published in PC Magazine \ BB4Wforth version by Richard Russell, 14-Sep-2009 VARIABLE RND : RANDOM ( n -- u ) RND @ 134775813 * 1 + DUP RND ! SWAP U/MOD DROP 1 + ; : FERN 8 MODE 2 0 GCOL 0 0 ( X Y ) 80000 1 DO ( Loop 80000 times ) 100 RANDOM DUP 10 <= IF DROP SWAP DROP 0 SWAP 16 * 100 / ELSE DUP 86 <= IF DROP 2DUP 2DUP ( X Y X Y X Y ) 4 * 100 / SWAP 85 * 100 / + ( X Y X Y x ) -ROT ( X Y x X Y ) 85 * 100 / SWAP 4 * 100 / - 160 + ( X Y x y ) 2SWAP 2DROP ELSE DUP 93 <= IF DROP 2DUP 2DUP ( X Y X Y X Y ) -26 * 100 / SWAP 20 * 100 / + ( X Y X Y x ) -ROT ( X Y x X Y ) 22 * 100 / SWAP 23 * 100 / + 160 + ( X Y x y ) 2SWAP 2DROP ELSE DROP 2DUP 2DUP ( X Y X Y X Y ) 28 * 100 / SWAP 15 * 100 / - ( X Y X Y x ) -ROT ( X Y x X Y ) 24 * 100 / SWAP 26 * 100 / + 44 + ( X Y x y ) 2SWAP 2DROP THEN THEN THEN 2DUP SWAP 600 + SWAP 2DUP MOVE DRAW LOOP 2DROP ." OK" ; FERN
S" fern.f" EXEC
|
|


|
|
.
|


|
|
|
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
|
MODE 8 OFF GCOL 2 : X%=0 Y%=0 : FOR I%=1 TO 80000 R% = RND(100) : CASE TRUE OF WHEN R%<=10 A%=0: B%=0: C%=0: D%=16: F%=0 WHEN R%>10 AND R%<=86 A%=85: B%=4: C%=-4: D%=85: F%=160 WHEN R%>86 AND R%<=93 A%=20: B%=-26: C%=23: D%=22: F%=160 WHEN R%>93 A%=-15: B%=28: C%=26: D%=24: F%=44 ENDCASE : Z%=A%*X%DIV100+B%*Y%DIV100 Y%=C%*X%DIV100+D%*Y%DIV100+F% X%=Z% MOVE 600+X%, Y% DRAW 600+X%, Y% : NEXT I%
\ 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 : ONTIME ." ON TIME!" CR ; : TEST BEGIN POLL 0 MS AGAIN ; TEST
forth progname.f