home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / me34src.zip / me3 / mutt / builtin / popup.mut < prev    next >
Lisp/Scheme  |  1995-01-14  |  10KB  |  377 lines
  1.   ;; popup.mut : put a popup window on the screen
  2.   ;; The window is transient - it goes away on redraw.
  3.   ;; ME knows nothing about the window
  4.   ;; C Durland
  5.  
  6. (include max.mut)
  7. (include me.mh)
  8.  
  9. (const
  10.   UPPER-LEFT-CORNER "." UPPER-RIGHT-CORNER "."
  11.   LEFT-SIDE         "|" RIGHT-SIDE         "|"
  12.   LOWER-LEFT-CORNER "`" LOWER-RIGHT-CORNER "'"
  13.   HEDGES  "--------------------------------------------------------------------------------"
  14.   BLANKS "                                                                            "
  15. )
  16.  
  17. (const MPICKER ">")        ;; query menu pointer
  18.  
  19. (small-int ulrow ulcol brow bcol)
  20.  
  21. (defun
  22.   popup-window (int row col width length)
  23.   {
  24.     (int j r)
  25.  
  26.     (ulrow (brow (+ row 1)))(ulcol (bcol (+ col 1)))
  27.     (move-cursor row col)
  28.     (puts UPPER-LEFT-CORNER (extract-elements HEDGES 0 width)
  29.       UPPER-RIGHT-CORNER)
  30.     (for {(r ulrow)(j 0)} (< j length) {(+= j 1)(+= r 1)}
  31.     {
  32.       (move-cursor r col)
  33.       (puts LEFT-SIDE (extract-elements BLANKS 0 width) RIGHT-SIDE)
  34.     })
  35.     (move-cursor r col)
  36.     (puts LOWER-LEFT-CORNER (extract-elements HEDGES 0 width)
  37.       LOWER-RIGHT-CORNER)
  38.   }
  39.   wputs    (string msg)
  40.   {
  41.     (move-cursor brow bcol)(puts msg)
  42.     (+= brow 1)
  43.   }
  44. )
  45.  
  46. (defun
  47.   xpopup-window (int row col width length)
  48.   {
  49.     (int j r)
  50.  
  51.     (ulrow (brow (+ row 1)))(ulcol (bcol (+ col 1)))
  52.     (move-cursor row col
  53.     (concat UPPER-LEFT-CORNER (extract-elements HEDGES 0 width)
  54.         UPPER-RIGHT-CORNER))
  55.  
  56.     (for {(r ulrow)(j 0)} (< j length) {(+= j 1)(+= r 1)}
  57.       (move-cursor r col
  58.     (concat LEFT-SIDE (extract-elements BLANKS 0 width) RIGHT-SIDE)))
  59.  
  60.     (move-cursor r col
  61.     (concat LOWER-LEFT-CORNER (extract-elements HEDGES 0 width)
  62.         LOWER-RIGHT-CORNER))
  63.   }
  64.   xwputs (string msg)
  65.   {
  66.     (move-cursor brow bcol msg)
  67.     (+= brow 1)
  68.   }
  69. )
  70.  
  71. ;******************************************************************************;
  72. ;***                                                                        ***;
  73. ;**                           . . M E N U - B O X                            **;
  74. ;***                                                                        ***;
  75. ;******************************************************************************;
  76.  
  77. ; Desc: Draw one or more boxes justified to the top right corner of the screen.
  78. ;       Each parameter represents a line in the box. 
  79. ;       The box width is ajusted to the max width of the lines to be
  80. ;       contained in the current box.
  81. ;       If a box does not fit vertically, it is broken in 2 boxes.
  82. ;       Some lines (parameters) have special effect:
  83. ;           ''      Close current box and open a new box in the next column.
  84. ;                       To have a blank line, just use ' '.
  85. ;           '-'     Is replaced by a solid line across the box.
  86. ;           '>xxxx' xxxx is centered in the box.
  87. ;       
  88. ; Use : For popup menus
  89. ; Call: (menu-box text text ...)
  90. ; Author: Original idea and code from Michel St-Louis, rewritten by C Durland
  91.  
  92. (const
  93.   BOX-OVERLAP     2        ;; 1 (share borders) or 2 (don't share)
  94.   BOX-MAX-LENGTH 3        ;; 4 (don't cover modeline), 3 (go ahead)
  95. )
  96.  
  97. (defun
  98.    menu-box { (do-menu-box (floc  popup-window) (floc  wputs) (push-args 0)) }
  99.   xmenu-box { (do-menu-box (floc xpopup-window) (floc xwputs) (push-args 0)) }
  100. )
  101.  
  102. (array small-int box-width 10 box-length 10)
  103. (int boxes popup-left-edge)
  104.  
  105. (defun do-menu-box (pointer defun popup-window wputs) HIDDEN
  106. {
  107.   (int  i j k w l max-length left-edge total-width)
  108.  
  109.   (max-length (- (screen-length) BOX-MAX-LENGTH))
  110.   (for {(j 2) (total-width (boxes (w (l 0))))} (< j (nargs)) (+= j 1)
  111.     {
  112.       (w (max w (length-of (arg j))))
  113.       (if (or (== "" (arg j)) (== (+= l 1) max-length))    ;; need another box
  114.     {
  115.       (box-width boxes w)(box-length boxes l)
  116.       (if (== (nargs) (+ j 1)) (continue))    ;; last entry
  117.       (+= boxes 1)
  118.       (+= total-width (+ w BOX-OVERLAP))
  119.       (w (l 0))
  120.     })
  121.     })
  122.   (box-width boxes w)(box-length boxes l)(+= boxes 1)
  123.   (+= total-width (+ w 2))
  124.  
  125.   (popup-left-edge (left-edge (max 0 (- (screen-width) total-width))))
  126.   
  127.   (for {(i 0)(j 2)} (< i boxes) (+= i 1)
  128.     {
  129.       (popup-window 0 left-edge (box-width i) (box-length i))
  130.       (+= left-edge (box-width i) BOX-OVERLAP)
  131.       (if (== "" (arg j)) (+= j 1))
  132.  
  133.       (for (k 0) (< k (box-length i)) { (+= k 1)(+= j 1) }
  134.     (wputs
  135.       (cond
  136.         (== '-' (arg j)) (extract-elements HEDGES 0 (box-width i))
  137.         (== '>' (extract-elements (arg j) 0 1))
  138.         (concat
  139.           (extract-elements BLANKS 0
  140.               (/ (- (box-width i) (length-of (arg j))) 2))
  141.           (extract-elements (arg j) 1 100))
  142.         TRUE  (arg j)
  143.       )))
  144.       })
  145. })
  146.  
  147.  
  148.  
  149. ;******************************************************************************
  150. ;***                                                                        ***
  151. ;**            Popup Menus                         **
  152. ;***                                                                        ***
  153. ;******************************************************************************
  154.  
  155.  
  156. ;; Use it like so:
  157. ;;  (query-menu <entry-to-start-cusor-on>
  158. ;;    (floc "<get-action>") (floc "<call-back>") entry ...)
  159. ;;     TRUE is returned if an entry is selected, FALSE otherwise.
  160. ;; The call-back routine is called when an entry is selected.  It is a
  161. ;;   routine you define:
  162. ;;     (defun my-call-back (int nth-entry)(string entry-name)
  163. ;;     {
  164. ;;       (msg "Entry selected: " entry-name)
  165. ;;     })
  166. ;; Input:
  167. ;;   get-action : Pointer to routine used to query user and return an
  168. ;;     action.  You can use (floc "menu-get-action") for a default.
  169. ;;   call-back : Pointer to routine that is called when a menu entry is
  170. ;;     selected.
  171. ;;   entry : A bunch of strings that make up the menu entries.  Same format
  172. ;;     as for menu-box.
  173. ;; Returns:
  174. ;;   TRUE : Entry selected, call-back called, etc.
  175. ;;   FALSE : User quit
  176. ;;   abort : 
  177.  
  178. (const
  179.   MENU-NOOP    0
  180.   MENU-SELECT    1
  181.   MENU-SELECTED    2
  182. )
  183.  
  184. (bool menu-not-done menu-return-code)
  185. (small-int row column the-box menu-keymap global-keymap menu-do-what)
  186.  
  187. (defun
  188.   MAIN
  189.   {
  190.     (bind-key (menu-keymap (create-keymap))
  191.     "menu-down"        "j"
  192.     "menu-down"        "C-n"
  193.     "menu-down"        "F-D"    ;; down arrow
  194.  
  195.     "menu-up"        "k"
  196.     "menu-up"        "C-p"
  197.     "menu-up"        "F-C"    ;; up arrow
  198.  
  199.     "menu-end"        "M->"
  200.     "menu-end"        "F-B"    ;; end
  201.  
  202.     "menu-top"        "M-<"
  203.     "menu-top"        "F-A"    ;; home
  204.  
  205.     "menu-quit"        "q"
  206.     "menu-abort"        "Q"
  207.     "menu-abort"        "C-g"
  208.  
  209.     "menu-select"        "C-m"
  210.     "menu-select"        "F-N"    ;; select
  211.  
  212.     "ack-do-mouse"        "S-m"    ;; From the mouse driver
  213.     "menu-mouse-select"    "S-1"    ;; mouse button 1
  214.     )
  215.   }
  216.   xquery-menu (int first)
  217.          (pointer defun get-action call-back) (string text) ;  ...
  218.     { (query-menu first call-back (push-args 3)) }
  219.   query-menu (int first) (pointer defun call-back) (string text) ;  ...
  220.   {
  221. (int b)
  222.     (if (pgm-exists "keymap-special") (keymap-special menu-keymap))
  223.  
  224.     (xmenu-box (push-args 2))
  225.  
  226.     (the-box 0)(row 0)(column popup-left-edge)
  227.  
  228.     (move-pick first 1)
  229.  
  230.     (global-keymap (install-keymap GLOBAL-KEYMAP))
  231.     (install-keymap menu-keymap GLOBAL-KEYMAP)
  232. ;(install-keymap NULL-KEYMAP LOCAL-KEYMAP)
  233.     (current-buffer (create-buffer "*menu*"))
  234.     (buffer-read-only TRUE)
  235.  
  236.     (menu-do-what MENU-NOOP)(menu-return-code FALSE)(menu-not-done TRUE)
  237.     (while { (exe-key (get-key)) menu-not-done } ())
  238.     (menu-restore)
  239.     (switch menu-do-what
  240.       MENU-SELECT (send-the-pick (push-args 1))
  241.       MENU-SELECTED
  242.     (menu-send-selected call-back (arg-prefix) (arg (+ 2 (arg-prefix))))
  243.     )
  244.     menu-return-code
  245.   }
  246.   ack-do-mouse
  247.   {
  248.     (install-keymap global-keymap GLOBAL-KEYMAP)
  249.     (if (load-code "mouse" FALSE TRUE)
  250.       {
  251.     (install-keymap menu-keymap GLOBAL-KEYMAP)
  252.     (floc "do-mouse" ())
  253.       }
  254.       {
  255.     (install-keymap menu-keymap GLOBAL-KEYMAP)
  256.     (msg "popup: Could not load mouse")
  257.       })
  258.   }
  259.   menu-restore
  260.   {
  261.     (install-keymap global-keymap GLOBAL-KEYMAP)
  262.   }
  263.   menu-down  { (move-pick 1  1) }
  264.   menu-up    { (move-pick 1 -1) }
  265.   menu-end   { (move-pick-to-end) }
  266.   menu-top   { (move-pick-to-start) }
  267.   menu-quit  { (menu-not-done FALSE) }
  268.   menu-stop  { (msg "Exiting menu system")(menu-restore)(halt) }
  269.   menu-abort { (menu-restore)(abort) }
  270.   menu-select
  271.   {
  272.     (menu-do-what MENU-SELECT)
  273.     (menu-return-code TRUE)
  274.     (menu-quit)
  275.   }
  276.   menu-selected
  277.   {
  278.     (menu-do-what MENU-SELECTED)
  279.     (menu-return-code TRUE)
  280.     (menu-quit)
  281.   }
  282.   menu-mouse-select
  283.   {
  284.     (small-int button mrow mcol state modifiers)    ;; MouseInfo
  285.     (int dir last-row)
  286.  
  287.     (mouse-info (loc button))
  288.     (-= mrow 2)        ;; 1 for menu border, 1 because first row is 0
  289. ;(msg ">>>" row "  " mrow)(get-key)
  290.     (dir (if (< mrow row) -1 1))(last-row row)
  291.     (while (!= mrow row)
  292.     {
  293.       (move-pick 1 dir)
  294.       (if (== last-row row) (done))
  295.       (last-row row)
  296.     })
  297.     (menu-select)
  298.   }
  299.   picket (int r c)(string thing) HIDDEN { (move-cursor (+ 1 r) c thing) }
  300.   move-pick (int n tick) HIDDEN
  301.   {
  302.     (int i)
  303.  
  304.     (picket row column LEFT-SIDE)
  305.     (i n)
  306.     (while (!= 0 i)
  307.     {
  308.       (-= i 1)
  309.       (+= row tick)
  310.       (cond
  311.     (< row 0)
  312.       {
  313.         (if (< 0 the-box)
  314.           {
  315.         (-= the-box 1)
  316.         (-= column (box-width the-box) 2)
  317.         (row (- (box-length the-box) 1))
  318.           }
  319.           (row 0))
  320.       }
  321.     (== row (box-length the-box))
  322.       {
  323.         (if (< the-box (- boxes 1))
  324.           {
  325.         (row 0)
  326.         (+= column (box-width the-box) 2)
  327.         (+= the-box 1)
  328.           }
  329.           (row (- (box-length the-box) 1)))
  330.       }
  331.       )
  332.     })
  333.     (picket row column MPICKER)
  334.   }
  335.   move-pick-to-end HIDDEN
  336.   {
  337.     (picket row column LEFT-SIDE)
  338.     (row (- (box-length the-box) 1))
  339.     (picket row column MPICKER)
  340.   }
  341.   move-pick-to-start HIDDEN
  342.   {
  343.     (picket row column LEFT-SIDE)
  344.     (row 0)
  345.     (picket row column MPICKER)
  346.   }
  347.   menu-send-selected (pointer defun call-back) (int n) (string selection)
  348.     HIDDEN
  349.   {
  350.     (call-back n
  351.       (if (== '>' (extract-elements selection 0 1))
  352.       (extract-elements selection 1 100)
  353.       selection))
  354.   }
  355.   send-the-pick (pointer defun call-back) ; (string ...)
  356.     HIDDEN
  357.   {
  358.     (int j n b)
  359.  
  360.     (n 0)(b 0)
  361.     (for (j 1) (< j (nargs)) (+= j 1)
  362.       {
  363.     (if (== "" (arg j)) (continue))
  364.  
  365.     (if (== n (box-length b)) { (+= b 1) (n 0) })
  366.     (if (and (== b the-box)(== n row))
  367.       {
  368.         (menu-send-selected call-back (- j 1) (arg j))
  369.         (done)
  370.       })
  371.  
  372.     (+= n 1)
  373.       })
  374.     (call-back -1 "")
  375.   }
  376. )
  377.