Specialized Pop-Up Menus

["Mark A. Tapia" <markt@dgp.toronto.edu>]

On Sat Jul 17 15:43:35 allender@aristotle.ils.nwu.edu writes:
   I am trying to create a specialized version of pop-up windows which
   have a minimum width and some other font.  In Inside Macintosh:
   Toolbox Essentials I discovered two commands which come close --
   popUpFixedWidth and popupUseWFont (page 5-28).  From their descriptions
   these sound like what I want, but I'm not sure how to use them?
 
   Has anyone have code that adds one or more of these features?
   If not how/where do I add this code to make a modified popup class?
 
Here is some code for manipulating pop-up menus under system 7.
If you want to use marking menus (basically menus formed by making
connected straight-line strokes), see the pub/MCL2/contrib directory
at cambridge.apple.com (menu-enhancementes.sit.hqx).
 
Here is the code for modifying popp-up menus with the source credited:
 
Mark
;;;-*- Mode: Lisp; Package: gc -*-
 
(in-package :gc)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;;   File           : system7-pop-up-menu.lisp
;;;   Pathname       : Daten:Gerd:contribs:dialog-items:menu-dialog-items:
;;;   Module         :
;;;   Abstract       :
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;; Written by :
 
;;; Gerd Kamp
 
;;; University of Hamburg,
;;; Computer-Science Department,
;;; Artificial Intelligence Laboratory,
;;; Bodenstedtstr. 16
;;; 2000 Hamburg 50
 
;;; Germany
 
 
;;; Copyright (c) 1992 by Gerd Kamp. All rights reserved.
 
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted, so long as the following
;;; conditions are met:
;;;      o no fees or compensation are charged for use, copies, or
;;;        access to this software
;;;      o this copyright notice is included intact.
;;; This software is made available AS IS, and no warranty is made about
;;; the software or its performance.
 
;;; Please send bug reports, comments and suggestions to
;;; kamp@informatik.uni-hamburg.de or the real address mentioned above
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;; Created: 23:18:12  Do., 14.01.1993
 
;;; Last modified: 10:27:07  Mo., 22.02.1993
 
;;; Modification history:
 
#|
This file provides a quick hack to use pop-up-menus as defined on IM VI pp.
3-16 (At least the things I need). To achieve this result it is necessary
to slightly patch control-dialog-item (I think it is now cleaner :-)).
There is no support of popUpAddResMenu as well as popUpTitleJustXXX does
not the things I expected it to do.
 
 
It does not support hierarchical menus cause they are not allowed by the
apple human interface-guidelines
 
So please feel encouraged to modify this dialog-item, but please send me
youre changes.
|#
 
(export '(system-7-pop-up-menu
          menu-selection))
 
#|
We need system 7
|#
(let ((pop-up-available (> (ccl::gestalt :|pop!|)
                           0)))
  (unless pop-up-available
    (message-dialog
      (format nil "Sorry, these contribs need the Pop Up Menu Control
Dialog Item  delivered with System 7. Installation aborted")
      :size #@(350 120))
    (cancel)))
 
#|
The patches to control-dialog-item etc.
 
The proc id's of the standard control-dialog-items are hard coded in
original mcl, I thinks that's not Clossy, cause it's not extendable, so we
do make it into a method
|#
(defmethod procId ((item ccl::control-dialog-item))
  (error "No procID specified for control-dialog-item ~s" item))
 
(defmethod procId ((item radio-button-dialog-item))
  (declare (ignore item))
  10)
 
(defmethod procId ((item check-box-dialog-item))
  (declare (ignore item))
  9)
 
(defmethod procId ((item button-dialog-item))
  (declare (ignore item))
  8)
 
(defmethod procId ((item ccl::scroll-bar-dialog-item))
  (declare (ignore item))
  16)
 
(let ((*warn-if-redefine-kernel* nil))
  (defclass ccl::control-dialog-item (dialog-item)
    ((refcon :accessor ccl::refcon :initform 0)
     (min :accessor ccl::ctl-min :initform 0)
     (max :accessor ccl::ctl-max :initform 1)
     (value :accessor ccl::ctl-value :initform 0))))
 
(let ((*warn-if-redefine-kernel* nil))
  (defmethod install-view-in-window :before ((dialog-item
ccl::control-dialog-item) dialog)
  (ccl::set-default-size-and-position dialog-item (view-container dialog-item))
  (with-pstrs ((sp (dialog-item-text dialog-item)))
    (ccl::with-item-rect (rect dialog-item)
      (setf (dialog-item-handle dialog-item)
            (#_NewControl
             (wptr dialog)
             rect
             sp
             nil
             (ccl::ctl-value dialog-item)
             (ccl::ctl-min dialog-item)
             (ccl::ctl-max dialog-item)
             (procId dialog-item)
             (ccl::refcon dialog-item))))
    (unless (dialog-item-enabled-p dialog-item)
      ;sync up what we believe with what the mac believes.
      (#_HiliteControl (dialog-item-handle dialog-item) 255)))))
 
#|
Now here goes the implementation of the pop-up-menu
|#
 
#|
We have to do this with to slots fixed-width-p and use-window-font-p cause
we only have a reader for procId not a writer
(this would result in a more severe path of control dialog-item: a new
slot). so we have to store the values and use them in the procId method.
|#
(defclass system-7-pop-up-menu (menu ccl::control-dialog-item)
  ((fixed-width-p :initarg :fixed-width-p)
   (use-window-font-p :initarg :use-window-font-p))
  (:default-initargs
    :fixed-width-p t
    :use-window-font-p t
    :dialog-item-action
    #'(lambda (item)
        (menu-item-action (menu-selection item)))))
 
(defmethod install-view-in-window :before ((item system-7-pop-up-menu)
                                           (window window))
           (menu-install item))
 
(defmethod ccl::ctl-min ((item system-7-pop-up-menu))
  (menu-id item))
 
(defmethod ccl::ctl-max ((item system-7-pop-up-menu))
  (string-width (dialog-item-text item)
                (view-font item)))
 
(defmethod ccl::ctl-value ((menu system-7-pop-up-menu))
  (+ (slot-value menu 'value)
     (logand 65355 (third (multiple-value-list (font-codes (view-font
menu)))))))
 
(defmethod menu-selection ((menu system-7-pop-up-menu))
  (when (and (dialog-item-handle menu)
             (menu-items menu))
  (let ((value (#_GetCtlValue (dialog-item-handle menu))))
    (nth (max 0 (1- value)) (menu-items menu)))))
 
(defmethod (setf menu-selection) ((new-selection fixnum) (menu
system-7-pop-up-menu))
  (when (menu-item-enabled-p (nth (1- new-selection) (menu-items menu)))
    (#_SetCtlValue (dialog-item-handle menu) new-selection)
    (when (view-window menu)
      (invalidate-view menu)))
  (menu-selection menu))
 
(defmethod (setf menu-selection) ((new-selection menu-item) (menu
system-7-pop-up-menu))
  (setf (menu-selection menu)
        (1+ (position new-selection (menu-items menu)))))
 
(defmethod initialize-instance :after ((menu system-7-pop-up-menu)
                                       &key
                                       (title-justification :left))
  ;; this doesn't work as described in IM VI, any clues?
  (setf (slot-value menu 'value)
        (case title-justification
          (:center 1)
          (:right 255)
          (otherwise 0))))
 
 
(defmethod menu-title ((menu system-7-pop-up-menu))
  (dialog-item-text menu))
 
 
(defmethod menu-install ((menu system-7-pop-up-menu))
  "Creates the actual Macintosh menu with all of the menu's current items."
  (let* ((menu-items (menu-items menu)))
    (apply #'remove-menu-items menu menu-items)
    (ccl::init-menu-id menu)
    (with-pstrs ((menu-title (menu-title menu)))
      (let ((menu-handle (#_NewMenu :word (slot-value menu 'menu-id)
                                   :ptr menu-title
                                   :ptr)))
        (#_InsertMenu :ptr menu-handle
                     :word -1)
        (setf (slot-value menu 'menu-handle) menu-handle)))
    (let* ((colors (part-color-list menu)))
      (loop
        (unless colors (return))
        (set-part-color menu (pop colors) (pop colors))))
    (apply #'add-menu-items menu menu-items)))
 
(defmethod menu-deinstall ((menu system-7-pop-up-menu))
  (let* ((*menubar-frozen* t))
    (call-next-method)))
 
(defmethod remove-view-from-window :after ((menu system-7-pop-up-menu))
           (menu-deinstall menu))
 
 
(defmethod procId ((item system-7-pop-up-menu))
  (+ 1008
     (if (slot-value item 'use-window-font-p) 8 0)
     (if (slot-value item 'fixed-width-p) 1 0)))
 
 
(defmethod view-click-event-handler ((item system-7-pop-up-menu) where
                                     &aux ok)
  (with-focused-dialog-item (item)
    (let ((handle (dialog-item-handle item)))
      (setq ok (#_TrackControl :ptr handle :long where :long -1 )))
                            (view-draw-contents item))
  (unless (eq ok 0) (dialog-item-action item)))
 
(defmethod ccl::dialog-item-width-correction ((menu system-7-pop-up-menu))
  (third (multiple-value-list (font-info (view-font menu)))))
 
#|
 
(make-instance 'window
  :view-subviews
  (list (setq a (make-instance 'system-7-pop-up-menu
          :dialog-item-text "fgsagurptru"
          :view-size #@(400 40)
          :view-font  '("Courier" 24)
          :help-spec "sdfasdfasfdsaf"
          :title-justification :center
          :menu-items
          (list (make-instance 'menu-item :menu-item-title "sdgfsa3jk"
                               :menu-item-action #'(lambda () (print "aaa"))
                               :style '(:bold :outline))
                (make-instance 'menu-item :menu-item-title "hjdsgfjdgf")))
        )))
;same with fixed-width-p nil
 
(make-instance 'window
  :view-subviews
  (list (setq a (make-instance 'system-7-pop-up-menu
          :dialog-item-text "fgsagurptru"
          :view-size #@(400 40)
          :view-font  '("Courier" 12)
          :fixed-width-p nil
          :help-spec "sdfasdfasfdsaf"
          :title-justification :center
          :menu-items
          (list (make-instance 'menu-item :menu-item-title "sdgfsa3jk"
                               :menu-item-action #'(lambda () (print "aaa")))
                (make-instance 'menu-item :menu-item-title "hjdsgfjdgf")))
        )))
 
|#
 
 
 
 
&