home *** CD-ROM | disk | FTP | other *** search
/ Set of Apple II Hard Drive Images / hard.hdv / HARD / FORTH / POLYPHON.WRD < prev    next >
Encoding:
Text File  |  1991-03-12  |  3.1 KB  |  136 lines  |  [04] ASCII Text (0x0000)
  1. ( POLYPHONY )
  2.  
  3.  
  4. MASC DEFINITIONS
  5.  
  6. 960 TO TEMPO
  7.  
  8. ( DEFINE ARRAY FOR POLYPHONIC VOICES )
  9. VARIABLE POLY 
  10. 128 ALLOT  ( MAXIMUM 32 VOICES )
  11. POLY 128 0 FILL
  12.  
  13. ( FREE WILL BE USED TO GET INDEX OF FREE NODE )
  14. VARIABLE FREE 0 FREE !
  15.  
  16. ( POLY+0,+1 = COUNTER    )
  17. ( POLY+2,+3 = DUR1       )
  18. ( POLY+4,+5 = NOTE1/VEL1 )
  19. ( POLY+6,+7 = DUR2       )
  20. ( POLY+8,+9 = NOTE2/VEL2 )
  21.  
  22. : DURINDEX ( I -- ADRS OF DURATION WORD )
  23.    4 * 2 - POLY + ;
  24.  
  25. : NOTEINDEX ( I -- ADRS OF NOTE BYTE )
  26.    4 * POLY + ;
  27.  
  28. : VELINDEX ( I -- ADRS OF VELOCITY BYTE )
  29.    4 * 1+ POLY + ;
  30.  
  31.  
  32. : GETDUR  ( INDEX -- DUR ) DURINDEX @ ;
  33. : GETNOTE ( INDEX -- NOTE ) NOTEINDEX C@ ;
  34. : GETVEL  ( INDEX -- VEL ) VELINDEX C@ ;
  35. ( HI BIT OF VELOCITY IS USED AS A MARKER FOR PROCESSING NOTES )
  36.  
  37. : PUTDUR  ( NUMBER INDEX -- )  DURINDEX ! ;
  38. : PUTNOTE ( NUMBER INDEX -- ) NOTEINDEX C! ;
  39. : PUTVEL  ( NUMBER INDEX -- ) VELINDEX C! ;
  40.  
  41. : GETFREE
  42.    0 FREE !
  43.    POLY @ 1+ 1  ( LOOP FROM 1 TO COUNTER )
  44.  
  45.    DO I GETDUR 0= IF FREE @ 0= IF I FREE ! LEAVE THEN THEN LOOP
  46.    ( IF DUR#I = 0, CHECK FREE AND STORE INDEX )
  47.  
  48.    ( IF REACHED END OF LOOP WITHOUT CHANGING FREE - ADD 1 TO COUNTER )
  49.    FREE @ 0= IF POLY @ 1+ DUP POLY ! FREE ! THEN 
  50.  
  51.    ( SPECIAL CASE FOR POLY=0 )
  52.    POLY @ 0= IF 1 POLY ! THEN 
  53. ;
  54.  
  55.  
  56. ( STORE NOTENUMBER IN FREE NODE)
  57.  
  58. : ,, ( NOTENUMBER -- )
  59.    GETFREE
  60.    FREE @ PUTNOTE
  61.    MGATE FREE @ PUTDUR
  62.    VEL FREE @ PUTVEL
  63. ;
  64.  
  65.  
  66. ( MIDI PITCH NAMES )        DECIMAL                                             : PITCH  ( OCT NAME -- )  CREATE ,       
  67.    DOES> @ SWAP 12 * + 24 + ,, ;                             
  68.                        
  69. 0  PITCH B#   0  PITCH C                
  70. 1  PITCH C#   1  PITCH D&               
  71. 2  PITCH D                              
  72. 3  PITCH D#   3  PITCH E&               
  73. 4  PITCH E    4  PITCH F&               
  74. 5  PITCH F    5  PITCH E#                            
  75. 6  PITCH F#   6  PITCH G& 
  76. 7  PITCH G            
  77. 8  PITCH G#   8  PITCH A&               
  78. 9  PITCH A             
  79. 10 PITCH A#   10 PITCH B&               
  80. 11 PITCH B    11 PITCH C&                                                       
  81. : REST 0 ,, ;  
  82.  
  83.  
  84. ( PLAY NOTES IN THE ARRAY )
  85.  
  86.  
  87. : ?NEWNOTE ( I -- FLAG )
  88.    GETVEL 128 AND 0= ;
  89.  
  90. : SETFLAG ( I -- )
  91.    DUP GETVEL 128 OR SWAP PUTVEL ;
  92.  
  93. VARIABLE SHORTEST
  94.  
  95. : ?SHORT ( I -- )
  96.    GETDUR DUP 0= IF DROP ELSE SHORTEST @ MIN SHORTEST ! THEN ;
  97. ( CALCULATES SHORTEST DURATION IN ARRAY )
  98.  
  99.  
  100. : SUBSHORT ( I -- )
  101.    DUP GETDUR DUP 0= IF DROP DROP ELSE SHORTEST @ - SWAP PUTDUR THEN 
  102. ;
  103.  
  104. : NOTEOFF ( I -- )
  105.    DUP GETDUR 0= IF GETNOTE UP ELSE DROP THEN 
  106. ;
  107.  
  108. : FREENODE ( I -- )
  109.    ( DURATION WAS ALREADY ZEROED OUT )
  110.    ( LEAVE NOTE ALONE - FOR NOTEOFF )
  111.    DUP GETDUR 0= IF 128 SWAP PUTVEL ELSE DROP THEN
  112. ;
  113.  
  114.  
  115. : // ( -- )
  116. 32767 SHORTEST !
  117. POLY @ 1+ 1
  118.  
  119. ( SEND THE NOTEONS FOR NEW NOTES )
  120. DO I ?NEWNOTE IF I GETVEL VOL I GETNOTE DOWN I SETFLAG THEN I ?SHORT LOOP
  121.  
  122. ( DELAY FOR SHORTEST DURATION - NOTE: WAIT DOESN'T CHANGE STACK )
  123. SHORTEST @ TO MGATE WAIT
  124.  
  125. ( SUBTRACT SHORTEST FROM EACH DUR <> 0 AND SEND NOTEOFFS IF = 0)
  126. POLY @ 1+ 1
  127. DO I GETDUR 0= IF ELSE I SUBSHORT I NOTEOFF THEN LOOP 
  128.  
  129. ( COMPRESS ARRAY? )
  130. ;
  131.  
  132.  
  133.  
  134. ( EXAMPLE LINE )
  135. ( QN  3 C  3 E  3 G  EN  REST  //  EN  REST  // )
  136.