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 / gpacks / ged / control.icn next >
Text File  |  2000-07-29  |  9KB  |  411 lines
  1. ############################################################################
  2. #
  3. #    Name:    control.icn
  4. #
  5. #    Title:    Controls for ged.icn
  6. #
  7. #    Author: Robert J. Alexander
  8. #
  9. #    Date:    June 27, 1993
  10. #
  11. ############################################################################
  12. #
  13. #  General code for controls
  14. #
  15. ############################################################################
  16. #
  17. #  Requires:  Version 9 graphics
  18. #
  19. ############################################################################
  20.  
  21. global ControlList,ControlExit
  22.  
  23. record MouseEvent(type,x,y)
  24.  
  25.  
  26. procedure DoEvents(w,unusedEventProc,data)
  27.    local ctrl,evt,interval,mx,my
  28.    until \ControlExit do {
  29.       WAttrib(w,"pointer=top left arrow")
  30.       evt := Event(w)
  31.       interval := &interval
  32.       case type(evt) of {
  33.      "string": {
  34.         (\unusedEventProc)(w,evt,data,interval)
  35.         }
  36.      "integer": {
  37.         mx := &x
  38.         my := &y
  39.         if evt = &lpress then { # if left mouse button mouse down
  40.            if ctrl := GetControl(mx,my) then {
  41.           case type(ctrl) of {
  42.              "Button": {
  43.             TrackButton(ctrl,data,mx,my)
  44.             }
  45.              default: &null
  46.              } | break
  47.           }
  48.            else (\unusedEventProc)(w,evt,data,interval,mx,my)
  49.            }
  50.         else (\unusedEventProc)(w,evt,data,interval,mx,my)
  51.         }
  52.      default: (\unusedEventProc)(w,evt,data,interval)
  53.      }
  54.       }
  55.    return
  56. end
  57.  
  58.  
  59. procedure InitControl()
  60.    ControlList := []
  61.    return
  62. end
  63.  
  64.  
  65. procedure AddControl(ctrl)
  66.    push(ControlList,ctrl)
  67.    return ctrl
  68. end
  69.  
  70.  
  71. procedure RemoveControl(ctrl)
  72.    local i
  73.    every i := 1 to *ControlList do {
  74.       if ControlList[i] === ctrl then {
  75.      ControlList := ControlList[1:i] ||| ControlList[i + 1:0]
  76.      return ctrl
  77.      }
  78.       }
  79. end
  80.  
  81.  
  82. procedure GetControl(x,y)
  83.    local btn
  84.    every btn := !ControlList do {
  85.       if PtInRect(x,y,btn.x,btn.y,btn.width,btn.height) then
  86.         return btn
  87.       }
  88. end
  89.  
  90.  
  91. #
  92. #  Buttons
  93. #
  94.  
  95. record Button(w,x,y,width,height,event,data,value,
  96.       contents,font)
  97.  
  98.  
  99. procedure TrackButton(btn,data,mx,my)
  100.    local evt,w
  101.    w := btn.w
  102.    btn.event(btn,"pressed",data,mx,my)
  103.    repeat {
  104.       evt := Event(w)
  105.       if type(evt) == "integer" then {
  106.      mx := &x
  107.      my := &y
  108.      case evt of {
  109.         &ldrag|&mdrag|&rdrag: { # dragging
  110.            btn.event(btn,"dragging",data,mx,my)
  111.            }
  112.         &lrelease: {    # mouse release left
  113.            return btn.event(btn,
  114.              if PtInRect(mx,my,btn.x,btn.y,btn.width,btn.height) then
  115.              "released" else "cancelled",data,mx,my)
  116.            }
  117.         }
  118.      }
  119.       }
  120. end
  121.  
  122.  
  123. procedure NewButton(w,x,y,width,height,event,data,value,contents,font)
  124.    local btn
  125.    btn := Button(w,x,y,width,height,event,data,value,contents,font)
  126.    return AddControl(btn)
  127. end
  128.  
  129.  
  130. procedure RemoveButton(btn)
  131.    return RemoveControl(btn)
  132. end
  133.  
  134.  
  135. procedure DrawButton(btn)
  136.    local charHeight,charWidth,font,nameWidth,nm,w,x,y
  137.    w := btn.w
  138.    DrawRectangle(w,btn.x,btn.y,btn.width,btn.height)
  139.    case type(nm := btn.contents) of {
  140.       "string": {
  141.      Font(w,\font)
  142.      charWidth := WAttrib(w,"fwidth")
  143.      charHeight := WAttrib(w,"fheight")
  144.      nameWidth := *nm * charWidth
  145.      GotoXY(w,x + (btn.width - nameWidth) / 2,
  146.            y + (btn.height - charHeight) / 2 + charHeight *  7 / 8)
  147.      writes(w,nm)
  148.      GotoXY(w,0,0)
  149.      }
  150.       "procedure": {
  151.      btn.contents(w,btn)
  152.      }
  153.       }
  154.    return
  155. end
  156.  
  157.  
  158. #
  159. # Scrollers
  160. #
  161.  
  162. global ScrollDelay
  163.  
  164. record Scroller(w,x,y,width,height,event,data,value,
  165.       maxValue,smallScroll,largeScroll,upBtn,downBtn,thumbBtn,centerBtn)
  166.  
  167.  
  168. procedure NewScroller(w,x,y,width,height,event,data,value,
  169.       maxValue,smallScroll,largeScroll)
  170.    local scroller
  171.    initial ScrollDelay := 100
  172.    /value := 1
  173.    /width := 18
  174.    scroller := Scroller(w,x,y,width,height,event,data,value,
  175.      maxValue,smallScroll,largeScroll)
  176.    AddControl(scroller)
  177.    scroller.upBtn := NewButton(w,x,y,width,width,
  178.      Scroll_BtnEvent,scroller,,Scroll_UpArrow)
  179.    scroller.downBtn := NewButton(w,x,y + height - width,width,width,
  180.      Scroll_BtnEvent,scroller,,Scroll_DownArrow)
  181.    scroller.centerBtn := NewButton(w,x,y + width,width,height - 2 * width,
  182.      Scroll_CenterEvent,scroller,,Scroll_CenterContents)
  183.    scroller.thumbBtn := NewButton(w,x,0,width,width,
  184.      Scroll_ThumbEvent,scroller,,Scroll_ThumbContents)
  185.    Scroll_SetValue(scroller,scroller.value)
  186.    return scroller
  187. end
  188.  
  189.  
  190. procedure RemoveScroller(scroller)
  191.    every RemoveButton(scroller.upBtn | scroller.downBtn | scroller.thumbBtn |
  192.      scroller.centerBtn)
  193.    return RemoveControl(scroller)
  194. end
  195.  
  196.  
  197. procedure DrawScroller(scroller)
  198.    local height,w,width,x,y
  199.    w := scroller.w
  200.    x := scroller.x
  201.    y := scroller.y
  202.    width := scroller.width
  203.    height := scroller.height
  204.    DrawRectangle(w,x,y,width,height)
  205.    DrawButton(scroller.upBtn)
  206.    DrawButton(scroller.downBtn)
  207.    Scroll_DrawThumb(scroller)
  208.    return scroller
  209. end
  210.  
  211.  
  212. procedure Scroll_BtnEvent(btn,evt,data)
  213.    local incr,scroller
  214.    static delayDone
  215.    scroller := btn.data
  216.    incr := case btn of {
  217.       scroller.upBtn: -scroller.smallScroll
  218.       default: +scroller.smallScroll
  219.       }
  220.    if evt == "pressed" then {
  221.       delayDone := &null
  222.       Scroll_DoScroll(scroller,incr,data)
  223.       }
  224.    else if evt == ("released" | "cancelled") then return
  225.    until type(Pending(btn.w)[1]) == "integer" do {
  226.       if /delayDone then {
  227.      delay(ScrollDelay)
  228.      delayDone := 1
  229.      }
  230.       else Scroll_DoScroll(scroller,incr,data)
  231.       }
  232.    return
  233. end
  234.  
  235.  
  236. procedure Scroll_CenterEvent(btn,evt,data,x,y)
  237.    local incr,largeScroll,scroller,thumbBtn
  238.    static delayDone,direction
  239.    scroller := btn.data
  240.    thumbBtn := scroller.thumbBtn
  241.    largeScroll := scroller.largeScroll
  242.    incr := if y < thumbBtn.y then -largeScroll else +largeScroll
  243.    if evt == "pressed" then {
  244.       delayDone := &null
  245.       direction := incr
  246.       Scroll_DoScroll(scroller,incr,data)
  247.       }
  248.    else if evt == ("released" | "cancelled") then return
  249.    until type(Pending(btn.w)[1]) == "integer" do {
  250.       if incr := if y >= thumbBtn.y + thumbBtn.height then
  251.         +largeScroll else if y < thumbBtn.y then -largeScroll then {
  252.      if incr = direction then {
  253.         if /delayDone then {
  254.            delay(ScrollDelay)
  255.            delayDone := 1
  256.            }
  257.         else Scroll_DoScroll(scroller,incr,data)
  258.         }
  259.      }
  260.       }
  261.    return
  262. end
  263.  
  264.  
  265. procedure Scroll_DoScroll(scroller,incr,data)
  266.    local oldValue
  267.    oldValue := scroller.value
  268.    if Scroll_SetValue(scroller,scroller.value + incr) ~= oldValue then {
  269.       Scroll_DrawThumb(scroller)
  270.       scroller.event(scroller,"scrolled",data,oldValue)
  271.       }
  272.    return
  273. end
  274.  
  275.  
  276. procedure Scroll_ThumbEvent(btn,evt,data,x,y)
  277.    local scroller,w
  278.    static dy
  279.    scroller := btn.data
  280.    case evt of {
  281.       "pressed": {
  282.      dy := y - btn.y
  283.      }
  284.       "released" | "cancelled": {
  285.      Scroll_DoThumb(scroller,y - dy,data)
  286.      return
  287.      }
  288.       }
  289.    until type(Pending(btn.w)[1]) === "integer" do {
  290.       Scroll_DoThumb(scroller,y - dy,data)
  291.       }
  292.    return
  293. end
  294.  
  295.  
  296. procedure Scroll_DoThumb(scroller,y,data)
  297.    local centerBtn,oldValue
  298.    centerBtn := scroller.centerBtn
  299.    oldValue := scroller.value
  300.    if Scroll_SetValue(scroller,(scroller.maxValue - 1) *
  301.      (y - centerBtn.y) /
  302.      (centerBtn.height - centerBtn.width) + 1) ~= oldValue then {
  303.       Scroll_DrawThumb(scroller)
  304.       scroller.event(scroller,"scrolled",data,oldValue)
  305.       }
  306.    return
  307. end
  308.  
  309.  
  310. procedure Scroll_CenterContents(w,btn)
  311.    $ifdef TRUE_GRAY
  312.       WAttrib(w,"fg=gray")
  313.    $else
  314.       Pattern(w,"2,1,2")
  315.       WAttrib(w,"fillstyle=opaquestippled")
  316.    $endif
  317.    FillRectangle(w,btn.x,btn.y,btn.width,btn.height)
  318.    $ifdef TRUE_GRAY
  319.       WAttrib(w,"fg=black")
  320.    $else
  321.       WAttrib(w,"fillstyle=solid")
  322.    $endif
  323.    DrawRectangle(w,btn.x,btn.y,btn.width,btn.height)
  324.    return
  325. end
  326.  
  327.  
  328. procedure Scroll_ThumbContents(w,btn)
  329.    FillRectangle(w,btn.x,btn.y,btn.width,btn.height)
  330.    return
  331. end
  332.  
  333.  
  334. procedure Scroll_SetValue(scroller,value)
  335.    (value >:= scroller.maxValue) | (value <:= 1)
  336.    scroller.value := value
  337.    scroller.thumbBtn.y := scroller.y + scroller.width +
  338.      ((scroller.height - 3 * scroller.width) *
  339.      (scroller.value - 1) / (0 ~= scroller.maxValue - 1) | 0)
  340.    return value
  341. end
  342.  
  343.  
  344. procedure Scroll_DrawThumb(scroller)
  345.    DrawButton(scroller.centerBtn)
  346.    DrawButton(scroller.thumbBtn)
  347.    return
  348. end
  349.  
  350.  
  351. procedure Scroll_UpArrow(w,btn)
  352.    local x,xseg,y,yseg
  353.    x := btn.x
  354.    y := btn.y
  355.    xseg := btn.width / 6.0
  356.    yseg := btn.height / 6.0
  357.    DrawLine(w,
  358.         x + 3 * xseg,y + 1 * yseg,
  359.         x + 5 * xseg,y + 3 * yseg,
  360.         x + 4 * xseg,y + 3 * yseg,
  361.         x + 4 * xseg,y + 5 * yseg,
  362.         x + 2 * xseg,y + 5 * yseg,
  363.         x + 2 * xseg,y + 3 * yseg,
  364.         x + 1 * xseg,y + 3 * yseg,
  365.         x + 3 * xseg,y + 1 * yseg)
  366.    return
  367. end
  368.  
  369.  
  370. procedure Scroll_DownArrow(w,btn)
  371.    local x,xseg,y,yseg
  372.    x := btn.x
  373.    y := btn.y
  374.    xseg := btn.width / 6.0
  375.    yseg := btn.height / 6.0
  376.    DrawLine(w,
  377.         x + 3 * xseg,y + 5 * yseg,
  378.         x + 5 * xseg,y + 3 * yseg,
  379.         x + 4 * xseg,y + 3 * yseg,
  380.         x + 4 * xseg,y + 1 * yseg,
  381.         x + 2 * xseg,y + 1 * yseg,
  382.         x + 2 * xseg,y + 3 * yseg,
  383.         x + 1 * xseg,y + 3 * yseg,
  384.         x + 3 * xseg,y + 5 * yseg)
  385.    return
  386. end
  387.  
  388.  
  389. #
  390. #  Utility Procedures
  391. #
  392.  
  393. procedure PtInRect(px,py,rx,ry,rwidth,rheight)
  394.    return (rx <= px < rx + rwidth & ry <= py < ry + rheight,&null)
  395. end
  396.  
  397. ## procedure ShowArgs(x[])
  398.    ## argnbr := 0
  399.    ## every y := !x do {
  400.       ## write("arg ",argnbr +:= 1," = ",image(y))
  401.    ## }
  402.    ## return y
  403. ## end
  404.  
  405. ## procedure wr(s[])
  406.    ## return
  407.    ## every writes(!s)
  408.    ## write()
  409.    ## return
  410. ## end
  411.