/hmsl/pieces/xforms.fth

https://github.com/philburk/hmsl · Forth · 297 lines · 264 code · 32 blank · 1 comment · 7 complexity · 321827b00c16fe05bde18af08f5d5dc2 MD5 · raw file

  1. \ This piece uses three tracks.
  2. \ Track one repeats a simple 5 note theme.
  3. \ This sounds good on a bass or tuned drum preset.
  4. \ The second track grabs the theme and slowly transforms it
  5. \ by adding or removing notes, transposing notes, etc.
  6. \ This sounds nice on a flute like preset.
  7. \ The third track periodically grabs a copy of the second
  8. \ track and plays it. Sometimes the playing is delayed.
  9. \ This third track is sometimes slowed down by 2.
  10. \ Try a violin or clarinet sound for this.
  11. \
  12. \ MOD: PLB 9/89 Converted to 3.3 system.
  13. \ MOD: PLB 10/4/89 Added call to SE.UPDATE.SHAPE
  14. \ MOD: PLB 3/26/90 Use new collection, }STUFF:
  15. \ MOD: PLB 4/9/91 Explicit names for clone.
  16. \ MOD: PLB 4/28/96 Use General MIDI presets
  17. \
  18. \ Composer Phil Burk
  19. \ Copyright 1987 Phil Burk
  20. include? { ju:locals
  21. ANEW TASK-XFORMS
  22. OB.SHAPE SH-THEME
  23. OB.SHAPE SH-DEVEL
  24. OB.SHAPE SH-DELAY
  25. OB.COLLECTION XF-PAR-COL
  26. OB.PRODUCTION PRODUCTION-5
  27. 13 constant PRESET_TRACK_1 \ bass or tuned drum
  28. 74 constant PRESET_TRACK_2 \ flute
  29. \ 41 constant PRESET_TRACK_3 \ violin
  30. \ 43 constant PRESET_TRACK_3 \ cello
  31. 25 constant PRESET_TRACK_3 \ guitar
  32. \ Play theme on drum or bass. ---------------------------------
  33. VARIABLE XF-MEASURE ( length of a measure )
  34. rtc.rate@ 3 * 5 / ticks/beat !
  35. ticks/beat @ 2/ constant DUR_BASIC
  36. : XF.BUILD.THEME ( -- theme in sh-theme )
  37. 20 3 new: sh-theme
  38. DUR_BASIC 14 100 add: sh-theme
  39. DUR_BASIC 2* 12 80 add: sh-theme
  40. DUR_BASIC 6 90 add: sh-theme
  41. DUR_BASIC 15 80 add: sh-theme
  42. DUR_BASIC 9 70 add: sh-theme
  43. ( ---- )
  44. DUR_BASIC 6 * xf-measure !
  45. ;
  46. : XF.INIT.THEME ( -- )
  47. xf.build.theme
  48. sh-theme ins-midi-1 build: player-1
  49. 1 put.channel: ins-midi-1
  50. PRESET_TRACK_1 put.preset: ins-midi-1
  51. \ Use the current key, the default is D minor.
  52. tr-current-key put.gamut: ins-midi-1
  53. 20 put.offset: ins-midi-1
  54. 800000 put.repeat: player-1
  55. sh-theme standard.dim.names
  56. " SH-THEME" put.name: sh-theme
  57. ;
  58. \ ------------------------------------------------------------
  59. \ Develop theme by adding, removing and changing notes. ------
  60. \ Played on Pan Flute.
  61. \ These Forth words support this motivic development.
  62. : COPY.SHAPE { shape1 shape2 -- , copy contents of shape }
  63. \ shapes must have same number of dimensions and be newed
  64. shape2 empty: []
  65. shape1 many: [] 0
  66. DO i shape1 get: []
  67. shape2 add: []
  68. LOOP
  69. ;
  70. 2 constant XF_SMALLEST_DUR
  71. : INSERT.NOTE { shape | elmnt dur -- , place new note in shape }
  72. \ Find notes to subdivide with sufficient duration.
  73. \ Give up after 20 tries to avoid hanging. piece.
  74. 20 0
  75. DO shape many: [] 1- choose -> elmnt
  76. elmnt 0 shape ed.at: [] ( get duration )
  77. dup -> dur xf_smallest_dur >
  78. IF leave THEN
  79. LOOP
  80. \
  81. \ Fit two notes in duration of existing note
  82. \ by splitting time alloted
  83. elmnt 1 shape stretch: [] ( copy element )
  84. dur 2/ dup elmnt 0 shape ed.to: [] ( 1/2 duration )
  85. dur swap - elmnt 1+ 0 shape ed.to: [] ( remainder )
  86. \
  87. \ The new note is placed between two existing notes
  88. \ with a random displacement from their average.
  89. \ This "Midpoint Subdivision" method is common in computer
  90. \ graphics where it is used to generate fractal landscapes.
  91. elmnt 1 shape ed.at: [] ( get note )
  92. elmnt 2+ 1 shape ed.at: [] ( get next note )
  93. + 2/ ( average and displace )
  94. 2 choose+/- +
  95. elmnt 1+ 1 shape ed.to: []
  96. ;
  97. \ These are START and REPEAT functions for a Player
  98. : XF.COPY.SHAPE ( player -- , make copy )
  99. drop sh-theme sh-devel copy.shape
  100. 27 put.offset: ins-midi-2
  101. \ Update SE display in case it is being shown.
  102. sh-devel se.update.shape
  103. ;
  104. : XF.MODIFY ( player -- , randomly execute a function )
  105. drop
  106. many: production-3 choose
  107. exec: production-3
  108. sh-devel se.update.shape
  109. ;
  110. \ This is a set of modifying functions that can work in a production.
  111. : XF.INSERT.NOTE ( - )
  112. sh-devel insert.note \ ." I"
  113. ;
  114. : XF.TRANSPOSE ( -- , random walk offset of MIDI instrument.)
  115. get.offset: ins-midi-2
  116. 9 choose 4 - + 20 40 clipto
  117. put.offset: ins-midi-2 \ ." T"
  118. ;
  119. : XF.REMOVE ( -- , remove note and lengthen previous note )
  120. \ This maintains original total length.
  121. many: sh-devel dup 2 >
  122. IF 1- choose ( -- elmnt )
  123. dup 1+ 0 ed.at: sh-devel ( -- elmnt dur2 )
  124. over 0 ed.at: sh-devel + ( -- elmnt new_dur )
  125. over 0 ed.to: sh-devel
  126. 1+ remove: sh-devel
  127. ELSE drop
  128. THEN \ ." R"
  129. ;
  130. : XF.CHANGE.NOTE ( -- , change one of the notes )
  131. many: sh-devel choose dup
  132. 1 ed.at: sh-devel ( get note )
  133. 11 choose 5 - + 1 25 clipto ( move up or down )
  134. swap 1 ed.to: sh-devel
  135. \ ." C"
  136. ;
  137. : STOP.ECHO ( morph -- , stop echoing player )
  138. drop finish: player-1
  139. finish: player-3
  140. ;
  141. : XF.INIT.DEVEL ( -- , setup objects to develop theme )
  142. 40 3 new: sh-devel
  143. sh-devel ins-midi-2 build: player-2
  144. tr-current-key put.gamut: ins-midi-2
  145. 2 put.channel: ins-midi-2
  146. PRESET_TRACK_2 put.preset: ins-midi-2
  147. sh-theme sh-devel copy.shape
  148. sh-devel standard.dim.names
  149. " SH-DEVEL" put.name: sh-devel
  150. \
  151. \ Add measure rest before playing shape.
  152. xf-measure @ put.start.delay: player-2
  153. \
  154. \ Production-3 holds functions that are randomly executed
  155. \ by the word XF.MODIFY.
  156. stuff{
  157. 'c xf.insert.note
  158. 'c xf.insert.note
  159. 'c xf.insert.note
  160. 'c xf.transpose
  161. 'c xf.remove
  162. 'c xf.change.note
  163. 'c xf.change.note
  164. }stuff: production-3
  165. \
  166. \ Execute XF.MODIFY every time PLAYER-2 repeats.
  167. 'c xf.copy.shape put.start.function: player-2
  168. 'c xf.modify put.repeat.function: player-2
  169. \ Put Player-2 in a Collection so we can restart it.
  170. stuff{ player-2 }stuff: coll-p-2
  171. 8 put.repeat: player-2 ( 1 development cycle )
  172. 100000 put.repeat: coll-p-2 ( develop 8 times )
  173. 'c stop.echo put.stop.function: coll-p-2
  174. ;
  175. \ ---------------------------------------------------------
  176. \ Third track which embellishes piece. --------------------
  177. \ This will play a delayed and sometimes slower copy of s2
  178. : XF.COPY.S2-S3 ( -- )
  179. sh-devel sh-delay copy.shape
  180. \ Set random delay to 0-3 measures to space out responses
  181. xf-measure @ 4 choose * put.repeat.delay: player-3
  182. sh-delay se.update.shape
  183. ;
  184. : XF.PROLONG.S3 ( -- , multiply all durations by 2 )
  185. many: sh-delay 0
  186. DO i 0 ed.at: sh-delay 2*
  187. i 0 ed.to: sh-delay
  188. LOOP
  189. sh-devel se.update.shape
  190. ;
  191. : XF.EXEC.FLUFF ( player -- , randomly copy or prolong )
  192. drop
  193. 2 choose
  194. IF 2 choose
  195. IF xf.copy.s2-s3
  196. ELSE xf.prolong.s3
  197. THEN
  198. THEN
  199. ;
  200. : XF.INIT.FLUFF ( -- )
  201. \ Setup player for sh-delay
  202. sh-delay ins-midi-3 build: player-3
  203. 3 put.channel: ins-midi-3
  204. PRESET_TRACK_3 put.preset: ins-midi-3
  205. tr-current-key put.gamut: ins-midi-3
  206. 'c xf.exec.fluff put.repeat.function: player-3
  207. 800000 put.repeat: player-3
  208. \
  209. \ Setup shape
  210. 40 3 new: sh-delay
  211. sh-theme sh-delay copy.shape
  212. sh-delay standard.dim.names
  213. " SH-DELAY" put.name: sh-delay
  214. ;
  215. \ ------------------------------------------------------
  216. : XF.INIT ( -- , tie everything together )
  217. xf.init.theme
  218. xf.init.devel
  219. xf.init.fluff
  220. \
  221. \ Top level collection.
  222. 0 player-1 \ Play Theme
  223. coll-p-2 \ Development
  224. player-3 \ echo
  225. 0stuff: xf-par-col
  226. 1 put.repeat: xf-par-col
  227. \
  228. \ Put shapes in holder for editing
  229. clear: shape-holder
  230. sh-theme add: shape-holder
  231. sh-devel add: shape-holder
  232. sh-delay add: shape-holder
  233. \
  234. \ use explicit names for clone
  235. " sh-theme" put.name: sh-theme
  236. sh-theme standard.dim.names
  237. " sh-devel" put.name: sh-devel
  238. sh-devel standard.dim.names
  239. " sh-delay" put.name: sh-delay
  240. sh-delay standard.dim.names
  241. \
  242. \ print.hierarchy: xf-par-col
  243. ;
  244. : XF.TERM ( -- )
  245. free: production-3
  246. default.hierarchy: xf-par-col
  247. free.hierarchy: xf-par-col
  248. sh-theme delete: shape-holder
  249. sh-devel delete: shape-holder
  250. sh-delay delete: shape-holder
  251. ;
  252. : XFORMS ( -- , play piece )
  253. cls
  254. xf.init
  255. cr ." Seed = " rand-seed ? cr
  256. xf-par-col hmsl.play
  257. xf.term
  258. ;
  259. : XF.RAND ( seed -- , provide seed for repeatable performance )
  260. depth 1 <
  261. abort" Supply seed for random function."
  262. rand-seed !
  263. xforms
  264. ;
  265. cr ." Enter: XFORMS or seed XF.RAND" cr