home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / gprogs / subdemo.icn < prev    next >
Text File  |  2000-07-29  |  6KB  |  265 lines
  1. ############################################################################
  2. #
  3. #    File:     subdemo.icn
  4. #
  5. #    Subject:  Program to show the turtle graphics subset
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     May 31, 1994
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #     subdemo displays various random designs in a window using the
  18. #  turtle graphics subset library procedures.  Click in the window,
  19. #  or enter a character on the keyboard, to start a new design.
  20. #
  21. #     The following keyboard characters have meaning:
  22. #
  23. #    w or W:            random walk
  24. #    b or B:            fractal bush (looks like "desert broom")
  25. #    s or S:            spiral design
  26. #    p or P:            polygon design
  27. #    t or T:            rectangular tiling
  28. #    r or R:            radial tiling
  29. #
  30. #    \n, \r, \t, or SP:    choose design randomly
  31. #    q or Q:            exit program
  32. #
  33. #    0:            pause drawing
  34. #    1, ... 9:        set speed of drawing (9 is fastest)
  35. #
  36. ############################################################################
  37. #
  38. #  Requires:  Version 9 graphics
  39. #
  40. ############################################################################
  41. #
  42. #  Links: options, optwindw, subturtl, random, graphics
  43. #
  44. ############################################################################
  45.  
  46. link options
  47. link optwindw
  48. link subturtl
  49. link random
  50. link graphics
  51.  
  52. global msec    # delay between drawing actions
  53. global event    # interrupting event, if any
  54.  
  55. procedure main(args)
  56.    local opts, dlist, p, e
  57.  
  58.    opts := options(args, winoptions())
  59.    /opts["W"] := /opts["H"] := 500
  60.    &window := optwindow(opts)
  61.  
  62.    randomize()
  63.    dlist := [walk, bush, poly, spiral, tile, radial]
  64.    msec := 0
  65.    event := "\r"
  66.    repeat {
  67.       e := \event | Event()
  68.       event := &null
  69.       case e of {
  70.          QuitEvents():                break
  71.          "\n" | "\r" | "\t" | " ":        run(?dlist)
  72.          &lrelease | &mrelease | &rrelease:    run(?dlist)
  73.          "b" | "B":                run(bush)
  74.          "w" | "W":                run(walk)
  75.          "s" | "S":                run(spiral)
  76.          "p" | "P":                run(poly)
  77.          "t" | "T":                run(tile)
  78.          "r" | "R":                run(radial)
  79.          "0"|"1"|"2"|"3"|"4"|"5"|"6"|"7"|"8"|"9": setdelay(e)
  80.          }
  81.       }
  82. end
  83.  
  84. #  run(p) -- execute procedure p after resetting screen environment
  85.  
  86. procedure run(p)
  87.    TReset()
  88.    return p()
  89. end
  90.  
  91. #  continue() -- delay and check for interrupts
  92. #
  93. #  Every demo should call this periodically and should exit if it fails.
  94. #  The global "event" is set to the interrupting event and can be checked
  95. #  to exit from recursive calls.
  96.  
  97. procedure continue()
  98.    local evlist
  99.  
  100.    event := &null
  101.    delay(msec)
  102.    if *Pending() = 0 then
  103.       return
  104.    event := Event()
  105.    if setdelay(event) then {
  106.       event := &null
  107.       return
  108.       }
  109.    else
  110.       fail
  111. end
  112.  
  113. #  setdelay(e) -- handle delay-setting event, or fail
  114.  
  115. procedure setdelay(e)
  116.    while e === "0" do        # 0 is pause -- wait until anything else input
  117.       e := Event()
  118.    if type(e) == "string" & *e = 1 & (e ? any(&digits)) then {
  119.       if e === "9" then
  120.          msec := 0
  121.       else
  122.          msec := ishift(1, 12 - e)
  123.       return
  124.       }
  125.    else
  126.       fail
  127. end
  128.  
  129.  
  130. #################### drawing routines ####################
  131.  
  132.  
  133. procedure walk()                # random walk
  134.    local stepsize, maxturn, bias
  135.  
  136.    maxturn := 30
  137.    bias := 1
  138.    while continue() do
  139.       every 1 to 10 do {
  140.          TDraw(1)
  141.          TRight(?maxturn - maxturn/2.0 + bias)
  142.          }
  143. end
  144.  
  145.  
  146. procedure bush(n, len)                # fractal bush
  147.    local maxturn
  148.  
  149.    if /n then {
  150.       TSkip(-150)
  151.       n := 4 + ?4
  152.       len := 400 / n
  153.       }
  154.    maxturn := 60
  155.    TSave()
  156.    TRight(?maxturn - maxturn / 2.0)
  157.    TDraw(?len)
  158.    if n > 0 & /event then {
  159.       continue()
  160.       every 1 to ?4 do
  161.          bush(n - 1, len)
  162.       }
  163.    TRestore()
  164. end
  165.  
  166.  
  167. procedure poly()                # regular nonconvex polygon
  168.    local angle, side, x0, y0
  169.    angle := 60 + ?119
  170.    side := 200 - 100 * cos(dtor(angle))
  171.    x0 := WAttrib("width") / 2 - side / 2
  172.    y0 := WAttrib("height") / 2 - side / 3
  173.    TGoto(x0, y0)
  174.    TLeft(THeading())                # set heading to zero (East)
  175.    while continue() do {
  176.       TDraw(side)
  177.       TRight(angle)
  178.       if abs(TX() - x0) + abs(TY() - y0) < 1 then break
  179.       }
  180. end
  181.  
  182.  
  183. procedure spiral()                # polygon spiral
  184.    local angle, side, incr
  185.    angle := 30 + ?149
  186.    incr := sqrt(4 * ?0) + 0.3
  187.    side := 0
  188.    while side < 1000 & continue() do {
  189.       TDraw(side +:= incr)
  190.       TRight(angle)
  191.       }
  192. end
  193.  
  194.  
  195. procedure tile()
  196.    local i, j, n, x0, y0, x, y, dx, dy, f, m
  197.  
  198.    n := 5
  199.    x0 := WAttrib("width") / 2
  200.    y0 := WAttrib("height") / 2
  201.    dx := x0 / n
  202.    dy := y0 / n
  203.    f := mkfig(?10)
  204.    x := dx / 2
  205.    m := dx + dy
  206.    every i := 1 to n do {
  207.       y := dy / 2
  208.       every j := 1 to n do {
  209.          THeading(45)
  210.          TGoto(x0 + x, y0 + y);  every 1 to 4 do { putfig(f, m); TRight(90) }
  211.          TGoto(x0 + x, y0 - y);  every 1 to 4 do { putfig(f, m); TRight(90) }
  212.          TGoto(x0 - x, y0 + y);  every 1 to 4 do { putfig(f, m); TRight(90) }
  213.          TGoto(x0 - x, y0 - y);  every 1 to 4 do { putfig(f, m); TRight(90) }
  214.          y +:= dy
  215.          if not continue() then
  216.             return
  217.          }
  218.       x +:= dx
  219.       }
  220. end
  221.  
  222.  
  223. procedure radial()
  224.    local f, i, j, nrings, rwidth, fwd, circ, nfig, da
  225.  
  226.    f := mkfig(?8)
  227.    nrings := 5
  228.    rwidth := WAttrib("width") / (2 * nrings)
  229.    every i := 1 to nrings do {
  230.       circ := &pi * 2 * i * rwidth
  231.       nfig := integer(circ / 50)
  232.       nfig := nfig / 2 + ?nfig
  233.       da := 360.0 / nfig
  234.       every j := 0 to nfig-1 do {
  235.          TGoto(WAttrib("width") / 2, WAttrib("height") / 2)
  236.          TRight(-THeading() + 90 - j * da)
  237.          TSkip(rwidth * (i - 0.9))
  238.          putfig(f, rwidth)
  239.          if not continue() then
  240.             return
  241.          }
  242.       }
  243. end
  244.  
  245.  
  246. procedure mkfig(nseg)
  247.    local f
  248.    f := []
  249.    every 1 to nseg do {
  250.       put(f, ?0 / nseg)        # draw
  251.       put(f, -90 + 180 * ?0)    # turn
  252.       }
  253.    return f
  254. end
  255.  
  256. procedure putfig(f, m)
  257.    local i
  258.    TSave()
  259.    every i := 1 to *f by 2 do {
  260.       TDraw(m * f[i])
  261.       TRight(f[i+1])
  262.       }
  263.    TRestore()
  264. end
  265.