home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 607.lha / FindWindow_v1.1 / PopUp_Menus.f < prev    next >
Encoding:
FORTH Source  |  1992-02-06  |  6.5 KB  |  334 lines
  1. \ Pop Up Menus
  2. \
  3. \ Pop Up a pseudo-menu anywhere on the screen.
  4. \ Uses left mouse button!
  5. \ It is assumed that the left mouse button  is already down.
  6. \
  7. \ The calls are typically made in this order:
  8. \   POPUP.OPEN ( xleft ytop width nitems title/0 -- window | 0 )
  9. \   POPUP.DRAW.TEXT ( addr count item# -- , draw item text )
  10. \   POPUP.SCAN  ( -- item# true | 0 , loop until done )
  11. \   POPUP.CLOSE ( -- )
  12. \
  13. \ You can change the colors used by calling:
  14. \   POPUP.SET.COLORS ( forecolor backcolor -- )
  15. \
  16. \ Author: Phil Burk
  17. \ Copyright 1991 Phil Burk
  18.  
  19. getmodule includes
  20. include? { ju:locals
  21. include? ev-last-code ju:amiga_events
  22.  
  23. ANEW TASK-POPUP_MENUS
  24.  
  25. \ Glue Routines to call Amiga Libraries --------------------
  26.  
  27. : RectFill() ( rastport x1 y1 x2 y2 -- )
  28.     callvoid>abs graphics_lib RectFill
  29. ;
  30.  
  31. : Move() ( rastport x y -- , Move to new position. )
  32.      callvoid>abs graphics_lib move
  33. ;
  34. : Draw() ( rastport x y -- , Draw to new position. )
  35.      callvoid>abs graphics_lib draw
  36. ;
  37.  
  38. : SetDrMd()  ( rastport mode -- , Set drawing mode )
  39.     callvoid>abs graphics_lib SetDrMd
  40. ;
  41.  
  42. : SetAPen()  ( rastport mode -- , Set pen color )
  43.     callvoid>abs graphics_lib SetAPen
  44. ;
  45.  
  46. : SetBPen()  ( rastport mode -- , Set background pen color )
  47.     callvoid>abs graphics_lib SetBPen
  48. ;
  49.  
  50. : Text() ( rastport addr count -- , draw characters )
  51.      callvoid>abs graphics_lib text
  52. ;
  53.  
  54. : GET.WORKBENCH.SCREEN ( -- screen )
  55. \ check to see if library needs to be opened
  56.     intuition_lib @ dup 0=
  57.     IF
  58.         drop intuition? intuition_lib @
  59.     THEN
  60.     >rel \ get IntuitionBase
  61.     s@ ib_ActiveScreen dup 0=
  62.     IF
  63.         ." No screen active!" abort
  64.     THEN
  65. ;
  66.  
  67. \ Data Structures and Constants  -------------------------
  68. variable POP-HIGH      \ currently highlighted
  69. variable POP-PICKED    \ item number picked , 0 based
  70. variable POP-NUM-ITEMS \ number of items allowed for
  71. variable POP-WINDOW
  72. variable POP-RASTPORT
  73.  
  74. 2 value POP_Y_START
  75. 6 value POP_X_START
  76.  
  77. 10 value POP_LINE_HEIGHT
  78. 200 value POP_TEXT_WIDTH
  79.  
  80. 640 value POP_SCREEN_WIDTH \ modified by POPUP.OPEN
  81. 200 value POP_SCREEN_HEIGHT
  82.  
  83. 1 value POP_FORE_COLOR
  84. 0 value POP_BACK_COLOR
  85.  
  86. \ Graphics routines for PopUp RastPort ----------------
  87.  
  88. : POP.MOVE ( x y -- )
  89.     pop-rastport @ -rot Move()
  90. ;
  91. : POP.DRAW ( x y -- )
  92.     pop-rastport @ -rot Draw()
  93. ;
  94.  
  95. : POP.COLOR! ( color -- )
  96.     pop-rastport @ swap SetAPen()
  97. ;
  98.  
  99. : POP.BCOLOR! ( color -- )
  100.     pop-rastport @ swap SetBPen()
  101. ;
  102.  
  103. \ ------------------------------------------------------
  104.  
  105. : POP.N>XY ( n -- x y , top left of Nth item )
  106.     pop_x_start swap
  107.     pop_line_height * pop_y_start +
  108. ;
  109.  
  110. : POP.XY>N { x y | flag -- n true | false , which item is selected? }
  111.     0 -> flag
  112. \ check to see if in X bounds
  113.     x pop_x_start dup pop_text_width + within?
  114.     IF
  115.         y pop_y_start -  pop_line_height +
  116.         dup 0<
  117.         IF
  118.             drop
  119.         ELSE
  120.             pop_line_height /  ( calc which line )
  121. \
  122. \ make sure N is legal
  123.             dup pop-num-items @ < dup -> flag not
  124.             IF
  125.                 drop
  126.             THEN
  127.         THEN
  128.     THEN
  129.     flag
  130. ;
  131.  
  132. : POP.COMP.N ( n -- , unconditionally COMPlement an item )
  133. \ set Exclusive OR drawing mode
  134.     pop-rastport @
  135.     dup 0= abort" POP.COMP.N - no rastport!"
  136.     2 SetDrMd() \ XOR mode!!!
  137. \
  138. \ draw rectangle over item
  139.     pop-rastport @
  140.     swap POP.n>xy
  141.     over pop_text_width +
  142.     over pop_line_height +
  143.     RectFill()
  144. \
  145. \ restore drawing mode
  146.     pop-rastport @ JAM2 SetDrMd()
  147. ;
  148.  
  149. : POP.DEHIGHLIGHT ( -- , dehighlight previous if any )
  150.     pop-high @ dup 0< \ any currently highlighted?
  151.     IF
  152.         drop
  153.     ELSE
  154.         pop.comp.n
  155.         -1 pop-high !
  156.     THEN
  157. ;
  158.  
  159. : POP.HIGHLIGHT ( x y -- , highlight the current choice )
  160.     pop.xy>n
  161.     IF
  162.         dup pop-high @ =
  163.         IF
  164.             drop \ already highlighted
  165.         ELSE
  166.             pop.dehighlight
  167. \ remember which one is highlighted
  168.             dup pop-high !
  169.             pop.comp.n
  170.         THEN
  171.     ELSE
  172.         pop.dehighlight
  173.     THEN
  174. ;
  175.  
  176. : POP.PICK ( x y -- )
  177.     pop.xy>n
  178.     IF
  179.         pop-picked !
  180.     THEN
  181. ;
  182.  
  183. : POP.PROCESS { class | result -- done? , process events from IDCMP }
  184.     false -> result
  185.     class
  186.     CASE
  187.         MOUSEBUTTONS OF   ( only respond to Mouse UP )
  188.             ev-last-code @ SELECTUP =
  189.             IF
  190.                 ev.getxy00 POP.pick
  191.                 true -> result
  192.             THEN
  193.         ENDOF
  194.  
  195.         MOUSEMOVE OF
  196.             ev.getxy00 POP.highlight
  197.         ENDOF
  198.  
  199.         CLOSEWINDOW OF true -> result ENDOF
  200.  
  201.         warning" POPUP.LOOP -- Unrecognized event!"
  202.     ENDCASE
  203.     result
  204. ;
  205.  
  206. : POPUP.SCAN  ( -- item true | 0 , loop until done )
  207.     -1 pop-picked !
  208. \
  209.     BEGIN
  210.         pop-window @ ev.wait
  211.         pop-window @ ev.getclass dup
  212.         IF pop.process
  213.         THEN
  214.     UNTIL
  215. \
  216.     pop-picked @ dup 0<
  217.     IF
  218.         drop false
  219.     ELSE
  220.         true
  221.     THEN
  222. ;
  223.  
  224. : POPUP.DRAW.TEXT ( addr count n -- , draw item text )
  225.     pop-rastport @ 0= abort" POPUP.SET.TEXT - No rastport!"
  226.     dup pop-num-items @ < not abort" POPUP.SET.TEXT - Item# too high!"
  227. \
  228. \ draw text
  229.     POP.n>xy pop_line_height + 2- pop.move
  230.     pop_fore_color pop.color!
  231.     pop_back_color pop.bcolor!
  232.     pop-rastport @ -rot Text()
  233.     
  234. ;
  235.  
  236. : POP.DRAW.BOX { x1 y1 x2 y2 -- }
  237.     x1 y1 pop.move
  238.     x2 y1 pop.draw
  239.     x2 y2 pop.draw
  240.     x1 y2 pop.draw
  241.     x1 y1 pop.draw
  242. ;
  243.  
  244. : POP.CALC.HEIGHT ( nitems -- height )
  245.     pop_line_height * pop_y_start 2* + 2+
  246. ;
  247.  
  248. : POP.CALC.WIDTH ( inwidth -- width )
  249.     pop_x_start 2* +
  250. ;
  251.  
  252. : (POPUP.OPEN) { x y width height title -- window | 0 }
  253. \ adjust X and Y so that the menu fits nicely on screen
  254.     x
  255.     x width +
  256.     pop_screen_width -  ( ammount past edge )
  257.     0 max - -> x \ move left
  258. \
  259.     y
  260.     y height +
  261.     pop_screen_height -  ( ammount past edge )
  262.     0 max - -> y \ move up
  263. \
  264.     x pad s! nw_LeftEdge
  265.     y pad s! nw_TopEdge
  266.     width  pad s! nw_Width
  267.     height pad s! nw_Height
  268.     title pad s! nw_title
  269. \
  270.     CLOSEWINDOW MOUSEBUTTONS | MOUSEMOVE |   ( add MOUSEMOVE )
  271.         pad s! nw_idcmpflags
  272.     REPORTMOUSE SMART_REFRESH |
  273.     BORDERLESS | ACTIVATE | NOCAREREFRESH |
  274.         pad s! nw_flags
  275. \
  276. \ Create window from template and make it the current window.
  277.     pad OpenWindow() dup
  278.     IF
  279. \ set window and rastport
  280.         dup pop-window !
  281.         dup s@ wd_rport pop-rastport !
  282. \
  283. \ Draw Background of Popup Window
  284.         pop_back_color pop.color!
  285.         pop-rastport @
  286.         0 0 width 1-
  287.         height 1-
  288.         RectFill()
  289. \
  290. \ draw box outline
  291.         pop_fore_color pop.color!
  292.         0 0 width 1-
  293.         height 1- pop.draw.box
  294.     ELSE
  295.         pop-window off
  296.         pop-rastport off
  297.     THEN
  298. ;
  299.  
  300. : POPUP.OPEN { x y width nitems title | height -- window | 0 }
  301.     -1 pop-high !  \ none highlighted
  302.     nitems pop-num-items !
  303.     width -> pop_text_width
  304. \
  305.     pad NewWindow.Setup      ( Set defaults for window )
  306. \
  307. \ get screen width and height
  308.     get.workbench.screen
  309.     dup s@ sc_width -> pop_screen_width
  310.     s@ sc_height -> pop_screen_height
  311. \
  312. \ Make sure PopUp window fits on screen
  313.     width pop.calc.width  pop_screen_width min -> width
  314.     nitems pop.calc.height  pop_screen_height min -> height
  315.     x y width height title (popup.open)
  316. ;
  317.  
  318. : POPUP.CLOSE ( -- )
  319.     pop-window @ ?dup
  320.     IF
  321.         CloseWindow()
  322.         pop-window off
  323.         pop-rastport off
  324.     THEN
  325. ;
  326.  
  327. : POPUP.SET.COLORS ( forecolor backcolor -- )
  328.     -> pop_back_color
  329.     -> pop_fore_color
  330. ;
  331.  
  332. if.forgotten popup.close
  333.  
  334.