home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / logo / powerlogo / examples / music < prev    next >
Text File  |  1992-11-10  |  10KB  |  338 lines
  1. ; *********************************************************************
  2.  
  3. ;  An example music synthisizer
  4.  
  5. ; *********************************************************************
  6.  
  7. make "preppiano [
  8.    procedure [ [ ] [ ]
  9.                [  :data :bytes :freq :period :note :octive
  10.                   :envelopedata :sindata ] ]
  11.    if and namep "w1 namep "t1 [ ] [ turtle-fm ]
  12.    if namep "piano-list
  13.    [ ]
  14.    [
  15.       make "envelopedata ( system 3 1000 )
  16.       prepenvelope 10000000 0.8   100 0.7  0.5
  17.       make "piano-list [ ]
  18.       make "octive 1
  19.       make "freq  ( * 0.25 :octive item 24 :scaledata )
  20.       make "bytes ( * :freq 64 0.3 )
  21.       repeat 4 [  
  22.          make "data ( system 4 :bytes )
  23.          loadnote :data  :bytes  * :freq 0.3  :octive
  24.          make "note 1
  25.          repeat 12 [
  26.             make "period round item :note :scaledata
  27.             make "piano-list  lput  (  se    :data
  28.                                              /  *  :bytes
  29.                                                    item  + 1 :note
  30.                                                          :scaledata
  31.                                                 item 24 :scaledata
  32.                                              :period
  33.                                              64
  34.                                              1 )
  35.                                     :piano-list
  36.             make "note + 2 :note ]
  37.          make "octive * 2 :octive ]
  38.       ( system 5 :envelopedata )
  39.    ]
  40.    make "notelist :piano-list ]
  41.  
  42. ; *********************************************************************
  43.  
  44. make "preptone [
  45.    procedure [ [ ] [ ] [ :i :p :n ] ]
  46.    if and namep "w1 namep "t1 [ ] [ turtle-fm ]
  47.    if namep "tone-list
  48.    [ ]
  49.    [
  50.       make "data ( system 4 ( + 8 16 32 64 ) )
  51.       make "i 0
  52.       repeat 64 [
  53.          poke 1 ( psum :data :i ) * 126 sin * 5.625 :i
  54.          make "i + 1 :i ]
  55.       make "i 0
  56.       repeat 32 [
  57.          poke 1 ( psum :data :i 64 ) * 126 sin * 11.25 :i
  58.          make "i + 1 :i ]
  59.       make "i 0
  60.       repeat 16 [
  61.          poke 1 ( psum :data :i 96 ) * 126 sin * 22.5 :i
  62.          make "i + 1 :i ]
  63.       make "i 0
  64.       repeat 8 [
  65.          poke 1 ( psum :data :i 112 ) * 126 sin * 45 :i
  66.          make "i + 1 :i ]
  67.       make "tone-list [ ]
  68.       make "i 64
  69.       repeat 4 [
  70.          make "n 1
  71.          repeat 12 [
  72.             make "p round item :n :scaledata
  73.             make "tone-list   lput  (  se    :data
  74.                                              :i
  75.                                              :p
  76.                                              64
  77.                                              /  300000
  78.                                                 ( * :p :i 0.279 ) )
  79.                                     :tone-list
  80.             make "n + 2 :n ]
  81.          make "i / :i 2 ]
  82.    ]
  83.    make "notelist :tone-list ]
  84.  
  85. ; *********************************************************************
  86.  
  87. make "playnotelist [
  88.    procedure [ [ ] [ ] [ :n ] ]
  89.    make "n 1
  90.    repeat 48 [
  91.       sound [ ] [ ] [ ] item :n :notelist
  92.       make "n + 1 :n ] ]
  93.  
  94. make "randnotes [
  95.    procedure [ ]
  96.    repeat 48 [
  97.       sound    item + 1 random 48 :notelist
  98.                item + 1 random 48 :notelist
  99.                item + 1 random 48 :notelist
  100.                item + 1 random 48 :notelist ] ]
  101.  
  102. make "keyboard [
  103.    procedure [ [ ] [ ] [ :k :o ] ]
  104.    pr [ Click the Fractal Music window. ]
  105.    repeat 1000000 [
  106.       make "k ascii rc
  107.       if > :k 96
  108.          [  make "k - :k 96
  109.             make "o 0 ]
  110.          [  make "k - :k 64
  111.             make "o 24 ]
  112.       if and < :k 25 > :k 0 [ sound [ ] [ ] [ ] item + :k :o :notelist ] [ ] ] ]
  113.  
  114. make "midpoint [
  115.    procedure [ [ :range :factor :depth ] ]
  116.    make "a + 24 * 48 20
  117.    sound    item + 1 remainder :a 48 :notelist [ ] [ ] [ ]
  118.    midpoint-1 :range :depth :a :a
  119.    stop ]
  120.  
  121. make "midpoint-1 [
  122.    procedure [ [ :range :depth :a :b ] [ ] [ :x ] ]
  123.    make "depth - :depth 1
  124.    if < :depth 1 [ 
  125.       sound    item int + 1 remainder :b 48 :notelist [ ] [ ] [ ]
  126.       stop ] [ ]
  127.    make "x +  - random :range   random :range    / + :a :b 2
  128.    make "range * :range :factor
  129.    midpoint-1 :range :depth :a :x
  130.    midpoint-1 :range :depth :x :b
  131.    stop ]
  132.  
  133.  
  134. ; *********************************************************************
  135. ;  turtle-fm
  136. ;     Prepare window, and turtle for turtle fractal music.
  137.  
  138. make "turtle-fm [
  139.    procedure [ ]
  140.    recycle
  141.    make "w1 ( openwindow @0 3 [ Fractal Music ] 150 0 340 120 )
  142.    make "t1 ( openturtle :w1 1 ) ]
  143.  
  144. make "turtlesound [
  145.    procedure [ ]
  146.    make "t tpos :t1
  147.    sound [ ]
  148.             item  +  remainder   +  int   *  :scalefactor
  149.                                              item  2
  150.                                                    :t
  151.                                     10000
  152.                                  48
  153.                      1
  154.                   :notelist
  155.             item  +  remainder   +  int   *  :scalefactor
  156.                                              first :t
  157.                                     10000
  158.                                  48
  159.                      1
  160.                   :notelist
  161.          [ ] ]
  162.  
  163. make "scalefactor 0.5
  164.  
  165. ; *********************************************************************
  166. ;  tree           size limit factor angle
  167. ;     A musical turtle tree.
  168. ;  tree 50 5 0.5 45
  169. ;  tree 50 2 0.7 90
  170. ;  tree 40 3 0.6 15
  171.  
  172. make "tree [
  173.    procedure [ [ :size :limit :f :angle ] ]
  174.    if < :size :limit [
  175.       fd :size
  176.       turtlesound
  177.       bk :size
  178.       turtlesound
  179.       stop ] [ ]
  180.    fd :size
  181.    turtlesound
  182.    rt :angle
  183.    tree * :size :f :limit :f :angle
  184.    lt + :angle :angle
  185.    tree * :size :f :limit :f :angle
  186.    rt :angle
  187.    bk :size
  188.    turtlesound ]
  189.  
  190.  
  191.  
  192. ; *********************************************************************
  193. ;  s-dragon       size limit angle
  194. ;     Musical size limit dragon.
  195. ;  s-dragon 50 5 45
  196.  
  197. make "s-dragon [
  198.    procedure [ [ :size :size-limit :angle1 ] [ ] [ :leg1 :leg2 :angle2 ] ]
  199.    make "angle2 - 90 :angle1
  200.    make "leg1  /  * 0.5 sin - 180 * 2 :angle1  sin :angle1
  201.    make "leg2  /  * 0.5 sin - 180 * 2 :angle2  sin :angle2
  202.    s-dragon1 :size 1 ]
  203.  
  204. make "s-dragon1 [
  205.    procedure [ [ :size :par ] ]
  206.    if > :size-limit :size
  207.       [  fd :size
  208.  
  209.          turtlesound
  210.  
  211.          stop ] [ ]
  212.    if >0 :par
  213.       [  rt :angle1
  214.          s-dragon1 * :size :leg1 1
  215.          lt 90
  216.          s-dragon1 * :size :leg2 -1
  217.          rt :angle2 ]
  218.       [  lt :angle2
  219.          s-dragon1 * :size :leg2 1
  220.          rt 90
  221.          s-dragon1 * :size :leg1 -1
  222.          lt :angle1 ] ]
  223.  
  224. ;  Lots of dragons.
  225.  
  226. make "s-dragons [
  227.    procedure [ [ ] [ ] [ :angle :size-limit ] ]
  228.    make "size-limit 80
  229.    while [ make "size-limit / :size-limit 3  > :size-limit 0.5 ] [
  230.       make "angle 0
  231.       while [ make "angle + :angle 5  < :angle 90 ] [
  232.          clean
  233.          home
  234.          pu
  235.          lt 70
  236.          bk 52
  237.          lt 20
  238.          pd
  239.          s-dragon 100 :size-limit :angle ] ] ]
  240.  
  241. ; *********************************************************************
  242.  
  243. make "scaledata [       ;  16 samples per cycle
  244.    253.7693006    880.8
  245.    240.0257455    932.3
  246.    225.5205576    987.8
  247.    214.2251770    1046.5
  248.    202.2188712    1108.7
  249.    189.5481953    1174.7
  250.    180.2317162    1244.5
  251.    170.3229483    1318.5
  252.    159.8398055    1396.9
  253.    150.8369330    1480.0
  254.    143.3199104    1568.0
  255.    135.3258509    1661.2 ]
  256.  
  257. make "envelope [
  258.    procedure [ [ :x ] [ ] ]
  259.    make "x - 1 :x
  260.    op          (  +  *  :e1b
  261.                         sin   *  180
  262.                                  /  power    :e1a
  263.                                              :x
  264.                                     :e1a
  265.                      *  :e2b
  266.                         sin   *  180
  267.                                  /  power    :e2a
  268.                                              :x
  269.                                     :e2a
  270.                      *  :e3
  271.                         sin   *  180
  272.                                  :x ) ]
  273.  
  274. make "prepenvelope [
  275.    procedure [ [ :e1a :e1b :e2a :e2b :e3 ] [ ]
  276.                [ :x :y :q :ef ] ]
  277.    make "x 0
  278.    make "sindata [ ]
  279.    repeat 64 [
  280.       make "sindata lput   *  (  +  sin * :x 5.625
  281.                                     /  sin * :x 11.25
  282.                                        3
  283.                                     /  sin * :x 22.5
  284.                                        5 )
  285.                               0.326086957
  286.                            :sindata
  287.       make "x + 1 :x ]
  288.    make "ef 0
  289.    make "y 0
  290.    make "x 0
  291.    while [ >= :y :ef ] [
  292.       make "ef :y
  293.       make "y envelope / :x 1000
  294.       make "x + 1 :x ]
  295.    make "x 0
  296.    repeat 1000 [
  297.       make "q  / :x 1000
  298.       make "y  /  *  envelope :q
  299.                      253
  300.                   :ef
  301.       poke 1 psum :envelopedata :x   :y
  302.       make "x + 1 :x ] ] 
  303.  
  304.  
  305. make "loadnote [
  306.    procedure [ [ :data :bytes :cycles :octive ] [ ]
  307.                [ :x :y :xx ] ]
  308.    make "xx 1
  309.    make "x 0
  310.    repeat :bytes [
  311.       make "y  *  item :xx :sindata
  312.                   peek 1 psum :envelopedata * 1000 / :x :bytes
  313.       poke 1 psum :data :x   :y
  314.       make "xx + :octive :xx
  315.       if >= :xx 64 [ make "xx 1 ] [ ]
  316.       make "x + 1 :x ] ] 
  317.  
  318. ; *********************************************************************
  319.  
  320. pr [ ]
  321. pr [ A LOGO sound example. ]
  322. pr [ ]
  323. pr [ To use these you must first run "preptone" or "preppiano". ]
  324. pr [ "preptone" takes a few seconds.  ]
  325. pr [ "preppiano" takes about 16 minutes, but sounds better.  ]
  326. pr [ ]
  327. pr [ You may then use these noise makers: ]
  328. pr [ ]
  329. pr [ playnotelist ]
  330. pr [ randnotes ]
  331. pr [ keyboard ]
  332. pr [ midpoint 20 0.6 6 ]
  333. pr [ home clean tree 20 4 0.7 45 ]
  334. pr [ home clean s-dragon 50 5 45 ]
  335. pr [ ]
  336. pr [ Try different numbers. ]
  337. pr [ ]
  338.