home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / logo / powerlogo / examples / demo next >
Text File  |  1992-11-10  |  15KB  |  623 lines
  1. ; *********************************************************************
  2.  
  3. ; ***               A demo of Power LOGO graphics                   ***
  4.  
  5. ; *********************************************************************
  6.  
  7.  
  8. make "demo [
  9.    procedure [ [ ] [ ] [ :abort-screen :abort-window ] ]
  10.    pr [ ]
  11.    pr [ ]
  12.    pr [ Welcome to the Power LOGO graphics demo! ]
  13.    say [ Welcome to the Power lo go graphics demo ]
  14.    pr [ ]
  15.    dowhile
  16.    [  about-windows
  17.       about-turtles
  18.       double-dragon
  19.       inc-spiral
  20.       nested-snowflake
  21.       multi-ferns
  22.       if namep "scram [ ] [ ( seedrand * 100 seconds ) make "scram 1 ] ]
  23.    [ requester [ Would you like to see the demo again? ] ]
  24.    if requester [ Do you want to quit LOGO? ] [ quit ] [ ] ]
  25.  
  26.  
  27. ; *********************************************************************
  28.  
  29.  
  30. make "about-windows [
  31.    procedure [ [ ] [ ] [ :dw1 :dw2 :dt1 :dt2 ] ]
  32.    make "dw1 ( openwindow @0 0 [ Demo Window 1 ] 100 30 440 160 2 3 )
  33.    make "dt1 openturtle :dw1
  34.    setpen :dw1 1
  35.    move :dw1 25 30
  36.    text :dw1 [ With PowerLOGO you can open your own ]
  37.    move :dw1 25 40
  38.    text :dw1 [ custom graphics screens, windows, and turtles. ]
  39.    say [ With power lo go you can open your own
  40.          custom graphics screens, windows, and turtles. ]
  41.    make "dw2 ( openwindow @0 15 [ Demo Window 2 ] 400 130 240 70 2 1 )
  42.    make "dt2 ( openturtle :dw2 1 )
  43.    setpen :dw2 3
  44.    move :dw2 25 30
  45.    text :dw2 [ As many as you wish. ]
  46.    say [ As many as you, wish. ]
  47.    wait 0.5
  48.  
  49.    clean
  50.    setfont :dw1 "diamond 20
  51.    move :dw1 25 50
  52.    setpen :dw1 3
  53.    text :dw1 [ Text may be in any font, ]
  54.    setstyle :dw1 7
  55.    move :dw1 25 75
  56.    text :dw1 [ any style, ]
  57.    setpen :dw1 1
  58.    text :dw1 [ or any color. ]
  59.    say [ Text may be in any font, any style, or any color. ]
  60.    wait 0.5
  61.  
  62.    move :dw1 25 30
  63.    setstyle :dw1 4
  64.    setdrmode :dw1 1
  65.    ( setpen :dw1 2 1 )
  66.    clean
  67.    text :dw1 [ You may use coordinate graphics: ]
  68.    say [ You may use co ordinate graphics: ]
  69.    move :dw1 25 55
  70.    text :dw1 [ draw, flood, copy, ... ]
  71.    say [ draw, flood, copy, \  ]
  72.  
  73.    move :dw1 100 100
  74.    draw :dw1 200 130
  75.    draw :dw1 300 100
  76.    draw :dw1 400 140
  77.    draw :dw1 200 140
  78.    draw :dw1 20  120
  79.    draw :dw1 100 100
  80.    wait 0.2
  81.  
  82.    setpen :dw2 1
  83.    move :dw2 100 30
  84.    draw :dw2 200 20
  85.    draw :dw2 200 60
  86.    draw :dw2 100 50
  87.    draw :dw2 100 30
  88.    wait 1
  89.  
  90.    ( setpen :dw1 1 2 )
  91.    setpen :dw1 3
  92.    floodol :dw1 100 110
  93.    wait 0.2
  94.  
  95.    setpen :dw2 2
  96.    floodpc :dw2 150 40
  97.    wait 1
  98.  
  99.    copyrect :dw2 90 15 :dw1 20 90 120 50
  100.    wait 0.2
  101.    copyrect :dw2 90 15 :dw1 150 70 120 50
  102.    wait 0.2
  103.    copyrect :dw2 90 15 :dw1 280 85 120 50
  104.    wait 1
  105.  
  106.    move :dw1 25 30
  107.    clean
  108.    text :dw1 [ And of course turtle graphics. ]
  109.    say [ And of course turtle graphics. ]
  110.    ( settpn 1 0 :dt1 )
  111.    ( settpn 3 0 :dt2 )
  112.    rt 18 bk 12 cornerpoly 22 144 3 0.42 
  113.    wait 1
  114.  
  115.    ( closewindow :dw1 :dw2 ) ]
  116.  
  117.  
  118. make "cornerpoly [
  119.    procedure [ [ :size :angle :limit :factor ] [ ] [ :totalturn ] ]
  120.    if =0 :limit [ stop ] [ ]
  121.    make "totalturn 0
  122.    dowhile 
  123.    [  fd :size
  124.       cornerpoly * :factor :size +- :angle - :limit 1 :factor
  125.       rt :angle
  126.       make "totalturn + :totalturn :angle ]
  127.    [  not =0 remainder :totalturn 360 ] ]
  128.  
  129.  
  130. ; *********************************************************************
  131.  
  132.  
  133. make "about-turtles [
  134.    procedure [ [ ] [ ] [ :ds1 :dw1 :dt1 :dt2 :dt3 :dt4 :d :tl :ct ] ]
  135.    recycle
  136.    make "ds1 ( openscreen 3 2 [ ] )
  137.    set-abort :ds1
  138.    setrgb :ds1 0 [  0  0  0 ]
  139.    setrgb :ds1 1 [ 15  0  0 ]
  140.    setrgb :ds1 2 [  0 15  0 ]
  141.    setrgb :ds1 3 [ 13 13 13 ]
  142.    make "dw1 openwindow :ds1
  143.    ( intuition 7 :ds1 0 )
  144.    make "dt1 ( openturtle :dw1 3.8 0.88 128 350 0 0 )
  145.    ( settpn 1 0 :dt1 )
  146.    ( wrap :dt1 )
  147.    make "dt2 ( openturtle :dw1 3.8 0.88 256 350 0 -1 )
  148.    ( settpn 1 0 :dt2 )
  149.    ( settpn 2 1 :dt2 )
  150.    ( settdm 1 :dt2 )
  151.    ( settlp "xxx-----xxx----- :dt2 )
  152.    make "dt3 ( openturtle :dw1 2 0.88 384 350 0 0 )
  153.    ( settpn 2 0 :dt3 )
  154.    make "dt4 ( openturtle :dw1 5 0.88 512 350 0 0 )
  155.    ( settpn 3 0 :dt4 )
  156.    ( settlp "xxxxxxxx---xx--- :dt4 )
  157.  
  158.    setfont :dw1 "diamond 20
  159.    setpen :dw1 2
  160.    move :dw1 50 27
  161.    text :dw1 [ Each turtle can have it's own pens, line pattern, ]
  162.    move :dw1 50 52
  163.    text :dw1 [ sense of distance, and sense of direction. ]
  164.    say [ Each turtle can have it's own penz, line pattern,
  165.          sense of distance, andsense ofdirection. ]
  166.    move :dw1 50 76
  167.    text :dw1 [ Turtles may be used all together, ]
  168.    say [ Turtles may be used all together, ]
  169.    rt 165
  170.    repeat 2 [
  171.       make "d 2
  172.       repeat 26 [
  173.          fd :d
  174.          rt 124.21
  175.          make "d + :d 1 ] ]
  176.    wait 0.2
  177.  
  178.    move :dw1 50 100
  179.    text :dw1 [ one at a time, ]
  180.    say [ one at a time, ]
  181.    make "tl ( list :dt1 :dt2 :dt3 :dt4 )
  182.    repeat 4 [
  183.       make "ct first :tl
  184.       make "tl bf :tl
  185.       make "d 2
  186.       repeat 26 [
  187.          ( fd :d :ct )
  188.          ( rt 124.21 :ct )
  189.          make "d + :d 1 ]
  190.       wait 0.2 ]
  191.  
  192.    text :dw1 [ or in any combination. ]
  193.    say [ or in any combination. ]
  194.    make "tl ( list :dt2 :dt4 )
  195.    make "d 2
  196.    repeat 26 [
  197.       ( fd :d :tl )
  198.       ( rt 124.21 :tl )
  199.       make "d + :d 1 ]
  200.    wait 0.2
  201.    make "tl ( list :dt1 :dt2 :dt3 )
  202.    make "d 2
  203.    repeat 26 [
  204.       ( fd :d :tl )
  205.       ( rt 124.21 :tl )
  206.       make "d + :d 1 ]
  207.    wait 0.2
  208.    make "tl ( list :dt1 :dt3 )
  209.    make "d 2
  210.    repeat 26 [
  211.       ( fd :d :tl )
  212.       ( rt 124.21 :tl )
  213.       make "d + :d 1 ]
  214.    wait 0.2
  215.  
  216.    repeat 10 [
  217.       make "d 2
  218.       repeat 26 [
  219.          fd :d
  220.          rt 124.21
  221.          make "d + :d 1 ] ]
  222.    wait 1
  223.  
  224.    clear-abort
  225.    closescreen :ds1 ]
  226.  
  227.  
  228. ; *********************************************************************
  229.  
  230.  
  231. make "double-dragon [
  232.    procedure [ [ ] [ ] [ :ds1 :dw1 :dt1 :dt2 ] ]
  233.    recycle
  234.    make "ds1 ( openscreen 3 1 [ ] )
  235.    set-abort :ds1
  236.    setrgb :ds1 0 [  0  0  0 ]
  237.    setrgb :ds1 1 [ 15  2  0 ]
  238.    make "dw1 openwindow :ds1
  239.    ( intuition 7 :ds1 0 )
  240.    make "dt1 ( openturtle :dw1 3.8 0.88 150 288 0 0 )
  241.    ( settpn 1 0 :dt1 )
  242.    make "dt2 ( openturtle :dw1 3.8 0.88 490 288 0 -1 )
  243.    ( settpn 1 0 :dt2 )
  244.    s-dragon 70 2 35
  245.    wait 10
  246.    clear-abort
  247.    closescreen :ds1 ]
  248.  
  249.  
  250. ;  s-dragon       size limit angle
  251. ;     Size limit dragon.
  252. ;  s-dragon 50 5 45
  253.  
  254. make "s-dragon [
  255.    procedure [ [ :size :size-limit :angle1 ] [ ] [ :leg1 :leg2 :angle2 ] ]
  256.    make "angle2 - 90 :angle1
  257.    make "leg1  /  * 0.5 sin - 180 * 2 :angle1  sin :angle1
  258.    make "leg2  /  * 0.5 sin - 180 * 2 :angle2  sin :angle2
  259.    s-dragon1 :size 1 ]
  260.  
  261. make "s-dragon1 [
  262.    procedure [ [ :size :par ] ]
  263.    if > :size-limit :size [ fd :size stop ] [ ]
  264.    if >0 :par
  265.       [  rt :angle1
  266.          s-dragon1 * :size :leg1 1
  267.          lt 90
  268.          s-dragon1 * :size :leg2 -1
  269.          rt :angle2 ]
  270.       [  lt :angle2
  271.          s-dragon1 * :size :leg2 1
  272.          rt 90
  273.          s-dragon1 * :size :leg1 -1
  274.          lt :angle1 ] ]
  275.  
  276.  
  277. ; *********************************************************************
  278.  
  279.  
  280. make "inc-spiral [
  281.    procedure [ [ ] [ ] [ :ds1 :dw1 :dt1 ] ]
  282.    recycle
  283.    make "ds1 ( openscreen 3 2 [ ] )
  284.    set-abort :ds1
  285.    setrgb :ds1 0 [  0  0  0 ]
  286.    setrgb :ds1 1 [ 15 15 15 ]
  287.    setrgb :ds1 2 [  0  0  4 ]
  288.    setrgb :ds1 3 [ 10  2  0 ]
  289.    make "dw1 openwindow :ds1
  290.    ( intuition 7 :ds1 0 )
  291.    make "dt1 ( openturtle :dw1 )
  292.    ( settpn 1 0 :dt1 )
  293.    pu
  294.    settpos [ 104.1 48.3 ]
  295.    seth 277.5
  296.    pd
  297.    ( inspi 3.3 349 3.25 1338 )
  298.    setdrmode :dw1 1
  299.    setafpt :dw1 [ xxx----x----xxxx
  300.                   xx-----x-----xxx
  301.                   x-----xxx-----xx
  302.                   -----xxxxx-----x
  303.                   ----xxxxxxx----x
  304.                   x--xxxxxxxxx--xx
  305.                   xxxxxxxxxxxxxxxx
  306.                   x--xxxxxxxxx--xx
  307.                   ----xxxxxxx----x
  308.                   -----xxxxx-----x
  309.                   x-----xxx-----xx
  310.                   xx-----x-----xxx
  311.                   xxx----x----xxxx
  312.                   xxxx--xxx--xxxxx
  313.                   xxxxxxxxxxxxxxxx
  314.                   xxxx--xxx--xxxxx ]
  315.    ( setpen :dw1 3 0 )
  316.    ( setpen :dw1 2 1 )
  317.    floodpc :dw1 0 0
  318.    setafpt :dw1 [ x-------x-------
  319.                   x-------x-------
  320.                   -x-------x------
  321.                   -x-------x------
  322.                   --x-------x-----
  323.                   --x-------x-----
  324.                   ---x-------x----
  325.                   ---x-------x----
  326.                   ----x-------x---
  327.                   ----x-------x---
  328.                   -----x-------x--
  329.                   -----x-------x--
  330.                   ------x-------x-
  331.                   ------x-------x-
  332.                   -------x-------x
  333.                   -------x-------x ]
  334.    ( setpen :dw1 3 0 )
  335.    ( setpen :dw1 0 1 )
  336.    floodpc :dw1 630 390
  337.    wait 15
  338.    clear-abort
  339.    closescreen :ds1 ]
  340.  
  341.  
  342. make "inspi [
  343.    procedure [ [ :side :angle :i-inc :steps ] ]
  344.    repeat :steps
  345.    [  fd :side
  346.       rt :angle
  347.       make "angle remainder + :angle :i-inc 360 ] ]
  348.  
  349.  
  350. ; *********************************************************************
  351.  
  352.  
  353. make "nested-snowflake [
  354.    procedure [ [ ] [ ] [ :ds1 :dw1 :dt1 :d :c :i :s ] ]
  355.    recycle
  356.    make "ds1 ( openscreen 3 3 )
  357.    set-abort :ds1
  358.    setrgb :ds1 0 [  0  0  0 ]
  359.    setrgb :ds1 1 [  0 15  0 ]
  360.    setrgb :ds1 2 [ 14  2  0 ]
  361.    setrgb :ds1 3 [  2 13  4 ]
  362.    setrgb :ds1 6 [  8  8  8 ]
  363.    make "dw1 openwindow :ds1
  364.    ( intuition 7 :ds1 0 )
  365.    make "dt1 openturtle :dw1
  366.    make "s 112
  367.    make "i 4
  368.    repeat 4 [
  369.       make "d :i
  370.       make "c 2
  371.       repeat + 1 :i [
  372.          ( settpn :c 0 :dt1 )
  373.          setpen :dw1 :c
  374.          snowflake :s :d
  375.          floodpc :dw1 320 200
  376.          make "c + 1 :c
  377.          make "d - :d 1 ]
  378.       make "s / :s 2
  379.       make "i - :i 1 ]
  380.    wait 15
  381.    clear-abort
  382.    closescreen :ds1 ]
  383.  
  384.  
  385. make "snowflake [
  386.    procedure [ [ :size :depth ] [ ] [ :d ] ]
  387.    make "d * 0.577350269189626 :size
  388.    pu
  389.    bk :d
  390.    lt 30
  391.    pd
  392.    flake :size :depth
  393.    rt 120
  394.    flake :size :depth
  395.    rt 120
  396.    flake :size :depth
  397.    rt 150
  398.    pu
  399.    fd :d ]
  400.  
  401.  
  402. make "flake [
  403.    procedure [ [ :size :depth ] ]
  404.    if =0 :depth [ fd :size stop ] [ ]
  405.    make "size / :size 3
  406.    make "depth - :depth 1
  407.    flake :size :depth
  408.    lt 60
  409.    flake :size :depth
  410.    rt 120
  411.    flake :size :depth
  412.    lt 60
  413.    flake :size :depth ]
  414.  
  415.  
  416. ; *********************************************************************
  417.  
  418.  
  419. make "multi-ferns [
  420.    procedure [ [ ] [ ] [ :ds1 :dw1 :dt1 :p :c :i :t ] ]
  421.    recycle
  422.    make "ds1 ( openscreen 3 3 )
  423.    set-abort :ds1
  424.    setrgb :ds1 0 [  0  0  0 ]
  425.    make "dw1 ( openwindow :ds1 224 )
  426.    ( intuition 7 :ds1 0 )
  427.    make "c [   [  9 12  1 ]
  428.                [ 15 13  0 ]
  429.                [  9  8  0 ]
  430.                [  3  9  1 ]
  431.                [  0 10  1 ]
  432.                [  0 12  0 ]
  433.                [  1 14  0 ] ]
  434.    make "p [   "-xxxx-----xxxx--
  435.                "--xx-xxx-xx-----
  436.                "x-----x------xxx
  437.                "x-xxx--xx---xxx-
  438.                "--xxxxx--xxxxx--
  439.                "xx-----xxx-xxxxx ]
  440.    make "i 1
  441.    repeat 7 [
  442.       make "dt1 ( openturtle  :dw1
  443.                               + 1.4 * 3.5 rand
  444.                               0.88
  445.                               320
  446.                               395
  447.                               0
  448.                               +- random 2 )
  449.       ( settpn :i 0 :dt1 )
  450.       ( settpn + 1 random 7 1 :dt1 )
  451.       ( rt - random 120 60 :dt1 )
  452.       setrgb :ds1 :i item :i :c
  453.       ( settlp item + 1 random 6 :p :dt1 )
  454.       make "i + 1 :i ]
  455.    settdm 1
  456.    fern2 80 2.8 4 0.35 0.3 60
  457.    clear-abort
  458.    setpen :dw1 2
  459.    move :dw1 164 10
  460.    text :dw1 [ End of demo. Press any key to continue. ]
  461.    say [ End of demo. Press any key to continue. ]
  462.    sleep
  463.    closescreen :ds1 ]
  464.  
  465.  
  466. ;  fern2          size size-limit curl thickness node-spacing branch-angle
  467. ;     A more versatile fern leaf.
  468. ;  fern2 90 3 2 0.2 0.1 60
  469. ;  fern2 90 3 2 0.3 0.18 60
  470. ;  fern2 90 2 4 0.35 0.3 60
  471.  
  472. make "fern2 [
  473.    procedure [ [ :size :limit :curl :thick :nspace :angle ] [ ]
  474.                [ :d1 :d2 :a1 ] ]
  475.    make "d1 * :size :nspace
  476.    make "d2 * - 1 :nspace :size
  477.    fd :d1
  478.    if > :limit :size
  479.    [  make "a1 atan / :thick - 1 :nspace
  480.       fd :d2
  481.       rt :a1
  482.       bk :d2
  483.       fd :d2
  484.       lt + :a1 :a1
  485.       bk :d2
  486.       fd :d2
  487.       rt :a1
  488.       bk :d2 ]
  489.    [  rt :curl
  490.       fern2 :d2 :limit :curl :thick :nspace :angle
  491.       rt - :angle :curl
  492.       fern2 * :thick :size :limit :curl :thick :nspace :angle
  493.       lt + :angle :angle
  494.       fern2 * :thick :size :limit :curl :thick :nspace :angle
  495.       rt :angle ]
  496.    bk :d1 ]
  497.  
  498.  
  499. ; *********************************************************************
  500.  
  501.  
  502. make "requester [
  503.    procedure [ [ :t ] [ ] [ :rw :m ] ]
  504.    make "rw ( openwindow @0 131 [ LOGO Request ] 0 0 400 64 )
  505.  
  506.    setpen :rw 1
  507.    rectfill :rw 2 10 397 62
  508.    rectfill :rw 4 12 395 60
  509.  
  510.    setpen :rw 0
  511.    ( setpen :rw 1 1 )
  512.    move :rw 25 27
  513.    text :rw :t
  514.  
  515.    move :rw 38 48
  516.    text :rw [ YES ]
  517.    move :rw 341 48
  518.    text :rw [ NO ]
  519.  
  520.    move :rw 20 37
  521.    draw :rw 80 37
  522.    draw :rw 80 54
  523.    draw :rw 20 54
  524.    draw :rw 20 37
  525.    move :rw 319 37
  526.    draw :rw 379 37
  527.    draw :rw 379 54
  528.    draw :rw 319 54
  529.    draw :rw 319 37
  530.  
  531.    setpen :rw 3
  532.    move :rw 19 36
  533.    draw :rw 81 36
  534.    draw :rw 81 55
  535.    draw :rw 19 55
  536.    draw :rw 19 36
  537.    move :rw 318 36
  538.    draw :rw 380 36
  539.    draw :rw 380 55
  540.    draw :rw 318 55
  541.    draw :rw 318 36
  542.  
  543.    ( intuition 6 @0 )
  544.  
  545.    while [ true ]
  546.    [  make "m getmouse
  547.       if = :rw first :m
  548.       [  make "mx item 2 :m
  549.          make "my item 3 :m
  550.          if and   >= :my 36
  551.                   <= :my 55
  552.          [  if and   >= :mx 19
  553.                      <= :mx 81
  554.             [  closewindow :rw
  555.                op true ] [ ]
  556.             if and   >= :mx 318
  557.                      <= :mx 380
  558.             [  closewindow :rw
  559.                op false ] [ ] ] [ ] ] [ ] ] ]
  560.    
  561.  
  562. ; *********************************************************************
  563.  
  564.  
  565. make "set-abort [
  566.    procedure [ [ :screen ] ]
  567.    make "abort-screen :screen
  568.    make "abort-window ( openwindow :screen 0 [ ] 540 380 100 20 0 1 )
  569.    setpen :abort-window 1
  570.    move :abort-window 14 12
  571.    text :abort-window [ Quit Demo ]
  572.    while [ mousep ] [ ignore getmouse ]
  573.    whenmouse [ abort-demon ] ]
  574.  
  575.  
  576. make "clear-abort [
  577.    procedure [ ]
  578.    closewindow :abort-window
  579.    whenmouse [ ] ]
  580.  
  581.  
  582. make "abort-demon [
  583.    procedure [ [ ] [ ] [ :m :comp ] ]
  584.    make "m getmouse
  585.    if = :abort-window first :m
  586.    [  comp-abort
  587.       make "comp true
  588.       while [ true ]
  589.       [  make "m mouse :abort-window
  590.          if =0 last :m
  591.          [  if or <0 first :m <0 item 2 :m
  592.             [  if :comp [ comp-abort ] [ ]
  593.                stop ]
  594.             [  clear-abort
  595.                if requester [ Do you want to quit LOGO? ] [ quit ] [ ]
  596.                while [ not emptyp screenlist ]
  597.                   [ closescreen first screenlist ]
  598.                toplevel ]
  599.          ]
  600.          [  if or <0 first :m <0 item 2 :m
  601.             [  if :comp
  602.                [  comp-abort
  603.                   make "comp false ] [ ] ]
  604.             [  if :comp
  605.                [ ]
  606.                [  comp-abort
  607.                   make "comp true ] ]
  608.          ]
  609.       ]
  610.    ] [ ]
  611. ]
  612.  
  613.  
  614. make "comp-abort [
  615.    procedure [ ]
  616.    ( copyrect :abort-window 0 0 :abort-window 0 0 100 20 80 ) ]
  617.  
  618.  
  619.  
  620. ; *********************************************************************
  621.  
  622. launch [ demo ]
  623.