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 / symdraw.icn < prev    next >
Text File  |  2000-07-29  |  9KB  |  339 lines
  1. ############################################################################
  2. #
  3. #    File:     symdraw.icn
  4. #
  5. #    Subject:  Program to draw symmetrically
  6. #
  7. #    Author:   Ralph E. Griswold
  8. #
  9. #    Date:     November 21, 1996
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  Pressing the left mouse button draws a point.  Dragging with the left mouse
  18. #  button draws a line.  Pressing and dragging with the middle mouse
  19. #  shows a dashed straight line, which is drawn solid when
  20. #  the middle mouse button is released.  Dragging with the right mouse
  21. #  button erases in the vicinity of the mouse pointer.
  22. #
  23. #  There are several known bugs:
  24. #
  25. #    Erasing in restricted mode is bogus outside the generating region.
  26. #
  27. #    Perfectly vertical and horizontal straight lines are not clipped.
  28. #
  29. #    Some legal straight lines are not drawn.
  30. #
  31. #  In other words, the clipping logic is not correct.
  32. #
  33. ############################################################################
  34. #
  35. #  Requires:  Version 9 graphics
  36. #
  37. ############################################################################
  38. #
  39. #  Links:  graphics, interact, vsetup
  40. #
  41. ############################################################################
  42.  
  43. link graphics
  44. link interact
  45. link vsetup
  46.  
  47. global W, H, X, Y, xc, yc, restrict, nonrestrict, gcurr, pcurr, galt, palt
  48. global number, xd, yd, pattern, x1, y1, x2, y2, delta, x, y, lines, Pane
  49.  
  50. procedure main(args)
  51.    local pane, vidgets, obg
  52.  
  53.    number := -1
  54.  
  55.    vidgets := ui()
  56.  
  57.    VSet(vidgets["lines"], 1)        # Start with lines,
  58.    VSet(vidgets["shade"], 1)        # shading,
  59.    VSet(vidgets["restrict"], 1)        # and restricted drawing enabled.
  60.  
  61.    pane := vidgets["pane"]
  62.  
  63.    W := pane.uw
  64.    H := pane.uh
  65.    X := pane.ux
  66.    Y := pane.uy
  67.  
  68.    Pane := Clone("bg=white", "dx=" || X, "dy=" || Y)
  69.    Clip(Pane, 0, 0, W, H)
  70.  
  71.    restrict := 1            # initially restricted
  72.    nonrestrict := &null
  73.  
  74.    xc := W / 2
  75.    yc := H / 2
  76.  
  77.    W -:= 1            # adjustment for 0-origin indexing
  78.    H -:= 1
  79.  
  80.    gcurr := "light blue"
  81.    pcurr := "pink"
  82.    galt := "white"
  83.    palt := "white"
  84.  
  85.    Pattern(Pane, "2,#01")    # pattern for shading generation region
  86.  
  87.    obg := Bg(Pane)
  88.    Bg(Pane, "white")
  89. #  EraseArea(Pane, 0, 0, W, H)
  90.    EraseArea(Pane)
  91.    Bg(Pane, obg)
  92.  
  93.    if lines := NewColor(Pane, gcurr) then {    # requires mutable colors
  94.       drawlines()
  95.       }
  96.  
  97.    if pattern := NewColor(Pane, pcurr) then {    # requires mutable colors
  98.       shade()
  99.       }
  100.    GetEvents(vidgets["root"], shortcuts)
  101.  
  102. end
  103.  
  104. procedure file_cb(vidget, value)
  105.  
  106.    case value[1] of {
  107.       "save  @S":  save()
  108.       "help  @H":  help()
  109.       "quit  @Q":  exit()
  110.       }
  111.  
  112.    fail
  113.  
  114. end                # not handled
  115.  
  116. procedure pane_cb(vidget, event)    # handle drawing events
  117.    local obg
  118.  
  119.    &x -:= X
  120.    &y -:= Y
  121.  
  122.    case event of {
  123.       &lpress: {            # start free-hand drawing
  124.          if \restrict & ((real(&x) / (&y + 0.0001) < 1.0) | (&x > xc) |
  125.             (&y > yc)) then fail
  126.          every DrawPoint(Pane, &x | (W - &x), &y | (H - &y))
  127.          every DrawPoint(Pane, &y | (W - &y), &x | (H - &x))
  128.          x := &x
  129.          y := &y
  130.          }
  131.       &ldrag: {                # free-hand drawing
  132.          if \x then {            # just in case (for artificial events)
  133.             if \restrict & ((real(x) / (y + 0.0001)  < 1.0) | (x > xc) |
  134.                (y > yc)) then fail
  135.             DrawLine(Pane, x, y, &x, &y)
  136.             DrawLine(Pane, W - x, y, W - &x, &y)
  137.             DrawLine(Pane, x, H - y, &x, H - &y)
  138.             DrawLine(Pane, W - x, H - y, W - &x, H - &y)
  139.             DrawLine(Pane, y, x, &y, &x)
  140.             DrawLine(Pane, W - y, x, W - &y, &x)
  141.             DrawLine(Pane, y, H - x, &y, H - &x)
  142.             DrawLine(Pane, W - y, H - x, W - &y, H - &x)
  143.             }
  144.          x := &x
  145.          y := &y
  146.          }
  147.       &lrelease: {            # end free-hand drawing
  148.          x := y := &null
  149.          }
  150.       &mpress: {            # start straight line
  151.          x1 := xd := &x
  152.          y1 := yd := &y
  153.          WAttrib(Pane, "linestyle=dashed")
  154.          WAttrib(Pane, "drawop=reverse")
  155.          DrawLine(Pane, x1, y1, xd, yd)    # start trace line
  156.          }
  157.       &mdrag: {                # locate end of straight line
  158.          DrawLine(Pane, x1, y1, xd, yd)    # erase current trace
  159.          xd := &x
  160.          yd := &y
  161.          DrawLine(Pane, x1, y1, xd, yd)    # draw new trace line
  162.          }
  163.       &mrelease: {            # end straight line
  164.          DrawLine(Pane, x1, y1, xd, yd)    # erase trace line
  165.          WAttrib(Pane, "drawop=copy")
  166.          WAttrib(Pane, "linestyle=solid")
  167.          x2 := &x
  168.          y2 := &y
  169.  
  170.       #  This probably can be done in a better way.  What's here "just grew"
  171.  
  172.          if \restrict then {                # adjust end points
  173.             if ((x1 > xc) & (x2 > xc)) | ((y1 > yc) & (y2 > yc)) then fail
  174.             if x2 > x1 then {
  175.                x1 :=: x2
  176.                y1 :=: y2
  177.                }
  178.             if x1 > xc * x1 ~= x2 then {
  179.                y1 := y2 + ((xc - x2) * (y1 - y2)) / (x1 - x2)
  180.                x1 := xc
  181.                }
  182.             if y2 > yc & y1 ~= y2 then {
  183.                x2 := x1 - ((x1 - x2) * (y1 - yc)) / (y1 - y2)
  184.                y2 := yc
  185.                }
  186.             if y1 > y2 then {
  187.                y1 :=: y2
  188.                x1 :=: x2
  189.                }
  190.             if y1 > x1 then fail
  191.             if y2 > x2 & y1 ~= y2 then {
  192.                delta := real(x2 - x1) / (y2 - y1)
  193.                x2 := (x1 - y1 * delta) / (1 - delta)
  194.                y2 := x2
  195.                }
  196.             }
  197.          DrawLine(Pane, x1, y1, x2, y2)
  198.          DrawLine(Pane, W - x1, y1, W - x2, y2)
  199.          DrawLine(Pane, x1, H - y1, x2, H - y2)
  200.          DrawLine(Pane, W - x1, H - y1, W - x2, H - y2)
  201.          DrawLine(Pane, y1, x1, y2, x2)
  202.          DrawLine(Pane, W - y1, x1, W - y2, x2)
  203.          DrawLine(Pane, y1, H - x1, y2, H - x2)
  204.          DrawLine(Pane, W - y1, H - x1, W - y2, H - x2)
  205.          x := &x
  206.          y := &y
  207.          }
  208.  
  209.       #  This code is not correct when pointer is outside
  210.       #  the generation region.
  211.  
  212.       &rpress | &rdrag: {        # erase around pointer
  213.          obg := Bg(Pane)
  214.          Bg(Pane, "white")
  215.          every EraseArea(Pane, ((&x - 2) | (W - &x - 2)),
  216.             ((&y - 2) | (H - &y - 2)), 5, 5)
  217.          every EraseArea(Pane, ((&y - 2) | (W - &y - 2)),
  218.             ((&x - 2) | (H - &x - 2)), 5, 5)
  219.          Bg(Pane, obg)
  220.          }
  221.       }
  222. end
  223.  
  224. procedure help()            # help (someday)
  225.  
  226.    Notice("There is no help to be had")
  227.  
  228. end
  229.  
  230. procedure shortcuts(event)
  231.  
  232.    if &meta & event := string(event) then
  233.       case map(event) of {            # fold case
  234.          "q":    exit()
  235.          "h":    help()
  236.          "s":    save()
  237.          }
  238.  
  239.    return
  240.  
  241. end
  242.  
  243. procedure lines_cb()            # toggle lines
  244.  
  245.    Color(Pane, \lines, gcurr :=: galt)
  246.  
  247. end
  248.  
  249. procedure clear_cb()            # clear drawing area
  250.    local obg
  251.  
  252.    obg := Bg(Pane)
  253.    Bg(Pane, "white")
  254.    EraseArea(Pane, 0, 0, W, H)
  255.    Bg(Pane, obg)
  256.    if \lines then {
  257.       drawlines()
  258.       shade()
  259.       }
  260.  
  261. end
  262.  
  263. procedure drawlines()            # draw lines
  264.    local ofg, obg
  265.  
  266.    ofg := Fg(Pane)
  267.    obg := Bg(Pane)
  268.    Fg(Pane, lines)
  269.    Bg(Pane, "white")
  270.    DrawLine(Pane, 0, 0, W, H)
  271.    DrawLine(Pane, W, 0, 0, H)
  272.    DrawLine(Pane, 0, H / 2, W, H / 2)
  273.    DrawLine(Pane, W / 2, 0, W / 2, H)
  274.    Fg(Pane, ofg)
  275.    Bg(Pane, obg)
  276.  
  277.    return
  278.  
  279. end
  280.  
  281. procedure shade()            # shade generating region
  282.    local ofg, obg
  283.  
  284.    ofg := Fg(Pane)
  285.    obg := Bg(Pane)
  286.    Fg(Pane, pattern)
  287.    Bg(Pane, "white")
  288.    WAttrib(Pane, "fillstyle=textured")
  289.    FillPolygon(Pane, 1, 0, W / 2, 1, W / 2, H / 2, 1, 0)
  290.    WAttrib(Pane, "fillstyle=solid")
  291.    Fg(Pane, ofg)
  292.    Bg(Pane, obg)
  293.  
  294.    return
  295.  
  296. end
  297.  
  298. procedure save()            # save drawing in image file
  299.  
  300.    Color(Pane, \lines, "white")
  301.    Color(Pane, \pattern, "white")
  302.    snapshot(Pane, 0, 0, W, H)
  303.    Color(Pane, \lines, gcurr)
  304.    Color(Pane, \pattern, pcurr)
  305.  
  306. end
  307.  
  308. procedure restrict_cb()            # toggle restriction to generating
  309.                     # region
  310.    restrict :=: nonrestrict
  311.  
  312. end
  313.  
  314. procedure shade_cb()            # toggle shading of generating region
  315.  
  316.    Color(Pane, \pattern, pcurr :=: palt)
  317.  
  318. end
  319.  
  320. #===<<vib:begin>>===    modify using vib; do not remove this marker line
  321. procedure ui_atts()
  322.    return ["size=523,461", "bg=pale-gray", "label=symdraw"]
  323. end
  324.  
  325. procedure ui(win, cbk)
  326. return vsetup(win, cbk,
  327.    ["symdraw:Sizer:::0,0,523,461:symdraw",],
  328.    ["clear:Button:regular::20,45,64,20:clear",clear_cb],
  329.    ["file:Menu:pull::33,4,36,21:File",file_cb,
  330.       ["save  @S","help  @H","quit  @Q"]],
  331.    ["line:Line:::0,30,528,30:",],
  332.    ["lines:Button:regular:1:20,84,64,20:lines",lines_cb],
  333.    ["restrict:Button:regular:1:20,165,64,20:restrict",restrict_cb],
  334.    ["shade:Button:regular:1:20,125,64,20:shade",shade_cb],
  335.    ["pane:Rect:grooved::105,45,405,405:",pane_cb],
  336.    )
  337. end
  338. #===<<vib:end>>===    end of section maintained by vib
  339.