src/lsp/menus.lsp

   1 ;;;;
   2 ;;;; menus.lsp Menus for the Macintosh, MS Windows, and UNIX
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9 (in-package "XLISP")
  10 (provide "menus")
  11
  12
  13 ;;;;
  14 ;;;; Standard Menus for Macontosh Version
  15 ;;;;
  16
  17 #+macintosh
  18 (progn
  19   ;;**** check over exports
  20   (export '(find-menu set-menu-bar
  21             *apple-menu* *file-menu* *edit-menu* *command-menu*
  22             *standard-menu-bar*))
  23
  24 ;;;;
  25 ;;;; Editing Methods
  26 ;;;;
  27
  28   (defmeth edit-window-proto :edit-selection ()
  29     (send (send edit-window-proto :new)
  30           :paste-stream (send self :selection-stream)))
  31
  32   (defmeth edit-window-proto :eval-selection ()
  33     (let ((s (send self :selection-stream)))
  34       (do ((expr (read s nil '*eof*) (read s nil '*eof*)))
  35           ((eq expr '*eof*))
  36           (eval expr))))
  37
  38   (let ((last-string ""))
  39     (defmeth edit-window-proto :find ()
  40       "Method args: ()
  41 Opens dialog to get string to find and finds it. Beeps if not found."
  42       (let ((s (get-string-dialog "String to find:" :initial last-string)))
  43         (when s
  44               (if (stringp s) (setq last-string s))
  45               (unless (and (stringp s) (send self :find-string s))
  46                       (sysbeep)))))
  47     (defmeth edit-window-proto :find-again ()
  48       (unless (and (stringp last-string)
  49                    (< 0 (length last-string))
  50                    (send self :find-string last-string))
  51               (sysbeep))))
  52
  53 ;;;;
  54 ;;;; General Menu Methods and Functions
  55 ;;;;
  56   (defmeth menu-proto :find-item (str)
  57     "Method args: (str)
  58 Finds and returns menu item with tile STR."
  59     (dolist (item (send self :items))
  60       (if (string-equal str (send item :title))
  61           (return item))))
  62
  63   (defun find-menu (title)
  64     "Args: (title)
  65 Finds and returns menu in the menu bar with title TITLE."
  66     (dolist (i *hardware-objects*)
  67       (let ((object (nth 2 i)))
  68         (if (and (kind-of-p object menu-proto)
  69                  (send object :installed-p)
  70                  (string-equal (string title) (send object :title)))
  71             (return object)))))
  72
  73   (defun set-menu-bar (menus)
  74     "Args (menus)
  75 Makes the list MENUS the current menu bar."
  76     (dolist (i *hardware-objects*)
  77       (let ((object (nth 2 i)))
  78         (if (kind-of-p object menu-proto) (send object :remove))))
  79     (dolist (i menus) (send i :install)))
  80
  81 ;;;;
  82 ;;;; Apple Menu
  83 ;;;;
  84   (defvar *apple-menu* (send apple-menu-proto :new (string #\apple)))
  85   (send *apple-menu* :append-items
  86         (send menu-item-proto :new "About XLISP-STAT"
  87               :action 'about-xlisp-stat))
  88
  89 ;;;;
  90 ;;;; File Menu
  91 ;;;;
  92   (defvar *file-menu* (send menu-proto :new "File"))
  93
  94   (defproto file-edit-item-proto '(message) '() menu-item-proto)
  95
  96   (defmeth file-edit-item-proto :isnew (title message &rest args)
  97     (setf (slot-value 'message) message)
  98     (apply #'call-next-method title args))
  99
 100   (defmeth file-edit-item-proto :do-action ()
 101     (send (front-window) (slot-value 'message)))
 102
 103   (defmeth file-edit-item-proto :update ()
 104     (send self :enabled (kind-of-p (front-window) edit-window-proto)))
 105
 106   (send *file-menu* :append-items
 107         (send menu-item-proto :new "Load" :key #\L :action
 108               #'(lambda ()
 109                   (let ((f (open-file-dialog t)))
 110                     (when f (load f) (format t "; finished loading ~s~%" f)))))
 111         (send dash-item-proto :new)
 112         (send menu-item-proto :new "New Edit" :key #\N
 113               :action #'(lambda () (send edit-window-proto :new)))
 114         (send menu-item-proto :new "Open Edit" :key #\O
 115               :action #'(lambda ()
 116                           (send edit-window-proto :new :bind-to-file t)))
 117         (send dash-item-proto :new)
 118         (send file-edit-item-proto :new "Save Edit" :save :key #\S)
 119         (send file-edit-item-proto :new "Save Edit As" :save-as)
 120         (send file-edit-item-proto :new "Save Edit Copy" :save-copy)
 121         (send file-edit-item-proto :new "Revert Edit" :revert)
 122         (send dash-item-proto :new)
 123         (send menu-item-proto :new "Quit" :key #\Q :action 'exit))
 124
 125 ;;;;
 126 ;;;; Edit Menu
 127 ;;;;
 128   (defproto edit-menu-item-proto '(item message) '() menu-item-proto)
 129
 130   (defmeth edit-menu-item-proto :isnew (title item message &rest args)
 131     (setf (slot-value 'item) item)
 132     (setf (slot-value 'message) message)
 133     (apply #'call-next-method title args))
 134
 135   (defmeth edit-menu-item-proto :do-action ()
 136     (unless (system-edit (slot-value 'item))
 137             (let ((window (front-window)))
 138               (if window (send window (slot-value 'message))))))
 139
 140   (defvar *edit-menu* (send menu-proto :new "Edit"))
 141   (send *edit-menu* :append-items
 142         (send edit-menu-item-proto :new "Undo" 0 :undo :enabled nil)
 143         (send dash-item-proto :new)
 144         (send edit-menu-item-proto :new "Cut" 2 :cut-to-clip :key #\X)
 145         (send edit-menu-item-proto :new "Copy" 3 :copy-to-clip :key #\C)
 146         (send edit-menu-item-proto :new "Paste" 4 :paste-from-clip :key #\V)
 147         (send edit-menu-item-proto :new "Clear" 5 :clear :enabled nil)
 148         (send dash-item-proto :new)
 149         (send menu-item-proto :new "Copy-Paste" :key #\/ :action
 150               #'(lambda ()
 151                   (let ((window (front-window)))
 152                     (when  window
 153                            (send window :copy-to-clip)
 154                            (send window :paste-from-clip)))))
 155         (send dash-item-proto :new)
 156         (send menu-item-proto :new "Find ..." :key #\F :action
 157               #'(lambda ()
 158                   (let ((window (front-window)))
 159                     (if window (send window :find)))))
 160         (send menu-item-proto :new "Find Again" :key #\A :action
 161               #'(lambda ()
 162                   (let ((window (front-window)))
 163                     (if window (send window :find-again)))))
 164         (send dash-item-proto :new)
 165         (send menu-item-proto :new "Edit Selection" :action
 166               #'(lambda () (send (front-window) :edit-selection)))
 167         (send menu-item-proto :new "Eval Selection" :key #\E :action
 168               #'(lambda () (send (front-window) :eval-selection))))
 169
 170 ;;;;
 171 ;;;; Command Menu
 172 ;;;;
 173   (defvar *command-menu* (send menu-proto :new "Command"))
 174   (send *command-menu* :append-items
 175         (send menu-item-proto :new "Show XLISP-STAT"
 176               :action #'(lambda () (send *listener* :show-window)))
 177         (send dash-item-proto :new)
 178         (send menu-item-proto :new "Clean Up" :key #\, :action #'clean-up)
 179         (send menu-item-proto :new "Toplevel" :key #\. :action #'top-level)
 180         (send dash-item-proto :new)
 181         (let ((item (send menu-item-proto :new "Dribble")))
 182           (send item :action
 183                 #'(lambda ()
 184                     (cond
 185                      ((send item :mark) (dribble) (send item :mark nil))
 186                      (t (let ((f (set-file-dialog "Dribble file:")))
 187                           (when f
 188                                 (dribble f)
 189                                 (send item :mark t)))))))
 190           item))
 191
 192   (defconstant *standard-menu-bar*
 193     (list *apple-menu* *file-menu* *edit-menu* *command-menu*)))
 194
 195
 196 ;;;;
 197 ;;;; Standard Menus for Microsoft Windows Version
 198 ;;;;
 199
 200 #+msdos
 201 (progn
 202   (export '(find-menu set-menu-bar
 203             *file-menu* *edit-menu* *command-menu*
 204             *standard-menu-bar*))
 205
 206   (setf *file-menu* (send menu-proto :new "&File"))
 207
 208   (send *file-menu* :append-items
 209         (send menu-item-proto :new "&Load" :action
 210               #'(lambda ()
 211                   (let ((fname (open-file-dialog)))
 212                     (if fname (load fname)))))
 213         (let ((dribble-item (send menu-item-proto :new "&Dribble")))
 214           (defmeth dribble-item :do-action ()
 215             (case (send self :mark)
 216                   (nil (let ((df (set-file-dialog "Dribble File Name:")))
 217                          (when df
 218                                (dribble df)
 219                                (send self :mark t))))
 220                   (t (dribble) (send self :mark nil))))
 221           dribble-item)
 222         (send dash-item-proto :new)
 223         #+win32 (send menu-item-proto :new "&Print...\tCtrl+P" :action
 224                       #'msw-print)
 225         #+win32 (send dash-item-proto :new)
 226         (send menu-item-proto :new "E&xit" :action #'msw-exit)
 227         (send menu-item-proto :new "About XLISP-STAT ..." :action
 228               #'about-xlisp-stat))
 229
 230   (setf *edit-menu* (send menu-proto :new "&Edit"))
 231   (send *edit-menu* :append-items
 232         (send menu-item-proto :new "&Undo\tCtrl+Z" :enabled nil)
 233         (send dash-item-proto :new)
 234         (send menu-item-proto :new "Cu&t\tCtrl+X" :action #'msw-cut)
 235         (send menu-item-proto :new "&Copy\tCtrt+C" :action #'msw-copy)
 236         (send menu-item-proto :new "&Paste\tCtrl+V" :action #'msw-paste)
 237         (send menu-item-proto :new "C&lear\tDel" :action #'msw-clear)
 238         (send dash-item-proto :new)
 239         (send menu-item-proto :new "Copy-Paste\tAlt+V"
 240               :action #'msw-copy-paste))
 241
 242   (defun set-menu-bar (menus)
 243     "Args (menus)
 244 Makes the list MENUS the current menu bar."
 245     (dolist (i *hardware-objects*)
 246       (let ((object (nth 2 i)))
 247         (if (kind-of-p object menu-proto) (send object :remove))))
 248     (dolist (i menus) (send i :install)))
 249
 250   (defconstant *standard-menu-bar* (list *file-menu* *edit-menu*)))
 251
 252
 253 ;;;
 254 ;;; Fake menu bar for UNIX systems with graphics
 255 ;;; This is a complete hack but at least provides enough functionality
 256 ;;; to do the examples in the book.
 257 ;;;
 258
 259 #+unix
 260 (progn
 261   (export 'find-menu)
 262
 263   (defun make-fake-menu-bar ()
 264     (cond
 265      ((and (boundp '*fake-menu-bar*) *fake-menu-bar*)
 266       (send *fake-menu-bar* :show-window))
 267      (t (let* ((ascent (send graph-window-proto :text-ascent))
 268                (descent (send graph-window-proto :text-descent))
 269                (gap (floor (/ ascent 2)))
 270                (width 400))
 271           (setf *fake-menu-bar*
 272                 (send graph-window-proto :new
 273                       :title "Menu Bar"
 274                       :menu-button nil
 275                       :size (list width (+ ascent descent (* 2 gap))))))
 276
 277         (send *fake-menu-bar* :add-slot 'menus)
 278
 279         (defmeth *fake-menu-bar* :menus (&optional (menus nil set))
 280           (if set (setf (slot-value 'menus) menus))
 281           (slot-value 'menus))
 282
 283         (defmeth *fake-menu-bar* :install-menu (menu)
 284           (unless (member menu (send self :menus))
 285                   (send self :menus (append (send self :menus) (list menu)))
 286                   (send self :show-window)
 287                   (send self :redraw)))
 288
 289         (defmeth *fake-menu-bar* :remove-menu (menu)
 290           (send self :menus (remove menu (send self :menus)))
 291           (send self :redraw))
 292
 293         (defmeth *fake-menu-bar* :redraw ()
 294           (let* ((ascent (send self :text-ascent))
 295                  (gap (floor (/ ascent 2)))
 296                  (menus (send self :menus))
 297                  (left gap)
 298                  (bottom (+ gap ascent)))
 299             (apply #'send self :erase-rect (send self :view-rect))
 300             (dolist (m menus)
 301               (let ((title (send m :title)))
 302                 (send self :draw-string title left bottom)
 303                 (setf left (+ left gap (send self :text-width title)))))))
 304
 305         (defmeth *fake-menu-bar* :do-click (x y m1 m2)
 306           (declare (ignore m1 m2))
 307           (let* ((loc (+ (list x y) (send self :location)))
 308                  (gap (floor (/ (send self :text-ascent) 2)))
 309                  (menus (send self :menus))
 310                  (x (- x gap)))
 311             (dolist (m menus)
 312               (let ((w (send self :text-width (send m :title))))
 313                 (when (< 0 x w)
 314                       (apply #'send m :popup loc)
 315                       (return))
 316                 (setf x (- x gap w))))))
 317         (defun find-menu (name)
 318           (dolist (m (send *fake-menu-bar* :menus))
 319             (if (string-equal (string name) (send m :title))
 320                 (return m)))))))
 321
 322   (defmeth menu-proto :install ()
 323     (make-fake-menu-bar)
 324     (send *fake-menu-bar* :install-menu self))
 325
 326   (defmeth menu-proto :remove ()
 327     (send *fake-menu-bar* :remove-menu self)))
 328
 329