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 / gprocs / wopen.icn < prev    next >
Text File  |  2001-06-10  |  6KB  |  231 lines
  1. ############################################################################
  2. #
  3. #    File:     wopen.icn
  4. #
  5. #    Subject:  Procedures for graphics input/output
  6. #
  7. #    Authors:  Gregg M. Townsend and Ralph E. Griswold
  8. #
  9. #    Date:     July 26, 1999
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    These procedures provide window input and output using "W" names as
  18. #    substitutes for standard input and output functions.  WOpen() opens
  19. #    and returns a window; the result is also assigned to &window if
  20. #    &window is null. 
  21. #
  22. #    WOpen(attrib, ...)    opens and returns a window.
  23. #
  24. #    WRead(W)        reads a line from a window.
  25. #
  26. #    WReads(W, i)        reads i characters from a window.
  27. #
  28. #    WWrite(W, s, ...)    writes a line to window.
  29. #
  30. #    WWrites(W, s, ...)    writes a partial line to window.
  31. #
  32. #    WDelay(W, n)        flushes a window, then delays n milliseconds.
  33. #                default:  n = 1
  34. #
  35. #    WClose(W)        closes a window;
  36. #                if W === &window, sets &window to &null.
  37. #
  38. #    WDone(), WQuit(), QuitCheck(), and QuitEvents() incorporate knowledge
  39. #    of the Icon standard set of "quit" events, currently the letters
  40. #    "q" or "Q".  The procedures themselves are trivial.
  41. #
  42. #    WQuit() consumes unread window events and succeeds if a quit event
  43. #    is seen.  It does not wait.  WDone() waits until a quit event is read,
  44. #    then exits the program.  QuitCheck(ev) calls exit() if its parameter
  45. #    is a quit event; QuitCheck can be used with the vidget package as a
  46. #    default event handler.  QuitEvents() generates the standard set of
  47. #    quit events.
  48. #
  49. #    ZDone() is a zooming version of WDone().  If the window is resized
  50. #    while waiting for a quit event, its contents are zoomed to fill the
  51. #    new size.  Zooming to a multiple of the original size can also be
  52. #    accomplished by typing a nonzero digit into the window.
  53. #
  54. #    Subwindow(W, x, y, w, h) produces a subwindow by creating and
  55. #    reconfiguring a clone of the given window.  The original window
  56. #    is not modified.  In the clone, which is returned, clipping
  57. #    bounds are set by the given rectangle and the origin is
  58. #    set at the rectangle's upper left corner.
  59. #
  60. ############################################################################
  61. #
  62. #  Requires:  Version 9 graphics
  63. #
  64. ############################################################################
  65.  
  66. link gpxop
  67.  
  68. procedure WOpen(args[])
  69.    push(args, "g")
  70.    push(args, "")
  71.    if /&window then
  72.       return &window := open ! args
  73.    else
  74.       return open ! args
  75. end
  76.  
  77.  
  78. procedure WRead(window)
  79.    if /window then
  80.       window := \&window | runerr(140, &window)
  81.    return read(window)
  82. end
  83.  
  84.  
  85. procedure WReads(window, i)
  86.    static type
  87.  
  88.    initial type := proc("type", 0)    # protect attractive name
  89.    if /window then
  90.       window := \&window | runerr(140, &window)
  91.    else if type(window) ~== "window" then {
  92.       i := window
  93.       window := \&window | runerr(140, &window)
  94.       }
  95.    return reads(window, i)
  96. end
  97.  
  98.  
  99. procedure WWrite(args[])
  100.    static type
  101.  
  102.    initial type := proc("type", 0)    # protect attractive name
  103.    if not (type(args[1]) == "window") then
  104.       push(args, \&window) | runerr(140, &window)
  105.    return write ! args
  106. end
  107.  
  108.  
  109. procedure WWrites(args[])
  110.    static type
  111.  
  112.    initial type := proc("type", 0)    # protect attractive name
  113.    if not (type(args[1]) == "window") then
  114.       push(args, \&window) | runerr(140, &window)
  115.    return writes ! args
  116. end
  117.  
  118.  
  119. procedure WDelay(window, n)
  120.    static delay, type
  121.  
  122.    initial {
  123.       delay := proc("delay", 0)        # protect attractive names
  124.       type := proc("type", 0)
  125.       }
  126.  
  127.    if /window then
  128.       window := \&window | runerr(140, &window)
  129.    else if type(window) ~== "window" then {
  130.       n := window
  131.       window := \&window | runerr(140, &window)
  132.       }
  133.    /n := 1
  134.    integer(n) | runerr(101, n)
  135.    WFlush(window)
  136.    delay(n)
  137.  
  138.    return window
  139.  
  140. end
  141.  
  142.  
  143. procedure WClose(window)
  144.    if /window then
  145.       window := \&window | runerr(140, &window)
  146.    if window === &window then
  147.       &window := &null
  148.    return close(window)
  149. end
  150.  
  151.  
  152. procedure QuitEvents()
  153.    suspend !"qQ"
  154. end
  155.  
  156.  
  157. procedure QuitCheck(ev)
  158.    if ev === QuitEvents() then
  159.       exit()
  160.    return
  161. end
  162.  
  163.  
  164. procedure WQuit(win)
  165.    /win := &window
  166.    while *Pending(win) > 0 do
  167.       if Event(win) === QuitEvents() then
  168.          return win
  169.    fail
  170. end
  171.  
  172.  
  173. procedure WDone(win)
  174.    /win := &window
  175.    until Event(win) === QuitEvents()
  176.    exit()
  177. end
  178.  
  179.  
  180. #  ZDone(win) -- like WDone(), but zoom window if resized while waiting
  181.  
  182. procedure ZDone(win)
  183.    local org, e, w, h, ww, hh, x0, y0
  184.  
  185.    /win := &window
  186.    x0 := -WAttrib(win, "dx")
  187.    y0 := -WAttrib(win, "dy")
  188.    w := WAttrib(win, "width")
  189.    h := WAttrib(win, "height")
  190.    org := WOpen("width=" || w, "height=" || h, "canvas=hidden") | WDone()
  191.    CopyArea(win, org, x0, y0)
  192.    WAttrib(win, "resize=on")
  193.    while e := Event(win) do case e of {
  194.       QuitEvents():
  195.          exit()
  196.       &resize:
  197.          Zoom(org, win, , , , , x0, y0)
  198.       !"123456789": {
  199.          ww := e * w
  200.          hh := e * h
  201.          WAttrib(win, "width=" || ww, "height=" || hh)
  202.          Zoom(org, win, , , , , x0, y0, ww, hh)
  203.          }
  204.       }
  205. end
  206.  
  207. procedure SubWindow(win, x, y, w, h)
  208.    static type
  209.    initial type := proc("type", 0)    # protect attractive name
  210.  
  211.    if type(win) ~== "window" then
  212.       return SubWindow((\&window | runerr(140)), win, x, y, w)
  213.  
  214.    /x := -WAttrib(win, "dx")
  215.    /y := -WAttrib(win, "dy")
  216.    /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
  217.    /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))
  218.  
  219.    if w < 0 then
  220.       x -:= (w := -w)
  221.    if h < 0 then
  222.       y -:= (h := -h)
  223.  
  224.    win := Clone(win,
  225.       "dx=" || WAttrib(win, "dx") + x,
  226.       "dy=" || WAttrib(win, "dy") + y)
  227.    Clip(win, 0, 0, w, h)
  228.    GotoRC(win, 1, 1)
  229.    return win
  230. end
  231.