RE: Drawing icons in pop-up menus

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

In a recent posting (lost since my machine crashed while reading),
someone asked why combining pop-up menus and icon-dialog-items
did not work.

Rather than basing the code on pop-up-menu.lisp in the library file,
try the following code which supports different fonts specifications
for popup menus. The code is contributed by Gerd Kamp at the University
of Hamburg. Among other features, it also supports various text 
justifications (center, left, and right)

mark
:
;;;-*- Mode: Lisp; Package: ccl -*-
 
;(in-package :gc)
(in-package :ccl)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;;   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")))
        )))
 
|#