home *** CD-ROM | disk | FTP | other *** search
/ Set of Apple II Hard Drive Images / hard.hdv / HARD / FORTH / SOURCE / ERICMASC.PRD < prev    next >
Encoding:
Text File  |  1995-05-29  |  9.4 KB  |  395 lines  |  [04] ASCII Text (0x0000)
  1. ( ERIC'S VERSION OF MASC )
  2. ( META LANGUAGE FOR ADAPTIVE SYTHESIS )
  3.  
  4. \ : DECIMAL DEC ;
  5. : 2@ DUP 2+ @ OVER @ ROT DROP ;
  6.                                              
  7. ( PASSPT APPLE INTERFACE OUT)    
  8.  
  9. HEX                                           
  10. C0A8 CONSTANT CTRLREG               
  11.                                               
  12. CTRLREG 1+ CONSTANT DATAREG            
  13.        
  14. VARIABLE FIRSTTIME  1 FIRSTTIME !                                        
  15.        
  16. : INIT 13 CTRLREG C! 11 CTRLREG C! 0 FIRSTTIME ! ;
  17.  
  18. : ?XMIT ( -- TDRE )   CTRLREG C@ 2 AND ;                                               
  19. DECIMAL                                                                                               
  20. VARIABLE %TO      0 %TO !
  21.        
  22. : TO   1 %TO ! ;             
  23.                               
  24. : FROM/TO   
  25.    %TO @ IF ! 0 %TO ! ELSE @ THEN ;                                                                             
  26. : PARAMETER  ( N -- NAME )                  
  27.    CREATE , DOES> FROM/TO ;            
  28.  
  29. : PARAMETERS   ( SIZE -- NAME )            
  30.    CREATE DUP , 0 DO 0 , LOOP                
  31.    DOES> SWAP 2* + 2+ FROM/TO ;
  32.  
  33. : <BUILDS 0 CONSTANT ;                                                              
  34. 0 PARAMETER DEBUGGING   
  35. 0 PARAMETER SEQUENCING
  36. 0 PARAMETER NEEDZERODLY                                 
  37. 0 PARAMETER PREVSTAT
  38. 0 PARAMETER DLYLENGTH
  39.                                                   
  40. : MSND ( BYTE -- ) 
  41. DEBUGGING IF HEX . DEC ELSE
  42.    SEQUENCING IF   
  43.       NEEDZERODLY IF
  44.           0 C,   0 TO NEEDZERODLY
  45.       THEN
  46.       DUP 127 > OVER 240 < AND IF
  47.           DUP PREVSTAT = IF        ( CHECK FOR RUNNING STS )
  48.               DROP
  49.           ELSE
  50.               DUP TO PREVSTAT  C,
  51.           THEN
  52.       ELSE
  53.           C,
  54.       THEN
  55.       0 TO DLYLENGTH  ( TO SIGNAL THAT THERE WAS AN EVENT SINCE LAST DELAY )
  56.    ELSE
  57.       FIRSTTIME @ IF INIT THEN
  58.       BEGIN ?XMIT UNTIL DATAREG C! 
  59.    THEN
  60. THEN 
  61. ;                                                     
  62.    
  63. VARIABLE JOYX   0 JOYX !
  64. VARIABLE JOYY   0 JOYY !
  65.     
  66. HEX
  67. CODE JOY
  68.   XSAVE STX,
  69.   0 # LDX,  0 # LDY,  80 # LDA,  SEC,
  70.   C070 BIT, C064 BIT,  10 C, 03 C,  INX,  D0 C, 02 C,
  71.   NOP, NOP, C065 BIT,  10 C, 03 C,  INY,  D0 C, 02 C,
  72.   NOP, NOP, 1 # SBC,   B0 C, E8 C,
  73.   ' JOYX STX,  ' JOYY STY,  
  74.   XSAVE LDX,  NEXT JMP,
  75. END-CODE 
  76.  
  77.  
  78.  ( CODE TO TRAP PROGRAM CHANGES )
  79.  
  80. CODE WAITPC
  81. BEGIN,
  82.    C0A8 LDA,
  83.    1 # AND,
  84. 0= NOT UNTIL,
  85. BEGIN,
  86.    C0A9 LDA,
  87.    F0 # AND,
  88.    C0 # CMP,
  89. 0= UNTIL, 
  90. BEGIN,
  91.    C0A8 LDA,
  92.    1 # AND,
  93. 0= NOT UNTIL,
  94.  
  95. C0A9 LDA,
  96.      PHA,
  97. 0 #  LDA,
  98. PUSH JMP,
  99.  
  100. END-CODE
  101.   
  102. HEX
  103. 40 PARAMETER VEL   ( KEY VELOCITY)      
  104. 40 PARAMETER SAVEVEL
  105. 10 PARAMETER ACCENTINC ( ACCENTED KEY VELOCITY)
  106.  
  107. 0 PARAMETER CHANNEL                     
  108.  
  109. : VOL ( NUM -- ) DUP TO VEL TO SAVEVEL ;               
  110. : AC  ( -- ) VEL  DUP TO SAVEVEL  ACCENTINC + TO VEL ;
  111.  
  112. : CHNL ( NUM --) TO CHANNEL ;           
  113.  
  114. : END-INST
  115.    1 TO NEEDZERODLY  ;
  116.  
  117. : ON  ( KEY -- )  90 CHANNEL 0F AND      
  118.        + MSND MSND VEL MSND END-INST ;        
  119.  
  120. : OFF ( KEY -- )  90 CHANNEL 0F AND         
  121.        + MSND MSND 0 MSND END-INST ;          
  122.  
  123.  
  124. : CTRL-CHG ( VALUE CTRL-NUMBER -- )        
  125.    CHANNEL 0F AND B0 + MSND MSND MSND END-INST ;     
  126.  
  127. : RESETCTRLS   0 79 CTRL-CHG ;
  128.  
  129. 0 PARAMETER VARIATION
  130.  
  131. : VAR ( VARIATION# -- )
  132.    TO VARIATION ;
  133.  
  134. : PGM ( PROGRAM -- )
  135.    VARIATION 0 CTRL-CHG  0 32 CTRL-CHG   
  136.    C0 CHANNEL 0F AND + MSND 1 - MSND END-INST ;        
  137.  
  138. : AFTERTOUCH ( KEY VALUE -- )
  139.    CHANNEL 0F AND A0 + MSND SWAP MSND MSND END-INST ;
  140.  
  141. : PRESSURE ( VALUE )
  142.    CHANNEL 0F AND D0 + MSND MSND END-INST ;
  143.  
  144. : BEND ( -8192 THRU +8191 )
  145.    CHANNEL 0F AND E0 + MSND
  146.    DUP 80 MOD MSND 80 / MSND END-INST ;
  147.  
  148. ( CONTROLLERS ) 
  149. HEX
  150.                 
  151. : DAMPER ( 0..7 -- )                       
  152.    0 MAX 7 MIN 10 * 40 CTRL-CHG ;   
  153.                                                              
  154. : SOST ( 1=ON 0=OFF -- )              
  155.    0 MAX 1 MIN 40 * 42 CTRL-CHG ;   
  156.                                                              
  157. : SOFT ( 1=ON 0=OFF -- )              
  158.    0 MAX 1 MIN 40 * 43 CTRL-CHG ;                                                             
  159. : MODWHEEL ( 0-127 )  7F AND   1 CTRL-CHG ;
  160.                 
  161. : VOLUME ( 0-127 )    7F AND   7 CTRL-CHG ;
  162.  
  163. : EXPRESSION ( 0-127 ) 7F AND 0B CTRL-CHG ;
  164.  
  165. : PORTAMENTO ( 0-127 ) 7F AND 41 CTRL-CHG ;
  166.  
  167. : PANPOT ( 0-40-7F = LEFT,CENTER,RIGHT )  7F AND 0A CTRL-CHG ;
  168.  
  169. : PORTATIME ( 0-127 ) 7F AND 5 CTRL-CHG ;
  170.  
  171. : REVERB ( 0-127 ) 7F AND 5B CTRL-CHG ;
  172.  
  173. : CHORUS ( 0-127 ) 7F AND 5D CTRL-CHG ;
  174.  
  175.  
  176. DECIMAL 
  177.  
  178. VARIABLE SPEEDVAL  20 SPEEDVAL !
  179. : SETSPEED ( NUM -- ) SPEEDVAL ! ;
  180. : GETSPEED ( -- NUM ) SPEEDVAL @ ;
  181.  
  182. 2 OBJECT DELTA               \ DELAY FOR DELTA TIME PASSED IN
  183.          BOT       LDA,
  184.          1 PARM    STA,
  185.          BOT 1+    LDA,
  186.          2 PARM    STA,
  187.                    INX, INX,
  188. OBJ-CODE
  189.     CLC,
  190.     1 PARM LDA,
  191.     0= IF,
  192.       2 PARM LDA,
  193.       0= IF,
  194.         SEC,
  195.       THEN,
  196.     THEN,
  197.     CS NOT IF,
  198.       BEGIN,
  199.         SPEEDVAL LDA,
  200.         HEX FCA8 JSR,     \ CALL APPLE DELAY ROUTINE
  201.      
  202.         1 PARM DEC,       \ DECREMENT 2 BYTE VALUE
  203.         1 PARM LDA,
  204.         FF # CMP,
  205.         0= IF,
  206.           2 PARM DEC,
  207.         THEN,     
  208.         CLC,
  209.         1 PARM LDA,
  210.         0= IF,
  211.           2 PARM LDA,
  212.           0= IF,
  213.             SEC,
  214.           THEN,
  215.         THEN,
  216.       CS UNTIL,
  217.     THEN,
  218. OBJ-END
  219.  
  220. DECIMAL
  221.  
  222. : DELAY ( INTEGER -- ) 
  223.    SEQUENCING IF
  224.       DLYLENGTH 1 = IF  ( THERE HASN'T BEEN AN EVENT SINCE LAST DELAY)
  225.           -1 ALLOT  HERE C@ +  ( ADD PREV DELAY TO THIS DELAY)
  226.       THEN
  227.       DLYLENGTH 2 = IF
  228.           -2 ALLOT  HERE C@ 128 - 128 * HERE 1+ C@ + +
  229.       THEN
  230.  
  231.       0 TO NEEDZERODLY
  232.       1 TO DLYLENGTH
  233.       DUP 127 > IF
  234.          DUP 128 / 128 + C,  2 TO DLYLENGTH
  235.       THEN
  236.       128 MOD C,
  237.  
  238.    ELSE
  239.       DELTA 
  240.    THEN
  241. ;
  242.   
  243. 240 PARAMETER MGATE                   
  244.    
  245. : // MGATE DELAY  SAVEVEL TO VEL ;                    
  246.  
  247.  
  248. : KK  ( KEY -- )                           
  249.    DUP ON // OFF ;
  250.                                                            
  251. : CD+ ( NUM -- ) 
  252.    0 DO I PICK ON LOOP ;
  253.                
  254. : CD- ( NUM -- ) 
  255.    0 DO I PICK OFF LOOP ;               
  256.  
  257. HEX
  258.  
  259. : MUTE ( CHNL -- ) ( TURNS ALL SOUNDS OFF FOR CHANNEL )
  260.   B0 + MSND 78 MSND 00 MSND END-INST ;
  261.  
  262. : SHUTUP
  263.   CHANNEL MUTE ;
  264.  
  265. : QUIET ( -- )      
  266.   10 0 DO I MUTE LOOP ;
  267.  
  268.  
  269. 4 PARAMETER OCTAVE
  270.  
  271. : OCT ( N -- )   TO OCTAVE ;
  272. : O+ ( -- )  OCTAVE 1+ TO OCTAVE ;
  273. : O- ( -- )  OCTAVE 1 - TO OCTAVE ;
  274.                                                 
  275. DECIMAL
  276. : PITCH  ( NAME -- )  CREATE ,       
  277.    DOES> @ OCTAVE 12 * + 12 + ;                             
  278.                        
  279. 0  PITCH B#   0  PITCH C                
  280. 1  PITCH C#   1  PITCH D&               
  281. 2  PITCH D                              
  282. 3  PITCH D#   3  PITCH E&               
  283. 4  PITCH E    4  PITCH F&               
  284. 5  PITCH F    5  PITCH E#               
  285. 6  PITCH F#   6  PITCH G& 
  286. 7  PITCH G            
  287. 8  PITCH G#   8  PITCH A&               
  288. 9  PITCH A             
  289. 10 PITCH A#   10 PITCH B&                                              
  290. 11 PITCH B    11 PITCH C&
  291.  
  292. 960 PARAMETER WHOLEDELTA                                                   
  293.          
  294. : DURATION CREATE , , DOES>                        
  295.    WHOLEDELTA SWAP 2@ */ TO MGATE ;                                                   
  296. 2  1 DURATION BN    4  3 DURATION BN3
  297. 1  1 DURATION WN    2  3 DURATION WN3
  298. 1  2 DURATION HN    1  3 DURATION HN3   
  299. 1  4 DURATION QN    1  6 DURATION QN3   
  300. 1  8 DURATION EN    1 12 DURATION EN3   
  301. 1 16 DURATION SN    1 24 DURATION SN3   
  302. 1 32 DURATION TN    1 48 DURATION TN3                                         
  303. 1 64 DURATION GN    1 96 DURATION GN3
  304.  
  305. 3  2 DURATION WN.                              
  306. 3  4 DURATION HN.                       
  307. 3  8 DURATION QN.             
  308. 3 16 DURATION EN.                       
  309. 3 32 DURATION SN.             
  310. 3 64 DURATION TN.
  311.  
  312. 1 80 DURATION GN5
  313. 1 40 DURATION TN5
  314. 1 20 DURATION SN5
  315. 1 10 DURATION EN5
  316. 1  5 DURATION QN5
  317. 2  5 DURATION HN5
  318. 4  5 DURATION WN5
  319. 8  5 DURATION BN5
  320.  
  321. 0 PARAMETER TIEVAL
  322.  
  323. : <TIE
  324.    0 TO TIEVAL ;
  325.  
  326. : &
  327.    MGATE TIEVAL + TO TIEVAL ;
  328.  
  329. : TIE>
  330.    & TIEVAL TO MGATE ;
  331.  
  332. ( GRACE NOTES - SUBTRACTION WITHIN A TIE )
  333. ( EX: 3 C GN // 3 D HN GN- // )
  334.  
  335. : GN-
  336.    MGATE GN MGATE - TO MGATE 
  337. ;
  338.  
  339.  
  340. : CD ( KEYS  NUM -- )     ( PLAY A CHORD )                      
  341. DUP 0 DO I 2 + PICK ON LOOP 
  342. MGATE DELAY 0 DO OFF LOOP ;                                            
  343.  
  344.  
  345. ( FORTH SEQUENCER )
  346.  
  347. HEX
  348.  
  349. ( SEQUENCE STORES 0 AS THE INITIAL LENGTH AND PFA ADRS FOR END-SEQ)
  350. ( WHEN WORD IS EXECUTED, RETURNS STARTING ADDRESS AND LENGTH )
  351.  
  352. VARIABLE SEQPFA
  353.  
  354. : SEQUENCE  ( -- ) ( -- STARTADRS, LENGTH )
  355.    CREATE  HERE SEQPFA ! 
  356.    0 C, FF C, 7F C, 04 C, GETSPEED , 0 ,
  357.    0 TO PREVSTAT
  358.    1 TO NEEDZERODLY
  359.    1 TO SEQUENCING 
  360.    DOES> DUP 6 + @  
  361. ;
  362.  
  363. : END-SEQ
  364.    ( STORE TERMINATOR BYTES FOR PLAYBACK PROGRAM )
  365.    NEEDZERODLY IF
  366.        0 C,
  367.    THEN
  368.    FF C, 2F C, 0 C, 
  369.    0 TO PREVSTAT
  370.    0 TO NEEDZERODLY
  371.    0 TO SEQUENCING
  372.    ( CALCULATE LENGTH OF SEQUENCE & STORE IT )
  373.    HERE SEQPFA @ - SEQPFA @ 6 + !
  374. ;
  375.  
  376. ( LOADING AND SAVING SEQUENCES )
  377.  
  378. ( SYNTAX: PREFIX" /PATHNAME" )
  379.  
  380. : PREFIX"
  381.    1 PAD C! ASCII " WORD PAD 1+ ! PAD C6 MLI
  382. ;
  383.  
  384. : BSAVE"  ( START.ADRS LENGTH -- )
  385.    OVER                         ( ADRS LEN ADRS )
  386.    ASCII " WORD DUP             ( ADRS LEN ADRS WORD WORD )
  387.    ROT                          ( ADRS LEN WORD WORD ADRS )
  388.    6 ( BIN ) SWAP               ( ADRS LEN WORD WORD 6 ADRS )
  389.    ( CREATEF USES TOP 3 PARMS, OPENF USES WORD, WRITEF USES ADRS,LEN )
  390.    (CREATEF) ?DERR \ CREATE NEW FILE 
  391.    (OPENF) ?DERR   \ PASS PATHNAME - RETURN FILE#
  392.    (WRITEF) ?DERR  \ WRITE THE BINARY DATA TO THE FILE
  393.    0 (CLOSEF) ?DERR
  394. ;
  395.