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