home *** CD-ROM | disk | FTP | other *** search
/ Fish 'n' More 2 / fishmore-publicdomainlibraryvol.ii1991xetec.iso / dirs / powerlogo_377.lzh / PowerLOGO / Examples / Chaos next >
Text File  |  1990-10-10  |  4KB  |  138 lines
  1. ; Example procedures of nonlinear systems.
  2.  
  3. ; *********************************************************************
  4. ;  lorenz
  5. ;     The Lorenz attractor.
  6.  
  7. make "lorenz [ 
  8.    procedure [ [ ] [ ] [ :x :y :z :xn :yn :zn :h :f ] ] 
  9.    make "s1 ( openscreen 3 1 [  Lorenz ] ) 
  10.    make "w1 openwindow :s1 
  11.    setrgb :s1 0 [ 0 0 0 ] 
  12.    setrgb :s1 1 [ 15 15 15 ] 
  13.    setpen :w1 1 
  14.    make "x 0.06 
  15.    make "y 0.06 
  16.    make "z 0.06 
  17.    move :w1 + 320 * 6 :x - 200 * 6 :y 
  18.    make "h 0.005 
  19.    make "f / 8 3 
  20.    while [ true ] [ 
  21.       make "xn + :x ( * 10 :h - :y :x ) 
  22.       make "yn + :y * :h ( - * 28 :x :y * :z :x ) 
  23.       make "zn + :z * :h - * :x :y * :z :f 
  24.       make "x :xn 
  25.       make "y :yn 
  26.       make "z :zn 
  27.       draw :w1  + 320 * 6 :x  - 200 * 6 :y ] ]
  28.  
  29. ; *********************************************************************
  30. ;  bif
  31. ;     Bifurcation diagram for May's equation.
  32.  
  33. make "bif [ 
  34.    procedure [ [ ] [ ] [ :r :x :b :sx :c :y :l ] ] 
  35.    make "s1 ( openscreen 3 3 [ bif ] ) 
  36.    make "w1 openwindow :s1 
  37.    make "r 1 
  38.    while [ < :r 8 ] [ 
  39.       setrgb :s1 :r ( se 15 + :r :r + :r :r ) 
  40.       make "r + :r 1 ] 
  41.    setrgb :s1 0 [ 0 0 0 ] 
  42.    make "r 0 
  43.    make "sx 0 
  44.    while [ < :sx 640 ] [ 
  45.       make "x 0.9 
  46.       make "l + 40 / :sx 3 
  47.       repeat :l [ 
  48.          make "x  /   * :r :x     power + :x 1 5 
  49.          make "y  -  399  * :x 50 
  50.          make "c readpixel :w1 :sx :y 
  51.          setpen :w1  if  < :c 6  [ + 1 :c ]  [ 7 ] 
  52.          writepixel :w1 :sx :y ]
  53.       make "sx + :sx 1 
  54.       make "r + :r 0.2 ] ] 
  55.  
  56. ; *********************************************************************
  57. ;  bif2           pricesion ( limit )
  58. ;     Bifurcation diagram for May's equation.
  59. ;  bif2 1
  60. ;  ( bif2 10 18 )
  61.  
  62. make "bif2 [ 
  63.    procedure [ [ :z ] [ :l ] [ :m :mi :r :x :sx :c :y :yy :zz ] ] 
  64.    make "s1 ( openscreen 3 3 ( se "\ bif2 :z :l ) ) 
  65.    make "w1 openwindow :s1 
  66.    make "r 1 
  67.    while [ < :r 8 ] [ 
  68.       setrgb :s1 :r ( se 15 + :r :r + :r :r ) 
  69.       make "r + :r 1 ] 
  70.    setrgb :s1 0 [ 0 0 0 ] 
  71.    make "m ( system 3 ( * :z 8 640 ) )
  72.    make "mi :m
  73.    repeat * :z 640 [ poke 8 :mi 0.9 make "mi psum :mi 8 ]
  74.    make "zz / 0.2 :z
  75.    if emptyp :l [ make "l 40 ] [ ]
  76.    repeat :l [ 
  77.       make "r 0 
  78.       make "sx 0 
  79.       make "mi :m
  80.       while [ < :sx 640 ] [ 
  81.          make "yy -1
  82.          repeat :z [
  83.             make "x peek 8 :mi
  84.             make "x  /   * :r :x     power + :x 1 5 
  85.             poke 8 :mi :x
  86.             make "y  int -  399  * :x 45
  87.             if = :yy :y
  88.             [ ]
  89.             [  make "c readpixel :w1 :sx :y 
  90.                setpen :w1  if  < :c 6  [ + 1 :c ]  [ 7 ] 
  91.                writepixel :w1 :sx :y ]
  92.             make "mi psum :mi 8
  93.             make "r + :r :zz
  94.             make "yy :y ]
  95.          make "sx + :sx 1 ] ]
  96.    ( system 5 :m ) ]
  97.  
  98. ; *********************************************************************
  99. ;  bif3           pricesion ( limit )
  100. ;     Bifurcation diagram for May's equation.
  101. ;  bif3 1
  102. ;  ( bif3 10 18 )
  103.  
  104. make "bif3 [ 
  105.    procedure [ [ :z ] [ :l ] [ :m :mi :r :x :sx :c :y :yy :zz ] ] 
  106.    make "s1 ( openscreen 3 1 ( se "\ bif3 :z :l ) ) 
  107.    make "w1 openwindow :s1 
  108.    make "r 1 
  109.    setrgb :s1 0 [ 0 0 0 ] 
  110.    setrgb :s1 1 [ 15 15 15 ] 
  111.    make "m ( system 3 ( * :z 8 640 ) )
  112.    make "mi :m
  113.    repeat * :z 640 [ poke 8 :mi 0.9 make "mi psum :mi 8 ]
  114.    make "zz / 0.2 :z
  115.    if emptyp :l [ make "l 40 ] [ ]
  116.    repeat :l [ 
  117.       make "yy 399
  118.       move :w1 0 :yy
  119.       make "r 0 
  120.       make "sx 0 
  121.       make "mi :m
  122.       while [ < :sx 640 ] [ 
  123.          repeat :z [
  124.             make "x peek 8 :mi
  125.             make "x  /   * :r :x     power + :x 1 5 
  126.             poke 8 :mi :x
  127.             make "y  int -  399  * :x 45
  128.             if = :yy :y
  129.             [  writepixel :w1 :sx :y
  130.                move :w1 :sx :y ]
  131.             [  draw :w1 :sx :y ]
  132.             make "mi psum :mi 8
  133.             make "r + :r :zz
  134.             make "yy :y ]
  135.          make "sx + :sx 1 ] ]
  136.    ( system 5 :m ) ]
  137.  
  138.