home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 434.lha / PowerLOGO / Examples / Turtle-Shell-3D < prev    next >
Encoding:
Text File  |  1990-11-11  |  12.3 KB  |  459 lines
  1. ; *********************************************************************
  2.  
  3. ;  Three dimensional turtle graphics for LOGO.
  4.  
  5. ; *********************************************************************
  6.  
  7. if buriedp "turtle-3d-stuff [ unbury :turtle-3d-stuff ] [ ]
  8.  
  9. ; *********************************************************************
  10. ;  turtle3        ( bit-planes )
  11. ;     Open a screen, a window, and the 3-D turtle. 
  12.  
  13. make "turtle3 [
  14.    procedure [ [ ] [ :d ] ]
  15.    if numberp :d [ ] [ make "d 1 ]
  16.    ( intuition 6 @0 )
  17.    recycle
  18.    make "s1 ( openscreen 3 :d [ \ 3-D\ Turtle\ Graphics ] )
  19.    make "w1 openwindow :s1
  20.    ( prep3turtle :w1 0.88 1 )
  21.    setrgb :s1 0 [ 0  0  0 ]
  22.    setrgb :s1 1 [ 14 14 14 ]
  23.    ( intuition 2 @0 0 0 )
  24.    ( intuition 8 @0 550 54 )
  25.    if < 300 peek -2 psum peek 0 :s1 14
  26.    [  ( intuition 1 @0 0 350 ) ]
  27.    [  ( intuition 1 @0 0 150 ) ]
  28.    ( intuition 6 @0 ) ]
  29.  
  30. ; *********************************************************************
  31. ;  prep3turtle    window-pointer ( aspect-ratio pen-number )
  32. ;     Assign turtle to window.
  33.  
  34. make "prep3turtle [ 
  35.    procedure [ [ :w ] [ :ar :pn ] [ ] ] 
  36.    degrees 
  37.    if numberp :ar [ make "scr-t3ar :ar ] [ make "scr-t3ar 1 ] 
  38.    if numberp :pn [ setpen :w :pn ] [ ] 
  39.    make "scr-t3xscale / peek -2 + bf :w 8  200 
  40.    make "scr-t3yscale * :scr-t3xscale :scr-t3ar 
  41.    make "scr-t3xoff / peek -2 + bf :w 8  2 
  42.    make "scr-t3yoff / peek -2 + bf :w 10  2 
  43.    make "scr-t3wp :w 
  44.    home3 ] 
  45.  
  46. ; *********************************************************************
  47. ;  yaw            angle
  48. ;     Rotate turtle.
  49.  
  50. make "yaw [
  51.    procedure [ [ :a ] [ ] [ :t ] ] 
  52.    make "t rotate :scr-t3h :scr-t3l :a
  53.    make "scr-t3l  rotate :scr-t3l -v :scr-t3h :a
  54.    make "scr-t3h :t ]
  55.  
  56. ; *********************************************************************
  57. ;  pitch          angle
  58. ;     Rotate turtle.
  59.  
  60. make "pitch [
  61.    procedure [ [ :a ] [ ] [ :t ] ] 
  62.    make "t rotate :scr-t3h :scr-t3u :a
  63.    make "scr-t3u  rotate :scr-t3u -v :scr-t3h :a
  64.    make "scr-t3h :t ]
  65.  
  66. ; *********************************************************************
  67. ;  roll           angle
  68. ;     Rotate turtle.
  69.  
  70. make "roll [
  71.    procedure [ [ :a ] [ ] [ :t ] ] 
  72.    make "t rotate :scr-t3l :scr-t3u :a
  73.    make "scr-t3u  rotate :scr-t3u -v :scr-t3l :a
  74.    make "scr-t3l :t ]
  75.  
  76. ; *********************************************************************
  77. ;  fd3            number
  78. ;     Move turtle forward.
  79.  
  80. make "fd3 [
  81.    procedure [ [ :d ] ] 
  82.    make "scr-t3pos vadd :scr-t3pos vscale :scr-t3h :d
  83.    draw :scr-t3wp    + :scr-t3xoff   * item 1 :scr-t3pos  :scr-t3xscale 
  84.                      - :scr-t3yoff   * item 2 :scr-t3pos  :scr-t3yscale ] 
  85.  
  86. ; *********************************************************************
  87. ;  bk3            number
  88. ;     Move turtle backward.
  89.  
  90. make "bk3 [
  91.    procedure [ [ :d ] ] 
  92.    make "scr-t3pos vsub :scr-t3pos vscale :scr-t3h :d
  93.    draw :scr-t3wp    + :scr-t3xoff   * item 1 :scr-t3pos  :scr-t3xscale 
  94.                      - :scr-t3yoff   * item 2 :scr-t3pos  :scr-t3yscale ] 
  95.  
  96. ; *********************************************************************
  97. ;  setpos3        vector
  98. ;     Set the position of turtle. ( vectur = [ X Y Z ] )
  99.  
  100. make "setpos3 [
  101.    procedure [ [ :p ] ] 
  102.    make "scr-t3pos :p
  103.    draw :scr-t3wp    + :scr-t3xoff   * item 1 :scr-t3pos  :scr-t3xscale 
  104.                      - :scr-t3yoff   * item 2 :scr-t3pos  :scr-t3yscale ] 
  105.  
  106. ; *********************************************************************
  107. ;  movepos3       vector
  108. ;     Set the position of turtle. ( vectur = [ X Y Z ] )
  109.  
  110. make "movepos3 [
  111.    procedure [ [ :p ] ] 
  112.    make "scr-t3pos :p
  113.    move :scr-t3wp    + :scr-t3xoff   * item 1 :scr-t3pos  :scr-t3xscale 
  114.                      - :scr-t3yoff   * item 2 :scr-t3pos  :scr-t3yscale ] 
  115.  
  116. ; *********************************************************************
  117. ;  cw3
  118. ;     Clear window and home turtle.
  119.  
  120. make "cw3 [
  121.    procedure [ ] 
  122.    clean3 
  123.    home3 ] 
  124.  
  125. ; *********************************************************************
  126. ;  home3
  127. ;     Zero position and heading.
  128.  
  129. make "home3 [
  130.    procedure [ ] 
  131.    make "scr-t3pos [ 0 0 0 ]
  132.    make "scr-t3h [ 0 1 0 ]
  133.    make "scr-t3l [ -1 0 0 ]
  134.    make "scr-t3u [ 0 0 1 ]
  135.    move :scr-t3wp :scr-t3xoff :scr-t3yoff ] 
  136.  
  137. ; *********************************************************************
  138. ;  clean3
  139. ;     Clear window.
  140.  
  141. make "clean3 [
  142.    procedure [ [ ] [ ] [ :c ] ] 
  143.    make "c peek 1 + 25 peek 4 + 50 bf :scr-t3wp 
  144.    setpen :scr-t3wp 0 
  145.    rectfill :scr-t3wp 0 0 * :scr-t3xoff 2 * :scr-t3yoff 2 
  146.    setpen :scr-t3wp :c ] 
  147.  
  148. ; *********************************************************************
  149. ;  3-D vector arithmatic.
  150.  
  151. make "-v [
  152.    procedure [ [ :a ] ]
  153.    output vscale :a -1 ]
  154.  
  155. make "rotate [
  156.    procedure [ [ :v :pv :a ] ] 
  157.    output vadd vscale :v cos :a vscale :pv sin :a ]
  158.  
  159. make "vadd [
  160.    procedure [ [ :a :b ] ]
  161.    output ( list  + item 1 :a item 1 :b
  162.                   + item 2 :a item 2 :b
  163.                   + item 3 :a item 3 :b ) ]
  164.  
  165. make "vsub [
  166.    procedure [ [ :a :b ] ]
  167.    output ( list  - item 1 :a item 1 :b
  168.                   - item 2 :a item 2 :b
  169.                   - item 3 :a item 3 :b ) ]
  170.  
  171. make "vscale [
  172.    procedure [ [ :a :b ] ]
  173.    output ( list  * item 1 :a :b
  174.                   * item 2 :a :b
  175.                   * item 3 :a :b ) ]
  176.  
  177. ; *********************************************************************
  178. ;  Names defined for 3-D turtles.
  179.  
  180. make "turtle-3d-stuff   [  turtle3 prep3turtle yaw roll pitch fd3 bk3
  181.       setpos3 cw3 movepos3 home3 clean3 -v rotate vadd vsub vscale
  182.       turtle-3d-stuff ]
  183.  
  184. bury :turtle-3d-stuff
  185.  
  186. ; *********************************************************************
  187.  
  188. ;  Some examples of weeds in 3D turtle graphics.
  189.  
  190. ; *********************************************************************
  191. ;  gyp         size
  192. ;     Gypsopphila, babies breath. Gyp uses pens 6 and 7 for stems, and pen
  193. ;     3 for flowers.
  194. ;  gyp 35
  195.  
  196. make "gyp [
  197.    procedure [ [ :d ] [ ] [ :p :h :l :u :a :z ] ]
  198.    if < :d 4.3 [ gypbloom stop ] [ ]
  199.    make "p :scr-t3pos
  200.    make "h :scr-t3h
  201.    make "l :scr-t3l
  202.    make "u :scr-t3u
  203.    setpen :scr-t3wp + 6 random 2
  204.    fd3 :d
  205.    repeat 3 [
  206.       make "a random 90
  207.       make "z + 20 random 25
  208.       roll :a
  209.       pitch :z
  210.       gyp * :d + 0.54 * 0.25 rand
  211.       pitch +- :z
  212.       roll - 120 :a ]
  213.    movepos3 :p
  214.    make "scr-t3h :h
  215.    make "scr-t3l :l
  216.    make "scr-t3u :u ]
  217.  
  218. make "gypbloom [
  219.    procedure [ ]
  220.    setpen :w1 if = 1 random 4 [ 4 ] [ 3 ]
  221.    fd3 1.5
  222.    bk3 1.5 ]
  223.  
  224. ; *********************************************************************
  225. ;  fern3       size size-limit back-curl side-curl
  226. ;              twist thickness node-spacing
  227. ;     A fern leaf.
  228. ;  fern3 90 3 2 1 1 0.3 0.18
  229.  
  230. make "fern3 [
  231.    procedure [ [ :size :limit :bcurl :scurl :twist :thick :nspace ] [ ]
  232.                [ :d1 :d2 :a1 :p :h :l :u ] ]
  233.    make "d1 * :size :nspace
  234.    make "d2 * - 1 :nspace :size
  235.    make "p :scr-t3pos
  236.    make "h :scr-t3h
  237.    make "l :scr-t3l
  238.    make "u :scr-t3u
  239.    fd3 :d1
  240.    roll :twist
  241.    yaw :scurl
  242.    if > :limit :size
  243.    [  make "a1 atan / :thick - 1 :nspace
  244.       fd3 :d2
  245.       yaw :a1
  246.       bk3 :d2
  247.       fd3 :d2
  248.       yaw ( - 0 :a1 :a1 )
  249.       bk3 :d2 ]
  250.    [  pitch :bcurl
  251.       fern3 :d2 :limit :bcurl :scurl :twist :thick :nspace
  252.       pitch +- :bcurl
  253.       yaw 60
  254.       pitch +- :bcurl
  255.       fern3 * :thick :size :limit :bcurl :scurl :twist :thick :nspace
  256.       pitch :bcurl
  257.       yaw -120
  258.       pitch +- :bcurl
  259.       fern3 * :thick :size :limit :bcurl :scurl :twist :thick :nspace ]
  260.    movepos3 :p
  261.    make "scr-t3h :h
  262.    make "scr-t3l :l
  263.    make "scr-t3u :u ]
  264.  
  265. ; *********************************************************************
  266. ;  daisy       size petals height
  267. ;     A Gerbera daisy. Daisy uses pen 6 for the stem, pens 8 and 9 for the
  268. ;     center, pens 10 and 11 for under sides of petals, and pens 12 - 15
  269. ;     for the tops of the petals.
  270. ;  daisy 25 30 70
  271.  
  272. make "daisy [
  273.    procedure [ [ :size :petals :height ] [ ]
  274.                [ :a :d  :p :h :l :u ] ]
  275.    make "p :scr-t3pos
  276.    make "h :scr-t3h
  277.    make "l :scr-t3l
  278.    make "u :scr-t3u
  279.    setpen :scr-t3wp 6
  280.    make "d / :height 12
  281.    make "a * 0.8 + 0.5 rand
  282.    roll random 360
  283.    repeat 12 [
  284.       fd3 :d
  285.       yaw :a ]
  286.    pitch * 8 rand
  287.    yaw * 8 rand
  288.    daisybloom :size :petals
  289.    movepos3 :p
  290.    make "scr-t3h :h
  291.    make "scr-t3l :l
  292.    make "scr-t3u :u ]
  293.  
  294. make "daisybloom [
  295.    procedure [ [ :size :petals ] [ ]
  296.                [ :turn :rp :ry :s :p :h :l :u ] ]
  297.    make "p :scr-t3pos
  298.    make "h :scr-t3h
  299.    make "l :scr-t3l
  300.    make "u :scr-t3u
  301.    if >0 last :scr-t3h
  302.    [  make "turn / 360 :petals         ;  Top of daisy.
  303.       repeat :petals
  304.       [  roll :turn
  305.          make "rp + 82.5 * 5 rand
  306.          make "ry - 2.5 * 5 rand
  307.          pitch :rp
  308.          yaw :ry
  309.          setpen :scr-t3wp + 12 random 4
  310.          daisypetal * 0.9 + * 0.2 rand :size
  311.          yaw +- :ry
  312.          pitch +- :rp ]
  313.       repeat * 2 + :size :petals
  314.       [  setpen :scr-t3wp if > 50 random 100 [ 8 ] [ 9 ]
  315.          roll random 360
  316.          make "rp + 80 * 4 rand
  317.          make "s ( * 0.07 + 2.5 rand :size + 0.3 sin :rp )
  318.          pitch :rp
  319.          fd3 :s
  320.          bk3 :s
  321.          pitch +- :rp ]
  322.       repeat * 2 + :size :petals
  323.       [  setpen :scr-t3wp if > 40 random 100 [ 8 ] [ 9 ]
  324.          roll random 360
  325.          make "rp * 84 rand
  326.          make "s ( * 0.07 + 2.5 rand :size + 0.3 sin :rp )
  327.          pitch :rp
  328.          fd3 :s
  329.          bk3 :s
  330.          pitch +- :rp ]
  331.    ]
  332.    [  make "turn / 360 :petals         ;  Buttom of daisy.
  333.       repeat :petals
  334.       [  roll :turn
  335.          make "rp + 82.5 * 5 rand
  336.          make "ry - 2.5 * 5 rand
  337.          pitch :rp
  338.          yaw :ry
  339.          setpen :scr-t3wp + 10 random 2
  340.          daisypetal * 0.9 + * 0.2 rand :size
  341.          yaw +- :ry
  342.          pitch +- :rp ]
  343.       bk3 * 0.2 :size
  344.       repeat * 3 + :size :petals
  345.       [  setpen :scr-t3wp + 4 random 4
  346.          make "s ( * 0.09 + 2.5 rand :size )
  347.          roll random 360
  348.          make "rp + 45 * 2 rand
  349.          pitch :rp
  350.          fd3 :s
  351.          bk3 :s
  352.          pitch +- :rp ]
  353.    ]
  354.    movepos3 :p
  355.    make "scr-t3h :h
  356.    make "scr-t3l :l
  357.    make "scr-t3u :u ]
  358.  
  359. make "daisypetal [
  360.    procedure [ [ :size ] [ ] [ :step-size ] ]
  361.    fd3 * 0.2 :size
  362.    yaw 5.5
  363.    make "step-size * 0.08 :size
  364.    arc :step-size 4
  365.    yaw -1.3
  366.    arc :step-size 6.5      ; + 2.5
  367.    yaw -1.2
  368.    arc :step-size 8        ; + 1.5
  369.    yaw -1
  370.    arc :step-size 9        ; + 1
  371.    yaw -0.9
  372.    arc :step-size 9.7      ; + 0.7
  373.    yaw -0.6
  374.    arc :step-size 9.9      ; + 0.2
  375.    yaw -0.5
  376.    arc :step-size 10       ; + 0.1
  377.    yaw -0.5
  378.    arc :step-size 9.9      ; + 0.2
  379.    yaw -0.6
  380.    arc :step-size 9.7
  381.    yaw -0.9
  382.    arc :step-size 9
  383.    yaw -1
  384.    arc :step-size 8
  385.    yaw -1.2
  386.    arc :step-size 6.5
  387.    yaw -1.3
  388.    arc :step-size 4
  389.    yaw 5.5
  390.    bk3 * 0.2 :size ]
  391.  
  392. make "arc [
  393.    procedure [ [ :size :steps ] ]
  394.    repeat :steps [ fd3 :size pitch 1 ]
  395.    fd3 * frac :steps :size
  396.    bk3 * frac :steps :size
  397.    repeat :steps [ pitch -1 bk3 :size ] ]
  398.  
  399. ; *********************************************************************
  400. ;  bouquet
  401. ;     A handful of weeds. This takes hours to run.
  402.  
  403. make "bouquet [
  404.    procedure [ [ ] [ ] [ :a :h :r ] ]
  405.    ( turtle3 4 )
  406.    setrgb :s1 0 [ 0 0 0 ]           ;  Set screens colors.
  407.    setrgb :s1 1 [ 12 12 12 ]
  408.    setrgb :s1 2 [ 12 0 0 ]
  409.    setrgb :s1 3 [ 15 15 15 ]
  410.    setrgb :s1 4 [ 0 15 3 ]
  411.    setrgb :s1 5 [ 0 13 1 ]
  412.    setrgb :s1 6 [ 1 11 0 ]
  413.    setrgb :s1 7 [ 3 8 0 ]
  414.    setrgb :s1 8 [ 10 4  0 ]
  415.    setrgb :s1 9 [ 14 12 1 ]
  416.    setrgb :s1 10 [ 15 6 2 ]
  417.    setrgb :s1 11 [ 15 5 4 ]
  418.    setrgb :s1 12 [ 14 2 0 ]
  419.    setrgb :s1 13 [ 14 3 0 ]
  420.    setrgb :s1 14 [ 15 1 0 ]
  421.    setrgb :s1 15 [ 15 2 2 ]
  422.    setpen :scr-t3wp 0               ;  Set position.
  423.    yaw 30
  424.    pitch 30
  425.    bk3 60
  426.    repeat + 5 random 3              ;  Ferns.
  427.    [  roll random 360
  428.       make "a + 35 * 30 rand
  429.       make "r random 360
  430.       yaw :a
  431.       roll :r
  432.       setpen :scr-t3wp + 5 random 3
  433.       fern3    + 60 random 60
  434.                3
  435.                + 1 * 2 rand
  436.                - rand rand
  437.                - rand rand
  438.                + 0.28 * 0.04 rand
  439.                + 0.16 * 0.04 rand
  440.       roll +- :r
  441.       yaw +- :a ]
  442.    repeat + 4 random 3              ;  Babies breath.
  443.    [  roll random 360
  444.       make "a * 35 rand
  445.       yaw :a
  446.       gyp + 20 random 15
  447.       yaw +- :a ]
  448.                                     ;  Flowers.
  449.    repeat + 3 random 3 [ make "h fput + 75 random 45 :h ]
  450.    make "h sort "< :h
  451.    while [ not emptyp :h ]
  452.    [  roll random 360
  453.       make "a + 5 * 25 rand
  454.       yaw :a
  455.       daisy + 22 random 10 + 35 random 20 first :h
  456.       yaw +- :a
  457.       make "h bf :h ] ]
  458.  
  459.