;;;-*- Mode: Lisp; Package: CCL -*-
;;;
;;; Modern-MCL.lisp
;;;
;;; Gives MCL a more modern look & feel in accordance with Appearance, Themes and (for OSX) Aqua.
;;; Includes improvements to MCL and to the Appearance Manager modules in the Examples folder of MCL.
;;; Also patches some other optional modules.
;;;
;;; Version 2.1 (formerly called appearance-mcl before version 2.0 for MCL 5.1)
;;; Changes to original MCL code Copyright © 1999-2005 Terje Norderhaug and in¥Progress.
;;; All source code from MCL is copyright © Digitool. Other source code is copyright their respective authors.
;;;
;;; Use and copying of this software and preparation of derivative works in MCL
;;; based upon this software are permitted. Digitool and others are welcome and encouraged 
;;; to freely integrate parts or all of my changes into the MCL distribution and MCL application.
;;;
;;; This software is made available AS IS, and no warranty is made about 
;;; the software or its performance.
;;;
;;; Author: Terje Norderhaug <terje@in-progress.com> of in¥Progress.
;;;
;;; Available from <http://www.in-progress.com/src/>.
;;; Tested on MCL 5.0, 5.1 and 5.2 but should also work with other Carbon compatible versions of MCL.
;;; Should usually be loaded after other patches and modules.
;;;
;;; Most modifications to original MCL source code are in color.

#| VERSION HISTORY

@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

2008-Apr-03 Terje Version 2.1 released
                   Compatible with MCL 5.2 
                   Preferences dialog uses theme font in labels.
                   Use theme cursors for all directions of the pane splitter and bar dragger in MCL 5.2. 
                   Bar dragger in MCL 5.2 has three lines (instead of four), more like the dragger in e.g. Apple Mail.        
2006-Mar-01 Terje Version 2.0 released 
                   Compatible with MCL 5.1
2006-Mar-01 Terje Avoid "view has no slot named color-list" error when using drag & drop:
                   drag-hide-drag-hilite on drag-view-mixin has an ignore-error to work around part-color accessing color-list 
2006-Jan-10 Terje Typein-Menu has a look & feel more like the Carbon Combo-Box:
                   Added patched view-draw-contents, menu-display-v-offset, menu-display-h-offset.
                   Added point-in-click-region-p, view-activate-event-handler, view-deactivate-event-handler.
2006-Jan-09 Terje Added drag-hide-drag-hilite with a minor fix to its back color.
2005-Dec-29 Terje Eliminate warnings when defining  do-column-widths and do-row-heights
2005-Dec-24 Terje Version 2.0b 
                   Renamed from Appearance-MCL to Modern-MCL.
                   All pre-carbon code has been removed.
                   Updates to be compatible with MCL 5.1.
                   New view-default-size for 3d-button under MCL 5.1.
                   Fixed scrolling-fred-view for MCL 5.1 so it displays a theme frame (applies to Trace and Info dialogs).
2005-Dec-14 Terje Tables uses theme text colors as default
                   %draw-table-cell-new calls SetThemeTextColor
2005-Dec-14 Terje The text in an Editable-Text-Dialog-Item is visualized inactive in MCL 5.0/5.1
                   view-draw-contents on fred-dialog-item sets theme text colors.
2005-Dec-04 Terje Version 1.5 released
                   Last version still compatible with pre-carbon MCL 4.3.1
                   Next version will be renamed to Modern-MCL 2.0 and eliminate all pre-carbon code.
2005-Oct-03 Terje Added patched drag-show-drag-hilite method on drag-view-mixin (fixes problem with back color).
2005-Oct-03 Terje New section for patches to the drag and drop extension in the Examples folder of MCL.
2005-sep-30 Terje Set-cursor is made into a method. It still includes support for keyword theme cursors.
                  New abstract class for cursor, with a subclass for theme cursors.
2004-Sep-17 Terje Title-box-dialog-item locates the box more similarly between OSX and OS9:
                   New title-box-offset method, called when drawing and calculating the title offset.
2004-Jun-14 Terje Static text dialog items with custom color also displays as inactive/disabled:
                   Using TextMode #$grayishTextOr in the view-draw-contents method of static-text-dialog-item.
2004-Jun-04 Terje Changes for compatability with MCL 5.1b2:
                   The frame-table-item function has an added argument 'inset' in MCL 5.1.
                   Don't override view-draw-contents for arrow-dialog-item in MCL 5.1.
                   Removed set-dialog-item-text on static-text-dialog-item for MCL 5.1 as it is the same as in MCL.
                   Substituted (mouse-down-p) with (wait-mouse-up-or-moved) for MCL 5.1.
                   Initialize-instance :before on ed-help-window moves fred-title up one pixel in MCL 5.1.
2004-Jun-04 Terje Basic-editable-text-dialog-item again supports numerical outline and colors for frame and body.
2004-Jun-04 Terje Added view-pixel-depth and view-color-p functions and used them wherever required.
2004-Jun-04 Terje Uses theme text color as default for fred-dialog-item:
                   Eliminates view-draw-contents :around on basic-editable-text-dialog-item.
                   Added a patched view-draw-contents on fred-dialog-item that calls #_setThemetextColor.
2004-May-27 Terje Added an invalidate-view method on static-text-dialog-item under MCL 5 and beyond that provides T as default for erase-p.
2004-May-27 Terje Using a case construct to set the value of text-justification in view-draw-contents for static-text-dialog-item.
2004-May-23 Terje Theme compliant hilighting of table cells:
                   Modified %draw-table-cell-new to use a theme background for the hilight color instead of invert.
2004-May-09 Terje The label-offset function for title-box-dialog-item works even when the box has no title. 
2004-May-05 Terje view-activate-event-handler :before on pop-up-menu checks whether menu-enabled-p before activting the control.
2004-Apr-28 Terje Added patches for clock-dialog-items and the progress bar of the Appearance Manager.
2004-Apr-26 Terje theme-tab-title-proc uses #_GetThemeTextDimensions to get the font height.
2004-Apr-25 Terje Small fix to theme-tab-title-proc so the tab title is vertically centered in OSX.
2004-Apr-25 Terje The pop-up arrow of the pull-down menu is optional (suggested by Alice).
2004-Apr-25 Terje Poof button, bar dragger and backtrace's dragging pane splitter has legacy triangles icon for Alice.
2004-Apr-25 Terje The Fred pane splitter is black for Alice.
2004-Apr-25 Terje The feature :alice determines whether to adhere to Alice/Digitool's wishes for next gen MCL UI.
2004-Apr-20 Terje New view-setup-background for multi-pane-view to ensure proper background for contained controls.
2004-Apr-19 Terje New view-setup-background method to set up custom background for a control.
2004-Apr-19 Terje New view-apply-text-color to set up custom text color for a control.
2004-Apr-19 terje New handle->dialog-item to map from a control handle to its view.
2004-Apr-19 terje New control-color-proc callback to set custom text color and background for controls.
2004-Apr-15 terje Calling inset-rect changed to #_insetRect in theme-tab-title-proc.
2004-Apr-10 Terje Pane tabs are sized and drawn depending on theme text dimensions.
2004-Apr-10 Terje Subviews of Multi-pane-view uses the background of the pane instead of the one of the dialog:
                    Added call to applyThemeBackground in view-draw-contents for multi-pane-view.
2004-Apr-10 terje Minor changes to initialization of appearance manager
2004-Apr-08 Terje draw-up-rect fixed to work in MCL 4.3.1 when highlight-color is a number.
2004-Apr-07 Terje Version 1.4 released.
2004-Apr-01 Terje Several minor changes for better functionality under MCL 4.3.1.
2004-Mar-29 Terje view-draw-contents on pull-down-menu uses theme text colors.
                  Added inspector::set-selection to fix problems displaying selection in inspector under MacOS9.
                  New view-draw-contents for ellipsized-text-dialog-item in MCL 5.1.
                  Add MCL 5.0 modifications to view-(de)activate-event-handler for static-text-dialog-item.
                  Separator drawn below command pane in OSX.
2004-Mar-14 Terje Moves without-interrupts in view-click-event-handler for table-dialog-item as suggested in Digitool's woi-patch.
2004-Mar-14 Terje Pull down menus have nicer dimensions:
                   view-default-size on pull-down-menu uses GetThemeTextDimensions to get proper size for theme text.
                   Moved the menu text a few pixels to the right by changing view-draw-contents and view-click-event-handler.
2004-Feb-18 Terje Pull down menu more theme savvy:
                   New view-draw-contents for pull-down-menu to draw theme arrow etc.
                   Added view-click-event-handler for pull-down-menu that draws theme text and background when the menu is selected.
2004-Feb-14 Terje The Backtrace, Processes and Inspectors are now almost completely theme savvy.
2004-Feb-14 Terje Theme fonts for backtrace command and -info panes (suggested by Octav Popescu):
                   Added add-command-pane-items on command-pane with theme fonts.
                   Added initialize-instance on backtrace-info-pane with theme fonts.
                   Added initialize-instance on backtrace-command-pane with theme fonts.
                   New view-draw-contents on backtrace-info-pane to draw placard.
2004-Feb-10 Terje Improved appearance for the Bar Dragger under OSX (rubber instead of arrow).
2004-Feb-10 Terje Improved appearance for the pane splitter under OSX.
2004-Feb-03 Terje Adjusted the Bar Dragger for OSX so it is aligned with other arrows:
                   Added patch to draw-vertical-dragger.
2004-Feb-02 terje Modern 3D buttons to illustrate special keys in the Fred Commands window (and the Listener Commands window):
                   The key-cap class has 3d-button as superclass.
                   view-draw-contents on key-cap calls next method instead of drawing anything.
                   pushed-state and dialog-item-text methods on key-cap.
2004-feb-02 Terje The Inspector and BackTrace dialogs have more of a theme appearance:
                   Added a view-draw-contents :around for command-pane-mixin that sets the theme background to a window header look.
                   The inspector editor uses a theme background.
2004-feb-01 Terje The single line minibuffer separates itself better from the editor text:
                   view-draw-contents on new-mini-buffer draws theme placard and calls next method (to write text) afterwards.
                   view-draw-contents on scrolling-fred-view no longer draws a frame around the view under osx.
2004-Jan-29 Terje Radio Buttons and Check Boxes are properly deactivated:
                   Added view-activate-event-handler and view-deactivate-event-handler for control-dialog-item.
2004-Jan-29 Terje Eliminates white ring around disabled editable-text-dialog-item:
                   Takes call to DrawThemeFocusRect out of with-fore-color body in view-draw-contents :after of basic-editable-text-dialog-item.
                   Separate out the appearance savvy code in view-draw-contents :after of basic-editable-text-dialog-item to make non-carbon disposable.
2004-Jan-29 Terje Makes Multi-pane-view and Tab-Bar-View of the Appearance Manager from MCLs Examples use Carbon if loaded. 
2004-Jan-28 Terje Simplified and improved drawing of scrolling-fred-view: 
                   Combined :around and :after methods of view-(de)activate-event-handler on scrolling-fred-view into main method.
                   Integrated :before method of view-deactivate-event-handler for scrolling-fred-view into main method to get better compatability with the color-coded.lisp contribution to MCL (suggested by Octav Popescu).
                   Converted :before method of view-activate-event-handler for scrolling-fred-view into a main method.
                   Set an inactive scrolling-fred-view's theme text color to kThemeTextColorDialogInactive (except for Fred Window).
                   view-deactivate-event-handler for scrolling-fred-view calls invalidate-view in OSX instead of invalidate-view-border.
                   view-corners for scrolling-fred-view insets three pixels in OSX to cover focus ring.
2004-Jan-22 Terje Underlined View deactivates properly
                    Removed osx-p test in view-(de)activate-event-handler unless MCL 5.
                    view-draw-contents on underlined-view sets theme text color.
2004-Jan-22 Terje Better Fred display when the window is inactive:
                    new-mini-buffer uses a theme brush for its delimiter line.
                    Added view-draw-contents for scrolling-fred-view with theme brush.
2004-Jan-21 Terje Eliminated appearance-fore-color function.
2004-Jan-21 Terje Use modern pop-up also forOS9:
                    Sets *use-pop-up-control* to true.
2004-Jan-20 terje Theme Cursors under Carbon
                    Redefinition of set-cursor function to process theme cursor keywords.
                    Bar dragger uses theme cursor for horizontal resize.
                    Theme cursor under Carbon for most controls and dialog-items.
2004-Jan-19 Terje Theme Fonts under Carbon
                    Redefinition of font-codes function to process theme font keywords.
                    The font-codes function allows later font spec items to override existing values.
                    %get-theme-font-values function to look up font values from a font ID.
                    *theme-font-alist* maps from theme font keywords to constants.
2004-Jan-19 Terje 3D Button has a theme appearance (benefitting the Inspector):
                    Added simplified text-position method for 3D button.
                    View-draw-text for 3D button both for carbon and before.
                    Added numerous methods to implement the use of theme brushes.
2004-Jan-19 Terje The Fred editor pane splitter has a new look under OSX:
                    Added view-draw-contents method for pane-splitter with theme savvy button background
                    and drag stripes instead of black rectangle.
2004-Jan-19 Terje Pop-up menu (de)activated in OSX:
                    New view-deactivate-event-handler :before method on pop-up-menu for carbon.
                    New view-activate-event-handler :before method on pop-up-menu for carbon.
2004-Jan-19 Terje Left-border-view erased on (de)activation in OSX.
2004-Jan-19 Terje Table Dialog Items more theme savvy:
                    Added new view-draw-contents on table-dialog-item for MCL 5. 
                    New %draw-table-cell-new grays out table text under OS9 for inactive windows.
                    Increased inset in view-corners on table-dialog-item under OSX.
                    invert-cell-selection invalidates selected area instead of hiliting it under Carbon.
                    Added view-click-event-handler for table-dialog-item.
                    New carbon initialize-instance :around for table-dialog-item provides better initarg defaults.
                    Added separator-size for table-dialog-item using size of ThemeBrushListViewSeparator as default.
                    Attempted to fix an OSX problem with the theme focus rect remaining when scrolling.
2004-Jan-19 Terje Make theme backgrounds work also under MacOS 9 by patching window-make-parts on window.
2004-Jan-16 Terje Underlined View has theme savvy text and proper appearance under Carbon/Aqua:
                    New Carbon version of view-draw-contents of underlined-view.
                    view-activate-event-handler :before of underlined-view simplified for MCL5.
                    view-deactivate-event-handler :before of underlined-view simplified for MCL5. 
2004-Jan-16 Terje Ellipsized Text Dialog Item has proper OSX appearance rather than partly platinum look:
                    Patched draw-theme-text-box so it doesn't fail when truncating the text.
                    Fixes flaw in MCL 5 where e.g. the text in the Search Files dialog displaying the file currently 
                    searched has a gray background (problem also applies to other uses of ellipsized-text-dialog-item).
2004-Jan-16 Terje Fixes the title-box-dialog-item to make it compliant with OSX/Aqua:
                    view-activate-event-handler :before of title-box-dialog-item simplified for MCL5.
                    view-deactivate-event-handler :before of title-box-dialog-item simplified for MCL5.
                    view-draw-contents uses DrawThemeTextBox instead of drawstring to get theme savvy anti-aliased text.
                    view-draw-contents eliminates the erase so that existing background remains.
                    view-draw-contents allows the title to be outside the box.
                    New label-offset for Carbon calls GetThemeTextDimensions.
                    label-offset moves title above the box for OSX as specified by Aqua (suggested by Octav Popescu).
                    New view-default-font for title-box-dialog-item.
                    update-title-box-width allows box wihtout title.
                    update-title-box-width calls GetThemeTextDimensions under Carbon. 
2004-Jan-16 Terje Changing the text of a static-text-dialog-item erases previous text as it should also in OSX:
                    set-dialog-item-text of static-text-dialog-item erases when invalidating view.
                    view-activate-event-handler :before of static-text-dialog-item simplified for MCL5.
                    view-deactivate-event-handler :before of static-text-dialog-item simplified for MCL5.
                    view-draw-contents :around of static-text-dialog-item only patched before MCL 5.                  
2003-Feb-03 Terje Fixed missing inside 'shadow' on basic-editable-text-dialog-item.
2003-Feb-03 Terje Version 1.3 released.
2003-jan-31 Terje Patched view-draw-contents on static-text-dialog-item is bypassed when OSX.
                  Modified view-draw-contents on scrolling-fred-view to loose the stripes in OSX.
                  Table text not grayed out in OSX.
                  Updated view-draw-contents on underlined-view with code from MCL kernel.
                  Updated view-draw-contents on title-box-dialog-item to not gray out on OSX.
                  New draw-horizontal-dragger function used for the bar dragger.
                  View-corners on table-dialog-item covers osx inset.
                  Scroll-bar-dialog-item displays deactivated scrollers under appearance.
2002-Oct-27 Terje View-draw-contents on static-text-dialog-item uses gray rather than pattern when disabled.
2002-Aug-07 Terje Added osx-p function definition.
2002-Aug-07 Terje Added test for installed-item-p in view-corners on view.
2002-jun-28 terje Eliminated use of obsolete #$kThemeStateDisabled.
2002-jun-11 Terje Version 1.2 released.
2002-mar-17 Terje Bar dragger and poof-button has placard appearance.
                  Eliminated focus rectangle when a scrolling view is part of fred editor.
2002-mar-16 Terje Table-dialog-item displays focus rectangle when key-handler.
                  Eliminated focus for arrow dialog items as it is inherited from table-dialog-item.
                  New appearance-theme-state function provides theme state code.
                  Corrects inactive drawing by using new appearance-theme-state function.
                  Scroll bar dialog item has better appearance when inactive.
2002-jan-04 Terje No longer defines appearance-manager-p etc for mcl 4.3.1 and beyond
2002-jan-04 Terje Adds tests for osx-p to avoid platinum appearance in osx.
2002-jan-04 Terje Carbon compatability copied from mcl source to view-draw-contents for table-dialog-item.
2001-may-26 Terje view-click-event-handler on fred-mixin tests for key-handler-p. 
1999-oct-21 Terje Version 1.1 released.
1999-oct-15 Terje Renamed from appearance-editable-text
1999-oct-15 Terje No longer requires appearance manager contribution.
1999-sep-19 Terje Different drawing depending on whether window is active.
1999-08-09 Terje  Eliminated unecessarry back colors when appearance (that caused white frame).
1999-08-09 Terje  view-draw-contents uses with-focused-dialog-item macro.
1999-08-09 Terje  view-draw-contents uses with-item-rect macro.
1999-07-10 Terje  No focus unless the dialog item is enabled. 
1999-07-09 Terje  Correct background color when no appearance.
1999-07-06 Terje  Version 1.0 released.

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#| TO DO

- Editable-text-dialog-item for MCL 5.2 doesn't draw as inactive. Should be fixed in MCL, not here.
- 3d Buttons drawn as bevel buttons? (see ignored code).
- Consider making use of the theme cursors (and perhaps even the animated cursors).
- Inspector dialogs should properly visualize a selected field when inactive (not as a blue frame).
- Use #_getThemeMetric where appropriate:

(defun theme-metric-value (metric)
  (rlet ((&result :signed-long))
    (#_getThemeMetric metric &result)
    (pref &result :signed-long)))

e.g. (theme-metric-value #$kThemeMetricPaneSplitterHeight)

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :ccl)

; (add-feature :alice) 

#-carbon-compat
(error "Incompatible with pre-carbon MCL - use the Appearance-MCL contributed patches instead!")

#-ccl-5.0
(when (boundp '*appearance-compatibility-mode-p*)
  (setq *appearance-compatibility-mode-p* nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; NEW COLORS:

(defparameter *lightest-gray-color* (+ (* 239 256 256) (* 239 256) 239))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Patch for MCL uses view-corners instead of view-size.
;; This allows certain view-draw functions to draw outside its regular area.

#| DISCUSSION:

Many modern MacOS widgets after MacOS 7 draws outside of their boundaries. As a result, unwanted clipping may occur. 

For example, many of the controls of MacOS8/9 has a focus ring drawn outside the bounding box. If an editable-text-dialog-item is placed in the top left corner of a view, parts of the focus ring will be clipped. As a consequence, composite dialog items such as the TYPEIN-MENU won't be properly drawn with Appearance.

The problem is also manifest without Appearance. The default-button-dialog-item already draws outside its bounding box. If a default-button-dialog-item is placed in the top left corner of a view, the ring around it will be clipped:

(make-instance 'window
  :view-subviews
    (list
      (make-instance 'view
        :view-position #@(30 30)
        :view-size #@(62 20)
        :view-subviews
         (list
           (make-instance 'default-button-dialog-item :view-position #@(0 0))))))

MCL allows a view to have a specialized view-corners method that adjust the view region to draw outside the boundaries of view-position and view-size. However, it doesn't adapt when a subview unexpectedly draws further outside its area. This may lead to a maintainance nightmare when dialog items are upgraded to draw further outside their boundaries than at the time of original implementation.

There are at least three ways to resolve the problem with MCL clipping MacOS8 controls:

1. REQUIRE THE DEVELOPERS TO UPDATE THE VIEW-CORNER METHOD OF ALL AFFECTED VIEWS. The affected views are any that uses dialog items that draw further outside their bounding box than in earlier versions of the MacOS, and that place these dialog items close to the sides of the view. The TYPEIN-MENU is one example of an affected view in MCL.

The disadvantages of this solution is that it will require a lot of modifications for various developers, and potentially cause third party modules to be outdated. It also won't solve the problem for the future, requiring similar modifications each time Apple changes the drawing of controls.

2. ADD A VIEW-CORNERS METHOD ON VIEW THAT TAKES INTO ACCOUNT EVENTUAL SUBVIEWS THAT HAS ITS VIEW CORNERS OUTSIDE THE BOX OF THE VIEW. That is, view corners call view corners on all subviews, and return corners that covers the view region of all subviews.

The benefit of this solution is that it resolves the problem without requiring further work by Digitool or third party developers. The solution will also cover future changes to the drawing of controls. On the other hand, large dialogs with many layers may have a noticable performance decrease in drawing and other activities that requires calculation of view corners.

3. PROVIDE A NEW CLASS FOR BUILDING VIEWS THAT ACT AS DIALOG ITEMS. This class could for example be called COMPOSITE-DIALOG-ITEM, and should have the same interface as a dialog items with the addition that it can have subviews. A composite dialog item should compute its view corners based on the view corners of its subviews, as described in solution 2. TYPEIN-MENU is an example of a composite dialog item that should be of this class.

An advantage of this approach is that it provides a long-term solution to the problem of dialog items drawing outside the boundaries of its container. It allows regular views to still be used for layout purposes, without the overhead of recomputing view corners to cover subviews. However, the work still has to be done to change affected views to be subviews of composite-dialog-item instead of view.

The code below implements solution [2] in the list above. I suggest that solution [3] is selected for the long term, incorporating the code from solution [2] in a composite-dialog-item used for all views that have subviews close to its sides.
|#

(in-package :ccl)

;; Adjusts if subviews goes outside the corners of the view:

#-ccl-5.2 ;; No longer an issue in MCL 5.2???
(defmethod view-corners ((view view))
  (multiple-value-bind (topleft bottomright)
    (call-next-method)
    (let ((top-adjust 0)
          (left-adjust 0)
          (width (- (point-h bottomright) (point-h topleft)))
          (height (- (point-v bottomright) (point-v topleft)))) 
      (do-subviews (subview view)
       (when (installed-item-p subview)
        (multiple-value-bind (sub-topleft sub-bottomright)
          (view-corners subview)
          (when (< (point-h sub-topleft) left-adjust)
            (setf left-adjust (point-h sub-topleft)))
          (when (< (point-v sub-topleft) top-adjust)
            (setf top-adjust (point-v sub-topleft)))
          (when (> (point-h sub-bottomright) width)
            (setf width (point-h sub-bottomright)))
          (when (> (point-v sub-bottomright) height)
            (setf height (point-v sub-bottomright))))))
      (values (make-point (+ (point-h topleft) left-adjust)
                          (+ (point-v topleft) top-adjust))
              (make-point (+ width (point-h topleft))
                          (+ height (point-v topleft)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Fixes what appears to be a flaw in compute-view-region so that it takes into account the view-corners instead of using view-position and view-size:

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1 ;; integrated in MCL 5.1
(defmethod compute-view-region ((view view) rgn container)
  (when rgn
    (if container
     (multiple-value-bind (topleft bottomright)
      (view-corners view)
      (let* ((origin (view-origin-slot view))
             (container-origin (view-origin container))
             (tl (add-points topleft
                             (subtract-points origin container-origin)))
             (br (add-points tl (- bottomright topleft)))
             (offset (subtract-points container-origin origin))
             (offset-h (point-h offset))
             (offset-v (point-v offset))
             (container-region (view-clip-region container)))
        (#_SetRectRgn rgn (point-h tl) (point-v tl) (point-h br) (point-v br))
        (#_OffsetRgn rgn offset-h offset-v)
        (#_SectRgn rgn container-region rgn)
        (#_OffsetRgn rgn (- offset-h) (- offset-v))))
      (#_SetRectRgn rgn -32767 -32767 32767 32767)))
   rgn)

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; New: exit-key-handler notifies all its containers about the change, so that
;;; they can update accordingly. This makes sense when a view should display
;;; a focus rect but has one of its subviews as key handler (like scrolling-fred-view).

;;; Are these still needed in MCL 5.2???

(defmethod enter-key-handler (view old-item)
  (let ((container (view-container view)))
    (when container
      (enter-key-handler container old-item))))

(defmethod exit-key-handler (view new-item)
  (let ((container (view-container view)))
    (if container
      (exit-key-handler container new-item)
      (progn
        ;; Set current key handler to NIL, so that :after methods can redraw without object 
        ;; still being the key handler. 
        ;; ## eliminates the MCL exit-key-handler for arrow-dialog-item that does the same!
        (setf (%get-current-key-handler (view-window view)) NIL)
        T))))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defmethod enter-key-handler ((item key-handler-mixin) last-key-handler)
  (declare (ignore last-key-handler))
  #+ignore NIL
  (call-next-method))

(defmethod exit-key-handler ((item key-handler-mixin) next-key-handler)
  (declare (ignore next-key-handler))
  #+ignore T
  (call-next-method))

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-current-key-handler calls view-deactivate-event-handler and view-activate-event-handler.
;; These are documented to be called by the event system when the window containing the
;; view is (de)activated and a different window is made active. They should thus not
;; be called when setting the key handler. 
;;
;; Calling these in set-current-key-handler results in that views with a different
;; deactivated appearance are redrawn multiple times when changing the key handler.

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

;; ## Note: Has been changed in MCL 5.1, but unknown whether this resolves the issue!

#-ccl-5.1
(defmethod set-current-key-handler ((dialog window) item &optional (select-all t)
                                      &aux old)
  (unless (or (null item)
              (and (memq item (%get-key-handler-list dialog))
                   (key-handler-p item)))
    (error "~s is either disabled or is not a key-handler item of ~s" item dialog))
  (if (and (neq item (setq old (%get-current-key-handler dialog)))
           (if old 
             (when (exit-key-handler old item)
               (multiple-value-bind (s e) (selection-range old)
                 (declare (ignore s))
                 ; do this first else display may be wrong.
                 (set-selection-range old e e))
               ; (view-deactivate-event-handler old)
               t)
             t))
    (without-interrupts
     (setf (%get-current-key-handler dialog) item)
     (when item
       (when select-all
         (set-selection-range item 0 most-positive-fixnum))
       ;(if (window-active-p dialog)
       ;  (view-activate-event-handler item))
       (enter-key-handler item old)))
    (when (and item (eq item old) select-all)
      (set-selection-range item 0 most-positive-fixnum)))
  item)

) ; end redefine


;; The FRED-MIXIN appears to be the only that is affected by the correction to set-current-key-handler. 
;; Its activate event handlers are responsible for updating the caret. This should rather be taken 
;; care of by specializations of exit- and enter-key-handler:

;; Same as view-deactivate-event-handler for fred-mixin, to eliminate caret
;; Perhaps view-activate-event-handler should be eliminated???

#-ccl.5.1 ; might be needed for MCL 5.1, but removed until that is verified
(defmethod exit-key-handler :after ((w fred-mixin) next)
  (declare (ignore next))
  (without-interrupts
   (let ((frec (frec w)))
     (with-focused-view w
       (with-text-colors w
         (frec-deactivate frec)
         (frec-update frec t))))))

;; Same as view-deactivate-event-handler for fred-mixin, to get caret
;; Perhaps view-deactivate-event-handler should be eliminated???

#-ccl.5.1 ; might be needed for MCL 5.1, but removed until that is verified
(defmethod enter-key-handler :after ((w fred-mixin) previous)
  (declare (ignore previous))
  (without-interrupts
   (let ((frec (frec w)))
     (with-focused-view w
       (with-text-colors w
         (frec-activate frec)
         ; draw the thing now before frec idle happens giving us half caret
         (frec-update frec))))))
         ;(frec-update frec t))))))         ; redraw selection box

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ACTIVATE AND DEACTIVATE CONTROLS
;;
;; Affects the radio-button-dialog-item and the check-box-dialog-item.

(unless (module-loaded-p :appearance-activity-mixin) ; appearance-activity-mixin.lisp in the MCL Examples folder

#-ccl-5.1
(defmethod view-activate-event-handler ((view control-dialog-item))
  (call-next-method)
  (when (dialog-item-enabled-p view)
    (#_ActivateControl (dialog-item-handle view))))

#-ccl-5.1
(defmethod view-deactivate-event-handler ((view control-dialog-item))
  (when (dialog-item-enabled-p view)
    (#_DeactivateControl (dialog-item-handle view)))
  (call-next-method))

) ; end

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DRAW-ACTIVE-P
;; (Idea from Appearance-Activity-Mixin by Eric Russell)

(unless (fboundp 'draw-active-p) ; in case appearance-activity-mixin is loaded or these are defined elsewhere...
 
(defmethod draw-active-p ((view simple-view) &aux (window (view-window view)))
  (and window (window-active-p window)))

(defmethod draw-active-p ((view dialog-item) &aux (window (view-window view)))
  (and window (window-active-p window) (dialog-item-enabled-p view)))

) ; end

#+ccl-5.2 ;; 
(defun appearance-compatibility-mode-p ()
  NIL
  #+ignore
  (or (not *appearance-available-p*)
      *appearance-compatibility-mode-p*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; APPEARANCE THEME STATE

(defun appearance-theme-state (view)
  (cond
   ;((and (typep view 'dialog-item)
   ;      (not (dialog-item-enabled-p view)))
   ; #$kThemeStateInactive)
   ((draw-active-p view)
    #$kThemeStateActive)
   (T
    #$kThemeStateInactive)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make theme backgrounds work also under MacOS 9.
;; Digitool covers this in the theme-patch.lisp for MCL 5, and will likely include it in later versions of MCL.

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))
#-ccl-5.1 ; fixed in MCL 5.1
(unless (module-loaded-p :theme-patch)
(defmethod window-make-parts ((window window)
                              &key (view-position (view-default-position window) pos-p)
                              (view-size (view-default-size window) size-p)
                              (window-type :document-with-zoom wtype-p)
                              back-color
                              content-color
                              theme-background
                              procid
                              (window-title  "Untitled")
                              (close-box-p t)
                              (color-p t)
                              (grow-icon-p nil gip?))
  (unless (wptr window)
    (if procid (setq gip? nil grow-icon-p nil))
    (when gip?
      (if grow-icon-p
        (cond ((eq window-type :document) (setq window-type :document-with-grow))
              ((eq window-type :windoid) (setq window-type :windoid-with-grow))
              ((eq window-type :windoid-side)(setq window-type :windoid-side-with-grow))
              ((eq window-type :windoid-with-zoom)(setq window-type :windoid-with-zoom-grow))
              ((eq window-type :windoid-side-with-zoom)(setq window-type :windoid-side-with-zoom-grow))
              ((not (memq  window-type '(:document-with-grow :document-with-zoom
                                         :windoid-with-grow :windoid-with-zoom-grow :windoid-side-with-grow
                                         :windoid-side-with-zoom-grow)))
               (setq gip? nil grow-icon-p nil)))
        (cond ((eq window-type :document-with-grow) (setq window-type :document))
              ((eq window-type :document-with-zoom) (setq window-type :document-with-zoom-no-grow))
              ((eq window-type :windoid-with-grow) (setq window-type :windoid))
              ((eq window-type :windoid-side-with-grow)(setq window-type :windoid-side))
              ((eq window-type :windoid-side-with-zoom-grow)(setq window-type :windoid-side-with-zoom))
              ;; this is wrong?
              ((not (memq window-type '(:document :document-with-zoom)))
               (setq gip? nil grow-icon-p nil)))))
    (when wtype-p
      (when (and (not (typep window 'windoid)) (memq window-type *windoid-types*))
        ;(error "Need to make a windoid for window-type ~s." window-type)
        (change-class window 'windoid)        
        (when (not pos-p)(setq view-position (view-default-position window)))
        (when (not size-p)(setq view-size (view-default-size window)))
        )
      (when nil ;(and (typep window 'windoid)(not (memq window-type *windoid-types*)))
        (report-bad-arg window-type (cons 'member *windoid-types*))))
    (let* ((wptr (%new-window (or procid window-type)
                              view-position
                              view-size
                              close-box-p
                              nil
                              color-p))
           (procid (#_getwrefcon wptr)))   ; %new-window leaves it there
      (setf (wptr window) wptr)      
      #+ignore ;; - too slow
      (when (and nil (not pos-p) (eql view-position *window-default-position*))
        (set-view-position window #@(-3000 -3000))
        (window-show window)
        (let ((left-border (window-border-width window))
              (title-height (window-title-height window)))
          (window-hide window)
          (set-view-position window (make-point (max (1+ left-border)(point-h view-position))
                                                (max (+ title-height 2 (menubar-height)) (point-v view-position))))))
      (set-window-title window window-title)
      (setf (slot-value window 'grow-icon-p)
            (if gip? grow-icon-p (memq procid  *grow-procids*)))
      (when content-color  ;; is this used for anything?
        (set-part-color window :content content-color)
        ;(set-part-color window :title-bar *white-color*) doesnt help
        )
      (when back-color
        (setf (slot-value window 'back-color) back-color)  ; <<
        (set-back-color window back-color))
      (when (and theme-background #+ignore(osx-p))
        (view-put window 'theme-background 
                  (if (eq theme-background t)
                    (setq theme-background #$kThemeBrushModelessDialogBackgroundActive)
                    theme-background))
        (#_SetThemeWindowBackground wptr theme-background t))      
        
      (if (typep window 'windoid)
        (#_setwindowclass wptr #$kFloatingWindowClass )
        (when (and (wptr-dialog-p wptr)) ;(find-class 'drag-receiver-dialog nil)(typep window 'drag-receiver-dialog))
          ; make it non-modal till actually used modally - for IFT or for everybody
          (#_setwindowclass wptr #$kDocumentWindowClass )  ;; do we really need both of these?
          (setwindowmodality wptr #$kWindowModalityNone)
          )))))

)) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; THEME FONTS
;; Supports theme font keywords as part of MCL font descriptions.
;; http://developer.apple.com/documentation/Carbon/Reference/Appearance_Manager/Reference/reference.html#//apple_ref/doc/c_ref/kThemeSystemFont

(defparameter *theme-font-alist* ; 
  `(; -- Appearance 1.1 and later:
    (:system-font . #.#$kThemeSystemFont)
    (:small-system-font . #.#$kThemeSmallSystemFont)
   (:small-emphasized-system-font . #.#$kThemeSmallEmphasizedSystemFont)
   (:views-font . #.#$kThemeViewsFont)
   (:emphasized-system-font . #.#$kThemeEmphasizedSystemFont)
   ; -- OSX and CarbonLib 1.3:
   (:application-font . #.#$kThemeApplicationFont)
   (:label-font . #.#$kThemeLabelFont)
   (:menu-title-font . #.#$kThemeMenuTitleFont)
   (:menu-item-font . #.#$kThemeMenuItemFont)
   (:menu-item-mark-font . #.#$kThemeMenuItemMarkFont)
   (:menu-item-cmd-key-font . #.#$kThemeMenuItemCmdKeyFont)
   (:window-title-font . #.#$kThemeWindowTitleFont)
   (:push-button-font . #.#$kThemePushButtonFont)
   (:utility-window-title-font . #.#$kThemeUtilityWindowTitleFont)
   (:alert-header-font . #.#$kThemeAlertHeaderFont)
   #+ccl-5.2
   (:system-font-detail . #.#$kThemeSystemFontDetail)
   #+ccl-5.2
   (:system-font-detail-emphasized . #.#$kThemeSystemFontDetailEmphasized)
   (:current-port-font . #.#$kThemeCurrentPortFont)
   ; -- OSX 1.2 and later
   #+ccl-5.2
   (:toolbar-font . #.#$kThemeToolbarFont)
))

(defun %get-theme-font-values (font-id &optional script)
  "Looks up the font from the id and returns its code, size and style as values"
  (rlet ((name (:string 255))
         (size :word)
         (style :style))
    (errchk (#_getThemeFont 
             (or font-id #$kThemeSystemFont) 
             (or script #$smSystemScript)
             name size style))
    (values
     (#_FMGetFontFamilyFromName name) ; (font-number-from-name (%get-string name))
     (%get-word size)
     (#.(mactype-get-function (find-mactype :style)) style))))

;; ## Note that ater settings in a font spec will override earlier ones, so you can customize a theme font as in (:system-font 14)
;; ## I'd like support for :larger and :smaller keywords in the font-spec, respectively to increase/decrease the fontsize!

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defun font-codes (font-spec &optional old-ff old-ms
                             &aux 
                             (items font-spec) temp item font face mode size color
                             reset-style-p 
                             (font-mask 0) (face-mask 0) (color-mask 0)
                             (mode-mask 0) (size-mask 0))
  (if (null old-ff) (setq old-ff 0))
  (if (null old-ms) (setq old-ms (make-point 0 (xfer-mode-arg :srcor)))) ;;maybe should be #$transparent?? prob not
  (if (null font-spec)
    (return-from font-codes (values old-ff old-ms 0 0)))
  (setq item (if (consp items) (pop items) items))
  (tagbody
    LOOP
    (cond
     ((fixnump item)
      ;(if size 
      ;  (error "Font Spec: ~s contains two sizes" font-spec)
        (setq size item
              size-mask -1));)
     ((stringp item)
      ;(if font (error "Font Spec: ~s contains two strings" font-spec))
      (setq font-mask -1)
      (if (equalp item (car (sys-font-spec)))
        (setq font (ash (car *sys-font-codes*) -16))  ; in OS 8 its the real font-num - earlier it's 0 
        (let ((num (font-number-from-name item)))
          ;; so what do you do if it doesnt exist?
          (setq font
                (or num
                    (ash (car *sys-font-codes*) -16))))))
     ((consp item)
      (ecase (car item)
        (:color-index
         ;(when color
         ;  (error "Font Spec: ~s contains two color specs" font-spec))
         (setq color (second item))
         (unless (and (fixnump color)
                      (<= 0 color 255))
           (error "~s is not a valid font color" color))
         (setq color-mask 255))
        (:color
         ;(when color
         ;  (error "Font Spec: ~s contains two color specs" font-spec))
         (setq color (fred-palette-closest-entry (second item))
               color-mask 255))))
     ((setq temp (xfer-mode-arg item))
      ;(if mode 
      ;  (error "Font Spec: ~s contains two text-modes" font-spec)
        (setq mode temp
              mode-mask -1));)
     ((setq temp (assq item *style-alist*))
      (when (eq (%car temp) :plain)
        (setq reset-style-p t
              face-mask -1))
      (setq temp (%cdr temp))
      (setq face (if face (%ilogior2 face temp) temp)
            face-mask (%ilogior2 face-mask temp)))
     ((setq temp (assq item *theme-font-alist*))
      (multiple-value-setq (font size face) (%get-theme-font-values (%cdr temp))))
     (t (error "Unrecognized option ~a in font-spec: ~a" item font-spec)))
    (if (consp items) (progn (setq item (pop items)) (go LOOP))))
  (unless font (setq font (point-v old-ff)))
  (unless face (setq face (%ilsr 8 (point-h old-ff))))
  (unless color (setq color (%ilogand 255 (point-h old-ff))))
  (unless reset-style-p
    (setq face (%ilogior2 face (%ilsr 8 (point-h old-ff)))))
  (unless mode (setq mode (point-v old-ms)))
  (unless size (setq size (point-h old-ms)))
  (values (make-point (+ color (%ilsl 8 face)) font)
          (make-point size mode)
          (make-point (logior color-mask (%ilsl 8 face-mask)) font-mask)
          (make-point size-mask mode-mask)))

) ; end redefine

#|
(make-instance 'window
  :theme-background T
  :view-subviews 
  (list 
   (make-dialog-item 'static-text-dialog-item #@(10 10) nil "Theme Font" nil
                     :part-color-list `(:text ,*red-color*)
                     :view-font '(:system-font :bold))
   (make-dialog-item 'static-text-dialog-item #@(10 30) nil "Theme Font" nil 
                     :view-font '(:application-font 18))
   (make-dialog-item 'static-text-dialog-item #@(10 60) nil "Theme Font" nil 
                     :view-font `(:views-font (:color ,*blue-color*)))
   (make-dialog-item 'static-text-dialog-item #@(10 90) nil "Theme Font" nil 
                     :view-font :small-emphasized-system-font)))

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; THEME CURSORS

#-ccl-5.2 ; defined in MCL 5.2
(defparameter *theme-cursor-alist*
  `((:arrow-cursor . ,#$kThemeArrowCursor)
    (:contextual-menu-arrow-cursor . ,#$kThemeContextualMenuArrowCursor)
    (:alias-arrow-cursor . ,#$kThemeAliasArrowCursor)
    (:copy-arrow-cursor . ,#$kThemeCopyArrowCursor)
    (:I-beam-cursor . ,#$kThemeIBeamCursor)
    (:cross-cursor . ,#$kThemeCrossCursor)
    (:plus-cursor . ,#$kThemePlusCursor) ; discouraged for OSX
    (:watch-cursor . ,#$kThemeWatchCursor)
    (:closed-hand-cursor . ,#$kThemeClosedHandCursor)
    (:open-hand-cursor . ,#$kThemeOpenHandCursor)
    (:pointing-hand-cursor . ,#$kThemePointingHandCursor)
    (:counting-up-hand-cursor . ,#$kThemeCountingUpHandCursor) ; discouraged for OSX
    (:counting-down-hand-cursor . ,#$kThemeCountingDownHandCursor) ; discouraged for OSX
    (:counting-up-and-down-hand-cursor . ,#$kThemeCountingUpAndDownHandCursor) ; discouraged for OSX
    (:spinning-cursor . ,#$kThemeSpinningCursor) ; discouraged for OSX
    (:resize-left-cursor . ,#$kThemeResizeLeftCursor)
    (:resize-right-cursor . ,#$kThemeResizeRightCursor)
    (:resize-left-right-cursor . ,#$kThemeResizeLeftRightCursor)
    (:not-allowed-cursor . #+ccl-5.2 ,#$kThemeNotAllowedCursor #-ccl-5.2 18)
    #+ccl-5.2 
    (:resize-up-cursor . ,#$kThemeResizeUpCursor)
    #+ccl-5.2
    (:resize-down-cursor . ,#$kThemeResizeDownCursor)
    #+ccl-5.2
    (:resize-up-down-cursor . ,#$kThemeResizeUpDownCursor)
    #+ccl-5.2
    (:poof-cursor . ,#$kThemePoofCursor)
    ))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

; Before MCL 5.2, we couldn't just modify constants like *arrow-cursor* as they might be used directly with #_SetCursor!
; Digitool has thankfully replaced all calls to (#_SetCursor *arrow-cursor*) with a call to set-cursor in MCL 5.2.
; This made most of the patched methods below unecessarry! Thanks, Alice!!!
; Note that MCL 5.2 continues to not use keyword representations for *i-beam-cursor* and *arrow-cursor*, supposedly for speed reasons.

#-ccl-5.2
(defmethod view-cursor ((item arrow-dialog-item) where)
  (declare (ignore where))
  :arrow-cursor)

#-ccl-5.2
(defmethod view-cursor ((item control-dialog-item) where)
  (declare (ignore where))
  :arrow-cursor)

#-ccl-5.2
(defmethod view-cursor ((item key-handler-mixin) point)
  (declare (ignore point))
  (let ((w (view-window item)))
    (if (and w (eq item (current-key-handler w))) 
      :i-beam-cursor
      :arrow-cursor)))

#-ccl-5.2
(defmethod view-cursor ((v simple-view) point)
  (let ((container (view-container v)))
    (if container
      (view-cursor container (convert-coordinates point v container))
      :arrow-cursor)))

(defmethod view-cursor ((w fred-mixin) point)
  (let* ((c (call-next-method))
         (frec (frec w)))
    (if (and (or (eq c *i-beam-cursor*)
                 (eq c :i-beam-cursor))
             (frec-up-to-date-p frec))
      (with-font-codes nil nil
        (frec-cursor (frec w) point))
      c)))

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BETTER CURSORS - Suggested on Info-MCL September 30, 2005.

; 1) Turns set-cursor into a method, allowing developers to use alternative representations:

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(fmakunbound 'set-cursor) 

(defgeneric set-cursor (cursor)
  (:documentation "Make the argument the current cursor"))

#-ccl-5.2
(defmethod set-cursor (cursor)
  "Compatability with legacy representation of a cursor"
  (let ((temp *current-cursor*))
    (without-interrupts
     (if (fixnump cursor)
       (with-macptrs ((temp2 (#_GetCursor cursor)))
         (unless (%null-ptr-p temp2)
           (#_SetCursor (%setf-macptr temp (%get-ptr temp2)))))
       (when (and cursor (if (osx-p) (macptrp cursor)(pointerp cursor)) (not (%null-ptr-p cursor)))
         (#_SetCursor (if (not (eql cursor *arrow-cursor*))      ; special case - today cursors are handles or fixnums
                        (progn (#_LoadResource cursor)
                               (%setf-macptr temp (%get-ptr cursor)))
                        (%setf-macptr temp cursor))))))))

#+ccl-5.2 ;; mostly same as the set-cursor function in MCL 5.2
(defmethod set-cursor (cursor)
  (let ((temp *current-cursor*))
    (without-interrupts
     (typecase cursor
       (fixnum
        (with-macptrs ((temp2 (#_GetCursor cursor)))
          (unless (%null-ptr-p temp2)
            (#_SetCursor (%setf-macptr temp (%get-ptr temp2))))))
       (macptr
        (when (not (%null-ptr-p cursor))
          (#_SetCursor (if (handlep cursor) ; ;; most are pointers today - except *i-beam-cursor*
                         (progn ;(#_LoadResource cursor)  ;; our cursors aren't resources today
                                (%setf-macptr temp (%get-ptr cursor)))
                         (%setf-macptr temp cursor)))))
       #+ignore
       (keyword
        (let ((value (cdr (assq cursor *theme-cursor-alist*))))
          (when value 
            (#_SetThemeCursor value))))))))

) ; end redefine

; 2) Keyword representation of cursor:

(defmethod set-cursor ((cursor keyword))
  (let ((value (cdr (assq cursor *theme-cursor-alist*))))
    (when value
      (without-interrupts
       (#_SetThemeCursor value)))))

; 3) Abstract class for cursor with subclasses for different variations:

(defclass cursor ()())

(defclass theme-cursor (cursor)
  ((cursor-type :reader theme-cursor-type :type integer :initarg :type)))

(defmethod set-cursor ((cursor theme-cursor))
  (#_SetThemeCursor (theme-cursor-type cursor)))

; 4) Avoid redundant setting of the cursor (better accomplished by patching window-update-cursor):

(defparameter *the-current-cursor* NIL)

(defmethod set-cursor :around (cursor) ; # needs to be atomic...
  (unless (eq cursor *the-current-cursor*)  
    (setq *the-current-cursor* cursor) 
    (call-next-method)))

; 5) Animated theme cursors:

(defclass animated-theme-cursor (theme-cursor)
  ((period :reader animated-theme-cursor-period 
           :initarg :period 
           :initform 20
           :documentation "The ticks between changes to the cursor")))

(defmethod set-cursor ((cursor animated-theme-cursor))
  (let ((err (#_SetAnimatedThemeCursor (theme-cursor-type cursor) 0)))
    (if (= err #$themeBadCursorIndexErr) ; cursor cannot be animated
      (call-next-method)
      (flet ((animate-cursor (cursor)
               (let ((period-s (/ (animated-theme-cursor-period cursor) 60)))
                 (loop while (eq cursor *the-current-cursor*)
                       for state from 0
                       do (#_SetAnimatedThemeCursor (theme-cursor-type cursor) state)
                       do (sleep period-s)
                       when (= state most-positive-fixnum)
                       do (setf state 0)))))
        (eval-enqueue 
         `(process-run-function "Animate Cursor" ,(function animate-cursor) ,cursor))))))

#|

(defparameter %cursor% (make-instance 'animated-theme-cursor :type #$kThemeCountingUpAndDownHandCursor))

(defclass my-window (window)())

(defmethod view-cursor ((item my-window) where)
  (declare (ignore where))
  %cursor%)

(make-instance 'my-window)

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support for custom background and text color for controls.
;; Has been partly integrated in MCL 5.1.

;; ## should text also inherit color from container?

#-ccl-5.1  ;; has been added to MCL 5.1
(defvar handle->dialog-item (make-hash-table :weak :value))

#-ccl-5.1 ; covered in MCL 5.1
(defmethod (setf dialog-item-handle) :after (handle (item control-dialog-item))
  (setf (gethash handle handle->dialog-item) item))

;; MCL 5.1 misses this crucial method to let containing view setup the background of a control:

(defmethod view-setup-background (view depth color-p)
  (when view
    (view-setup-background (view-container view) depth color-p)))

;; A variation of this has been added to MCL 5.1, but it doesn't do the trick:

(defmethod view-setup-background ((item dialog-item) depth color-p)
  (let ((background-color (or (part-color item :back)(part-color item :body))))
    (cond
     (background-color
      (#_SetThemeBackground #$kThemeBrushWhite Depth color-p) ; hack to allow overriding the theme brush with custom color
      (with-rgb (rec background-color)
        (require-trap #_rgbBackColor rec))
      T)
     (T
      (call-next-method)))))

#-ccl-5.1
(defmethod view-apply-text-color (view depth color-p)
  (declare (ignore view depth color-p))
  NIL)

#-ccl-5.1 ;; has been added to MCL 5.1, with a minor change (only takes effect when dialog-item-enabled-p)
(defmethod view-apply-text-color ((item dialog-item) depth color-p)
  (declare (ignore depth))
  (when color-p
    (let ((color (part-color item :text)))
      (when color
        (with-rgb (rec color)
          (#_rgbForeColor rec))
        T))))

#-ccl-5.1 ;; has been added to MCL 5.1
(add-pascal-upp-alist 'control-color-proc
                      #'(lambda (procptr)(#_NewControlColorUPP procptr)))

#-ccl-5.1 ;; has been added to MCL 5.1
(defpascal control-color-proc (:pointer ControlHandle
                               :word Message ; sInt16
                               :word DrawDepth
                               :Boolean isColorDev
                               :word)
    (let ((view (gethash Controlhandle handle->dialog-item)))
      (if
        (case message
          (#.#$kControlMsgSetupBackground
           (view-setup-background view drawdepth iscolordev))
          (#.#$kControlMsgApplyTextColor ;; appearance 1.1
           (view-apply-text-color view drawdepth iscolordev)))
        #$noErr
        #$paramErr)))
  
#-ccl-5.1 ;; MCL 5.1 has a different install-view-in-window, so it has to be covered for each control (see below)
(defmethod install-view-in-window :after ((item control-dialog-item) window &aux (handle (dialog-item-handle item)))
  (declare (ignore window))
  (when handle
    (#_SetControlColorProc handle control-color-proc)))

; MCL 5.1 and beyond requires that a method like this is added to each control that setup background or text color: 
#+(and ccl-5.1 ignore)
(defmethod install-view-in-window :after ((item some-control) window &aux (handle (dialog-item-handle item)))
  (declare (ignore window))
  (when handle
    (setf (gethash handle handle->dialog-item) item)
    (#_SetControlColorProc handle control-color-proc)))

#| The code above and a view-setup-background for multi-pane-view (elsewhere) fixes the following problem...
   Without the patch this demo should result in a pane where the check box dialog item have a different background than the pane.

(progn
(require :appearance-manager "ccl:examples;appearance-manager-folder;appearance-manager.lisp")
(require :multi-pane-view "ccl:examples;appearance-manager-folder;multi-pane-view.lisp")
)

(let ((w (make-instance 'color-dialog
           :theme-background T))
      (pane-1 (make-instance 'view
                :view-subviews (list 
                                (make-instance 'check-box-dialog-item
                                  ; :part-color-list `(:text ,*blue-color*)
                                  ; :view-font :small-emphasized-system-font
                                  :view-position #@(20 20)
                                  :dialog-item-text "Check"))))
      (pane-2 (make-instance 'view
                :view-subviews (list
                                (make-instance 'button-dialog-item
                                  :view-position #@(32 20)
                                  :dialog-item-text "Button"))))
      (pane-3 (make-instance 'view
                :view-subviews (list
                                (make-instance 'radio-button-dialog-item
                                  :view-position #@(32 10)
                                  :dialog-item-text "Radio"))))
      (view   (make-instance 'multi-pane-view
                :view-position #@(20 30)
                :view-size     #@(300 120)
                ;:tab-font      '("Chicago" 12)
                ; :tab-bar-height 22
                )))
    (add-pane view pane-1 "Check")
    (add-pane view pane-2 "Button")
    (add-pane view pane-3 "Radio")
    (set-view-container view w))

|#

#| 

Should show the check-box text in yellow on a blue background:

(make-instance 'window
  :theme-background T
  :view-subviews
  (list
   (make-instance 'check-box-dialog-item 
        :view-position #@(10 10)
        :dialog-item-text "Test" 
        :part-color-list `(:text ,*yellow-color* :back ,*blue-color*))))

;; seems like this no longer is needed in MCL:
(defmethod redraw-color-dialog-item ((item check-box-dialog-item))
  nil)

#-ccl-5.1 ;; might be needed to make the demo work:
(defmethod view-draw-contents ((item check-box-dialog-item))
  ;(when (installed-item-p item)
   ; (without-the-text-if-osx item 
  (call-next-method))  ;))

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FUNCTIONS USED WHEN SETTING THEME BRUSHES

(defun view-pixel-depth (view) ; compare to the screen-bits function
  (let ((wptr (wptr view)))
    (if wptr
      (with-macptrs ((portpixmap (#_getportpixmap (#_getwindowport wptr))))
        (href portpixmap :pixmap.pixelsize))
      32)))

(defun view-color-p (view)
  (let ((wptr (wptr view)))
    (if wptr
      (wptr-color-p wptr)
      T)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MAKE STATIC TEXT DIALOG APPEARANCE SAVVY

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.0
(defmethod view-draw-contents :around ((item static-text-dialog-item))
  (if (osx-p)
    (call-next-method)
    (when (installed-item-p item)
      (with-focused-dialog-item (item)
        (let ((position (view-position item))
              (size (view-size item))
              (handle (dialog-item-handle item)))
          (with-slot-values (color-list text-justification #+ignore (enabled-p dialog-item-enabled-p))
                            item
            (rlet ((rect :rect)
                   ; (ps :penstate)
                   )
              (rset rect rect.topleft position)
              (rset rect rect.bottomright (add-points position size))
              (setq text-justification
                    (or (cdr (assq text-justification
                                   '((:left . #.#$tejustleft)
                                     (:center . #.#$tejustcenter)
                                     (:right . #.#$tejustright))))
                        (require-type text-justification 'fixnum)))
              (with-pointers ((tp handle))
                (with-fore-color (if (and 
                                      (ignore-errors (appearance-available-p))
                                      (not (draw-active-p item)))
                                   *gray-color*
                                   (getf color-list :text nil))
                  (with-back-color (getf color-list :body nil)
                    (#_TETextBox tp (#_GetHandleSize handle) rect text-justification))))
              #+ignore
              (unless enabled-p
                (#_GetPenState ps)
                (#_PenPat *gray-pattern*)
                (#_PenMode 11)
                (#_PaintRect rect)
                (#_SetPenState ps)))))))))

#+(and ccl-5.0 (not ccl-5.1)) ; Based on version in Digitool's theme-patch.lisp for MCL 5.0
(defmethod view-draw-contents ((item static-text-dialog-item))
  (when (installed-item-p item)
    (with-focused-dialog-item (item)
      (let ((position (view-position item))
            (size (view-size item))
            #|(handle (dialog-item-handle item))|#)
        (with-slot-values (color-list text-justification #|(enabled-p dialog-item-enabled-p)|#)
          item
          (rlet ((rect :rect) ;; # can use with-item-rect instead!!
                 #|(ps :penstate)|#)
            (rset rect rect.topleft position)
            (rset rect rect.bottomright (add-points position size))
            (setq text-justification
                  (case text-justification
                 #| (or (cdr (assq text-justification 
                                 '(|#
                    (:left #$tejustleft)
                    (:center #$tejustcenter)
                    (:right #$tejustright)
                    (otherwise (require-type text-justification 'fixnum))))
            (progn ;with-pointers ((tp handle)) ;; blech - the text is in the handle too
              (let ((back (getf color-list :body nil)))                
                (with-fore-color (or (getf color-list :text nil) *black-color*)
                  (with-back-color back
                    ;(if (and #|(osx-p)|# (null back)(theme-background-p (view-window item)))
                      (with-cfstrs ((cftext (dialog-item-text item)))  ;; n.b. font is semi ignored no longer
                        ;(multiple-value-bind (ff ms)(view-font-codes item)
                        ;  (let ((font-foo (if (> (logand ms #xffff) 10) #$kthemesystemfont 
                        ;                     (if (eq (ash (logand ff #xffff) -8) (cdr (assoc :bold *style-alist*))) ;; aka bold
                        ;                       #$kThemeSmallemphasizedSystemFont  ;; boy is that ugly
                        ;                       #$kThemeSmallSystemFont))))
                        (cond
                         ((getf color-list :text nil)
                          (unless (draw-active-p item)
                            (#_TextMode #$grayishTextOr)))
                         (T
                                                    (#_SetThemeTextColor 
                           (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                           (view-pixel-depth item)
                           (view-color-p item))))
                        (#_Drawthemetextbox cftext #$kThemeCurrentPortFont (appearance-theme-state item) t rect text-justification *null-ptr*))
                      ;(with-dereferenced-handle (tp handle)
                      ;  (#_TEtextbox tp (#_GetHandleSize handle) rect text-justification)))
                  ))))
            #+ignore
            (unless enabled-p
              (#_GetPenState ps)
              (#_PenPat *gray-pattern*)
              (#_PenMode 11)
              (#_PaintRect rect)
              (#_SetPenState ps))))))))

#+(and ccl-5.1 (not ccl-5.2)) ; based on code in MCL 5.1b4
(defmethod view-draw-contents ((item static-text-dialog-item))
  (when (installed-item-p item)
    (with-focused-dialog-item (item)
      (let ((position (view-position item))
            (size (view-size item))
            )
        (with-slots (color-list text-justification (enabled-p dialog-item-enabled-p))
                    item
          ;; Consider using with-item-rect instead...
          (rlet ((rect :rect :topleft position :botright (add-points position size) )
                 #+ignore
                 (ps :penstate))
            (setq text-justification
                  (or (cdr (assq text-justification
                                 '((:left . #.#$tejustleft)
                                   (:center . #.#$tejustcenter)
                                   (:right . #.#$tejustright))))
                      (require-type text-justification 'fixnum)))
            (let ((back (getf color-list :body nil))
                  (fore (getf color-list :text nil))
                  )
              (with-cfstrs ((cftext (dialog-item-text item)))
                (with-fore-and-back-color (or fore *black-color*) back
                  (if (or t back (not (theme-background-p item))) (#_eraserect rect))
                  (if fore
                    (unless (draw-active-p item)
                      (#_TextMode #$grayishTextOr))
                                        (#_SetThemeTextColor 
                     (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                     (view-pixel-depth item)
                     (view-color-p item)))
                  (#_Drawthemetextbox cftext #$kThemeCurrentPortFont (appearance-theme-state item) t rect text-justification (%null-ptr)))))
            #+ignore ;; inactive/disabled appearance is covered by the textMode or themeTextColor
            (unless enabled-p
              (#_GetPenState ps)
              (#_PenPat *gray-pattern*)
              (#_PenMode 11)
              (#_PaintRect rect)
              (#_SetPenState ps))))))))

#+(and ignore ccl-5.2) ;; draft version for MCL 5.2 with support for themes... misses a CGContextRef.
(defmethod view-draw-contents ((item static-text-dialog-item))
  (when (installed-item-p item)
    (without-interrupts
     (with-focused-view (view-container item)
       (let ((position (view-position item))
             (size (view-size item))
             (text-justification (slot-value item 'text-justification))
             (truncation (slot-value item 'text-truncation))
             #+ignore
             (enabled-p (dialog-item-enabled-p item))
             (compress-p (compress-text item))
             (old-state nil))
         (rlet ((rect :rect :topleft position :botright (add-points position size) ))
           (let* ((theme-back (theme-background-p item))
                  (back (or (part-color item :body)
                            (if (not theme-back) (slot-value (view-window item) 'back-color))))                          
                  (fore (part-color item :text) #+ignore (if enabled-p (part-color item :text) *gray-color*)))
             (when (and (not back) theme-back) ; (not (dialog-item-enabled-p item)))  ;; sometimes background goes white??
               (rlet ((old-statep :ptr))
                 (#_getthemedrawingstate old-statep)
                 (setq old-state (%get-ptr old-statep)))
               (let* ((wptr (wptr item))
                      (depth (current-pixel-depth)))
                 (#_setthemebackground  #$kThemeBrushModelessDialogBackgroundActive depth (wptr-color-p wptr))))
             (with-back-color back
               (multiple-value-bind (ff ms)(view-font-codes item)
                 (when t (#_eraserect rect))  ;; or when back?
                 (if t ; fore
                    (unless (draw-active-p item)
                      (#_TextMode #$grayishTextOr))
                                        (#_SetThemeTextColor 
                     (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                     (view-pixel-depth item)
                     (view-color-p item)))
                 (rlet ((info :HIThemeTextInfo 
                              :version 0
                              :state (appearance-theme-state item)
                              :font #$kThemeCurrentPortFont
                              :horizontalFlushness (ecase text-justification
                                                     ((:left NIL) #$kHIThemeTextHorizontalFlushLeft)
                                                     (:center #$kHIThemeTextHorizontalFlushCenter)
                                                     (:right #$kHIThemeTextHorizontalFlushRight))
                              :verticalFlushness #$kHIThemeTextVerticalFlushTop
                              :truncationMaxLines 1
                              :options 0
                              :truncationPosition (if truncation #$kHIThemeTextTruncationEnd #$kHIThemeTextTruncationNone)))
                   (#_HIThemeDrawTextBox cftext rect info CGContextRef #$kHIThemeOrientationNormal)) 
           #+ignore
                 (draw-string-in-rect (dialog-item-text item) rect 
                                      :justification text-justification
                                      :compress-p compress-p
                                      :truncation truncation
                                      :ff ff :ms ms :color fore)))
             (if old-state (#_setthemedrawingstate old-state t))
             )))))))

;; perhaps invalidate-view on simple-view should be changed like this to have a true default value for erase-p?
;; Calls to invalidate-view can be changed accordingly!

#+(and ccl-5.0 (not ccl-5.1)) ; Not needed in MCL 5.1 as it erases when drawing the static-text-dialog-item
(defmethod invalidate-view ((view static-text-dialog-item) &optional (erase-p t)) ;; erasing is required also in OS9!
  (call-next-method view erase-p))

#-ccl-5.2 ; covered by main method
(defmethod view-activate-event-handler :before ((item static-text-dialog-item))
  #-ccl-5.0
  (when (and (appearance-available-p)
             (not (osx-p)))
    (invalidate-view item))
  #+ccl-5.0
  (invalidate-view item))

#-ccl-5.2 ; covered by main method
(defmethod view-deactivate-event-handler :before ((item static-text-dialog-item))
  #-ccl-5.0
  (when (and (appearance-available-p)
             (not (osx-p)))
    (invalidate-view item))
  #+ccl-5.0
  (invalidate-view item))

#+(and ccl-5.0 (not ccl-5.1))
(defmethod set-dialog-item-text ((item static-text-dialog-item) text)
  (setq text (ensure-simple-string text))
  (let ((handle (dialog-item-handle item)))
    (when handle
      (%str-to-handle text handle)
      (invalidate-view item T #|(osx-p)|#)) ;; erasing is required also in OS9!
    (setf (slot-value item 'dialog-item-text) text))
  text)

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MAKE EDITABLE TEXT APPEARANCE SAVVY

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1
(defmethod view-draw-contents :after ((item basic-editable-text-dialog-item))
  (let (;(item-position (view-position item))
        ;(item-size (view-size item))
        (colorp (color-or-gray-p item)))
    (with-slot-values (dialog-item-enabled-p draw-outline) item
      (with-focused-dialog-item (item)
        (with-item-rect (rect item)
      ;(rlet ((rect :rect)
      ;       (ps :penstate))
      ;  (rset rect rect.topleft item-position)
      ;  (rset rect rect.bottomright
      ;        (add-points item-position item-size))
      ;  (#_GetPenState ps)
      ;  (unwind-protect
      ;    (progn
            (when draw-outline
              (let ((rgn1 *temp-rgn*)
                    (rgn2 *temp-rgn-2*)
                    (inset (if (fixnump draw-outline) draw-outline -1))
                    (frame-color (part-color item :frame))
                    (body-color (part-color item :body))
                    (focus? (and dialog-item-enabled-p
                                 (draw-active-p item)
                                 (eq (window-key-handler (view-window item)) 
                                     item))))
                (#_RectRgn rgn1 rect)
                (#_insetRect rect inset inset) ; I like -2 -2 better
                (#_RectRgn rgn2 rect)
                (#_DiffRgn rgn2 rgn1 rgn1)
                ;(#_PenNormal)
                ;(unless (or dialog-item-enabled-p colorp)
                ;  (#_PenPat *gray-pattern*))
                (when body-color
                  (with-back-color body-color
                    (#_EraseRgn rgn1)))
                (unless focus? 
                  (#_DrawThemeFocusRect rect NIL))
                (if frame-color
                  (with-fore-color (if (and colorp (not dialog-item-enabled-p))
                                     *gray-color*
                                     frame-color)
                    (#_FrameRect rect))
                  (#_DrawThemeEditTextFrame rect (appearance-theme-state item)))
                (when focus? 
                  (#_DrawThemeFocusRect rect T))
                ;(#_insetRect rect 1 1)
                ;(frame-table-item item nil (- inset 3))
                ))
            #+ignore
            (unless (or colorp dialog-item-enabled-p)
              (#_PenPat *gray-pattern*)
              (#_PenMode 11)
              (#_PaintRect rect)))
          #+ignore
          (#_SetPenState ps))))) ;)


#+(and ccl-5.1 (not ccl-5.2))
(defmethod view-draw-contents :after ((item basic-editable-text-dialog-item))
  (let (#+ignore (pos (view-position item))
        #+ignore (colorp (color-or-gray-p item)))
    (with-slots (dialog-item-enabled-p draw-outline) item      
      (when draw-outline
        (let () ;(inset (if (fixnump draw-outline) draw-outline -3)))
          (frame-key-handler item))) ; (- inset 3))))
      #+ignore ; inactive color covered by themeTextColor
      (unless (or colorp dialog-item-enabled-p) 
        (rlet ((ps :penstate)
               (rect :rect :topleft pos :botright (add-points pos (view-size item))))
          (unwind-protect
            (progn
              (#_GetPenState ps)
              (#_PenPat *gray-pattern*)
              (#_PenMode 11)
              (#_PaintRect rect))
            (#_SetPenState ps)))))))

) ; end redefine

#-ccl-5.1 ;;; Not needed in MCL 5.1. Ensures that focus ring is considered part of the dialog item.
(defmethod view-corners :around ((item basic-editable-text-dialog-item))
  (if (and (slot-value item 'draw-outline) (appearance-available-p))
    (multiple-value-call #'inset-corners #@(-4 -4) (call-next-method))
    (call-next-method)))

#-ccl-5.1 ; may not be required in MCL 5.1?
(defmethod exit-key-handler :after ((item basic-editable-text-dialog-item) new-item)
  (declare (ignore new-item))
  (when (and (slot-value item 'draw-outline) (appearance-available-p))
     (invalidate-view-border item)
     (view-focus-and-draw-contents item)
     t))

#-ccl-5.1 ; may not be required in MCL 5.1?
(defmethod enter-key-handler :after ((item basic-editable-text-dialog-item) old-item)
  (declare (ignore old-item))
  (when (and (slot-value item 'draw-outline) (appearance-available-p))
    ; (invalidate-view-border item)
    (view-focus-and-draw-contents item)))

#-ccl-5.1 
(defmethod view-activate-event-handler #-ccl-5.0 :before #+ccl-5.1 :after ((item basic-editable-text-dialog-item))
  (when (appearance-available-p)
    (invalidate-view item (osx-p))))

#-ccl-5.1 
(defmethod view-deactivate-event-handler :after ((item basic-editable-text-dialog-item))
  (when (appearance-available-p)
    (invalidate-view item (osx-p))))

#-ccl-5.1 ; covered by view-draw-contents on fred-dialog-item
(defmethod view-draw-contents :around ((item basic-editable-text-dialog-item))
  (if (and (not (osx-p))
           (appearance-available-p)
           (not (draw-active-p item)))
    (with-slots (color-list) item
      (unwind-protect
        (progn ;; I don't like this, use theme constant instead!
          (setf color-list (list* :text #.*gray-color* color-list))
          (call-next-method))
        (setf color-list (cddr color-list))))
    (call-next-method)))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#+(and ccl-5.0 (not ccl-5.2)) ; code borrowed from MCL 5.1 - but works also in MCL 5.0 to display inactive text, yet not ccl-5.2!!!
(defmethod view-draw-contents ((item fred-dialog-item))
  (unless (view-quieted-p item)
    (let* (#+ignore (enabled-p (dialog-item-enabled-p item))
           (colorp (color-or-gray-p item)))
      (with-focused-view item
        (with-fore-color (if (and colorp (not (draw-active-p item)))
                           *gray-color*
                           (part-color item :text))
          (unless (part-color item :text)
                        (#_SetThemeTextColor 
             (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
             (view-pixel-depth item) (view-color-p item)))
          (with-back-color (part-color item :body)              
            (frec-draw-contents (frec item))
            #-ccl-5.1
            (progn
              (#_setorigin :long (view-origin (view-container item)))  ;; << added this for the after method
              (#_SetClip (view-clip-region (view-container item)))
            )))))))

#+(and ignore ccl-5.2) ; does not provide the inactive color - but neither does the version in MCL 5.2 due to implementation of %redraw-screen-lines (called through frec-draw-contents)! This requires surgical fix in MCL.
(defmethod view-draw-contents ((item fred-dialog-item))
  (unless (view-quieted-p item)
    (let* ((enabled-p (dialog-item-enabled-p item))
           (colorp (color-or-gray-p item)))
      (with-focused-view item
        (with-fore-color (or (when (and colorp enabled-p)
                               (part-color item :text))
                             (rlet ((rgb :rgbcolor))
                                                              (#_GetThemeTextColor 
                                (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                                (view-pixel-depth item) (view-color-p item)
                                rgb)
                               (rgb-to-color (pref rgb :rgbcolor))))
          (with-back-color (part-color item :body)              
            (frec-draw-contents (frec item))
            ))))))
 
#|

*default-foreground-rgb*
*foreground-rgb*

(add-subviews
  (make-instance 'window :theme-background t)
  (make-dialog-item
   'editable-text-dialog-item
   #@(10 10)
   #@(100 20)
   "bla"))

(defparameter *edti* (first (subviews (target))))

(setf (part-color-list *edti*) `(:text ,*red-color* :BODY 16777215)) 

(%buf-find-font (mark.buffer (fred-buffer *edti*)) 0)
(bf.flist (mark.buffer (fred-buffer *edti*)))

(unwind-protect
  (progn
    (trace '%buf-find-font)
    (invalidate-view *edti* T))
  (untrace '%buf-find-font)) 

(ccl::%buf-find-font (fred-buffer *edti*) 0)

|#


) ; end redefine

#-ccl-5.1 ;; seems to be resolved in MCL 5.1
(defmethod view-click-event-handler :before ((item fred-mixin) where)
  ;; Sets key handler immediately as setting it in fred-mixin causes focus ring to appear too late
  (declare (ignore where))
  (when (key-handler-p item)
    (unless (eq item (current-key-handler (view-window item)))
      (set-current-key-handler (view-window item) item nil))))

;; see frec-click for MCL 5.1b2 problem when click & hold on editable-text-dialog-item

#|

(make-instance 'dialog
            ; :window-type :movable-dialog
            :window-title "Styling Prefs"
            :view-nick-name 'prefs-dialog
            ;:back-color *tool-back-color*
            :theme-background t
            ;:view-position (dialog-position pm)
            :view-size #@(300 100)
            ;:close-box-p nil
            ; :window-show nil
  :view-subviews
  (list
   (make-dialog-item 'editable-text-dialog-item #@(40 40) #@(40 40) "" nil 
                     :dialog-item-enabled-p t
                     :draw-outline nil
                     :part-color-list `(:frame ,*blue-color* :body ,*red-color*))
   (make-dialog-item 'table-dialog-item #@(100 40) #@(40 40) "" nil :dialog-item-enabled-p nil)
   (make-dialog-item 'fred-dialog-item #@(160 40) #@(40 40) "Test" nil :part-color-list `(:text ,*red-color*))
))

(add-subviews
  (make-instance 'window :theme-background t)
  (make-dialog-item
   'editable-text-dialog-item
   #@(10 10)
   #@(100 20)
   "bla")
  (make-dialog-item
   'editable-text-dialog-item
   #@(125 10)
   #@(100 20)
   "ble"
   nil
   ;:dialog-item-enabled-p 1
   :draw-outline t
   :part-color-list `(:frame ,*red-color* :body ,*yellow-color*)))

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MAKES SCROLLING FRED VIEW THEME SAVVY

(in-package :ccl)

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#+(and ccl-5.1 (not ccl-5.2)) ;; from MCL 5.1, no longer in MCL 5.2 (renamed to frame-key-handler, see below).
(defun frame-scrolling-fred-view (view)
  (with-focused-view (view-container view)
    (with-item-rect (rect view)      
      (let* ((w (view-window view))
             (window-active-p (window-active-p w)))         
        (if (and window-active-p (eq (fred-item view)(current-key-handler w))(cdr (key-handler-list w))) ;; do iff more than one key-handler
          (progn 
            (#_insetrect rect 1 1) ;; overwrite the frame
            (#_drawthemefocusrect rect t))          
          ;; leaves 1 pixel gray rect on osx - fixed - see view-corners
          (progn 
            #+ignore
            (with-fore-color (if (not window-active-p)
                               (if (osx-p) *light-gray-color* *gray-color*)
                               (or (part-color (fred-item view) :frame) *black-color*))
              (#_framerect rect))
            (#_insetrect rect 1 1)  ;; consider using #$kThemeMetricEditTextFrameOutset
            (#_DrawThemeEditTextFrame rect (appearance-theme-state view))
            (#_insetrect rect -1 -1)
            (IF (and (NOT (OSX-P)) )(#_INSETRECT  RECT 1 1))
            (draw-nil-theme-focus-rect w rect))          
          )))))

#+ccl-5.2
(defmethod frame-key-handler ((view scrolling-fred-view-with-frame))
  (with-focused-view (view-container view)
    (with-item-rect (rect view)      
      (let* ((w (view-window view))
             (fred-item (fred-item view))
             (window-active-p (window-active-p w)))         
        (if (and window-active-p (eq fred-item (current-key-handler w))(cdr (key-handler-list w))) ;; do iff more than one key-handler
          (progn 
            (#_insetrect rect 1 1) ;; overwrite the frame
            (#_drawthemefocusrect rect t))          
          ;; leaves 1 pixel gray rect on osx - fixed - see view-corners - no don't
          (progn
            #+ignore
            (with-fore-color (if (not window-active-p)
                               (if t #|(osx-p)|# *light-gray-color* *gray-color*)
                               (or (part-color fred-item :frame) *black-color*))
              (#_framerect rect))
            (#_insetrect rect 1 1)  ;; consider using #$kThemeMetricEditTextFrameOutset
            (#_DrawThemeEditTextFrame rect (appearance-theme-state view))
            (#_insetrect rect -1 -1)
            ;(IF (and (NOT (OSX-P)) )(#_INSETRECT  RECT 1 1))
            (draw-nil-theme-focus-rect w rect))          
          )))))

#-ccl-5.1
(defmethod view-draw-contents ((view scrolling-fred-view))
  (progn ;with-focused-view view
    (let ((draw-inactive (and (not (draw-active-p view))
                              (not (typep (view-window view) 'fred-window)))))
      (with-fore-color (when draw-inactive *gray-color*)
        (when draw-inactive
                    (#_SetThemeTextColor #$kThemeTextColorDialogInactive (view-pixel-depth view) (view-color-p view)))
        (if (and (osx-p)(view-get (view-window view) 'theme-background))
          (with-back-color (or (part-color view :body) *white-color*)  ;; kludge to lose the stripes [still needed?]
            (call-next-method))
          (call-next-method)))) ; its the one for view - does the subviews    
    (when (draw-scroller-outline view)
      (unless (osx-p)
        (with-fore-color *gray-color* ; bogus, just to restore pen
          (#_setThemePen
           (if (draw-active-p view) 
             #$kThemeBrushScrollBarDelimiterActive
             #$kThemeBrushScrollBarDelimiterInactive)
           (view-pixel-depth view)
           (view-color-p view))
          (rlet ((r :rect
                    :topleft 0
                    :bottomright (view-size view))) ; (subtract-points (view-size view) #@(1 1))))
            (#_FrameRect r))))
      (when (not (typep (view-window view) 'fred-window))
        (let* ((w (view-window view))
               (active? (window-active-p w))
               (key-handler? (eq (fred-item view) (current-key-handler w))))
          (with-focused-dialog-item (view)
            (with-item-rect (r view)
              (#_insetrect r 1 1)
              (unless (and active? key-handler?)
                (#_DrawThemeFocusRect r NIL))
              (#_DrawThemeEditTextFrame r (appearance-theme-state view))
              (when (and active? key-handler?)
                (#_DrawThemeFocusRect r T)))))))))

#+ccl-5.1
(defmethod view-draw-contents ((view scrolling-fred-view))
  (progn ;with-focused-view view 
    (let ((draw-inactive (and (not (draw-active-p view))
                              (not (typep (view-window view) 'fred-window)))))
      (with-fore-color (when draw-inactive *gray-color*)
        (when draw-inactive
                    (#_SetThemeTextColor #$kThemeTextColorDialogInactive (view-pixel-depth view) (view-color-p view)))  
        (call-next-method))) ; its the one for view - does the subviews    
    (when (draw-scroller-outline view)
      #-ccl-5.2
      (unless (osx-p)
        (with-fore-color *gray-color* ; bogus, just to restore pen
          (#_setThemePen
           (if (draw-active-p view) 
             #$kThemeBrushScrollBarDelimiterActive
             #$kThemeBrushScrollBarDelimiterInactive)
           (view-pixel-depth view)
           (view-color-p view))
          (rlet ((r :rect
                    :topleft 0
                    :bottomright (view-size view))) ; (subtract-points (view-size view) #@(1 1))))
            (#_FrameRect r))))
      #+ignore ; seems to be covered by scrolling-fred-view-with-frame
      (when (not (typep (view-window view) 'fred-window))
        (let* ((w (view-window view))
               (active? (window-active-p w))
               (key-handler? (eq (fred-item view) (current-key-handler w))))
          (with-focused-dialog-item (view)
            (with-item-rect (r view)
              (#_insetrect r 1 1)
              (unless (and active? key-handler?)
                (#_DrawThemeFocusRect r NIL))
              (#_DrawThemeEditTextFrame r (appearance-theme-state view))
              (when (and active? key-handler?)
                (#_DrawThemeFocusRect r T)))))))))


) ;; redefine

#-ccl-5.1 ; seems to be covered by scrolling-fred-view-with-frame
(defmethod view-corners ((item scrolling-fred-view))
  (if (not (typep item 'CCL::NEW-MINI-BUFFER))
    (multiple-value-call #'inset-corners (if (osx-p) #@(-3 -3) #@(-2 -2)) (call-next-method))
    (call-next-method)))

#-ccl-5.1 ; seems to be covered by scrolling-fred-view-with-frame
(defmethod exit-key-handler :after ((item scrolling-fred-view) new-item)
  (declare (ignore new-item))
  (when (not (typep item 'CCL::NEW-MINI-BUFFER))
     (invalidate-view-border item)
     (view-focus-and-draw-contents item)))

#-ccl-5.1 ; seems to be covered by scrolling-fred-view-with-frame
(defmethod enter-key-handler :after ((item scrolling-fred-view) old-item)
  (declare (ignore old-item))
  (when (not (typep item 'CCL::NEW-MINI-BUFFER))
    ;(invalidate-view-border item)
    (view-focus-and-draw-contents item)))

#-ccl-5.1 ; seems to be covered by scrolling-fred-view-with-frame
(defmethod view-activate-event-handler ((item scrolling-fred-view))
  (invalidate-view item)
  (call-next-method))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

;; is this still needed for MCL 5.2??
(defmethod view-deactivate-event-handler ((view scrolling-fred-view))
  ;; # maybe this should be after the call-next-method instead of before? May eliminate blue in scroller...
  (if (osx-p)
    (invalidate-view view)
    (invalidate-view-border view))
  (if (not (window-active-p (view-window view)))
    (call-next-method)
    (view-deactivate-event-handler (fred-item view))))


) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MINI BUFFER

;; new-mini-buffer is a subclass of scrolling-fred-view!

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defmethod view-draw-contents ((view new-mini-buffer))
  ;(call-next-method)
  (let ((h-scroller (h-scroller view)))
    (when h-scroller
      (let ((pos (view-position h-scroller)))
        (if (osx-p)
          (rlet ((rect :rect 
                       :topleft (make-point 0 (point-v pos)) 
                       :bottomright (make-point (point-h pos) (+ (point-v pos)(point-v (view-size h-scroller))))))
            (#_DrawThemePlacard rect (appearance-theme-state view)))
          (with-fore-color 
            *red-color* ; bogus, just to restore pen
            (#_setThemePen
             (if (draw-active-p view) 
               #$kThemeBrushScrollBarDelimiterActive
               #$kThemeBrushScrollBarDelimiterInactive)
             (view-pixel-depth view)
             (view-color-p view))
            (#_moveto :word 0 :word (point-v pos))
            (#_lineto :word (point-h pos) :word (point-v pos))))))
    (unless h-scroller
      (when (osx-p) 
        ; hack... only the frame remains after text has been drawn...
        (rlet ((rect :rect :topleft #@(0 0) :bottomright (view-size view)))
          (#_DrawThemePlacard rect (appearance-theme-state view)))
        )))
  (call-next-method))

(defmethod view-activate-event-handler :before ((item new-mini-buffer))
  (invalidate-view item))

(defmethod view-deactivate-event-handler :before ((item new-mini-buffer))
  (invalidate-view item))

(defmethod view-draw-contents ((item fred-item))
  (call-next-method)
  (unless (view-quieted-p item)
    (with-focused-view item
      (with-text-colors item
          (frec-draw-contents (frec item))))      
      (#_SetClip (view-clip-region (view-container item)))))

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; APPEARANCE & THEME SAVVY TABLE DIALOG ITEM

; This is the URL for how to properly design an OSX scrolling list:
; http://developer.apple.com/documentation/UserExperience/Conceptual/OSXHIGuidelines/XHIGControls/chapter_18_section_6.html#//apple_ref/doc/uid/TP30000359/TPXREF114
; http://developer.apple.com/documentation/mac/HIGuidelines/HIGuidelines-155.html
; http://developer.apple.com/documentation/mac/HIGuidelines/HIGuidelines-140.html
; http://developer.apple.com/documentation/mac/HIGOS8Guide/thig-25.html
; http://developer.apple.com/documentation/Carbon/Reference/Control_Manager/controlman_ref/constant_116.html
; http://developer.apple.com/documentation/LegacyTechnologies/Conceptual/AquaHIGuidelines/AHIGControls/chapter_7_section_2.html


(in-package :ccl)

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#| Consider this:

(defmacro with-focus-rect ((rect &optional (has-focus T)) &body body)
  `(prog2
     (unless ,has-focus
       (#_DrawThemeFocusRect ,rect NIL))
     (progn ,@body)
     (when ,has-focus
       (#_DrawThemeFocusRect ,rect T))))
|#
 
#-ccl-5.1
(defmethod view-draw-contents ((item table-dialog-item))
  (without-interrupts
   (let* ((my-dialog (view-container item))
          (wptr (and my-dialog (wptr my-dialog))))
     (when wptr
       (with-focused-dialog-item (item my-dialog)
         (let ((dialog-item-enabled-p (dialog-item-enabled-p item))
               #+ignore
               (color-list (part-color-list item))
               (back-color (getf (part-color-list item) :body))
               (pos (view-position item))
               (inner-size (table-inner-size item))
               (appearance? (appearance-available-p))
               (active? (draw-active-p item))
               (key-handler? (eq item (current-key-handler (view-window item)))))
           (rlet ((rect :rect :topleft pos :botright (add-points pos inner-size)))
             (with-clip-rect-intersect rect
               (with-temp-rgns (rgn rgn3)
                 (#_getclip rgn)
                 (with-back-color (or back-color *red-color*)
                   (unless back-color
                    (#_SetThemeBackground #$kThemeBrushListViewBackground 
                     (view-pixel-depth item) (view-color-p item)))
                   (#_erasergn rgn)
                   (when (and *updating* dialog-item-enabled-p)
                     (let ((selection-rgn (if (view-active-p item)
                                            (table-selection-region item)
                                            (table-outline-region item))))
                       (with-hilite-mode
                         (#_InvertRgn selection-rgn))))
                   (let ()
                     (get-window-visrgn wptr rgn3)
                     (#_sectrgn rgn rgn3 rgn))
                   (let* ((row (table-top-row item))
                          (column (table-left-column item))
                          (rows (table-rows item))
                          (columns (table-columns item))
                          (first-column column)
                          (cell-size (cell-size item))
                          (column-width (point-h cell-size))
                          (row-height (point-v cell-size))
                          (column-widths-hash (column-widths-hash item))
                          (row-heights-hash (row-heights-hash item))
                          (separator-visible-p (separator-visible-p item))
                          (separator-size (separator-size item))
                          (separator-color (separator-color item))
                          (separator-pattern (separator-pattern item))
                          (might-draw-separator (and separator-visible-p
                                                     (not (eql separator-size #@(0 0)))
                                                     (macptrp separator-pattern)))
                          (draw-col-separator (and might-draw-separator (> columns 1))) ;nil)
                          (top-left (view-position item))
                          (bottom-right (add-points top-left (table-inner-size item)))
                          (top (point-v top-left))
                          (left (point-h top-left))
                          (right (point-h bottom-right))
                          (bottom (point-v bottom-right)))
                     (rlet ((rect :rect :topleft top-left :botright bottom-right))
                       (with-clip-rect-intersect rect
                         (loop
                           (let ((row-height (or (and row-heights-hash (gethash row row-heights-hash)) row-height)))
                             (when (plusp row-height)
                               (setf (pref rect :rect.bottom) (+ (pref rect :rect.top) row-height))
                               (setf (pref rect :rect.left) left)
                               (setq column first-column)
                               #|
                               (when (and might-draw-separator
                                          (or (>= row (1- rows))
                                              (>= (+ (pref rect :rect.bottom) row-height (point-v separator-size)) bottom)))
                                 (setf draw-col-separator t))|#

                               (loop
                                 (let ((column-width (or (and column-widths-hash (gethash column column-widths-hash))
                                                         column-width)))
                                   (setf (pref rect :rect.right) 
                                         (+ (pref rect :rect.left) column-width))
                                   (when (and (plusp column-width)
                                              (#_RectInRgn rect rgn))
                                     (unless (or (>= column columns) (>= row rows))
                                       ;(when (and appearance? (not active?) #+ccl-5.0 (not (osx-p))) 
                                       ;  (setf (slot-value item 'color-list) (list* :text #.*gray-color* color-list)))
                                       (draw-table-cell-new item column row rect (cell-selected-p item column row))
                                       ;(when (and appearance? (not active?) #+ccl-5.0 (not (osx-p)))
                                       ;  (setf (slot-value item 'color-list) (cddr (slot-value item 'color-list))))
                                       (when draw-col-separator
                                         ;; draw the column separator to the right of the current
                                         (with-fore-color separator-color
                                           (with-pen-saved
                                             (#_PenSize :long separator-size)
                                             (#_PenPat separator-pattern)
                                             (#_MoveTo (pref rect :rect.right) top)
                                             (#_LineTo (pref rect :rect.right) (pref rect :rect.bottom)))))))
                                   (incf column)
                                   (when (or (>= column columns)
                                             (>= (incf (pref rect :rect.left) 
                                                       (if (zerop column-width) 
                                                         0 
                                                         (+ column-width (point-h separator-size))))
                                                 right))
                                     (return))))
                               (when (and separator-visible-p  (< row rows))
                                 ;; draw the row separator below the current row
                                 (with-fore-color (or separator-color *red-color*) ;; saves theme drawing state! 
                                   (with-pen-saved
                                     (cond
                                      ((not separator-color)
                                       (#_setThemePen #$kThemeBrushListViewSeparator 255 t))
                                      (T
                                       (#_PenSize :long separator-size)
                                       (when (macptrp separator-pattern)
                                         (#_PenPat separator-pattern))))
                                     (#_MoveTo left (pref rect :rect.bottom))
                                     (#_LineTo (pref rect :rect.right) (pref rect :rect.bottom))
                                     (incf (pref rect :rect.top) ; quickdraw (pen-size item)
                                           (point-v
                                            (rlet ((pport (:pointer :grafport))
                                                   (pensize :point))
                                              (#_GetPort pport)
                                              (%get-point (#_getportpensize (%get-ptr pport) pensize)))
                                            #+ignore
                                            (let ((wptr (wptr item)))
                                              (with-macptrs ((port (#_getwindowport wptr)))
                                                (rlet ((foo :point))
                                                  (%get-point (#_getportpensize port foo)))))))))))
                             (incf row)
                             (when (or (>= row rows)
                                       (>= (incf (pref rect :rect.top) 
                                                 (if (zerop row-height) 
                                                   0 
                                                   (+ row-height #|(point-v separator-size)|#)))
                                           bottom))
                               (return)))))))))))
           (if appearance?
             (with-item-rect (r item)
               #| #+ccl-5.0
               (when (osx-p)
                 (with-temp-rgns (r-rgn)
                   (#_RectRgn r-rgn r)
                   (decf (pref r :rect.top) 2)
                   (incf (pref r :rect.bottom) 2)
                   (decf (pref r :rect.left) 2)
                   (incf (pref r :rect.right) 1)
                   ;(#_insetRect r 1 -2)
                   (with-temp-rgns (t-rgn) 
                     (#_RectRgn t-rgn r)
                     (#_diffRgn t-rgn r-rgn t-rgn)
                     (with-fore-color *white-color*
                       (#_paintrgn t-rgn))))) |#
               (unless (and active? key-handler?)
                 (#_DrawThemeFocusRect r NIL))
               (#_DrawThemeListBoxFrame r (appearance-theme-state item))
               (when (and active? key-handler?)
                (#_DrawThemeFocusRect r T)))
             #+ignore
             (with-item-rect (r item)
               (with-fore-color (getf color-list :frame nil)                         
                 (#_insetRect r -1 -1)              
                 (#_FrameRect r))
               (unless dialog-item-enabled-p
                 (rlet ((ps :penstate))
                   (#_GetPenState ps)
                   (#_PenPat *gray-pattern*)
                   (#_PenMode 11)
                   (#_PaintRect r)
                   (#_SetPenState  ps)))))))))))

#+ccl-5.1
(defmethod view-draw-contents ((item table-dialog-item))
  (without-interrupts
   (let* ((my-dialog (view-container item))
          (wptr (and my-dialog (wptr my-dialog))))
     (when wptr
       (with-focused-dialog-item (item my-dialog)
         (let* ((dialog-item-enabled-p (dialog-item-enabled-p item))
                #+ignore
                (color-p (and (not dialog-item-enabled-p)(color-or-gray-p item)))
                #+ignore
                (color-list (part-color-list item))
                (back-color (part-color item :body))
                (pos (view-position item))
                (inner-size (table-inner-size item))
                (active? (draw-active-p item))
                (key-handler? (eq item (current-key-handler (view-window item)))))
           (rlet ((rect :rect :topleft pos :botright (add-points pos inner-size)))
             (with-clip-rect-intersect rect
               (with-temp-rgns (rgn rgn3)
                 (#_getclip rgn)
                 (with-back-color (or back-color *red-color*)
                   (unless back-color
                     (#_SetThemeBackground #$kThemeBrushListViewBackground 
                      (view-pixel-depth item) (view-color-p item)))
                   (when back-color
                     (#_erasergn rgn)
                     #+ignore
                     (when (osx-p)
                       (with-fore-color back-color
                         (#_paintrgn rgn))))
                   (when (and *updating* dialog-item-enabled-p)
                     (let ((selection-rgn (if (view-active-p item)
                                            (table-selection-region item)
                                            (table-outline-region item))))
                       (with-hilite-mode
                         (#_InvertRgn selection-rgn))))                   
                   (let ()
                     (get-window-visrgn wptr rgn3)
                     (#_sectrgn rgn rgn3 rgn))
                   (let* ((row (table-top-row item))
                          (column (table-left-column item))
                          (rows (table-rows item))
                          (columns (table-columns item))
                          (first-column column)
                          (cell-size (cell-size item))
                          (column-width (point-h cell-size))
                          (row-height (point-v cell-size))
                          (column-widths-hash (column-widths-hash item))
                          (row-heights-hash (row-heights-hash item))
                          (separator-visible-p (separator-visible-p item))
                          (separator-size (separator-size item))
                          (separator-color (separator-color item))
                          (separator-pattern (separator-pattern item))
                          (might-draw-separator (and separator-visible-p
                                                     (not (eql separator-size #@(0 0)))
                                                     (macptrp separator-pattern)))
                          (draw-col-separator (and might-draw-separator (> columns 1))) ;nil)
                          (top-left (view-position item))
                          (bottom-right (add-points top-left (table-inner-size item)))
                          (top (point-v top-left))
                          (left (point-h top-left))
                          (right (point-h bottom-right))
                          (bottom (point-v bottom-right)))
                     (rlet ((rect :rect :topleft top-left :botright bottom-right))
                       (with-clip-rect-intersect rect
                         (loop
                           (let ((row-height (or (and row-heights-hash (gethash row row-heights-hash)) row-height)))
                             (when (plusp row-height)
                               (setf (pref rect :rect.bottom) (+ (pref rect :rect.top) row-height))
                               (setf (pref rect :rect.left) left)
                               (setq column first-column)
                               #|
                               (when (and might-draw-separator
                                          (or (>= row (1- rows))
                                              (>= (+ (pref rect :rect.bottom) row-height (point-v separator-size)) bottom)))
                                 (setf draw-col-separator t))|#

                               (loop
                                 (let ((column-width (or (and column-widths-hash (gethash column column-widths-hash))
                                                         column-width)))
                                   (setf (pref rect :rect.right) 
                                         (+ (pref rect :rect.left) column-width))
                                   (when (and (plusp column-width)
                                              (#_RectInRgn rect rgn))
                                     (unless (or (>= column columns) (>= row rows))
                                       (draw-table-cell-new item column row rect (cell-selected-p item column row))
                                       (when draw-col-separator
                                         ;; draw the column separator to the right of the current
                                         (with-fore-color separator-color
                                           (with-pen-saved-simple
                                             (#_PenSize :long separator-size)
                                             (#_PenPat separator-pattern)
                                             (#_MoveTo (pref rect :rect.right) top)
                                             (#_LineTo (pref rect :rect.right) (pref rect :rect.bottom)))))))
                                   (incf column)
                                   (when (or (>= column columns)
                                             (>= (incf (pref rect :rect.left) 
                                                       (if (zerop column-width) 
                                                         0 
                                                         (+ column-width (point-h separator-size))))
                                                 right))
                                     (return))))
                               (when (and separator-visible-p #+ignore might-draw-separator (< row rows))
                                 ;; draw the row separator below the current row
                                 (with-fore-color (or separator-color *red-color*)
                                   (with-pen-saved-simple
                                     (cond
                                      ((not separator-color)
                                       (#_setThemePen #$kThemeBrushListViewSeparator (view-pixel-depth item) (view-color-p item)))
                                      (T
                                       (#_PenSize :long separator-size)
                                       (#_PenPat separator-pattern)))
                                     (#_MoveTo left (pref rect :rect.bottom))
                                     (#_LineTo (pref rect :rect.right) (pref rect :rect.bottom))
                                     (incf (pref rect :rect.top) ; quickdraw (pen-size item)
                                           (point-v
                                            (rlet ((pport (:pointer :grafport))
                                                   (pensize :point))
                                              (#_GetPort pport)
                                              (%get-point (#_getportpensize (%get-ptr pport) pensize)))))))))
                       (incf row)
                       (when (or (>= row rows)
                                 (>= (incf (pref rect :rect.top) 
                                           (if (zerop row-height) 
                                             0 
                                             (+ row-height 
                                                #+ignore (point-v separator-size))))
                                     bottom))
                               (return)))))))))))
     (with-item-rect (r item)
       (unless (and active? key-handler?)
         (#_DrawThemeFocusRect r NIL))
       (#_DrawThemeListBoxFrame r (appearance-theme-state item))
       (when (and active? key-handler?)
         (#_DrawThemeFocusRect r T)))
     #+ignore
           (with-item-rect (r item)
             (with-fore-color (getf color-list :frame nil)               
               (#_insetRect r -1 -1)
               (#_FrameRect r))
             (when (and (not dialog-item-enabled-p) (not color-p))
               (rlet ((ps :penstate))
                 (#_GetPenState ps)
                 (#_PenPat *gray-pattern*)
                 (#_PenMode 11)
                 (#_PaintRect r)
                 (#_SetPenState  ps))))))))))


#|
(make-instance 'window
  :theme-background t
  :view-subviews
  (list (make-instance 'sequence-dialog-item :view-position #@(10 10) :view-size #@(100 100) :table-sequence '(abc def ghi))))
|#

#-ccl-5.2
(defun %draw-table-cell-new (item h v rect selectedp)
  (when (wptr item)
    (let* ((container (view-container item))
           (enabled-p (dialog-item-enabled-p item))
           (color-p (if (not enabled-p)(color-or-gray-p item))))
      (with-focused-view container
        (let ((cell-fonts (table-cell-fonts item)))
          (multiple-value-bind (ff ms) (view-font-codes item)
            (let* ((top (pref rect rect.top))
                   (key (cons h v))
                   (back-color-p (eq (cell-colors item) :background))
                   (cell-color (part-color-h-v item h v)))
              (declare (dynamic-extent key))
              (without-interrupts
               (let* ((font (and cell-fonts
                                 (gethash key cell-fonts)))
                      (back-color (or (and back-color-p cell-color)
                                      (part-color item :body)))
                      (pos (view-position item))
                      (botright (add-points pos (table-inner-size item))))
                 (with-font-codes
                   (or (car font) ff)
                   (or (cdr font) ms)
                   (with-fore-color (if (or (and (not enabled-p) color-p)
                                            (and #+ccl-5.0 (not (osx-p)) ; <- why this??
                                                 (not (draw-active-p item))) )
                                      *gray-color*
                                      (or (and (not back-color-p) cell-color)
                                          (part-color item :text)
                                          *table-fore-color*
                                          *black-color*))
                     (cond
                      ((or (not enabled-p)
                           (not (draw-active-p item)))
                       (#_SetThemeTextColor #$kThemeTextColorDialogInactive (view-pixel-depth item) (view-color-p item)))
                      ((not (or (and (not back-color-p) cell-color)
                                (part-color item :text)
                                *table-fore-color*))
                       (#_SetThemeTextColor #$kThemeTextColorListView (view-pixel-depth item) (view-color-p item))))
                     (with-temp-rgns (temp-rgn temp-rgn-2)
                       (#_SetRectRgn temp-rgn (point-h pos) (point-v pos) (point-h botright) (point-v botright))
                       (#_RectRgn temp-rgn-2 rect)
                       (#_sectrgn temp-rgn temp-rgn-2 temp-rgn)
                       ;; mostly for clim?? - with-clip-region does this now
                       ;(#_sectrgn temp-rgn (view-clip-region container) temp-rgn)
                       (with-clip-region temp-rgn
                         (progn ;with-clip-rect-intersect rect
                           (with-back-color back-color
                             (cond
                              (selectedp
                               ;; should use a proper value for pix depth!
                               ;; see "Table View Highlighting Styles" at apple's developer connection for further improvements in osx 10.3
                               (#_SetThemeBackground
                                (if (and (window-active-p (view-window item)) (dialog-item-enabled-p item))
                                  #-ccl-5.2 -3 #+ccl-5.2 #$kThemeBrushPrimaryHighlightColor 
                                  #-ccl-5.2 -4 #+ccl-5.2 #$kThemeBrushSecondaryHighlightColor) 
                                (view-pixel-depth item) (view-color-p item)))
                             ((not (getf (part-color-list item) :body))
                               ;; should use a proper value for pix depth!
                               (#_SetThemeBackground #$kThemeBrushListViewBackground 
                                (view-pixel-depth item) (view-color-p item))))
                             (#_eraserect rect))  ;;  change scope -weird?? - from Gilles Bisson                               
                           #+ignore
                           (when (osx-p)
                             (with-fore-color back-color
                               (#_paintrect rect)))
                           (#_moveto  (+ 3 (pref rect rect.left)) (+ top (font-codes-info ff ms)))
                           (draw-cell-contents item h v)
                           #+ignore
                           (when (and selectedp (not *updating*) (dialog-item-enabled-p item))
                             (with-hilite-mode
                               (#_InvertRgn (if (view-active-p item)
                                              (table-selection-region item)
                                              (table-outline-region item)))))))))))))))))))

#+ccl-5.2
(defun %draw-table-cell-new (item h v rect selectedp)
  (when (wptr item)
    (let* ((container (view-container item))
           #+ignore (enabled-p (dialog-item-enabled-p item))
           #+ignore (color-p (if (not enabled-p)(color-or-gray-p item))))
      (with-focused-view container
        (let ((cell-fonts (table-cell-fonts item)))
          (multiple-value-bind (ff ms) (view-font-codes item)
            (let* ((top (pref rect rect.top))
                   (key (cons h v))
                   (back-color-p (eq (cell-colors item) :background))
                   (cell-color (part-color-h-v item h v)))
              (declare (ignore-if-unused top))
              (declare (dynamic-extent key))
              (without-interrupts
               (let* ((font (and cell-fonts
                                 (gethash key cell-fonts)))
                      (back-color (or (and back-color-p cell-color)
                                      (part-color item :body)))
                      (fore-color #+ignore
                                  (if (or (and (not enabled-p) color-p)
                                          (not (draw-active-p item)))
                                    *gray-color*
                                    (or (and (not back-color-p) cell-color)
                                        (part-color item :text)
                                        *table-fore-color*))
                                  (or (when (draw-active-p item)
                                        (or cell-color (part-color item :text)))
                                      (rlet ((rgb :rgbcolor))
                                        (#_GetThemeTextColor
                                         (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                                         (view-pixel-depth item) (view-color-p item) rgb)
                                        (rgb-to-color (pref rgb :rgbcolor)))))
                      (pos (view-position item))
                      (botright (add-points pos (table-inner-size item))))
                 (setq ff (or (car font) ff)
                       ms (or (cdr font) ms))
                 (rlet ((table-inner-rect :rect :topleft pos :botright botright))
                   (with-clip-rect-intersect table-inner-rect
                     (progn ;with-clip-rect-intersect rect - draw-string-in-rect does it
                       (with-back-color back-color
                         (cond
                          (selectedp
                           ;; should use a proper value for pix depth!
                           ;; see "Table View Highlighting Styles" at apple's developer connection for further improvements in osx 10.3
                           (#_SetThemeBackground
                            (if (and (window-active-p (view-window item)) (dialog-item-enabled-p item))
                              #$kThemeBrushPrimaryHighlightColor 
                              #$kThemeBrushSecondaryHighlightColor) 
                            (view-pixel-depth item) (view-color-p item)))
                          ((not (getf (part-color-list item) :body))
                           ;; should use a proper value for pix depth!
                           (#_SetThemeBackground #$kThemeBrushListViewBackground 
                            (view-pixel-depth item) (view-color-p item))))
                         (#_eraserect rect)  ;;  change scope -weird?? - from Gilles Bisson  UNDO change
                         (rlet ((my-rect :rect))
                           (copy-record rect :rect my-rect)
                           (incf (pref my-rect :rect.left) 3)  ;; ok to clobber rect? - not if multiple columns
                           (let ((string (cell-contents-string-new item h v)))
                             (draw-string-in-rect string my-rect :truncation :end :ff ff :ms ms :color fore-color)))
                         #+ignore ; non-standard
                         (when (and selectedp (not *updating*) enabled-p)
                           (with-hilite-mode
                             (#_InvertRgn (if (view-active-p item)
                                            (table-selection-region item)
                                            (table-outline-region item))))))))))))))))))
#-ccl-5.1
(defmethod view-corners ((item table-dialog-item))
  (multiple-value-call #'inset-corners                     
    (if (osx-p)
        #@(-7 -9)
        #@(-3 -3)
        #+ignore
        #@(-1 -1))
    (call-next-method)))

(defun invert-cell-selection (item h v selected-p)
  (when (wptr item)
    (with-focused-dialog-item (item)
      (with-back-color (or (and (eq (cell-colors item) :background)
                                (part-color-h-v item h v))
                           (part-color item :body))
        (let* ((rgn (if (view-active-p item)
                      (table-selection-region item)
                      (table-outline-region item)))
               (pos (view-position item))
               (botright (add-points pos (table-inner-size item))))
          (with-temp-rgns (temp-rgn)
            (#_SetRectRgn temp-rgn (point-h pos) (point-v pos) (point-h botright) (point-v botright))
            (with-clip-region temp-rgn
              (#_CopyRgn rgn temp-rgn)
              (add-to-selection-region item selected-p h v)
              (#_XorRgn rgn temp-rgn temp-rgn)
              #+ignore
              (with-hilite-mode (#_InvertRgn temp-rgn))
              (invalidate-region (view-container item) temp-rgn)
              )))))))

(defmethod view-click-event-handler ((item table-dialog-item) where)
  (progn ; without-interrupts
  (let* ((pos (view-position item))
         (botright (add-points pos (table-inner-size item))))
    (if (not (point<= where botright))
      (if (> (point-h where) (point-h botright))
        (let ((vscroll (table-vscroll-bar item)))
          (when vscroll
            (view-click-event-handler vscroll where)))
        (let ((hscroll (table-hscroll-bar item)))
          (when hscroll
            (view-click-event-handler hscroll where))))
      (let* ((type (selection-type item))
             (shift-key-p (shift-key-p))
             (command-key-p (command-key-p))
             (container (view-container item))
             (top-row (table-top-row item))
             (left-column (table-left-column item))
             (rows (table-rows item))
             (bottom-row (+ top-row rows))
             (columns (table-columns item))
             (right-column (+ left-column columns))
             (left (point-h pos))
             (top (point-v pos))
             (right (point-h botright))
             (bottom (point-v botright))
             h v where-h where-v start-selected-p now-in-range last-h last-v)
        (with-focused-dialog-item (item)
          (with-back-color (part-color item :body)
            (#+ccl-5.1 with-timer #-ccl-5.1 progn ; without-interrupts
             (multiple-value-bind (start-h start-v start-in-range) (find-clicked-cell item where)
               (if start-in-range
                 (setq start-selected-p (cell-selected-p item start-h start-v))
                 (deselect-cells item))
               (loop
                (without-interrupts
                 (setq where-h (point-h where)
                       where-v (point-v where))
                 (multiple-value-setq (h v now-in-range) (find-clicked-cell item where))
                 (multiple-value-setq (left-column top-row)
                   (do-auto-scroll item left-column top-row columns rows where-h where-v left top right bottom))
                 (if (and (not now-in-range)(not start-in-range)(not command-key-p)) ;(not shift-key-p))
                   (deselect-cells item)
                   (when (and now-in-range
                              (<= left-column h)
                              (< h right-column)
                              (<= top-row v)
                              (< v bottom-row)
                              (not (and (eql h last-h) (eql v last-v))))
                     (setq last-h h last-v v)
                     (cond ((and (eq type :disjoint)
                                 (or shift-key-p command-key-p)                                 
                                 (eql h start-h)(eql v start-v))
                            (if shift-key-p
                              (cell-select item h v)
                              (if start-selected-p
                                (cell-deselect item h v)
                                (cell-select item h v))))
                           ((and (eq type :disjoint)
                                 command-key-p
                                 start-selected-p)
                            (deselect-cells-between item start-h start-v h v))
                           ((or (eq type :single)
                                (and (not shift-key-p)
                                     (or ;(eq type :contiguous)
                                      (not command-key-p))))
                            (let* ((hash (table-selection-hash item))
                                   (colored-cells-p (colored-cells-p item)))
                              (with-temp-rgns (rgn)
                                (#_SetRectRgn :ptr rgn :long pos :long botright)
                                (with-clip-region rgn
                                  (with-hilite-mode
                                    (if (cell-selected-p item h v)
                                      (if (eq type :single)
                                        (cell-select item h v)
                                        (when hash
                                          (when colored-cells-p
                                            (let ((f #'(lambda (k val)
                                                         (declare (ignore val))
                                                         (unless (and (eql (car k) h)
                                                                      (eql (cdr k) v))
                                                           (cell-deselect item k)))))
                                              (declare (dynamic-extent f))
                                              (maphash f hash)))
                                          (clrhash hash)
                                          (setf (gethash (cons h v) hash) t)
                                          (setf (first-selected-cell-slot item) (make-big-point h v))                                          
                                          (with-temp-rgns (invert-region)
                                            (let ((selection-region
                                                   (if (view-active-p item)
                                                     (table-selection-region item)
                                                     (table-outline-region item))))
                                              (#_CopyRgn selection-region invert-region)
                                              (compute-selection-regions item)
                                              (when (not colored-cells-p)
                                                (#_DiffRgn invert-region selection-region invert-region)
                                                (#_InvertRgn invert-region))
                                              (cell-select item h v)
                                              ))))  ; << fixes bengtsons double click thing                                      (progn
                                      (progn 
                                        (when hash
                                          (when colored-cells-p  ; <<
                                            (deselect-cells item))
                                          (clrhash hash)
                                          (setf (first-selected-cell-slot item) nil)
                                          (when (not colored-cells-p) ; <<
                                            (invalidate-region (view-container item)
                                                               (if (view-active-p item)
                                                                 (table-selection-region item)
                                                                 (table-outline-region item)))
                                            )
                                          (compute-selection-regions item))
                                        (cell-select item h v))))))))
                           ((and (eq type :contiguous)
                                 command-key-p
                                 (eql h start-h)(eql v start-v))                          
                            (deselect-cells item)
                            (when (not start-selected-p)(cell-select item h v)))
                           ((and (eq type :contiguous)
                                 shift-key-p
                                 (cell-selected-p item h v))
                            (deselect-cells-above item h v))                           
                           (t #|(or (and moved
                                         (or shift-key command-key)
                                         (or contiguous disjoint))
                                    (and contiguous shift-key (not selected)))
                                |#
                              (let* ((p (if (eq type :contiguous)(first-selected-cell item)))
                                     (first-h (if p (point-h p) start-h))
                                     (first-v (if p (point-v p) start-v)))
                                (if (and (eq type :contiguous)  ; don't know bout this
                                         shift-key-p
                                         (neq 1 (point-h (table-dimensions item)))
                                         ;(not (cell-selected-p item h v)) ; always true
                                         )
                                  (multiple-value-bind (max-h max-v)(max-selected-h&v item)
                                    (select-cells-between item
                                                          (min first-h h)
                                                          (min first-v v)
                                                          (max first-h h max-h)
                                                          (max first-v v max-v)))
                                  (select-cells-between item first-h first-v h v))
                                #+ignore
                                (when (and (eq type :contiguous) 
                                           (neq 1 (point-h (table-dimensions item))))
                                  (deselect-cells-above item  h v))))))) )
                #+ccl-5.1 ;; from mcl 5.1b4
                (progn
                  (when (not (#_stilldown))(return))
                  (if (eql where (%get-local-mouse-position))                   
                    (unless (wait-mouse-up-or-moved) (return)))
                  (setq where (view-mouse-position container))
                  (%run-masked-periodic-tasks)) ;; is this of any use? 
                #-ccl-5.1
                (progn
                  (unless (mouse-down-p) (return))
                  (%run-masked-periodic-tasks)
                  (setq where (view-mouse-position container)))))))
            (dialog-item-action item)))))))

) ;; redefine

;; in MCL 5.2, consider to instead change toggle-cell-outlining to just invalidate... or eliminate it!

(defmethod view-activate-event-handler :before ((item table-dialog-item))
  (invalidate-view item (osx-p)))

(defmethod view-deactivate-event-handler :before ((item table-dialog-item))
  (invalidate-view item))

;; Platinum look & feel of table and sequence dialogs:

(defmethod initialize-instance :around ((item table-dialog-item)
                                    &rest initargs &key part-color-list separator-color separator-size (track-thumb-p T track-thump-p-arg))
  (declare (ignore part-color-list))
  (apply #'call-next-method item 
         :separator-color separator-color ; NIL as default separator color instead of the default initarg
         :track-thumb-p (if track-thump-p-arg track-thumb-p T)
         :separator-size  separator-size ; NIL if none instead of the default initarg
         initargs))

(defmethod separator-size :around ((item table-dialog-item))
  (or (call-next-method)
      (set-slot-value item 'separator-size
       (with-fore-color *red-color* ;; saves theme drawing state!
         (with-pen-saved
           (#_setThemePen #$kThemeBrushListViewSeparator 
            (view-pixel-depth item)(view-color-p item)) 
           (rlet ((pport (:pointer :grafport))
                  (pensize :point))
             (#_GetPort pport)
             (%get-point (#_getportpensize (%get-ptr pport) pensize))))))))

; borrowed from MCL 5.0/5.1 as it is needed when compiling:
(eval-when (:execute :compile-toplevel)
  (unless (fboundp 'do-column-widths) ;; defined in MCL 5.1 patches
    (defmacro do-column-widths ((item column-width &optional (column (gensym))) (&optional start end from-end)
                                &body body)
      (let ((thunk (gensym)))
        `(block nil
           (let ((,thunk #'(lambda (,column-width ,column)
                             (declare (ignore-if-unused ,column))
                             ,@body)))
             (declare (dynamic-extent ,thunk))
             (map-column-widths ,thunk ,item ,start ,end ,from-end))))))

  (unless (fboundp 'do-row-heights)  ;; defined in MCL 5.1 patches
    (defmacro do-row-heights ((item row-height &optional (row (gensym))) (&optional start end from-end)
                              &body body)
      (let ((thunk (gensym)))
        `(block nil
           (let ((,thunk #'(lambda (,row-height ,row)
                             (declare (ignore-if-unused ,row))
                             ,@body)))
             (declare (dynamic-extent ,thunk))
             (map-row-heights ,thunk ,item ,start ,end ,from-end))))))

) ; end eval-when

#+(and ccl-5.0 (not ccl-5.2)) ; only required for OSX!
(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defmethod scroll-to-cell ((item table-dialog-item) h &optional v)
  (normalize-h&v h v)
  (let* ((old-top-row (table-top-row item))
         (old-left-column (table-left-column item))
         (rows (table-rows item))
         (columns (table-columns item))
         (visible-end-rows (table-visible-row-count
                            item
                            :end-row rows
                            :from-end t))
         (visible-end-columns (table-visible-column-count
                               item
                               :end-column columns
                               :from-end t))
         (new-top-row (max 0 (min v (- rows visible-end-rows))))
         (new-left-column (max 0 (min h (- columns visible-end-columns))))
         (hscroll (table-hscroll-bar item))
         (vscroll (table-vscroll-bar item))
         (wptr (wptr item)))
    (setf (table-top-row item) new-top-row
          (table-left-column item) new-left-column)
    (when hscroll
      (setf (scroll-bar-setting hscroll) new-left-column))
    (when vscroll
      (setf (scroll-bar-setting vscroll) new-top-row))
    (setf (visible-dimensions-slot item) nil)
    (when wptr
      (with-focused-dialog-item (item)
        (let* ((pos (view-position item))
               (inner-size (table-inner-size item))
               (cell-size (cell-size item))
               (separator-size (separator-size item))
               (cell-size-h (+ (point-h cell-size) (point-h separator-size)))
               (cell-size-v (+ (point-v cell-size) (point-v separator-size)))
               (delta-rows (- old-top-row new-top-row))
               (delta-columns (- old-left-column new-left-column))
               (delta-v 0)
               (delta-h 0))
          (if (row-heights-hash item)
            (cond ((< old-top-row new-top-row)
                   (do-row-heights (item row-height) (old-top-row new-top-row)
                     (decf delta-v row-height)))
                  ((< new-top-row old-top-row)
                   (do-row-heights (item row-height) (new-top-row old-top-row)
                     (incf delta-v row-height))))
            (setq delta-v (* delta-rows cell-size-v)))
          (if (column-widths-hash item)
            (cond ((< old-left-column new-left-column)
                   (do-column-widths (item column-width) (old-left-column new-left-column)
                     (decf delta-h column-width)))
                  ((< new-left-column old-left-column)
                   (do-column-widths (item column-width) (new-left-column old-left-column)
                     (incf delta-h column-width))))
            (setq delta-h (* delta-columns cell-size-h)))
          (rlet ((rect :rect :topleft pos :botright (add-points pos inner-size)))
            (without-interrupts ;; ## only applies to #_scrollrect?
             (let ((container (view-container item)))
               (with-temp-rgns (update-rgn)
                 (get-window-updatergn wptr update-rgn)
                 (unless (#_EmptyRgn update-rgn)
                   (let* ((container-origin (subtract-points (view-origin container) (view-position (view-window container)))))
                     (with-temp-rgns (new-update-rgn item-rgn)
                       (#_CopyRgn update-rgn new-update-rgn)
                       (#_CopyRgn (view-clip-region item) item-rgn)
                       ; Work in the container's coordinate system, since we're already focused on it.
                       ; The windowrecord.updatergn is in global coordinates
                       (#_OffsetRgn new-update-rgn (point-h container-origin) (point-v container-origin))
                       (#_OffsetRgn item-rgn (point-h pos) (point-v pos))
                       (#_SectRgn new-update-rgn item-rgn new-update-rgn)
                       (unless (#_EmptyRgn new-update-rgn)
                         (validate-region container new-update-rgn)
                         (#_OffsetRgn new-update-rgn delta-h delta-v)
                         (#_SectRgn new-update-rgn item-rgn new-update-rgn)
                         (invalidate-region container new-update-rgn))))))
                 (with-temp-rgns (invalid-rgn)
                   (with-temp-rgns (rgn1 rgn2)
                        (#_RectRgn rgn1 rect)
                     (#_insetRect rect 2 2) ; avoids scrolling traces of the likely blended colors of the sides in OSX
                     (#_RectRgn rgn2 rect)
                     (#_DiffRgn rgn1 rgn2 rgn1)
                     (Invalidate-region container rgn1)) ; invalidates the border area
                   (#_ScrollRect rect delta-h delta-v invalid-rgn)                   
                   (Invalidate-region container invalid-rgn))
                 ))))
          ; Could just call compute-selection-regions here, but that makes
          ; scrolling take a long time if there's a large selection.
          ; This code does incremental selection region calculation.
          (let ((selection-region (table-selection-region item))
                (outline-region (table-outline-region item))
                (pos-h (point-h pos))
                (pos-v (point-v pos))
                (inner-size-h (point-h inner-size))
                (inner-size-v (point-v inner-size)))
            (when selection-region
              (#_OffsetRgn selection-region delta-h delta-v)
              (#_OffsetRgn outline-region delta-h delta-v)
              (with-temp-rgns (rgn)
                (#_SetRectRgn rgn
                 (- pos-h cell-size-h)
                 (- pos-v cell-size-v)
                 (+ pos-h inner-size-h cell-size-h)
                 (+ pos-v inner-size-v cell-size-v))
                (#_SectRgn selection-region rgn selection-region)
                (#_SectRgn outline-region rgn outline-region))))
          (let* ((min-column (1- (table-left-column item)))
                 (left-column (table-left-column item))
                 (visible-columns (table-visible-column-count item :start-column left-column :end-column columns))
                 (max-column (+ min-column visible-columns 2))
                 (top-row (table-top-row item))
                 (visible-rows (table-visible-row-count item :start-row top-row :end-row rows))
                 (min-row (1- (table-top-row item)))
                 (max-row (+ min-row visible-rows 2)))
            (if (< delta-rows 0)
              (setq min-row (+ max-row delta-rows))
              (setq max-row (+ min-row delta-rows)))
            (if (< delta-columns 0)
              (setq min-column (+ max-column delta-columns))
              (setq max-column (+ min-column delta-columns)))
            (compute-selection-regions item min-row max-row min-column max-column))))))

#+ccl-5.2 ; may not be needed?
(defmethod scroll-to-cell ((item table-dialog-item) h &optional v)
  (normalize-h&v h v)
  (let* ((old-top-row (table-top-row item))
         (old-left-column (table-left-column item))
         (rows (table-rows item))
         (columns (table-columns item))
         (visible-end-rows (table-visible-row-count
                            item
                            :end-row rows
                            :from-end t))
         (visible-end-columns (table-visible-column-count
                               item
                               :end-column columns
                               :from-end t))
         (new-top-row (max 0 (min v (- rows visible-end-rows))))
         (new-left-column (max 0 (min h (- columns visible-end-columns))))
         (hscroll (table-hscroll-bar item))
         (vscroll (table-vscroll-bar item))
         (wptr (wptr item)))
    (setf (table-top-row item) new-top-row
          (table-left-column item) new-left-column)
    (when hscroll
      (setf (scroll-bar-setting hscroll) new-left-column))
    (when vscroll
      (setf (scroll-bar-setting vscroll) new-top-row))
    (setf (visible-dimensions-slot item) nil)
    (when wptr
      (with-focused-dialog-item (item)
        (let* ((pos (view-position item))
               (inner-size (table-inner-size item))
               (cell-size (cell-size item))
               (separator-size (separator-size item))
               (cell-size-h (+ (point-h cell-size) (point-h separator-size)))
               (cell-size-v (+ (point-v cell-size) (point-v separator-size)))
               (delta-rows (- old-top-row new-top-row))
               (delta-columns (- old-left-column new-left-column))
               (delta-v 0)
               (delta-h 0))
          (if (row-heights-hash item)
            (cond ((< old-top-row new-top-row)
                   (do-row-heights (item row-height) (old-top-row new-top-row)
                     (decf delta-v row-height)))
                  ((< new-top-row old-top-row)
                   (do-row-heights (item row-height) (new-top-row old-top-row)
                     (incf delta-v row-height))))
            (setq delta-v (* delta-rows cell-size-v)))
          (if (column-widths-hash item)
            (cond ((< old-left-column new-left-column)
                   (do-column-widths (item column-width) (old-left-column new-left-column)
                     (decf delta-h column-width)))
                  ((< new-left-column old-left-column)
                   (do-column-widths (item column-width) (new-left-column old-left-column)
                     (incf delta-h column-width))))
            (setq delta-h (* delta-columns cell-size-h)))
          (rlet ((rect :rect :topleft pos :botright (add-points pos inner-size)))
            (without-interrupts
             (let ((container (view-container item)))
               (with-temp-rgns (update-rgn)
                 (get-window-updatergn wptr update-rgn)
                 (unless (#_EmptyRgn update-rgn)
                   (let* ((container-origin (subtract-points (view-origin container) (view-position (view-window container)))))
                     (with-temp-rgns (new-update-rgn item-rgn)
                       (#_CopyRgn update-rgn new-update-rgn)
                       (#_CopyRgn (view-clip-region item) item-rgn)
                       ; Work in the container's coordinate system, since we're already focused on it.
                       ; The windowrecord.updatergn is in global coordinates
                       (#_OffsetRgn new-update-rgn (point-h container-origin) (point-v container-origin))
                       (#_OffsetRgn item-rgn (point-h pos) (point-v pos))
                       (#_SectRgn new-update-rgn item-rgn new-update-rgn)
                       (unless (#_EmptyRgn new-update-rgn)
                         (validate-region container new-update-rgn)
                         (#_OffsetRgn new-update-rgn delta-h delta-v)
                         (#_SectRgn new-update-rgn item-rgn new-update-rgn)
                         (invalidate-region container new-update-rgn))))))
               (if (or (> (abs delta-h) #x7fff)(> (abs delta-v) #x7fff))  ;; actually only needed if osx-p
                 (invalidate-view item)
                 (with-temp-rgns (invalid-rgn)
                   (with-temp-rgns (rgn1 rgn2)
                        (#_RectRgn rgn1 rect)
                     (#_insetRect rect 2 2) ; avoids scrolling traces of the likely blended colors of the sides in OSX
                     (#_RectRgn rgn2 rect)
                     (#_DiffRgn rgn1 rgn2 rgn1)
                     (Invalidate-region container rgn1))
                   (with-back-color (part-color item :body)  ;; << added
                     (#_ScrollRect rect delta-h delta-v invalid-rgn)
                     (Invalidate-region container invalid-rgn))
                   )))))
          ; Could just call compute-selection-regions here, but that makes
          ; scrolling take a long time if there's a large selection.
          ; This code does incremental selection region calculation.
          (let ((selection-region (table-selection-region item))
                (outline-region (table-outline-region item))
                (pos-h (point-h pos))
                (pos-v (point-v pos))
                (inner-size-h (point-h inner-size))
                (inner-size-v (point-v inner-size)))
            (when selection-region
              (#_OffsetRgn selection-region delta-h delta-v)
              (#_OffsetRgn outline-region delta-h delta-v)
              (with-temp-rgns (rgn)
                (#_SetRectRgn rgn
                 (- pos-h cell-size-h)
                 (- pos-v cell-size-v)
                 (+ pos-h inner-size-h cell-size-h)
                 (+ pos-v inner-size-v cell-size-v))
                (#_SectRgn selection-region rgn selection-region)
                (#_SectRgn outline-region rgn outline-region))))
          (let* ((min-column (1- (table-left-column item)))
                 (left-column (table-left-column item))
                 (visible-columns (table-visible-column-count item :start-column left-column :end-column columns))
                 (max-column (+ min-column visible-columns 2))
                 (top-row (table-top-row item))
                 (visible-rows (table-visible-row-count item :start-row top-row :end-row rows))
                 (min-row (1- (table-top-row item)))
                 (max-row (+ min-row visible-rows 2)))
            (if (< delta-rows 0)
              (setq min-row (+ max-row delta-rows))
              (setq max-row (+ min-row delta-rows)))
            (if (< delta-columns 0)
              (setq min-column (+ max-column delta-columns))
              (setq max-column (+ min-column delta-columns)))
            (compute-selection-regions item min-row max-row min-column max-column)))))))


) ; end redefine
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PATCHES THE ARROW DIALOG ITEM FOR APPEARANCE

(in-package :ccl)

;; require appr-table-dialog-item...

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1 ;; renamed to frame-key-handler!
(defun frame-table-item (item &optional pattern #+ccl-5.1 (inset -4))
  (declare (ignore pattern inset item))
  (let* (#+ignore (w (view-window item)))
    (if (appearance-available-p)
     (progn 
       #+ignore
      (with-back-color (slot-value w 'back-color) 
        (with-item-rect (r item)
          ;; Moved drawing of frame to table-dialog-item so that it is always covered.
          (#_DrawThemeFocusRect r
            (and (window-active-p w)(eq item (current-key-handler w))))
          (unless (eq item (current-key-handler w))
            (#_DrawThemeListBoxFrame r 
              (if (window-active-p w) #$kThemeStateActive #$kThemeStateDisabled)))
          )))
      #+ignore
      (when (and w (cdr (key-handler-list w)))      
       (let ((pos (view-position item)))
        (rlet ((rect :rect topleft pos bottomright (add-points pos (view-size item))))
          (#_insetrect :ptr rect :long #@(-4 -4))
          (if (and (window-active-p w)(eq item (current-key-handler w)))
            (rlet ((ps :penstate))
              (#_GetPenState :ptr ps)
              (#_PenPat :ptr *black-pattern*)
              (#_framerect :ptr rect)
              (#_insetrect :ptr rect :long #@(1 1))
              (#_framerect :ptr rect)
              (#_SetPenState :ptr ps))
            (let ((rgn *temp-rgn*)    ; <<
                  (rgn2 *temp-rgn-2*))
              (#_rectrgn rgn rect)
              (#_insetrect :ptr rect :long #@(3 3))
              (#_rectrgn rgn2 rect)
              (#_diffrgn rgn rgn2 rgn)
              (with-back-color (slot-value w 'back-color)  ; why needed?
                (#_erasergn rgn)
                )))))))))

#+(and ccl-5.1 (not ccl-5.2))
(defmethod frame-key-handler ((item table-dialog-item))
  (let* ((w (view-window item)))
    (when (and w (cdr (key-handler-list w)))      
      (let ((pos (view-position item))
            (active-p (window-active-p w)))
        (rlet ((rect :rect topleft pos bottomright (add-points pos (view-size item))))          
          (if (and active-p (eq item (current-key-handler w)))                         
            (progn              
              (#_drawthemefocusrect rect t))
            (progn
              (if (part-color item :frame)              
                (with-fore-color (if (not active-p)
                                   (if (osx-p) *light-gray-color* *gray-color*)  ;; do we like this - NO! 
                                   (or #+ignore (part-color item :frame) *black-color*))
                  (unless active-p
                    (#_setThemeTextColor #$kThemeTextColorDialogInactive (view-pixel-depth item) (view-color-p item)))
                  (#_insetRect rect -1 -1)
                  (#_FrameRect rect)
                  (if (not (osx-p))  (#_insetrect rect 1 1)))
                (progn
                  (#_insetRect rect -1 -1) ;; consider using $kThemeMetricListBoxFrameOutset
                  (#_DrawThemeListBoxFrame rect
                   (if active-p #$kThemeStateActive #$kThemeStateDisabled))))
              (draw-nil-theme-focus-rect w rect))))))))

#+ccl-5.2
(defmethod frame-key-handler ((item table-dialog-item))
  (let* ((w (view-window item)))
    (when (and w (cdr (key-handler-list w)))      
      (let ((pos (view-position item))
            (active-p (window-active-p w)))
        (rlet ((rect :rect topleft pos bottomright (add-points pos (view-size item))))          
          (if (and active-p (eq item (current-key-handler w)))                         
            (progn              
              (#_drawthemefocusrect rect t))
            (progn
              (if (part-color item :frame)               
                (with-fore-color (if (not active-p)
                                   (if t #|(osx-p)|# *light-gray-color* *gray-color*)  ;; do we like this  - NO! 
                                   (or (part-color item :frame) *black-color*))
                  (unless active-p
                    (#_setThemeTextColor #$kThemeTextColorDialogInactive (view-pixel-depth item) (view-color-p item)))
                  (#_insetRect rect -1 -1)
                  (#_FrameRect rect))
                (progn
                  (#_insetRect rect -1 -1) ;; consider using $kThemeMetricListBoxFrameOutset
                  (#_DrawThemeListBoxFrame rect
                   (if active-p #$kThemeStateActive #$kThemeStateDisabled))))
              ;(if (not (osx-p))  (#_insetrect rect 1 1))              
              (draw-nil-theme-focus-rect w rect))))))))

#-ccl-5.1
(defmethod view-draw-contents ((item arrow-dialog-item))
  (call-next-method)
  (let ((w (view-window item)))
    (when  w
      (frame-table-item item))))

(defmethod enter-key-handler :after ((item arrow-dialog-item) new-item)
  (declare (ignore new-item))
  ; (invalidate-view-border item)
  (view-focus-and-draw-contents item))

(defmethod exit-key-handler :after ((item arrow-dialog-item) new-item)
  (declare (ignore new-item))
  ; (invalidate-view-border item)
  (view-focus-and-draw-contents item))

#-ccl-5.1
(defmethod view-corners ((item arrow-dialog-item))
  (if (appearance-available-p)
    (call-next-method)
    #+ignore
    (let ((pos (view-position item)))
      (values
        (subtract-points pos #@(4 4))
        (add-points pos (add-points (view-size item) #@(4 4)))))))

)  ;; end redefine

; (select-item-from-list '(a b c d e f g h i j k l))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LEFT BORDER VIEW (used in Apropos dialog of MCL)

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defmethod view-draw-contents ((v left-border-view))
  (let (#+ignore (color-p (color-or-gray-p (view-window v))))
    (call-next-method)
    (rlet ((rect :rect))
      (rset rect :rect.topleft #@(0 0))
      (rset rect :rect.bottomright (make-point 3 (1- (point-v (view-size v)))))
      (#_DrawThemeSeparator rect (appearance-theme-state v)))
      #+ignore
      (progn
        (#_MoveTo 0 0)
        (with-fore-color (if color-p *white-color* *black-color*)
          (#_LineTo 0 (1- (point-v (view-size v)))))
        (when color-p
          (#_moveto 1 0)
          (with-fore-color *tool-line-color*
            (#_LineTo 1 (1- (point-v (view-size v)))))))))

) ; end redefine

(defmethod view-activate-event-handler :before ((view left-border-view))
  (when (appearance-available-p)
    (invalidate-corners view #@(0 0) (make-point 3 (1- (point-v (view-size view)))) #+ccl-5.0 (osx-p))))

(defmethod view-deactivate-event-handler :before ((view left-border-view))
  (when (appearance-available-p)
    (invalidate-corners view #@(0 0) (make-point 3 (1- (point-v (view-size view)))) #+ccl-5.0 (osx-p))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; UNDERLINED VIEW (used in Trace dialog of MCL)


(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1
(defmethod view-draw-contents ((item underlined-view))  
  (let* ((size (subtract-points (view-size item) #@(1 1)))   ; allow for descenders not to smash into line
         (topleft (view-position item))
         (bottomright (add-points topleft size))
         (bottomleft (add-points topleft (make-point 0 (point-v size))))
         (theme-state (if (draw-active-p item) #$kThemeStateActive #$kThemeStateInactive)))
    (multiple-value-bind (ff ms)(view-font-codes item)
      (with-font-codes ff ms
        (with-back-color (if (view-get (view-window item) 'theme-background) *white-color* nil)
          (with-fore-color *red-color* ; bogus to restore pen
                        (#_SetThemeTextColor 
             (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
             (view-pixel-depth item)
             (view-color-p item))
            (rlet ((rect :rect :topleft (add-points topleft #@(0 1)) :bottomright bottomright))
              (with-cfstrs ((cftext (dialog-item-text item) )) ; use draw-theme-text-box instead?
                (#_Drawthemetextbox cftext #$kThemeCurrentPortFont theme-state t rect #$teFlushDefault *null-ptr*)))
            (rlet ((rect :rect :topleft (subtract-points bottomleft #@(0 2)) :bottomright bottomright))
              (#_DrawThemeSeparator rect theme-state))))))))

#+(and ccl-5.1 (not ccl-5.2)) ; Digitool added much of the functionality in MCL 5.1, but unfortunately, not very well :-(
(defmethod view-draw-contents ((item underlined-view))
   (let* ((size (subtract-points (view-size item) #@(1 1)))   ; allow for descenders not to smash into line
          (topleft (view-position item))
          (bottomright (add-points topleft size))
          (bottomleft (add-points topleft (make-point 0 (point-v size))))
          (theme-state (if (window-active-p (view-window item)) #$kThemeStateActive #$kThemeStateInactive)))
     (multiple-value-bind (ff ms)(view-font-codes item)
         (with-font-codes ff ms
           (progn ;with-back-color (if (theme-background-p item) *white-color* nil)  ;; what??
             (rlet ((rect :rect :topleft (add-points topleft #@(0 1)) :bottomright bottomright))
               ;; ## alternatively cover this by having erase-p on invalidate-view be true by default! 
               (if (osx-p)(#_eraserect rect))  ;; <<<< else sometimes looks like drawn twice in sligtly different positions
               (with-fore-color *red-color* ; bogus to restore pen
                 (#_SetThemeTextColor 
                  (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                  (view-pixel-depth item)
                  (view-color-p item))
                 (with-cfstrs ((cftext (dialog-item-text item) )) ; call draw-theme-text-box instead?
                   (#_Drawthemetextbox cftext #$kThemeCurrentPortFont theme-state t rect #$teFlushDefault *null-ptr*))))
             (rlet ((rect :rect :topleft (subtract-points bottomleft #@(0 2)) :bottomright bottomright))
               (#_DrawThemeSeparator rect 
                (if  T #+ignore (not (osx-p))
                  theme-state
                  ;; osx seems to get states backwards
                  #+ignore ;; better to do what their specs states anyway... but it is just new appearance!
                  (if (eq theme-state #$kthemestateactive) 
                    #$kThemeStateInactive
                    #$kthemestateactive)))))))))

#+ccl-5.2 ; separator is drawn with correct state in MCL 5.2 in OSX 10.4.
(defmethod view-draw-contents ((item underlined-view))
  (let* ((size (subtract-points (view-size item) #@(1 1)))   ; allow for descenders not to smash into line
         (topleft (view-position item))
         (bottomright (add-points topleft size))
         (bottomleft (add-points topleft (make-point 0 (point-v size))))
         (active-p (window-active-p (view-window item)))
         (theme-state (if active-p #$kThemeStateActive #$kThemeStateInactive))
         (fore-color  (text-color item)))
    (with-fore-color fore-color
      (multiple-value-bind (ff ms)(view-font-codes item)
        (with-font-codes ff ms        
          (rlet ((rect :rect :topleft (add-points topleft #@(0 1)) :bottomright bottomright))
            ;(if (osx-p)(#_eraserect rect))  ;; <<<< else sometimes looks like drawn twice in sligtly different positions
            #+ignore
            (draw-string-in-rect (dialog-item-text item) rect :ff ff :ms ms :color (if (not active-p) *gray-color* fore-color))
            #-ignore
            (draw-theme-text-box (dialog-item-text item) rect :left nil active-p)
            )
          (rlet ((rect :rect :topleft (subtract-points bottomleft #@(0 2)) :bottomright bottomright))
            (#_DrawThemeSeparator rect 
             (if nil ;(not (osx-p))
               theme-state
               (if (neq theme-state #$kthemestateactive) 
                 #$kThemeStateInactive
                 #$kthemestateactive)))))))))

) ; end redefine

#-ccl-5.1 ; included in MCL 5.1
(defmethod view-activate-event-handler :before ((item underlined-view))
  #-ccl-5.0
  (when (appearance-available-p)
    (invalidate-view item #+ccl-4.3.5 T))
  #+ccl-5.0
  (invalidate-view item t))

#-ccl-5.1 ; included in MCL 5.1
(defmethod view-deactivate-event-handler :before ((item underlined-view))
  #-ccl-5.0
  (when (appearance-available-p)
    (invalidate-view item #+ccl-4.3.5 T))
  #+ccl-5.0
  (invalidate-view item t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MAKE TITLE BOX DIALOG ITEMS APPEARANCE SAVVY

;; The title box dialog item is in an optional library module used by the MCL Interface Toolkit.
;; I recommend renaming it to group-box-dialog-item in preparation for making a more
;; generalized view for grouping subviews.


(when (find-class 'title-box-dialog-item NIL)

;; new:

(defmethod title-box-offset ((item title-box-dialog-item))
  "The offset for the topleft corner of the title box relative to the corner of the view"
  ;; future version may have secoond value for bottom right offset, if that ever makes sense...
  (if (osx-p)
    (if (plusp (length (dialog-item-text item))) #@(0 8) #@(0 0))
    #@(0 0)))

;; consider integrating into MCL 5.2 version!
(defmethod view-draw-contents ((item title-box-dialog-item))
  (let* ((topleft (view-position item))
         (bottomright (add-points topleft (view-size item)))
         (text (dialog-item-text item)))
     (multiple-value-bind (offset top-offset descent) (label-offset item)
      (rlet ((r :rect 
                :topleft (add-points topleft (make-point (point-h offset) top-offset))
                :bottomright (add-points topleft
                                         (make-point (+ (point-h offset) (title-box-width item) 4)
                                                     (+ (point-v offset) descent)))))
            ; (#_EraseRect :ptr r)
            (rlet ((frame :rect :topleft (add-points topleft (title-box-offset item))
                          :bottomright bottomright))
              (with-temp-rgns (visible-rgn)
                (#_rectRgn visible-rgn frame)
                (when text
                  (with-temp-rgns (title-rgn)
                    (#_rectRgn title-rgn r) 
                    (#_diffRgn visible-rgn title-rgn visible-rgn)))
                (with-clip-region visible-rgn
                  (#_DrawThemePrimaryGroup frame (appearance-theme-state item))
                  #+ignore
                  (#_FrameRect :ptr frame))))
            (when text
              (with-fore-color (if (draw-active-p item) *black-color* *gray-color*)                
                (with-cfstrs ((cftext text)) 
                                    (#_SetThemeTextColor  ;; available with appearance 1.0
                   (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                   (view-pixel-depth item)
                   (view-color-p item))
                  (#_Drawthemetextbox ; carbonLib 1.3/OSX - use draw-theme-text-box instead?
                   cftext #$kThemeCurrentPortFont 
                   (appearance-theme-state item) t r #$tejustcenter *null-ptr*))
                #|(rlet ((r :rect :topleft topleft
                        :bottomright bottomright))          
                (rset r rect.left (+ (rref r rect.left) 4))
                (rset r rect.bottom (+ (rref r rect.top) 2))
                (rset r rect.right (+ (rref r rect.left) 4 (title-box-width item)))
                (#_EraseRect :ptr r) |#
                #+ignore
                (with-pstrs ((p-title text))
                  (#_MoveTo :long (add-points topleft (label-offset item)))
                  (#_DrawString :ptr p-title))))))))

(defun label-offset (title-box-dialog-item)
  "Returns three values: offset, top-vertical-offset and descent, all relative to topleft corner of the view"
  (multiple-value-bind (ff ms) (view-font-codes title-box-dialog-item) ; consider to use with-font-focused-view
    (with-font-codes ff ms
      (rlet ((size :point)
             (baseline :signed-word))
        (with-cfstrs ((cftext (or (dialog-item-text title-box-dialog-item) ""))) 
          (#_GetThemeTextDimensions cftext 
           #$kThemeCurrentPortFont 
           (appearance-theme-state title-box-dialog-item)
           NIL
           size
           baseline))
        (let* ((baseline (%get-signed-word baseline))
               (size (%get-point size))
               (ascent (+ (point-v size) baseline))
               (descent (abs baseline))
               (ascent/2 (floor ascent 2))
               (offset (point-v (title-box-offset title-box-dialog-item))))
          (values (make-point (if (osx-p) 11 6) (+ offset (if (osx-p) (- -3 descent) ascent/2)))
                  (+ offset (if (osx-p) (- -3 ascent descent) (- ascent/2 ascent)))
                  descent))))))

(defun update-title-box-width (item)
  (when (wptr item)
    (multiple-value-bind (ff ms) (view-font-codes item)
    (setf (title-box-width item)
      (if (dialog-item-text item)
        (with-font-codes ff ms ; consider to use with-font-focused-view
          ; should be a function!
          (rlet ((size :point)
                 (baseline :signed-word))
            (with-cfstrs ((cftext (dialog-item-text item))) 
              (#_GetThemeTextDimensions cftext 
               #$kThemeCurrentPortFont 
               (appearance-theme-state item)
               NIL
               size
               baseline))
            (point-h (%get-point size)))
          #+ignore
          (string-width (dialog-item-text item)))
        0)))))

(defmethod view-default-font ((view title-box-dialog-item))
  (sys-font-spec))

(defmethod view-activate-event-handler :before ((item title-box-dialog-item))
  #-ccl-5.0
  (when (not (osx-p))
    (invalidate-view item))
  #+ccl-5.0
  (invalidate-view item (osx-p)))

(defmethod view-deactivate-event-handler :before ((item title-box-dialog-item))
  #-ccl-5.0
  (when (not (osx-p))
    (invalidate-view item))
  #+ccl-5.0
  (invalidate-view item (osx-p)))

) ; end title-box-dialog-item redefinition

#|
(make-instance 'window
  :theme-background T
  :view-subviews
    (list
      (make-dialog-item 'title-box-dialog-item #@(10 15) #@(300 100) "Hello")))
|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SCROLL BAR 

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1
(defmethod view-draw-contents ((item scroll-bar-dialog-item))
  (let* ((handle (dialog-item-handle item))
         #+ignore
         (window (view-window item)))
    (when handle
      (if (#_iscontrolvisible handle)
        (#_Draw1Control handle)
        (#_ShowControl handle))
       #+ignore
        (multiple-value-bind (tl br) (scroll-bar-and-splitter-corners item)          
          (rlet ((rect :rect :topLeft tl :botRight br))
            (let* ((bc (get-back-color window)))
              ;(when (not (eql bc *white-color*))
                (with-back-color bc
                 (#_eraserect rect)));)
            (with-fore-color *dark-gray-color*
              (#_FrameRect rect)))))))

#-ccl-5.1
(defmethod view-activate-event-handler ((item scroll-bar-dialog-item))
  (when (draw-active-p item)
    (let ((handle (dialog-item-handle item))
          (container (view-container item)))
      (with-focused-view container
        (when (dialog-item-enabled-p item)
          (#_ActivateControl handle)) ;; recommended by apple to replace hilitecontrol          
        (unless (#_iscontrolvisible handle)
          ; #_ShowControl is similarly naughty
          (let* ((wptr (#_getcontrolowner handle))
                 (update-rgn *temp-rgn-3*)
                 (temp-rgn *temp-rgn*))
            (declare (dynamic-extent wptr update-rgn)
                     (type macptr wptr update-rgn))
            (progn
              (get-window-updatergn wptr update-rgn)
              (#_showcontrol handle)
              (get-window-updatergn wptr temp-rgn)
              (valid-window-rgn wptr temp-rgn)
              (inval-window-rgn wptr update-rgn)))
            
          (let ((splitter (pane-splitter item)))
            (when splitter (view-draw-contents splitter)))
          (multiple-value-bind (tl br) (scroll-bar-and-splitter-corners item)
            (validate-corners container tl br))))))
;  (call-next-method)
)

#-ccl-5.1
(defmethod view-deactivate-event-handler ((item scroll-bar-dialog-item))
  (let ((handle (dialog-item-handle item))
        (container (view-container item)))
    (when handle
      (with-focused-view container
        (unless (draw-active-p item)
          (#_DeactivateControl handle) ;; recommended by apple to replace hilitecontrol
          (call-next-method))))))


 ) ;end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FRED PANE SPLITTER

;; The black rectangle look of the Fred pane splitters was suggested by the User Interface Guidelines
;; for legacy versions of the MacOS, but doesn't fit as well into Platinum/Aqua. The following implements
;; a pane splitter using embossed lines similar to what is used in the Finder to signify an area for dragging/extending.

;; Consider to use #$kThemeMetricPaneSplitterHeight for the default size of the pane splitter...

#-ccl-5.2
(defun draw-dragger (rect direction &optional (active t)) ; surely there is a better name for this function...
  "Draw a suitable graphics to signify that something can be dragged in the given direction"
  (with-fore-color *red-color* ; just to restore pen
    (let ((highlight (if active
                       #$kThemeBrushButtonActiveDarkHighlight 
                       #$kThemeBrushButtonInactiveDarkHighlight
                       ))
          (shadow (if active
                    #$kThemeBrushBevelActiveDark ; #$kThemeBrushButtonActiveDarkShadow
                    #$kThemeBrushBevelinActiveDark ; #$kThemeBrushButtonInactiveDarkShadow
                    )))
      (ecase direction
        (:vertical
         (do ((left (pref rect :rect.left))
              (right (pref rect :rect.right))
              (top (pref rect :rect.top) (+ top 2)))
             ((>= top (pref rect :rect.bottom)))
           (#_setThemePen highlight 256 t)
           (#_MoveTo left top)
           (#_LineTo right top)             
           (#_setThemePen shadow 256 t)
           (#_MoveTo (1+ left) (1+ top))
           (#_LineTo (1+ right) (1+ top))))
        (:horizontal
         (do ((top (pref rect :rect.top))
              (bottom (pref rect :rect.bottom))
              (left (pref rect :rect.left) (+ left 2)))
             ((>= left (pref rect :rect.right)))
           (#_setThemePen highlight 256 t)
           (#_MoveTo left top)
           (#_LineTo left bottom)             
           (#_setThemePen shadow 256 t)
           (#_MoveTo (1+ left) (1+ top))
           (#_LineTo (1+ left) (1+ bottom))))))))

#+ccl-5.2
(defun draw-dragger (rect direction &optional (active t)) ; surely there is a better name for this function...
  "Draw a suitable graphics to signify that something can be dragged in the given direction"
  (with-fore-color *red-color* ; just to restore pen
    (let ((highlight (if active
                       #$kThemeBrushButtonActiveDarkHighlight 
                       #$kThemeBrushButtonInactiveDarkHighlight
                       ))
          (shadow (if active
                    #$kThemeBrushBevelActiveDark ; #$kThemeBrushButtonActiveDarkShadow
                    #$kThemeBrushBevelinActiveDark ; #$kThemeBrushButtonInactiveDarkShadow
                    )))
      (ecase direction
        (:vertical
         (do ((left (pref rect :rect.left))
              (right (pref rect :rect.right))
              (top (pref rect :rect.top) (+ top 3)))
             ((>= top (pref rect :rect.bottom)))
           (#_setThemePen highlight 256 t)
           (#_MoveTo left top)
           (#_LineTo right top)             
           (#_setThemePen shadow 256 t)
           (#_MoveTo (1+ left) (1+ top))
           (#_LineTo (1+ right) (1+ top))))
        (:horizontal
         (do ((top (pref rect :rect.top))
              (bottom (pref rect :rect.bottom))
              (left (pref rect :rect.left) (+ left 3)))
             ((>= left (pref rect :rect.right)))
           (#_setThemePen highlight 256 t)
           (#_MoveTo left top)
           (#_LineTo left bottom)             
           (#_setThemePen shadow 256 t)
           (#_MoveTo (1+ left) (1+ top))
           (#_LineTo (1+ left) (1+ bottom))))))))


#| Alternative way of drawing the dragger using theme arrows: 
    (ecase direction
      (:vertical
       (let ((middle (floor (+ (pref rect :rect.top) (pref rect :rect.bottom)) 2))
             (split (floor (+ (pref rect :rect.left) (pref rect :rect.right)) 2)))
         (rlet ((toprect :rect 
                         :top (- middle 5)
                              :left (- split 2)
                         :right (+ split 6)
                         :bottom (+ middle 1))
                (botrect :rect
                         :top (+ middle 2)
                         :left (- split 2)
                         :right (+ split 6)
                             :bottom (+ middle 9)))
             (#_DrawThemePopupArrow toprect #$kThemeArrowDown #$kThemeArrow5pt
              (if active #$kThemeStateActive #$kThemeStateInactive) (%null-ptr) 0)
             (#_DrawThemePopupArrow toprect #$kThemeArrowDown #$kThemeArrow5pt
              (if active #$kThemeStateActive #$kThemeStateInactive) (%null-ptr) 0)))))))
|#

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defclass pane-splitter (simple-view)
  ((scrollee :initarg :scrollee 
             :reader scroll-bar-scrollee)
   (direction :initarg :direction :reader scroll-bar-direction)
   (cursor :initarg :cursor :initform :arrow-cursor :accessor pane-splitter-cursor)
   (scroll-bar :initarg :scroll-bar :initform nil :reader scroll-bar)))

; A pane splitter with Aqua colors:

#-ccl-5.1
(defmethod view-draw-contents ((item pane-splitter))
  (with-fore-color (if (draw-active-p item) *black-color* *gray-color*)
    (with-item-rect (r item)
      (when (osx-p)
         (ecase (scroll-bar-direction item)
           (:horizontal
            (decf (pref r :rect.bottom)))
           (:vertical
            (decf (pref r :rect.right)))))
      (#_setThemePen 
       (if (osx-p)
         (if (draw-active-p item) 
           #$kThemeBrushBevelActiveDark ; #$kThemeBrushFocusHighlight
           #$kThemeBrushBevelInactiveDark)
         (if (draw-active-p item) #$kThemeBrushBlack #$kThemeBrushScrollBarDelimiterInactive))
      (view-pixel-depth item) 
       (view-color-p item))
      (#_FillRect r *black-pattern*))))

#+ccl-5.1 ;; code from MCL 5.1b4
(defmethod view-draw-contents ((item pane-splitter))
  (let ((active-p (window-active-p (view-window item))))
    (with-item-rect (r item)
      (ecase (scroll-bar-direction item)
        (:horizontal
         (decf (pref r :rect.bottom)))
        (:vertical
         (decf (pref r :rect.right))))
      (with-fore-color (if active-p *dark-gray-color* *gray-color*)
       (#_setThemePen 
        (if (osx-p)
          (if (draw-active-p item) 
            #$kThemeBrushBevelActiveDark ;; #$kThemeBrushFocusHighlight ; <- nice!
            #$kThemeBrushBevelInactiveDark)
          (if (draw-active-p item) 
            #$kThemeBrushBlack 
            #$kThemeBrushScrollBarDelimiterInactive))
       (view-pixel-depth item) (view-color-p item))
        (#_paintrect r)))))

#+ignore ; experimental
(defmethod view-draw-contents ((item pane-splitter))
  (with-item-rect (r item)
    (rlet ((info :themebuttondrawinfo 
                 :state (if (draw-active-p item) #$kThemeStateActive #$kThemeStateInactive)
                 :value (if nil #$kThemeButtonOn #$kThemeButtonOff) 
                 :adornment (if nil #$kThemeAdornmentDefault #$kThemeAdornmentNone)))
      (#_DrawThemeButton r #$kThemeBevelButton info info (%null-ptr) (%null-ptr) 0))))

#-ccl-5.2
(defmethod view-deactivate-event-handler ((item pane-splitter))
  (invalidate-view item))

#-ccl-5.2
(defmethod view-activate-event-handler ((item pane-splitter))
  (invalidate-view item))


) ; end redefine

;; not all modern pane splitter cursors works under early versions of carbon, but these do:

(defvar *old-left-ps-cursor* *left-ps-cursor*)
(setf *left-ps-cursor* :resize-right-cursor)
(defvar *old-right-ps-cursor* *right-ps-cursor*)
(setf *right-ps-cursor* :resize-left-cursor)

(defvar *old-top-ps-cursor* *top-ps-cursor*)
#+ccl-5.2
(setf *top-ps-cursor* :resize-down-cursor)

(defvar *old-bottom-ps-cursor* *bottom-ps-cursor*)
#+ccl-5.2
(setf *bottom-ps-cursor* :resize-up-cursor)

(defvar *old-vertical-ps-cursor* *vertical-ps-cursor*)
#+ccl-5.2
(setf *vertical-ps-cursor* :resize-up-down-cursor)

(defvar *old-horizontal-ps-cursor* *horizontal-ps-cursor*)
#+ccl-5.2
(setf *horizontal-ps-cursor* :resize-left-right-cursor)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; THEME BRUSHES

(defparameter *theme-brushes-alist* ; just a start...
  `((:focus-highlight-brush . ,#$kThemeBrushFocusHighlight)
    (:button-frame-active-brush . ,#$kThemeBrushButtonFrameActive)
    (:button-frame-inactive-brush . ,#$kThemeBrushButtonFrameInactive)
    (:button-face-active-brush . ,#$kThemeBrushButtonFaceActive)
    (:button-face-inactive-brush . ,#$kThemeBrushButtonFaceInactive)
    (:button-face-pressed-brush . ,#$kThemeBrushButtonFacePressed)
    (:button-active-dark-shadow-brush . ,#$kThemeBrushButtonActiveDarkShadow)
    (:button-active-dark-highlight-brush . ,#$kThemeBrushButtonActiveDarkHighlight)
    (:button-active-light-shadow-brush . ,#$kThemeBrushButtonActiveLightShadow)
    (:button-active-light-highlight-brush . ,#$kThemeBrushButtonActiveLightHighlight)
    (:button-inactive-dark-shadow-brush . ,#$kThemeBrushButtonInactiveDarkShadow)
    (:button-inactive-dark-highlight-brush . ,#$kThemeBrushButtonInactiveDarkHighlight)
    (:button-inactive-light-shadow-brush . ,#$kThemeBrushButtonInactiveLightShadow)
    (:button-inactive-light-highlight-brush . ,#$kThemeBrushButtonInactiveLightHighlight)
    (:button-pressed-dark-shadow-brush . ,#$kThemeBrushButtonPressedDarkShadow)
    (:button-pressed-dark-highlight-brush . ,#$kThemeBrushButtonPressedDarkHighlight)
    (:button-pressed-light-shadow-brush . ,#$kThemeBrushButtonPressedLightShadow)
    (:button-pressed-light-highlight-brush . ,#$kThemeBrushButtonPressedLightHighlight)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 3D BUTTON 
;;
;; Used in the Processes window and elsewhere.
;;
;; Note that the Apple Human User Interface Guidelines recommends Bevel Buttons for such uses...

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defun draw-up-rect (top-left bottom-right highlight-color shadow-color)
  (let* ((h1 (point-h top-left))
         (v1 (point-v top-left))
         (h2 (point-h bottom-right))
         (v2 (point-v bottom-right)))
    (with-fore-color (if (numberp highlight-color) 
                       highlight-color 
                       *white-color*)
      (when (keywordp highlight-color)
        (#_setThemePen (cdr (assoc highlight-color *theme-brushes-alist*)) 256 t)) ; need better depth!
      (#_moveto  h1 v1)
      (#_lineto  h1 v2)
      (with-fore-color (if (numberp shadow-color) 
                         shadow-color 
                         *tool-line-color*)
        (when (keywordp shadow-color)
          (#_setThemePen (cdr (assoc shadow-color *theme-brushes-alist*)) 256 t)) ; need better depth!
        (#_moveto  h2 v1)
        (#_lineto  h2 v2)
        (#_lineto  h1 v2))
      ; (with-fore-color light-color
      (#_moveto  h1 v1)
      (#_lineto  h2 v1))))

(defclass 3d-button (default-button-mixin dialog-item)
  ((pushed-state :initform nil :accessor pushed-state)
   (frame-p :initform #+ccl-5.1 T #-ccl-5.1 nil :initarg :frame-p :accessor frame-p))
  (:default-initargs
    :view-font #-ccl-5.1 :small-system-font #+ccl-5.1 :label-font) ;; Apple HIG recommends the label font for bevel-like buttons
  #+ignore
  (:default-initargs
    :part-color-list `(:back-color ,*tool-back-color* :dark-color ,*tool-line-color*)))

#+ccl-5.1
(defmethod view-default-size ((b 3d-button))
  (let ((text (dialog-item-text b)))
    (if text
      #+ignore
      (multiple-value-bind (ff ms)(view-font-codes b)
        (multiple-value-bind (string-width nlines)
                             (font-codes-string-width-with-eol text ff ms)
          (make-point (+ string-width 12)
                      (+ (* nlines (font-codes-line-height ff ms)) 10))))
      (with-font-focused-view b
        (rlet ((size :point)
               (baseline :signed-word))
          (with-cfstrs ((cftext text)) 
            (#_GetThemeTextDimensions cftext 
             #$kThemeCurrentPortFont 
             (ccl::appearance-theme-state b)
             NIL
             size
             baseline))
          (make-point (+ (point-h (%get-point size)) 12) 
                      (+ (* (1+ (count #\newline text)) (point-v (%get-point size))) 6))))
      #@(60 20))))

;; more compact impleementation:
#-ccl-5.1
(defmethod text-position ((b 3d-button))
  (let* ((size (view-size b))
         (height (point-v size))
         (width (point-h size))
         (text (dialog-item-text b)))
    (multiple-value-bind (ff ms)(view-font-codes b)    
      (multiple-value-bind (a d w l)(font-codes-info ff ms)
        (declare (ignore  a w))
        (multiple-value-bind (string-width nlines)
                             (font-codes-string-width-with-eol text ff ms)
        (make-point (max (ash (- width string-width) -1) 2)
                    (- height (+ (* (1- nlines) (font-codes-line-height ff ms))(+ 3 d l)))))))))

#+(and ccl-5.1 (not ccl-5.2))
(defmethod text-position ((b 3d-button))
  (let* ((size (view-size b))
         (height (point-v size))
         (width (point-h size))
         (text (dialog-item-text b)))
    (with-font-focused-view b
      (rlet ((size :point)
             (baseline :signed-word))
        (with-cfstrs ((cftext text)) 
          (#_GetThemeTextDimensions cftext 
           #$kThemeCurrentPortFont 
           (ccl::appearance-theme-state b)
           NIL
           size
           baseline))
        (make-point
         (max 3 (the fixnum (ash (the fixnum (- width (point-h (%get-point size)))) -1)))
         (ash (the fixnum (- height (* (1+ (count #\newline text)) (point-v (%get-point size))))) -1))))
    #+ignore
    (multiple-value-bind (ff ms)(view-font-codes b)    
      (multiple-value-bind (a d w l)(font-codes-info ff ms)
        (declare (fixnum a d l))
        (declare (ignore  w))
        (multiple-value-bind (string-width nlines)
                             (font-codes-string-width-with-eol text ff ms)
          (declare (fixnum string-width nlines))
          (let* ((line-height (+ a d l))
                 (string-height (* nlines line-height))
                 (height-delta (ash (the fixnum (- height string-height)) -1)))
            (declare (fixnum line-height string-height height-delta))
            (make-point (max 3 (the fixnum (ash (the fixnum (- width string-width)) -1)))
                        (if (plusp height-delta) (the fixnum (+ a height-delta)) a))))))))

(defmethod dark-color ((b 3d-button))
  (or (part-color b :dark-color) 
      (if (draw-active-p b)
        (if (pushed-state b)
          :Button-pressed-Dark-Highlight-brush
          :Button-Active-Dark-Shadow-brush)
        :Button-inactive-Dark-Shadow-brush)))

(defmethod light-color ((b 3d-button))
  (or (part-color b :light-color)
      (if (draw-active-p b)
        (if (pushed-state b)
          :button-pressed-dark-shadow-brush
          :Button-Active-Dark-Highlight-Brush)
        :Button-inactive-Dark-Highlight-Brush)))

(defmethod lighter-color ((b 3d-button))
  (or (part-color b :lighter-color) 
      (if (draw-active-p b)
        (if (pushed-state b)
          :button-pressed-light-shadow-brush
          :Button-Active-Light-Highlight-brush)
        :Button-inactive-Light-Highlight-brush)))

(defmethod darker-color ((b 3d-button))
  (or (part-color b :darker-color) 
      (if (draw-active-p b)
        (if (pushed-state b)
          :button-pressed-light-highlight-brush
          :Button-Active-Light-shadow-brush)
       :Button-inactive-Light-shadow-brush)))

(defmethod frame-color ((b 3d-button))
  (or (part-color b :frame) 
      #+ignore *black-color*
      (if (draw-active-p b)
        :button-frame-active-brush
        :button-frame-inactive-brush)))

(defmethod button-color ((b 3d-button))
  (or (part-color b :back-color)
      (if (draw-active-p b)
        (if (pushed-state b)
          :button-face-pressed-brush
          :button-face-active-brush) 
        :button-face-inactive-brush)))

(defmethod view-draw-contents :before ((item 3d-button))
  "erase area with appropriate color"
  (when (and (view-container item) (view-window item))
    (with-focused-view item
      (rlet ((rect :rect :topleft #@(1 1) 
                   :botright (subtract-points (view-size item) #@(1 1))))
        (let ((back-color (if (and (dialog-item-enabled-p item)
                                   (default-button-p item))
                            (or (button-default-color item) (darker-color item)) ; the darker-color is the same as shadow, so not optimal :-(
                            (or (button-color item) (get-back-color (view-window item))))))
          (with-back-color (if (keywordp back-color)
                             *red-color* ; bogus, just to restore back color                             
                             back-color)
            (when (keywordp back-color)
              (#_SetThemeBackground (cdr (assoc back-color *theme-brushes-alist*))
               (view-pixel-depth item) (view-color-p item)))
            (#_eraserect rect))))
      (when (frame-p item)
        (let ((frame-color (frame-color item))) 
          (with-fore-color (if (numberp frame-color) frame-color *black-color*)
            (when (keywordp frame-color)
              (#_setThemePen (cdr (assoc frame-color *theme-brushes-alist*)) 
               (view-pixel-depth item) (view-color-p item)))  
            (rlet ((rect :rect :topleft #@(0 0) 
                         :botright (view-size item)))
              (#_framerect rect))))))))

#+ccl-5.2 ; Apple HIG recommends bevel buttons for the same purpose as the 3d-button:
(defmethod view-draw-contents ((item 3d-button))
  (with-font-focused-view item
    (rlet ((rect :rect :topleft #@(0 0) :bottomright (view-size item))
           (info :themebuttondrawinfo 
                 :state (if (draw-active-p item) #$kThemeStateActive #$kThemeStateInactive)
                 :value (if (pushed-state item) #$kThemeButtonOn #$kThemeButtonOff) 
                 :adornment (if (default-button-p item) #$kThemeAdornmentDefault #$kThemeAdornmentNone)))
      (#_DrawThemeButton rect #$kThemeBevelButton info info (%null-ptr) (%null-ptr) 0)
      (view-draw-text item (if (pushed-state item) #@(1 1) #@(0 0))))))

(defmethod text-color ((b 3d-button))
  (part-color b :text))

#-ccl-5.2
(defmethod view-draw-text ((item 3d-button) offset)
  (when (and (view-window item) (dialog-item-text item) (string-not-equal (dialog-item-text item)
                                                                          ""))
    ;; text-position is the bottom of the text - the first line thereof
    (let* ((text-pos (add-points offset (text-position item)))
           (max-width (- (point-h (view-size item)) 5)))
      (with-fore-color (or (text-color item) *red-color*)
                       #+ignore
                       (if (and (or (not (dialog-item-enabled-p item))
                                    (not (draw-active-p item))) 
                                (color-or-gray-p item))
                         *gray-color*
                         (or (text-color item)
                              *black-color*))
        (with-back-color *red-color* ; ## likely not needed...
          #+ignore
          (if (and (dialog-item-enabled-p item)
                   (default-button-p item))
            (or (button-default-color item) (darker-color item))
            (or (button-color item) (get-back-color (view-window item))))
          (let* ((curstr (dialog-item-text item))
                 (eol (position #\newline curstr)))
            (if (not eol)
              (progn
                (unless (text-color item)
                                        (#_SetThemeTextColor 
                     ; (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                                          (if (draw-active-p item)
                                              (if (pushed-state item)
                                                  #$kThemeTextColorPushButtonPressed
                                                  #$kThemeTextColorPushButtonActive)
                       #$kThemeTextColorPushButtonInactive)
                     (view-pixel-depth item) (view-color-p item)))
                (rlet ((rect :rect :topleft offset :bottomright (view-size item)))
                  (incf (pref rect :rect.top)
                        (ceiling
                         (- (point-v (view-size item))
                            (font-line-height)
                            1)
                         2))
                  (draw-theme-text-box curstr rect :center :end))
                #+ignore
                (progn
                  (#_moveto :long text-pos)
                  (with-pstrs ((button-string curstr))
                    (#_TruncString max-width button-string #$truncEnd)
                    (#_drawstring button-string))))
              (let* ((v-delta (multiple-value-call 'font-codes-line-height (view-font-codes item)))
                     (vpos (point-v text-pos))
                      (pos 0))
                  (loop
                    (#_moveto :word (point-h text-pos) :word vpos)
                    (with-pstrs ((button-string curstr pos eol))
                      (#_TruncString max-width button-string #$truncEnd) 
                      (#_drawstring button-string))
                    (when (null eol)(return))
                    (setq vpos (+ vpos v-delta))
                    (setq pos  (1+ eol))
                    (setq eol (position #\newline curstr :start pos))
                    )))))))))

#+ccl-5.2
(defmethod view-draw-text ((item 3d-button) offset)
  (when (and (view-window item) (dialog-item-text item) (string-not-equal (dialog-item-text item)
                                                                          ""))
    ;; text-position is the bottom of the text - the first line thereof
    (let* ((pos #@(0 0)) ;(view-position item)) ;; dont scrible outside text region
           (inner-size (subtract-points (view-size item) #@(3 3))))
      (multiple-value-bind (ff ms)(view-font-codes item)
        (rlet ((rect :rect :topleft pos :botright (add-points pos inner-size)))
          (with-clip-rect-intersect rect
            (let* ((text-pos (add-points offset (text-position item)))
                   (fore-color (text-color item) 
                               #+ignore (if (and (not (dialog-item-enabled-p item))(color-or-gray-p item))
                                          *gray-color*
                                          (text-color item)))
                   (back-color (if (and (dialog-item-enabled-p item)
                                        (default-button-p item))
                                 (or (button-default-color item) (darker-color item))
                                 (or (button-color item) (get-back-color (view-window item))))))
 
              (with-back-color (if (numberp back-color) back-color *red-color*)
                #+ignore
                (if (and (dialog-item-enabled-p item)
                         (default-button-p item))
                  (or (button-default-color item) (darker-color item))
                  (or (button-color item) (get-back-color (view-window item))))
                #+ignore
                (unless (text-color item)
                    (setf fore-color NIL)
                                        (#_SetThemeTextColor 
                                          (if (draw-active-p item)
                                              (if (pushed-state item)
                                                  #$kThemeTextColorPushButtonPressed
                                                  #$kThemeTextColorPushButtonActive)
                       #$kThemeTextColorPushButtonInactive)
                     (view-pixel-depth item) (view-color-p item)))
                (unless (text-color item)
                  (rlet ((rgb :rgbcolor))
                                        (#_GetThemeTextColor 
                                          (if (draw-active-p item)
                                              (if (pushed-state item)
                                                  #$kThemeTextColorPushButtonPressed
                                                  #$kThemeTextColorPushButtonActive)
                       #$kThemeTextColorPushButtonInactive)
                     (view-pixel-depth item) (view-color-p item) rgb)
                    (setf fore-color (rgb-to-color (pref rgb :rgbcolor)))))
                (let* ((curstr (dialog-item-text item))) 
                  (#_moveto (point-h text-pos)(point-v text-pos))
                  (grafport-write-unicode curstr 0 (length curstr) ff ms fore-color))                      
                ))))))))


) ; end redefine

(defmethod view-activate-event-handler :before ((item 3d-button))
  (invalidate-view item))

(defmethod view-deactivate-event-handler :before ((item 3d-button))
  (invalidate-view item))

#|
(make-instance 'window
  :theme-background T
  :view-subviews
  (list
   (make-instance '3d-button :view-position #@(5 5) :view-size #@(40 20) :dialog-item-text "hello" 
                  :view-font :small-emphasized-system-font)
   (make-instance '3d-button :view-position #@(50 5) :view-size #@(40 20) :dialog-item-text "hello"
                  :dialog-item-enabled-p T
                  :view-font :system-font)))


(make-instance 'window
  :back-color ccl::*lighter-gray-color*
  :view-subviews
    (list
      (make-instance '3d-button
        :view-size #@(30 40)
        :dialog-item-text "testing
RRR")))
|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; POOF BUTTON

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1
(defmethod view-draw-contents ((p poof-button))
  ;; ## These are almost all the same as for bar-dragger...  
  (with-focused-view p
    (rlet ((r :rect
              :topleft 0
              :bottomright (view-size p)))
      (#_DrawThemePlacard r (appearance-theme-state p))
      #+ignore
      (progn
        (#_FrameRect r)
        (#_insetrect :ptr r :long #@(1 1))      
        (#_eraserect r))
      (cond
       #-alice
       ((osx-p)
        (#_OffsetRect r -1 -1)
        (#_InsetRect r 4 4)
        (decf (pref r :rect.right))
        (draw-dragger r :vertical (draw-active-p p)))
       (T
        (with-fore-color (if (draw-active-p p) *black-color* *gray-color*)
          (#_SetThemeTextColor (if (draw-active-p p) #$kThemeTextColorPlacardActive #$kThemeTextColorPlacardInactive)
           (view-pixel-depth p) (view-color-p p))
          (draw-vertical-dragger)))))))

#+ccl-5.1
(defmethod view-draw-contents ((p poof-button)) 
  (let ((active-p (window-active-p (view-window p))))
    (with-focused-view p
      (with-back-color (if active-p *lighter-gray-color* nil)        
        (rlet ((r :rect
                  :topleft 0
                  :bottomright (view-size p)))
          (#_DrawThemePlacard r (appearance-theme-state p))
          #+ignore
          (progn
            (#_FrameRect r)
            (#_insetrect :ptr r :long #@(1 1))      
            (#_eraserect r))
          (cond
           #-alice
           ((osx-p)
            (#_OffsetRect r -1 -1)
            (#_InsetRect r 4 4)
            (decf (pref r :rect.right))
            (draw-dragger r :vertical (draw-active-p p)))
           (T     
            (with-fore-color (if active-p  *dark-gray-color* *gray-color*)
              (#_SetThemeTextColor (if (draw-active-p p) #$kThemeTextColorPlacardActive #$kThemeTextColorPlacardInactive)
               (view-pixel-depth p) (view-color-p p))       
              ; like draw-vertical-dragger only different - now same
              (draw-vertical-dragger)))))))))

#+ignore ; experimental
(defmethod view-draw-contents ((p poof-button) nil) 
  (let ((mode (logior #$kThemeGrowLeft #$kThemeGrowRight #$kThemeGrowUp #$kThemeGrowDown)))
    (with-focused-view p
      (#_DrawThemeStandaloneGrowBox 
       (cond
        ((= 1 (logand mode #$kThemeGrowLeft))
          #@(16 0))
        (t
         #@(0 0)))
       mode
       nil
       (appearance-theme-state p)))))

(defmethod initialize-instance ((view new-mini-buffer) &key poof-button &aux (size (if (osx-p) #@(15 16) #@(16 16))))
  (call-next-method)
  (when poof-button
    (make-instance 'poof-button
      :view-size size
      :view-position (subtract-points (view-size view) size)
      :view-nick-name 'poof
      :view-container view)))

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BAR DRAGGER

(defun draw-horizontal-dragger ()
  (#_moveto :word 6 :word 4)
  (#_line :long #@(0 6))
  (#_line :long #@(-3 -3))
  (#_line :long #@(2 -2))
  (#_line :long #@(0 3))
  (#_line :long #@(-1 -1))
  (#_moveto :word 9 :word 4)
  (#_line :long #@(0 6))
  (#_line :long #@(3 -3))
  (#_line :long #@(-2 -2))
  (#_line :long #@(0 3))
  (#_line :long #@(1 -1)))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defun draw-vertical-dragger ()
  (#_moveto :word (if (osx-p) 4 5) :word 6)
  (#_line :long #@(6 0))
  (#_line :long #@(-3 -3))
  (#_line :long #@(-2 2))
  (#_line :long #@(3 0))
  (#_line :long #@(-1 -1))
  (#_moveto :word (if (osx-p) 4 5) :word 9)
  (#_line :long #@(6 0))
  (#_line :long #@(-3 3))
  (#_line :long #@(-2 -2))
  (#_line :long #@(3 0))
  (#_line :long #@(-1 1)))

(defmethod view-draw-contents ((view bar-dragger))
  (with-focused-view view
    (rlet ((rect :rect
                   :topleft #@(0 0)
                   :bottomright (if (not (osx-p)) 
                                  (+ (view-size view) #@(1 1))
                                  (view-size view))))
      (#_DrawThemePlacard rect (appearance-theme-state view))
      #+ignore
      (#_eraserect rect)
      (#_InsetRect rect 4 4)
      (#_OffsetRect rect -1 -1)
      (if #-alice (osx-p) #+alice nil
        (draw-dragger rect (dragger-direction view) (draw-active-p view))                 
        (with-fore-color (if (draw-active-p view) *black-color* *gray-color*)
          (#_SetThemeTextColor (if (draw-active-p view) #$kThemeTextColorPlacardActive #$kThemeTextColorPlacardInactive)
           (view-pixel-depth view) (view-color-p view))
          (case (dragger-direction view)
            (:horizontal
             (draw-horizontal-dragger))
            (:vertical
             (draw-vertical-dragger))))))))

#-ccl-5.2
(defmethod view-cursor ((view bar-dragger) where)
  (declare (ignore where))
  (if (eq (dragger-direction view) :vertical)
    *vertical-ps-cursor*
    :resize-left-right-cursor
    #+ignore
    *horizontal-ps-cursor*))

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ELLIPSIZED TEXT DIALOG ITEM 

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1 ; MCL 5.1 seems to fix the problem with truncation (but uses center as default justification)
(defun draw-theme-text-box (text rect &optional (text-justification #$teFlushDefault) truncwhere)
  ;; could add a truncate option and use TruncateThemeText
  (when (keywordp text-justification)
    (setq text-justification
          (case text-justification
            (:center #$tejustcenter)
            (:left #$tejustleft)
            (:right #$tejustright)
            (t #$teFlushDefault))))
  (with-cfstrs ((cftext text))
    (when truncwhere ;; not tested
      (setq truncwhere
          (case truncwhere
            (:end #$truncend)
            (:middle #$truncmiddle)
            (t #$truncend)))
      ;; The CFStringCreateWithCString in with-cfstrs creates an immutable string. It has to be made mutable to be truncated:
      (let ((old cftext)) ; hack...
        (setq cftext (#_CFStringCreateMutableCopy (%null-ptr) 0 cftext))
        (#_CFRelease old))
      (rlet ((foo :boolean))
        (#_TruncateThemeText cftext #$kThemeCurrentPortFont #$Kthemestateactive 
         (- (pref rect :rect.right)(pref rect :rect.left))
         truncwhere
         foo)))       
    (#_Drawthemetextbox cftext #$kThemeCurrentPortFont #$Kthemestateactive t rect text-justification *null-ptr*)))

#+(and ccl-5.0 (not ccl-5.1)) ; only relevant for OSX
(defmethod view-draw-contents ((item ellipsized-text-dialog-item))
  (when (installed-item-p item)
    (with-focused-dialog-item (item)
      (let ((position (view-position item))
            (size (view-size item))
            (handle (dialog-item-handle item)))
        (let ((color-list (slot-value item 'color-list))
              (text-justification (slot-value item 'text-justification))
              (enabled-p (dialog-item-enabled-p item)))
          (rlet ((rect :rect)
                 #+ignore
                 (ps :penstate))
            (rset rect rect.topleft position)
            (rset rect rect.bottomright (add-points position size))          
            ;(setq text-justification
            ;      (or (cdr (assq text-justification
            ;                     '((:left . #.#$tejustleft)
            ;                       (:center . #.#$tejustcenter)
            ;                       (:right . #.#$tejustright))))
            ;          (require-type text-justification 'fixnum)))
            (with-pointers ((tp handle))
              (with-fore-color (getf color-list :text nil)
                (unless (getf color-list :text nil)
                                    (#_SetThemeTextColor 
                   (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                   (view-pixel-depth item) (view-color-p item)))
                ;; use subtle gray cause can't figure out how to draw with theme-background in this case 
                ;; - maybe they won't notice [I did. Terje ;-]
                (with-back-color (or (getf color-list :body nil)
                                     #+ignore (if (and (osx-p)(view-get (view-window item) 'theme-background)) *power-book-back-color*))
                  (#_TextMode (if (or enabled-p (not (getf color-list :text nil))) #$srcCopy #$grayishTextOr)) ;#$srcCopy)
                  (#_EraseRect :ptr rect)
                  (when (compress-text-p item)
                    (#_TextFace (ash 1 #$condense)))
                  (draw-theme-text-box (dialog-item-text item) rect (or text-justification :left) t)
                  ;(draw-ellipsized-text-in-rect tp (#_GetHandleSize handle) rect
                  ;                              text-justification (compress-text-p item))
                  )))
            #+ignore
            (unless enabled-p
              (#_GetPenState ps)
              (#_PenPat *gray-pattern*)
              (#_PenMode 11)
              (#_PaintRect rect)
              (#_SetPenState ps))))))))

#+(and ccl-5.1 (not ccl-5.2))
(defmethod view-draw-contents ((item ellipsized-text-dialog-item))
   (when (installed-item-p item)
     (with-focused-dialog-item (item)
       (let (;(position (view-position item))
             ;(size (view-size item))
             ;(handle (dialog-item-handle item))
             )
         (let ((color-list (slot-value item 'color-list))
               (text-justification (slot-value item 'text-justification))
               (enabled-p (dialog-item-enabled-p item)))
           (with-item-rect (rect item)
             (progn ;with-pointers ((tp handle))
               (with-fore-and-back-color 
                 (getf color-list :text nil)
                 (getf color-list :body nil)
                 (if (getf color-list :text nil)
                   (if (not enabled-p)
                     (#_TextMode #$grayishTextOr))                    
                   (#_SetThemeTextColor 
                    (if (draw-active-p item) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                    (view-pixel-depth item) 
                    (view-color-p item)))
                 (#_EraseRect :ptr rect)
                 (draw-theme-text-box (dialog-item-text item) rect 
                                      (or text-justification :left)
                                      (#+ccl-5.2 compress-text #-ccl-5.2 compress-text-p item))))))))))

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; POP-UP MENU 

;; Compare with code in platinum-pop-up-menu (which should be eliminated?)
;; Also check those for button-dialog-item - can be simplified like below!

#+(and ccl-5.0 (not ccl-5.1)) ;; MCL 5.1 sets this to true by default
(setq *use-pop-up-control* t) ;; Use modern pop-up also forOS9

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.1
(defmethod view-deactivate-event-handler :before ((menu pop-up-menu))
  (when (and (installed-item-p menu)
             (control-handle menu)) ; control-handle may still be NIL even if installed-item-p
    (with-focused-dialog-item (menu)
      (#_DeactivateControl (control-handle menu)))))

#-ccl-5.1
(defmethod view-activate-event-handler :before ((menu pop-up-menu))
  (when (and (installed-item-p menu)
             (menu-enabled-p menu)
             (control-handle menu)) ; control-handle may still be NIL even if installed-item-p
    (with-focused-dialog-item (menu)
      (#_ActivateControl (control-handle menu)))))

) ; end redefine

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TYPE IN MENU
;;

#|From the Apple Human Interface Guidelines:

http://developer.apple.com/documentation/UserExperience/Conceptual/OSXHIGuidelines/XHIGControls/chapter_18_section_3.html#//apple_ref/doc/uid/TP30000359-BAAGGAHH

A combination box  (or combo box) is a text entry field combined with a drop-down list. Combo boxes are useful for displaying a list of likely choices while still allowing the user to type in an item not in the list. 

The user can type any appropriate characters into the text field. If the user types in an item already in the list, or types in a few characters that match the first characters of an item in the list, the item is highlighted when the user opens the list. A user-typed item is not added to the permanent list. 

The user opens the list by pressing or clicking the arrow to the right of the text field. The list is a window that descends from the text field; the window is the same width as the text field plus the arrow box, and has a drop shadow. DonÕt extend the right edge of the list beyond the right edge of the arrow box; if an item is too long, it is truncated. 

When the user selects an item in the list, the item replaces whatever is in the text entry field and the list closes. If the list was opened by pressing the arrow, the user selects an item in the list by dragging to it. If the list was opened by clicking the arrow, the user selects an item by clicking it or by pressing the Up Arrow or Down Arrow keys. The user can accept an item by pressing the Space bar, Enter, or Return. 

If the list is open and the user clicks outside it, including within the text entry field, the list closes. 
|#

#| make the typein-menu in OSX become a combo box? Nope, not supported, despite the following claim:
Carbon: Combo boxes are available in Interface Builder. To create them programmatically, use the HIComboBoxCreate function or DrawThemeButton with the appropriate constant.
See also:
http://developer.apple.com/documentation/Carbon/Conceptual/HIViewDoc/HIView_tasks/chapter_2_section_14.html
Note: HIComboBoxCreate is available in MCL 5.2!
|#

(in-package :ccl)

#+(and ccl-5.0 (not ccl-5.2)) ;; maybe still required on 5.1?
(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defmethod view-size-parts ((view typein-menu))  
  (let* ((size (view-size view))
         (size-v (point-v size))
         (size-h (point-h size))
         (menu (typein-menu-menu view))
         (text (typein-editable-text view))
         (title (menu-item-title menu))
         (title-width 0))
    (multiple-value-bind (ff ms)(view-font-codes view)
      (when (not (eql 0 (length title)))        
        (setq title-width (+ 8 (font-codes-string-width title ff ms))))
      (let* ((menu-h (if (> size-v 16) 22 20)))      
        (set-view-size menu (make-point menu-h  size-v))
        (set-view-size text (make-point (- size-h (+ menu-h 6 title-width)) (- size-v 4)))
        (case (typein-menu-menu-position view)
          (:left (set-view-position menu (make-point title-width 0))
                 (set-view-position text (make-point (+ menu-h 4 title-width ) 2)))
          (t 
           (set-view-position menu (make-point (+  size-h (- menu-h) (if (osx-p) 1 0)) 0))
           (set-view-position text (make-point (+ 2 title-width)  2))))))))

) ; end redefine

#+(and ccl-5.0 (not ccl-5.2)) ; new:
(defmethod view-draw-contents ((menu typein-menu-menu))
  (if (not (osx-p))
    (call-next-method)
    (with-focused-dialog-item (menu)
     ;(with-item-rect (rect menu)
      (rlet ((rect :rect)
             (info :themebuttondrawinfo 
                   :state (if (and (menu-enabled-p menu)
                                   (draw-active-p menu))
                            #$kThemeStateActive 
                            #$kThemeStateInactive)
                   :value #$kThemeButtonOff
                   :adornment #$kThemeAdornmentArrowDoubleArrow))
        (copy-record (pop-up-menu-rect menu) :rect rect)
        (#_EraseRect rect) ;; # maybe not needed
        (#_drawThemeButton rect #$kThemeArrowButton info info (%null-ptr) (%null-ptr) 0)))))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#+(and ccl-5.0 (not ccl-5.2))
(defmethod menu-display-v-offset ((menu typein-menu-menu))
  (case (typein-menu-menu-position (view-container menu))
    ((:right :left)
     (+
      (- (point-v (view-position menu)))
      (point-v (view-position (typein-editable-text (view-container menu))))
      (point-v (view-size (typein-editable-text (view-container menu))))
      5))
    #+ignore
    (:left 2) ; line up with title & text, doesn't cover the control (could erase it oneself)
    (t 2)))

#+(and ccl-5.0 (not ccl-5.2))
(defmethod menu-display-h-offset ((menu typein-menu-menu))
  (case (typein-menu-menu-position (view-container menu))
    (:right
     (- (point-h (view-position (typein-editable-text (view-container menu))))
        (point-h (view-position menu))))
    (:left
     (point-h (view-position (typein-editable-text (view-container menu))))
     )
    #+ignore
    ((:right :left)
     1)
    (t  ; this we probably won't ever use     
     (let* ((text-size (point-h (view-size (typein-editable-text 
                                            (view-container menu))))))       
       (- -5 text-size)))))

) ; end redefine

#+(and ccl-5.0 (not ccl-5.2)) ;; needed as the one on pop-up menu get wrong results due to that it calls menu-display-h-offset:
(defmethod point-in-click-region-p ((menu typein-menu-menu) where)
  (view-contains-point-p menu where))

#+(and ccl-5.0 (not ccl-5.2)) ;; needed as view-draw-contents doesn't use control
(defmethod view-activate-event-handler :after ((menu typein-menu-menu))
  (when (osx-p)
    (invalidate-view menu)))

#+(and ccl-5.0 (not ccl-5.2)) ;; needed as view-draw-contents doesn't use control
(defmethod view-deactivate-event-handler :after ((menu pop-up-menu)) 
  (when (osx-p)
    (invalidate-view menu)))

#|

;; without the patch above, these dialog items aren't properly aligned and might also be clipped:

(make-instance 'window
  ;:theme-background T
  :view-subviews
  (list
   (make-instance 'typein-menu
     :view-position #@(10 10)
     :view-size #@(155 21)
     :menu-items (make-menu-items '("Alpha" "Beta" "Gamma")))
   (make-instance 'typein-menu
     :view-position #@(10 40)
     :view-size #@(155 21))
   (make-instance 'pop-up-menu
     :view-position #@(10 70)
     :view-size #@(155 21))
   (make-instance 'pop-up-menu
     :view-position #@(143 100)
     :view-size #@(22 21))))

|#

;; Make the background stripes of the typein menu match the window background (which wasn't the case for MCL 5.1b4)
;; The problem happened in the trace dialog, where the specializers field had mismatching background stripes.

#| NOT YET READY - GET BACK TO IT FOR MCL 5.1 FINAL IF THE PROBLEM PERSISTS!!!!
#+ccl-5.1 ; new: 
(defmethod install-view-in-window :around ((item pop-up-menu) window)
  (declare (ignore window))
  (call-next-method)
  (let ((handle (control-handle item)))
    (when handle
      (setf (gethash handle handle->dialog-item) item)
      (#_SetControlColorProc handle control-color-proc))))

#+ccl-5.1
(defmethod view-setup-background ((view pop-up-menu) depth color-p)
  (let ((theme-background (window-theme-background (view-window view))))
    (when theme-background
      (with-focused-dialog-item (view (view-window view))
        (#_setThemeBackground #$kThemeBrushModelessDialogBackgroundActive
         depth color-p)))))

         (if (window-active-p (view-window view))
|#

#| This is the culprit from MCL 5.1, disabling it and the example below works fine!

(defmethod view-corners ((view typein-menu)) ;; so the focus rect will show up 
  (multiple-value-bind (tl br)
                       (multiple-value-call  #'inset-corners #@(-4 -4)(call-next-method))
    (if (eq (typein-menu-menu-position view) :left)
      (setq br (add-points br #@(2 0)))
      (setq tl (subtract-points tl #@(2 0))))
    (values tl br)))
|#

#| Without the fix above, this should show the typein-menu with misaligned theme background stripes:

;; ### funny, before loading this file, it works fine in the case below..... view-corners caused it!!!

(make-instance 'window
  :theme-background T
  :view-subviews
  (list
   (make-instance 'typein-menu :view-size #@(200 102))
   (setf foo (make-instance 'typein-menu))
   #+ignore
   (make-instance 'view
     :view-position #@(300 103)
     :view-subviews
     (list
      (make-instance 'pop-up-menu)))))

|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PULL DOWN MENU 

(in-package :ccl)

;; I recommend that the crescent is eliminated from the pull-down menu implementation. 
;; The crescent should be drawn by the command pane, if at all. 
;; Better to draw a triangle next to the pull-down menu to visualize that it is a menu (there is a call to do this in carbon).
;; Better yet to spread the items in the pull down menu in the command pane as done in e.g. Apple's Mail program.
;; I also recommend separating the code for drawing the pull-down menu from the code for the pop-up-menu, as they now diverge.

(let ((*warn-if-redefine* nil))

(defclass pull-down-menu (pop-up-menu)
  ((:crescent :initarg :crescent :initform nil :reader crescent)
   (arrow :initarg :arrow :initform NIL))
  (:default-initargs
    :auto-update-default nil
    :default-item 0))

) ; end redefine

;; view-draw-contents on pull-down-menu can benefit from a good cleaning to eliminate unecessarry code...

; borrowed from method on pop-up-menu in MCL 5.0 - note that this method doesn't exist in 5.1!
#-ccl-5.1
(defmethod view-draw-contents ((menu pull-down-menu))
  (let* ((text (menu-title menu))
         (ti-rect (pop-up-menu-title-rect menu))
         (no-title (or (null  text)(equal text "")))
         (enabled (menu-enabled-p menu))
         (colorp (and (color-or-gray-p menu)(window-color-p (view-window menu))))
         (disabled-color (if (and (not enabled) colorp)
                           *gray-color*))
         (title-color (or disabled-color
                          (part-color menu :menu-title))))
    (with-focused-dialog-item (menu)  ; take font from item, draw in containers coords - this is the other thing that dialog item gives us
      (multiple-value-bind (a d w leading)(view-font-codes-info menu)
        (declare (ignore a w))
        (rlet ((a-rect :rect))
          (copy-record (pop-up-menu-rect menu) :rect a-rect)
          (let ((mi-title (get-menu-body-text menu)))
            (with-fore-color disabled-color
              (unless no-title
                (with-fore-color title-color ; 21-Jun-91 -wkf                
                  (with-back-color (part-color menu :title-background)
                    (#_EraseRect :ptr ti-rect)
                    (#_MoveTo :word (+ (rref ti-rect rect.left) 3) ; (+ (point-h pos) 3)
                     :word (- (rref ti-rect rect.bottom) (+ d leading)))
                    (if (and (osx-p) #+ccl-5.0 (theme-background-p menu) t)
                      (draw-theme-text-box text ti-rect)
                      (with-pstrs ((di-title text))
                        (#_DrawString :ptr di-title))))))
              ;  (#_OffsetRect :ptr a-rect :long #@(0 -1))
              (with-back-color (part-color menu :menu-body) ; 10-Nov-92 -straz
                ;(#_FillRect :ptr a-rect :ptr *white-pattern*)
                ;(when (not (control-handle menu))
                ;  (#_EraseRect a-rect)
                ;  
                ;  )  ;; same as above
                (#_InsetRect :ptr a-rect :long #@(1 1))
                (with-fore-color (or title-color *red-color*)
                  (unless title-color
                    (#_SetThemeTextColor
                           (if (draw-active-p menu) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                           (view-pixel-depth menu) (view-color-p menu)))
                  (let* ((left (+ (rref a-rect rect.left) 6))
                         (right (rref a-rect rect.right))
                         (bottom (rref a-rect rect.bottom)))
                    (#_MoveTo :word left :word  (- bottom (+ leading 1 d)))
                    (with-clip-rect-intersect a-rect
                      (cond
                       (t ;(and (osx-p) (theme-background-p menu))
                        (incf (rref a-rect :rect.left) 3)
                        (unless (osx-p)
                          (#_offsetRect a-rect 0 1))
                        (draw-theme-text-box mi-title a-rect))  ;; will it crop?
                       )
                      (#_MoveTo :word (- right (+ 4 11))
                       :word (- (ash (+ bottom (rref a-rect :rect.top)) -1)
                                2)))))
                (when (slot-value menu 'arrow)
                  (rlet ((bounds :rect 
                                 :top (+ (rref a-rect rect.top) 6)
                                 :left (- (rref a-rect rect.right) 7)
                                 :bottom (rref a-rect rect.bottom)
                                 :right (rref a-rect rect.right)))
                    (#_DrawThemePopupArrow bounds #$kThemeArrowDown #$kThemeArrow5pt
                     (appearance-theme-state menu) (%null-ptr) 0)))))))
        (unless (or enabled colorp)
          (paint-menu-gray menu))))))

#+(and ccl-5.1 (not ccl-5.2)) ; borrowed from method on pop-up-menu in MCL 5.0 - note that this method doesn't exist in 5.1!
(defmethod view-draw-contents ((menu pull-down-menu))
  (let* (;(pos (view-position menu))
         (text (menu-title menu))
         (ti-rect (pop-up-menu-title-rect menu))
         (no-title (or (null  text)(equal text "")))
         (enabled (menu-enabled-p menu))
         (colorp (and (color-or-gray-p menu)(window-color-p (view-window menu))))
         (pull-down-p (pull-down-menu-p menu))
         (disabled-color (if (and (not enabled) colorp)
                           *gray-color*))
         (title-color (or disabled-color
                          (part-color menu :menu-title))))
    (with-focused-dialog-item (menu)  ; take font from item, draw in containers coords - this is the other thing that dialog item gives us
      (multiple-value-bind (a d w leading)(view-font-codes-info menu)
        (declare (ignore a))
        (rlet ((a-rect :rect))
          (copy-record (pop-up-menu-rect menu) :rect a-rect)
          (let ((mi-title (get-menu-body-text menu)))
            (with-fore-color disabled-color
              (unless no-title
                (with-fore-color title-color ; 21-Jun-91 -wkf                
                  (with-back-color (part-color menu :title-background)
                    (#_EraseRect :ptr ti-rect)
                    (#_MoveTo :word (+ (rref ti-rect rect.left) 3) ; (+ (point-h pos) 3)
                     :word (- (rref ti-rect rect.bottom) (+ d leading)))
                    (if (and #|(osx-p)|# (theme-background-p menu))
                      (draw-theme-text-box text ti-rect)
                      (with-pstrs ((di-title text))
                        (#_DrawString :ptr di-title))))))
              ;  (#_OffsetRect :ptr a-rect :long #@(0 -1))
              (with-back-color (part-color menu :menu-body) ; 10-Nov-92 -straz
                ;(#_FillRect :ptr a-rect :ptr *white-pattern*)
                (when (not (control-handle menu))
                  (#_EraseRect a-rect)
                  
                  )  ;; same as above
                
                (cond
                 #+ignore
                 ((not pull-down-p)                       
                       (let ((handle (control-handle menu)))
                         (if handle
                           (progn ;with-focused-view menu
                             ;(push (list menu handle (#_iscontrolvisible handle)) barf)
                               (if (#_iscontrolvisible handle)
                                   (#_Draw1Control handle)
                                   (#_ShowControl handle)))
                           
                           (With-fore-color (part-color menu :menu-frame)
                             (#_FrameRect :ptr a-rect)
                             (#_MoveTo :word (+ (rref a-rect rect.left) 3)
                              :word (rref a-rect rect.bottom))
                             (#_LineTo :word (rref a-rect rect.right)
                              :word (rref a-rect rect.bottom))
                             (#_LineTo :word (rref a-rect rect.right)
                              :word (+ (rref a-rect rect.top) 2))))))
                 ((crescent menu)
                  (let ((tl (rref a-rect rect.topleft)))
                    (#_moveto :long tl)
                    (dolist (length '(5 3 2 1 0 0))
                      (#_line :word length :word 0)
                      (#_move :word (- length) :word 1)))))                                       
                (#_InsetRect :ptr a-rect :long #@(1 1))
                (with-fore-color (or title-color *red-color*)
                  (unless title-color
                    (#_SetThemeTextColor
                     (if (draw-active-p menu) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                     (view-pixel-depth menu) (view-color-p menu)))
                  (let* ((left (+ (rref a-rect rect.left)(if pull-down-p 6 (max 6 w))))
                         (right (rref a-rect rect.right))
                         (bottom (rref a-rect rect.bottom)))
                    (#_MoveTo :word left :word  (- bottom (+ leading 1 d)))
                    (with-clip-rect-intersect a-rect
                      (when (not (control-handle menu))
                        (if (and pull-down-p #|(osx-p)|# (theme-background-p menu))
                          (draw-theme-text-box mi-title a-rect #$tejustcenter t)  ;; will it crop?
                          (draw-string-crop mi-title (- right left (if pull-down-p 0 12)))))
                      (#_MoveTo :word (- right (+ 4 11))
                       :word (- (ash (+ bottom (rref a-rect :rect.top)) -1)
                                2)))))
                ; Draw the little triangle.
                #+ignore
                (when (not (or pull-down-p (control-handle menu))) ;(push 'tri barf)
                  (draw-triangle menu))
                ; draw pull-down menu triangle (consider using this also in the draw-triangle method!)
                (when (slot-value menu 'arrow)
                  (rlet ((bounds :rect 
                                 :top (+ (rref a-rect rect.top) 6)
                                 :left (- (rref a-rect rect.right) 5)
                                 :bottom (rref a-rect rect.bottom)
                                 :right (rref a-rect rect.right)))
                    (#_DrawThemePopupArrow bounds #$kThemeArrowDown #$kThemeArrow5pt
                     (appearance-theme-state menu) (%null-ptr) 0)))))))
        (unless (or enabled colorp)
          (paint-menu-gray menu))))))

#+ccl-5.2
(defmethod view-draw-contents ((menu pull-down-menu))
  (let* ((enabled (menu-enabled-p menu))
         (colorp (and (color-or-gray-p menu)(window-color-p (view-window menu))))
         (disabled-color (if (and (not enabled) colorp)
                           *gray-color*))
         (title-color (or disabled-color
                          (part-color menu :menu-title))))
    (with-focused-dialog-item (menu)  ; take font from item, draw in containers coords - this is the other thing that dialog item gives us
      (multiple-value-bind (ff ms)(view-font-codes menu) 
        (draw-menu-title menu)  ;; very unlikely that there is one
        (rlet ((a-rect :rect))
          (copy-record (pop-up-menu-rect menu) :rect a-rect)
          (let ((mi-title (get-menu-body-text menu)))
            (with-back-color (part-color menu :menu-body) ; 10-Nov-92 -straz
              (#_EraseRect a-rect)
              (cond ((crescent menu)
                     (let ((tl (rref a-rect rect.topleft)))
                       (#_moveto (point-h tl)(point-v tl))
                       (dolist (length '(5 3 2 1 0 0))
                         (#_line length 0)
                         (#_move (- length) 1)))))
              (progn ;with-fore-color title-color ;; draw-string does it
                  (unless (part-color menu :menu-title)
                    #+ignore
                    (#_SetThemeTextColor
                     (if (draw-active-p menu) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                     (view-pixel-depth menu) (view-color-p menu))
                    (rlet ((rgb :rgbcolor))
                      (#_GetThemeTextColor
                       (if (draw-active-p menu) #$kThemeTextColorDialogActive #$kThemeTextColorDialogInactive)
                       (view-pixel-depth menu) (view-color-p menu) rgb)
                      (setf title-color (rgb-to-color (pref rgb :rgbcolor)))))
                (let* ((left (+ (rref a-rect rect.left) 7)))
                  (progn ;with-clip-rect-intersect a-rect  ;;draw-string does it
                    (setf (pref a-rect :rect.left) left)
                    (incf (pref a-rect :rect.top) 2)
                    (draw-string-in-rect mi-title  a-rect :ff ff :ms ms :color title-color))
                  ; draw pull-down menu triangle (consider using this also in the draw-triangle method!)
                  (when (slot-value menu 'arrow)
                    (rlet ((bounds :rect 
                                   :top (+ (rref a-rect rect.top) 6)
                                   :left (- (rref a-rect rect.right) 5)
                                   :bottom (rref a-rect rect.bottom)
                                   :right (rref a-rect rect.right)))
                      (#_DrawThemePopupArrow bounds #$kThemeArrowDown #$kThemeArrow5pt
                       (appearance-theme-state menu) (%null-ptr) 0)))
                  )))))               
        (unless (or enabled colorp)
          (paint-menu-gray menu))))))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.2
;; ripped from MCL 5
(defmethod view-click-event-handler ((menu pull-down-menu) where)
  (declare (ignore where))
  (when (menu-enabled-p menu)
    (multiple-value-bind (a d w leading) (view-font-codes-info menu)
      (declare (ignore a w))
      (with-focused-dialog-item (menu)  ; << focus she said
        (let ((orig-back (or (part-color menu :menu-body) *white-color*))
              (orig-fore  (or (part-color menu :menu-title) *black-color*)))
          (with-back-color orig-fore
            (with-fore-color orig-back
              (#_SetThemeTextColor #$kThemeTextColorRootMenuSelected 
               (view-pixel-depth menu) (view-color-p menu))
              (let* ((rect (pop-up-menu-rect menu))
                     (mi-title (get-menu-body-text menu))
                     (left (+ (rref rect rect.left) 7))  ;(if pull-down-p 6 (max 6 w))))
                     #+ignore
                     (right (rref rect rect.right))
                     (bottom (rref rect rect.bottom)))
                #+ignore 
                (#_Eraserect rect) 
              (#_DrawThemeMenuTitle rect rect #$kThemeMenuSelected 0 (%null-ptr) 0)           
                (#_moveto :word left :word  (- bottom (+ leading 2 d)))              
                (with-clip-rect-intersect rect
                  (rlet ((a-rect :rect))
                      (copy-record (pop-up-menu-rect menu) :rect a-rect)
                      (#_InsetRect :ptr a-rect :long #@(1 1))
                      (incf (rref a-rect :rect.left) 3) 
                      (unless (osx-p)
                        (#_offsetRect a-rect 0 1))                  
                      (draw-theme-text-box mi-title a-rect))
                   #+ignore
                   (draw-string-crop mi-title (- right left))))))) ; (if pull-down-p 0 12)))))))
        (menu-select menu 0)))))

#+ccl-5.2 ; code from MCL 5.2
(defmethod view-click-event-handler ((menu pull-down-menu) where)
  (declare (ignore where))
  (when (menu-enabled-p menu)
    (multiple-value-bind (ff ms)(view-font-codes menu)
      (with-focused-dialog-item (menu)  ; << focus she said
        ;; redraw with back-color black and fore-color white, or fore and back switched?
        (let ((orig-back (or (part-color menu :menu-body) #+ignore *white-color*))
              (orig-fore  (or (part-color menu :menu-title) #+ignore *black-color*)))
          (rlet ((rect :rect))
            (copy-record (pop-up-menu-rect menu) :rect rect)
            (with-back-color orig-fore
              #+ignore
              (#_SetThemeTextColor #$kThemeTextColorRootMenuSelected 
                 (view-pixel-depth menu) (view-color-p menu))
            (rlet ((rgb :rgbcolor))
                 (#_GetThemeTextColor #$kThemeTextColorRootMenuSelected 
                  (view-pixel-depth menu) (view-color-p menu) rgb)
                 (setf orig-back (rgb-to-color (pref rgb :rgbcolor))))
              (let* ((mi-title (get-menu-body-text menu))
                     (left (+ (rref rect rect.left) 7))  ;(if pull-down-p 6 (max 6 w))))
                     )
                #+ignore
                (#_Eraserect rect)
                (with-clip-rect-intersect rect
                (#_DrawThemeMenuTitle rect rect #$kThemeMenuSelected 0 (%null-ptr) 0))
                (progn ;with-clip-rect-intersect rect ;; draw-string does it
                  (setf (pref rect :rect.left) left) 
                  (incf (pref rect :rect.top) 2)
                  (draw-string-in-rect mi-title  rect :ff ff :ms ms :color orig-back)
                  )))))
        (menu-select menu 0)))))

) ; end redefine

; new:
(defmethod view-default-size ((menu pull-down-menu))
  ;; allow space for the triangle:
  (with-font-focused-view menu
    (rlet ((size :point)
           (baseline :signed-word))
      (with-cfstrs ((cftext (ccl::get-menu-body-text menu))) 
        (#_GetThemeTextDimensions cftext 
         #$kThemeCurrentPortFont 
         (ccl::appearance-theme-state menu)
         NIL
         size
         baseline))
      (make-point (+ (point-h (%get-point size)) 15) 
                  (point-v (call-next-method))))))

#|
(make-instance 'window
  :theme-background T
  :view-subviews
  (list
   (make-instance 'pull-down-menu
     :menu-items (make-menu-items '("Alpha" "Beta" "Gamma"))
     )))


|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INSPECTOR, PROCESSES, BACKTRACE WINDOWS

;; For consistency with Aqua, I recommend that the pull-down menu of the command pane is substituted by placing 
;; the command items in the pane bar, with an optional >> at the end for extra items, similar to what is found in Apple's mail program.  

(in-package :inspector)

;; new:

(defmethod view-draw-contents :around ((view command-pane-mixin))
  (progn ; with-back-color (when (appearance-available-p) *red-color*)
    (#_SetThemeBackground #$kThemeBackgroundWindowHeader 
     (ccl::view-pixel-depth view) (ccl::view-color-p view)) ; available with appearance 1.0
    (with-focused-dialog-item (view)
      (ccl::with-item-rect (rect view)
        (unless (osx-p)
          (decf (rref rect rect.top))
          (decf (rref rect rect.left)))
        (#_DrawThemeWindowHeader rect (ccl::appearance-theme-state view))
        (when (osx-p)
          (setf (rref rect rect.top) (- (rref rect rect.bottom) 2))
          (#_DrawThemeSeparator rect (ccl::appearance-theme-state view))
          )))
    (call-next-method)))

;; new:
(defmethod view-deactivate-event-handler :after ((view command-pane-mixin))
  (invalidate-view view (osx-p)))

;; new:
(defmethod view-activate-event-handler :after ((view command-pane-mixin))
  (invalidate-view view (osx-p)))

(let ((*warn-if-redefine* nil))

(defclass command-pane (command-pane-mixin #| bottom-line-mixin |# view)
  ())

) ; end redefine

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

#-ccl-5.2
(defclass inspector-window (undo-view-mixin window)
  ((selected-pane :initform nil :accessor selected-pane)
   (user-title :accessor user-title))
  (:default-initargs 
    :theme-background t
    :window-title nil))

; same functionality, but uses with-highlite-mode.
#-ccl-5.2
(defun %invert-region (rgn)
  ; (#_lmsethilitemode (logand (lognot (ash 1 #$hiliteBit)) (#_lmgethilitemode)))
  (ccl::with-hilite-mode 
    (#_InvertRgn :ptr rgn)))

;; ## better to instead move contents of hilight-selection to view-draw-contents, then make hilight-selection invalidate view?
#-ccl-5.2 ; MCL 5.2 only support osx, so no longer different
(defun set-selection (view new-selection)
  (setf (selection view) new-selection)
  (highlight-selection view)
  (unless (osx-p) ; redraws the selection, as just inverting it doesn't work, but should only invalidate selected area...
    (invalidate-view view)))

#-ccl-5.1
(defclass inspector::inspector-editor (window)
  ((inspector::done-fun :initarg :done-fun :accessor inspector::done-fun)
   (inspector::value :initarg :value :accessor inspector::value)
   (inspector::modcnt :initform -1 :accessor inspector::modcnt))
  (:default-initargs
   :theme-background t
   :WINDOW-TYPE :DOCUMENT
   :view-position ':CENTERED
   :view-size #@(452 175)
   :CLOSE-BOX-P t
   :view-FONT (ccl::sys-font-spec))) ;'("Chicago" 12 :SRCOR :PLAIN)))

(defmethod set-view-size ((pane command-pane-mixin) h &optional v)
  (let* ((size (make-point h v))
         (h (point-h size))         
         (menu (view-named 'command-menu pane))
         ;(button (elt (view-subviews pane) 0))
         ;(mv (if menu (point-v (view-size menu)) 0))
         ;(v (max mv (point-v size) (+ 6 (point-v (view-size button)))))
         )    
    (call-next-method pane h *command-pane-min-height*)
    (adjust-subview-positions pane)
    ; or maybe 0 0
    ; the menu is 2 pixels smaller than the button - phooey
    ; makes the crescent look funny (2 pix white above)
    (when menu 
      (set-view-size menu (point-h (view-size menu))(1- (point-v (view-size pane))))
      (set-view-position menu 0 0)) ; (+ 1 (- v mv))))
    size))

(defmethod add-command-pane-items ((command-pane command-pane) &optional (edit-value-button t))
  (let* ((font :small-system-font) ; '("Geneva" 10 :bold))
         ;(width (+ 8 19 (string-width "Commands" font)))        ; 19 is for the little triangle
         ;(height (+ 5 (font-line-height font))) 
         ;(menu-size (make-point width height))
         (resample-button (make-and-size-dialog-item
                           'ccl::3d-button ;'subtle-button
                           :view-nick-name 'resample-button
                           :frame-p t
                           ; :border-p nil
                           :default-button t
                           :dialog-item-text "Resample"
                           :view-font font
                           :dialog-item-action
                           #'(lambda (item)
                               (resample (view-window item)))))
         ;(button-size (view-size resample-button))
         )
    ;(set-view-size resample-button button-size)    
    (add-subviews command-pane
                  (make-instance 'pull-down-menu
                                 :item-display "Commands"
                                 :view-nick-name 'command-menu
                                 :crescent nil ; t
                                 :arrow T
                                 :view-font :small-system-font ; :small-emphasized-system-font ; font ("Geneva" 10 :bold)
                                 :view-size nil
                                 :menu-items nil
                                 :enabledp nil
                                 :auto-update-default nil
                                 :update-function #'(lambda (menu) 
                                                      (install-commands 
                                                       (view-container menu))))
                  resample-button)
    (when edit-value-button
      (add-subviews command-pane                  
                 (make-instance
                   'ccl::3d-button ;button-dialog-item
                   ;:view-size button-size
                   :view-nick-name 'Edit-button
                   :dialog-item-text "Edit Value"
                   :view-font font
                   ;:border-p nil
                   :frame-p t
                   :dialog-item-action
                   #'(lambda (item)
                       (edit-selection (view-window item))))
                   #|
                  (make-instance
                   'button-dialog-item ;'subtle-button
                    :default-button t
                   :view-size button-size
                   :view-nick-name 'inspect-button
                   :dialog-item-text "Inspect"
                   :view-font font
                   ;:border-p nil
                   :dialog-item-action
                   #'(lambda (item)
                       (inspect-selection (view-window item))))|#
                  ))))

; new:
(defmethod view-draw-contents :around ((pane inspector-pane))
  (if (appearance-available-p)
    (with-back-color *red-color*
      (#_SetThemeBackground #$kThemeBrushListViewBackground 
       (ccl::view-pixel-depth pane) (ccl::view-color-p pane))
      ;; ### Erases visible background on top of view, but perhaps this would be better elsewhere??
      (with-focused-view pane
        (rlet ((rect :rect :topleft #@(0 0) :bottom 3 :right (point-h (view-size pane))))
          (#_eraseRect rect)))
      (call-next-method)
      #+ignore
      (when (and (osx-p)
                 ; ugly... perhaps timely to clean up the class hierarchy...?
                 #+ignore
                 (not (and (typep pane 'backtrace-inspector-pane)
                           (eq (view-nick-name pane) 'stack-pane)))) 
        (with-focused-dialog-item (pane)
          (ccl::with-item-rect (rect pane)
            (#_DrawThemeListBoxFrame rect (ccl::appearance-theme-state pane))))))
    (call-next-method)))

(defun draw-inspector-view-internal (view &optional
                                         (start-line (start-line view)) end-line (vpos 0))
  (let ((inspector (inspector view)))
    (when inspector
      (with-errorfree-printing
        (with-focused-view view             ; simple-view's don't get focused
          (with-back-color *red-color*
            (#_SetThemeBackground #$kThemeBrushListViewBackground 
             (ccl::view-pixel-depth view) (ccl::view-color-p view))
;; In MCL 5.2, actual drawing of the inspector text happens in grafport-write-unicode, called from already-focused-stream-write-string.
;; However, grafport-write-unicode calls a function that uses #_ATSUdrawtext, which appears to not support themes => gray background.
;; Binding *use-quickdraw-for-roman* to T is a hack to avoid ATSUdrawtext and use theme compliant quickdraw instead.
            (let* (#+ccl-5.2 (ccl::*use-quickdraw-for-roman* T)
                   (pretty-p  (pretty-p view))
                   (*print-pretty* pretty-p)
                   (*print-circle* (and pretty-p *print-circle*))
                   (*print-right-margin* 
                    (floor (point-h (view-size view)) (string-width "N")))
                   (cache-p (and (not pretty-p) (cache-p view)))
                   (real-end-line (or end-line (inspector-line-count inspector))))
              (with-preserved-stream-font view
                (set-stream-font view '(:srccopy))
                (catch (page-truncation-tag view)
                  (if (eql 0 vpos)
                    (top-of-page view)
                    (progn
                      (setf (newline-pending? view) nil)
                      (#_MoveTo :word (margin view) :word vpos)))
                  (if cache-p
                    (draw-cached view start-line real-end-line)
                    (draw-uncached view start-line real-end-line))
                  (unless end-line
                    (clear-to-eop view)))))))))))

) ; end warn if redefine

;;;; BACKTRACE:

(let ((*warn-if-redefine* nil))

(defclass backtrace-command-pane (command-pane-mixin #| bottom-line-mixin |# view)
  ())

) ; end redefine 

; new:
(defmethod view-draw-contents :before ((view backtrace-info-pane))
  (with-focused-dialog-item (view)
  (ccl::with-item-rect (rect view)
    (unless (osx-p)
      (decf (rref rect rect.left))
      (incf (rref rect rect.bottom)))      
    (#_DrawThemePlacard rect (ccl::appearance-theme-state view)))))

; new
(defmethod view-deactivate-event-handler :after ((view backtrace-info-pane))
  (invalidate-view view (osx-p)))

; new
(defmethod view-activate-event-handler :after ((view backtrace-info-pane))
  (invalidate-view view (osx-p)))

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

; from MCL 5, still needed in MCL 5.2
(defclass backtrace-window (undo-view-mixin backtrace-view window) ()
  (:default-initargs
    :theme-background T
    :view-size (car *backtrace-sizes*)
    :view-position (cadr *backtrace-sizes*)
    :top-pane-size (caddr *backtrace-sizes*)
    :window-title "Backtrace"))

; The changed constant below is likely the width of a scroller... and should extract this value for more flexibility!
; from MCL 5
(defmethod adjust-subview-positions ((view backtrace-view))
  (let* ((size (view-size view))
         (width (point-h size))
         (height (point-v size))
         (command-pane (view-named 'command-pane view))   ; height unchanged top
         (stack-pane (view-named 'stack-pane view))  ; height unchanged second
         (info-pane (view-named 'info-pane view))  ; height unchanged bottom         
         (stack-frame-pane (view-named 'stack-frame-pane view))
         info-pane-height h v)
    (when (and stack-pane info-pane stack-frame-pane command-pane)   ; NIL on initialize-instance of backtrace-window
      (setq h (point-h (view-position command-pane)))
      (adjust-subview-positions info-pane)
      (setq info-pane-height (point-v (view-size info-pane)))
      (setq v (+ (point-v (view-size command-pane))
                 (point-v (view-size stack-pane))))
      (set-view-size command-pane width (point-v (view-size command-pane)))
      ;(adjust-subview-positions command-pane)
      (set-view-position stack-pane h (point-v (view-size command-pane)))
      (set-view-size stack-pane width (point-v (view-size stack-pane)))
      (set-view-position stack-frame-pane h  v)
      (set-view-size stack-frame-pane width (- height v info-pane-height -3))
      (set-view-position info-pane h (- height info-pane-height))
      (set-view-size info-pane (- width 14)(point-v (view-size info-pane)) ))))

; from MCL 5.0/5.1
(defmethod adjust-subview-positions ((view backtrace-info-pane))
  (let* ((h 6) 
         (labels (label-dialog-items view))
         (value-width (+ 6 (string-width "#xFFFFFFFF" (view-font (car labels))))))
    (do ((labs labels (cdr labs))
         (vals (value-dialog-items view) (cdr vals)))
        ((null labs))
      (let ((lab (car labs))
            (val (car vals)))
        (let ((size (view-default-size lab)))
          (set-view-size lab (subtract-points size (if (osx-p) #@(0 0) #@(0 2))))
          (set-view-position lab h (if (osx-p) 1 2))
          (setq h (+ h (point-h size) ))
          (set-view-position val h (if (osx-p) 1 2))
          (set-view-size val value-width (- (point-v size) (if (osx-p) 0 2)))
          (setq h (+ h value-width )))))
      (set-view-size view  ;; seems to be redundant as superceded by adjust-subview-positions on backtrace-view...
                     (- (point-h (view-size (view-container view))) 17)
                     (point-v (view-size view)))))

; from MCL 5.0/5.1
(defmethod initialize-instance ((view backtrace-view) &rest initargs &key 
                                view-container info (top-pane-size #@(100 82)))
  (declare (dynamic-extent initargs))
  (apply #'call-next-method view :view-container nil initargs)
  (let* ((command-pane (make-instance 'backtrace-command-pane
                         :view-nick-name 'command-pane
                         ;:view-size #@(100 17)
                         :view-container view))
         (stack-inspector (make-instance 'stack-inspector :info info))
         (error-frame (inspector-object stack-inspector))
         (stack-frame-pane (make-instance 'backtrace-inspector-pane
                                          :inspector (make-instance 'stack-frame-inspector
                                                                    :object error-frame)
                                          :pane-splitter :top
                                          :pane-splitter-cursor *arrow-cursor*
                                          :pane-splitter-class 'dragging-pane-splitter
                                          :grow-box-p nil
                                          :view-nick-name 'stack-frame-pane
                                          :view-container view
                                          :help-spec 14072)))    
    (set-view-size command-pane 100 (point-v (view-size (view-named 'menu command-pane))))
    (make-instance 'backtrace-inspector-pane
      :inspector stack-inspector
      :inspector-view-class 'stack-inspector-view
      :pane-splitter :bottom
      :double-bottom-line t
      :pane-splitter-class 'dragging-pane-splitter
      :pane-splitter-cursor *arrow-cursor*
      :pane-splitter-length 8
      :view-size top-pane-size
      :view-nick-name 'stack-pane
      :view-container view
      :cache-p (< (frame-count error-frame) 5000)
      :help-spec 14071)
    (make-instance 'backtrace-info-pane
                   :stack-frame-inspector (inspector stack-frame-pane)
                   :view-nick-name 'info-pane
                   :view-container view
                   :view-size (make-point (point-h top-pane-size) 15)
                   :help-spec 14070)
    (when view-container
      (set-view-container view view-container))))

; From MCL 5
(defmethod initialize-instance ((view backtrace-info-pane) &key)
  (call-next-method)
  (let* ((bfont (if (osx-p) :label-font :small-system-font))
         (font bfont)) ; '("monaco" 9 :bold)
    (setf (label-dialog-items view)
          (list (make-instance 'static-text-dialog-item
                               :dialog-item-text "Size:"
                               :view-font bfont
                               :view-container view
                               :help-spec 14073)
                (make-instance 'static-text-dialog-item
                               :dialog-item-text "PC:"
                               :view-font bfont
                               :view-container view
                               :help-spec 14075)
                (make-instance 'static-text-dialog-item
                               :dialog-item-text "Address:"
                               :view-font bfont
                               :view-container view
                               :help-spec 14074)))
    (setf (value-dialog-items view)
          (list (make-instance 'static-text-dialog-item
                               :dialog-item-text ""
                               :view-nick-name 'frame-size
                               :view-font font
                               :view-container view
                               :help-spec 14073)
                (make-instance 'static-text-dialog-item
                               :dialog-item-text ""
                               :view-nick-name 'program-counter
                               :view-font font
                               :view-container view
                               :help-spec 14075)
                (make-instance 'static-text-dialog-item
                               :dialog-item-text ""
                               :view-nick-name 'frame-address
                               :view-font font
                               :view-container view
                               :help-spec 14074)))))

; From MCL 5.0/5.1
(defmethod initialize-instance ((view backtrace-command-pane) &key)
  (call-next-method)
  (add-subviews view
                (make-instance
                  'ccl::3d-button ;button-dialog-item
                  ;:view-size button-size
                  :view-nick-name 'Edit-button
                  :dialog-item-text "Edit Value"
                  :view-font :small-system-font ; '("geneva" 10 :bold)
                  ;:view-position #@(100 0)
                  ;:border-p nil
                  :dialog-item-enabled-p nil
                  :frame-p t
                  :dialog-item-action
                  #'(lambda (item)
                      (edit-selection
                       (inspector-view
                        (view-named 'stack-frame-pane (view-window item)))))
                  :help-spec 14084))
  (let ((command-menu (make-instance 'pull-down-menu
                        :update-function 'update-backtrace-command-menu
                        :item-display "Commands"
                        :crescent nil ; t
                        :arrow T
                        :view-size nil
                        :view-position #@(1 1)
                        :auto-update-default nil
                        ;:justify :right
                        :view-nick-name 'menu
                        :view-font :small-system-font  ; :small-emphasized-system-font ; '("Geneva" 10 :bold)
                        :view-container view
                        :help-spec 14076)))
    ;(setf (command-menu (view-container view)) command-menu)
    (add-new-item command-menu
                  "Edit Definition"
                  #'(lambda ()
                      (edit-stack-definition
                       (inspector-view
                        (view-named 'stack-pane (view-window command-menu)))))
                  :help-spec 14081)
    (add-new-item command-menu
                  "Inspect Function"
                  #'(lambda ()
                      (inspect-selection
                       (inspector-view (view-named 'stack-pane (view-window command-menu)))))
                  :help-spec 14082)
    (add-new-item command-menu 
                  "Return from frameÉ"
                  #'(lambda () (backtrace-return-from-frame (view-window command-menu)))
                  :help-spec '(14078 1 2))
    (add-new-item command-menu 
                  "Restart frameÉ"
                  #'(lambda () (backtrace-restart-frame (view-window command-menu)))
                  :help-spec '(14079 1 2))
    (add-new-item command-menu
                  "RestartsÉ"
                   #'(lambda () (backtrace-choose-restart (view-window command-menu)))
                  :help-spec 14080)
    (add-new-item command-menu
                  "-"
                  nil
                  :disabled t)
    (add-new-item command-menu
                  "Edit ValueÉ"
                  #'(lambda ()
                      (edit-selection
                       (inspector-view
                        (view-named 'stack-frame-pane (view-window command-menu)))))
                  :help-spec '(14077 1 2))
    (add-new-item command-menu
                  "Inspect Value"
                  #'(lambda ()
                      (inspect-selection
                       (inspector-view (view-named 'stack-frame-pane (view-window command-menu)))))
                  :help-spec 14083)
    (add-new-item command-menu
                  "-"
                  nil
                  :disabled t)
    (add-new-item command-menu
                  "Inspect break condition"
                  #'(lambda ()
                      (inspect
                       (break-condition
                        (inspector-object
                         (find-named-sibling view 'stack-pane))))))
    (flet ((stack-pane-inspector-view (command-view)
             (inspector-view (find-named-sibling command-view 'stack-pane))))
      (let (item)
        (setq item
              (add-new-item command-menu
                            "Show all frames"
                            #'(lambda ()
                                (switch-show-all-frames (stack-pane-inspector-view view)))
                            :update-function
                            #'(lambda ()
                                (update-show-all-frames item (stack-pane-inspector-view view))))))
      (let (item)
        (setq item
              (add-new-item command-menu
                            "Default show all frames"
                            #'(lambda ()
                                (switch-default-show-all-frames (inspector-view (find-named-sibling view 'stack-pane))))
                            :update-function
                            #'(lambda ()
                                (update-default-show-all-frames item))))))))

; new, but should be merged with main method!
(defmethod view-draw-contents :around ((p dragging-pane-splitter))
  ;; Hack to draw the two pane splitters as if they were one dragger... but better to merge them into one instead!
  (let ((top? (eq :bottom (pane-splitter-position (scroll-bar p))))) ; TOP pane splitter (is at bottom of the scroller)...
    (with-focused-view p
      (let ((size (view-size p)))
        (rlet ((rect :rect
                     :top (if top? 0 (- (point-v size)))
                     :left 0
                     :bottom (* (point-v size) (if top? 2 1))
                     :right (- (point-h size) 1)))
          (unless (osx-p)
            (#_insetRect rect -1 -1)
            (incf (rref rect rect.left)))
          (#_DrawThemePlacard rect (ccl::appearance-theme-state p))
          (#_OffsetRect rect (if (osx-p) -1 -2) -1)
          (#_InsetRect rect 4 3)
          (unless (osx-p)
            (incf (rref rect rect.left))
            (#_InsetRect rect 0 1))
          (if (#-alice osx-p)
            (ccl::draw-dragger rect :vertical (ccl::draw-active-p p))
            (let ((origin (view-origin p))
                  (offset (if top? 1 (+ (point-v (view-size p)) 1))))
              (#_setOrigin (point-h origin)(+ (point-v origin) offset))
              (ccl::with-temp-rgns (clip)
                (#_getClip clip)
                (#_OffsetRgn clip 0 (1+ offset))
                (#_setClip clip))
              (with-fore-color (if (ccl::draw-active-p p) *black-color* *gray-color*)
                (#_SetThemeTextColor 
                 (if (ccl::draw-active-p p) #$kThemeTextColorPlacardActive #$kThemeTextColorPlacardInactive)
                 (ccl::view-pixel-depth p) (ccl::view-color-p p))
                (ccl::draw-vertical-dragger))
              )))))))

(defmethod view-draw-contents ((view double-bottom-line))
  (with-focused-dialog-item (view)
    (ccl::with-item-rect (rect view)
      (#_DrawThemeSeparator rect (ccl::appearance-theme-state view))
)))

(defmethod view-activate-event-handler :before ((view double-bottom-line))
  (invalidate-view view #+ccl-5.0 (osx-p)))

(defmethod view-deactivate-event-handler :before ((view double-bottom-line))
  (invalidate-view view #+ccl-5.0 (osx-p)))

) ; end redefine

(in-package :ccl)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FRED COMMANDS WINDOW (ed-help)

(let ((*warn-if-redefine* nil)
      (*warn-if-redefine-kernel* nil))

(defclass key-cap (3d-button)
  ((:down-p :initarg :down-p :initform nil :accessor key-cap-down-p)
   (:key-name :initarg :key-name :initform nil :accessor key-cap-name)
   (:color-list :initarg :part-color-list :initform `(:body ,*white-color*)
                :reader part-color-list))
  (:default-initargs :frame-p T))

(defmethod view-draw-contents ((view key-cap))
  (call-next-method))

; new (at least for MCL 5.1)
(defmethod pushed-state ((view key-cap))
  (key-cap-down-p view))

; new (at least for MCL 5.1)
(defmethod dialog-item-text ((view key-cap))
  (key-cap-name view))

) ; end redefine

#+ccl-5.0 ;; This is just to change the fonts... so fix that in the ed-help definition instead of adding this code to the core!
(defmethod initialize-instance :before ((w ed-help-window) &rest rest &key view-subviews)
  (declare (ignore rest))
  (labels ((update-font (subviews)
             (dolist (view subviews)
               (typecase view
                 (static-text-dialog-item
                  #+ccl-5.2
                  (set-view-font view '("geneva" :plain)) ;; to eliminate the :bold, which persists when setting just :small-system-font
                  (set-view-font view :small-system-font)
                  #+ccl-5.1
                  (when (eq 'fred-title (view-nick-name view))
                    (set-view-position view
                      (add-points (view-position view) #@(0 -1)))))
                 (view
                  (update-font (subviews view)))))))
    (update-font view-subviews)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PREFERENCES DIALOG

#+ccl-5.2 ;; This is just to change the fonts... so fix that in env-dialog!
(defmethod initialize-instance :before ((w prefs-dialog) &rest rest &key view-subviews)
  (declare (ignore rest))
  (labels ((update-font (subviews)
             (dolist (view subviews)
               (typecase view
                 (static-text-dialog-item
                  (set-view-font view '("geneva" :plain)) ;; hack to eliminate the :bold, which persists otherwise!
                  (set-view-font view :small-system-font))
                 (view
                  (update-font (subviews view)))))))
    (update-font view-subviews)))


;; @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;; @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;; OPTIONAL PATCHES TO THE DRAG AND DROP IN THE MCL EXAMPLES FOLDER

;; The drag and drop modules need to be loaded in advance for these to have an effect.
;; (require :drag-and-drop)

(in-package :ccl)

#+drag-and-drop
(defmethod drag-show-drag-hilite ((view drag-view-mixin)
                                  &optional
                                  (topleft nil) (bottomright nil))
  ; # I mentioned this fix to Dan 9/20/97, so it might be included in drag-and-drop after 1.5.5
  ; # Changed February 2, 1999 to no longer use white color as bgcolor, as it suddenly didn't work...
  (let ((region (drag-make-drag-hilite-region view topleft bottomright)))
    (with-focused-view (view-window view)
      (with-back-color (get-back-color (view-window view)) ;; *white-color* ;; required to get hilite for other back-colors! 
        (oserr-check (#_ShowDragHilite (drag-get-drag-reference) region T))))
    (dispose-region region)
    (setf (dr-hilite-p view) t))
  t)

#+drag-and-drop
(defmethod drag-hide-drag-hilite ((view drag-view-mixin))
  (with-focused-view (view-window view)
    (with-back-color 
      (ignore-errors ;; work-around to ignore when the part-color method attempts to access non-existing color-list slot
       (part-color view :body))
      (oserr-check (#_HideDragHilite (drag-get-drag-reference)))))
  (setf (dr-hilite-p view) nil)
  t)

;; @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;; @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
;; OPTIONAL PATCHES TO THE APPEARANCE MANAGER MODULE IN THE MCL EXAMPLES FOLDER

;; Load this file after the appearance manager modules for the patches to take effect.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CLOCK DIALOG ITEM

;; The Clock-dialog-item of the appearance manager no longer has a negative hour right after midnight during daylight savings time.
;; Reported to Digitool October 21 -2003 - included in MCL 5.1b1.

(in-package :ccl)

#-ccl-5.1
(when (module-loaded-p :clock-dialog-items)

(defmethod set-universal-time ((item clock-dialog-item) utime)
  (multiple-value-bind (second minute hour day month year day-of-week dst-p)
                       (decode-universal-time utime)
    (set-control-data item
                      #$kControlClockLongDateTag
                      :LongDateRec
                      :era       1
                      :year      year
                      :month     month
                      :day       day
                      :hour      (if dst-p
                                   (mod (1- hour) 24)
                                   hour)
                      :minute    minute
                      :second    second
                      :dayOfWeek day-of-week))
  utime)

) ; end

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PROGRESS BAR

(in-package :ccl)

; Reported to Digitool on oct-21-2003.
; Covered by new progress-bar-dialog-item by Digitool, which includes it with MCL 5.1.

; Makes sure determinate-p is boolean:

(when (module-loaded-p :tab-bar-view)

#-ccl-5.1
(defmethod set-progress-bar-determinate-p ((item progress-bar-dialog-item)
                                           determinate-p)
  (setf determinate-p (and determinate-p T)) ; ensure boolean to avoid eql problems
  (unless (eql determinate-p (progress-bar-determinate-p item))
    (setf (slot-value item 'determinate-p) determinate-p)
    (set-control-data item
                      #$kControlProgressBarIndeterminateTag
                      :byte
                      (if determinate-p 0 1)))
  determinate-p)

) ; end

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MULTI PANE VIEW

;; Multi-pane-view and Tab-Bar-View are in the Appearance-Manager folder of the Examples of MCL 4.3.5 and later.
;; The following updates these modules to Carbon if they are already loaded.

(when (module-loaded-p :tab-bar-view)

(defmethod initialize-instance ((view multi-pane-view)
                                &rest initargs
                                &key
                                (tab-font :system-font)
                                (tab-bar-height 20))
  (declare (ignore initargs))
  (call-next-method)
  (let ((tab-bar (make-instance 'tab-bar-view
                   :view-position #@(0 0)
                   :view-size     (make-point (point-h (view-size view))
                                              tab-bar-height)
                   :view-font      tab-font)))
    (setf (tab-bar view) tab-bar)
    (set-view-container tab-bar view)))

(defun tab-view-size (&key
                      view 
                      (text (dialog-item-text view))
                      (font (view-font view)))
  (multiple-value-bind (ff ms) (font-codes font)
    #+ignore
    (make-point (+ (font-codes-string-width text ff ms)
                   (* 2 (if (osx-p) 12 (dialog-item-width-correction view))))
                (+ (font-codes-line-height ff ms) (if (osx-p) 4 2)))
    (with-font-codes ff ms
      (rlet ((size :point)
             (baseline :signed-word))
        (with-cfstrs ((cftext text)) 
          (#_GetThemeTextDimensions cftext 
           #$kThemeCurrentPortFont 
           (appearance-theme-state view)
           NIL
           size
           baseline))
        (add-points (%get-point size)
                    (make-point 
                     24 ; (* 2 (if (osx-p) 12 (dialog-item-width-correction view)))
                     (if (osx-p) 4 2)))))))
  
; new:
(add-pascal-upp-alist 'theme-tab-title-proc 
                      #'(lambda (procptr)(#_NewThemeTabTitleDrawUPP procptr)))

; new:
(defpascal theme-tab-title-proc ((:ptr :rect) bounds 
                                 :ThemeTabStyle style
                                 :ThemeTabDirection direction
                                 :word depth
                                 :Boolean isColorDev
                                 :integer userData)
  (declare (ignore style direction direction  userData))
  ; Text color is set by the OS before the call:
  (declare (ignore depth isColorDev))
  (assert *current-view*)
  (with-cfstrs ((cftext (dialog-item-text *current-view*)))
    (let* ((draw-active (window-active-p (view-window *current-view*)))
           (font-height
            (rlet ((size :point)
                   (baseline :signed-word))
              (#_GetThemeTextDimensions cftext 
               #$kThemeCurrentPortFont 
               (if draw-active
                 #$Kthemestateactive
                 #$Kthemestateinactive) 
               NIL
               size
               baseline)
              (point-v (%get-point size))))
          (height (- (rref bounds rect.bottom)
                     (rref bounds rect.top))))
      (rlet ((rect :rect))
        (copy-record bounds :rect rect)
        (#_insetRect rect 0 #+ignore (ash (- height font-height) -1)
         (if (osx-p) 
           (ash (- height font-height) -1)
           -1))
        (#_Drawthemetextbox cftext 
         #$kThemeCurrentPortFont 
         (if draw-active
           #$Kthemestateactive
           #$Kthemestateinactive) 
         t 
         rect 
         #$teCenter
         *null-ptr*)))))

;; new - should be integrated in inner method...
(defmethod view-draw-tab :around ((view tab-view) &optional hilite-p (active-p t))
  (with-focused-dialog-item (view)
    (with-item-rect (rect view)
      ; (#_eraseRect rect)
      (let ((*current-view* view))
      (#_DrawThemeTab rect 
       (if (selected-p view)
         (if active-p
           #$kThemeTabFront
           #$kThemeTabFrontInactive)
         (if active-p
           (if hilite-p
             #$kThemeTabNonFrontPressed
             #$kThemeTabNonFront)
           #$kThemeTabNonFrontInactive))
       #$kThemeTabNorth 
       theme-tab-title-proc
       (if hilite-p 1 0))))))

(defmethod view-activate-event-handler :after ((view tab-view))
  (invalidate-view view t))

(defmethod view-deactivate-event-handler :after ((view tab-view))
  (invalidate-view view t))

(defmethod view-click-event-handler ((view tab-view) where)
  (declare (ignore where))
  (when (and (not (selected-p view))
             (track-button-click view))
    (call-next-method)))

; new:
(defmethod view-contains-point-p ((view tab-view) point)
  (with-item-rect (rect view)
    (with-temp-rgns (rgn) 
      (#_GetThemeTabRegion rect #$kThemeTabFront #$kThemeTabNorth rgn)
      (#_PtInRgn point rgn))))

) ; end changes to tab-bar-view

(when (module-loaded-p :multi-pane-view)

(defmethod view-draw-contents ((view multi-pane-view))
  (with-back-color (or #+(and ccl-4.3.5 (not ccl-5.0)) *red-color*)
    (rlet ((rect :rect 
                   :top (1- (point-v (view-size (tab-bar view))))
                   :left 0
                   :bottomright  (subtract-points (view-size view) #@(1 1))))
        (#_DrawThemeTabPane rect 
         (if (window-active-p (view-window view))
           #$kThemeStateActive 
           #$kThemeStateInactive))
      (unless (osx-p) ;; perhaps even needed under osx! call view-setup-backgrouns instead?
        (#_applyThemeBackground #$kThemeBackgroundTabPane rect
         (if (window-active-p (view-window view))
           #$kThemeStateActive 
           #$kThemeStateInactive)
         (view-pixel-depth view) (view-color-p view))))
      (call-next-method))
    #+ignore
   (progn
    (call-next-method)
    (let ((top (point-v (view-size (tab-bar view))))
          (botright (subtract-points (view-size view) #@(1 1))))
      (with-fore-color *black-color*
        (#_MoveTo :word 0 :word top)
        (#_LineTo :word 0 :word (point-v botright))
        (#_LineTo :long botright)
        (#_LineTo :word (point-h botright) :word top))
      (with-fore-color *white-color*
        (#_MoveTo :word 1 :word top)
        (#_LineTo :word 1 :word (1- (point-v botright))))
      (with-fore-color +shadow-color+
        (#_LineTo :long (subtract-points botright #@(1 1)))
        (#_LineTo :word (1- (point-h botright)) :word top)))))

; new:
(defmethod view-setup-background ((view multi-pane-view) depth color-p)
  (with-item-rect (rect view)
    (#_insetRect rect 1 1)
    (#_ApplyThemeBackground #$kThemeBackgroundTabPane rect (if (draw-active-p view) #$kThemeStateActive  #$kThemeStateInactive) Depth color-p)
    T))

; new:
(defmethod view-corners ((item multi-pane-view))
  (if (osx-p)
    (multiple-value-bind (topleft bottomright)
                         (call-next-method)
      (values
       (subtract-points topleft #@(5 0))
       bottomright))
    (call-next-method)))

(defmethod view-activate-event-handler :after ((view multi-pane-view))
  (invalidate-view view t))

(defmethod view-deactivate-event-handler :after ((view multi-pane-view))
  (invalidate-view view t))

(defmethod view-draw-contents ((view tab-bar-view))
  (call-next-method)
  #+ignore
  (unless (appearance-version 1.1)
    (let* ((view-size (view-size view))
           (line-v (1- (point-v view-size))))
      (#_MoveTo :word 0 :word line-v)
      (#_LineTo :word (1- +initial-tab-h+) :word line-v)
      (#_MoveTo :word (max-tab-h view) :word line-v)
      (#_LineTo :word (1- (point-h view-size)) :word line-v))))

) ; end

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SEPARATOR DIALOG ITEM

;; Separator-Dialog-Item is in the Appearance-Manager folder of the Examples of MCL.
;; The following updates this module to Carbon if it already is loaded.

(when (module-loaded-p :separator-dialog-item)

(defmethod view-activate-event-handler :after ((item separator-dialog-item))
  (invalidate-view item (osx-p)))

(defmethod view-deactivate-event-handler :after ((item separator-dialog-item))
  (invalidate-view item (osx-p)))

#-ccl-5.1 ; has been integrated
(defmethod view-draw-contents ((item separator-dialog-item))
  (declare (function appearance-available-p))
  (with-item-rect (rect item)
    (#_DrawThemeSeparator rect
     (if (window-active-p (view-window item))
          1 ; $kThemeStateActive
          0 ; $kThemeStateDisabled
       ))
    #+ignore
    (let* ((active? (window-active-p (view-window item)) )
           (position (+ (view-position item) #@(0 1)))
           (size (view-size item))
           (bottomright
             (if (< (point-v size)(point-h size))
               (make-point (+ (point-h size) (point-h position) -1) (point-v position))
               (make-point (point-h position) (+ (point-v size) (point-v position) -1)))))
       (with-fore-color (part-color item (if active? :separator-color :disabled-color))
         (#_MoveTo :long position)
         (#_LineTo :long bottomright))
       (with-fore-color (part-color item (if active? :hilite-color :disabled-color))
         (#_MoveTo :long (+ position #@(1 1)))
         (#_LineTo :long (+ bottomright #@(1 1)))))))

) ; end

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLACARD DIALOG ITEM

;; Placard-Dialog-Item is in the Appearance-Manager folder of the Examples of MCL 4.3.5 and later.
;; The following makes it use theme text if it already is loaded.

(when (module-loaded-p :placard-dialog-item)

(defclass placard-dialog-item (new-control-dialog-item)
  ((procid :allocation :class :initform #$kControlPlacardProc)
   (menu :initform NIL :initarg :menu))
  (:default-initargs
   :view-font (if (osx-p) :label-font :small-System-Font) ;; osx guidelines says placards should use either the small system font or the label font for text.
   :view-position #@(0 0)
   :view-size #@(64 16))) ; osx guidelines says placards should be 15 pixels high.

(defmethod view-draw-contents ((item placard-dialog-item))
  (call-next-method)
  (with-font-focused-view item
    (with-fore-color (if (draw-active-p item)
                       *black-color* *gray-color*)
      (let ((fill 0)) ;(floor (- (point-v (view-size item)) (font-line-height)) 2)))
        (rlet ((rect :rect 
                     :topleft (make-point 0 fill) ; (make-point 0  2))
                     :bottomright (subtract-points (view-size item) (make-point 0 fill))))
          (with-cfstrs ((cftext (dialog-item-text item)))
                        (#_SetThemeTextColor (if (draw-active-p item) 
                                                                    #$kThemeTextColorPlacardActive 
                                                                    #$kThemeTextColorPlacardInactive)
                          (view-pixel-depth item) (view-color-p item))
            (#_Drawthemetextbox cftext #$kThemeCurrentPortFont (appearance-theme-state item) t rect #$tejustcenter *null-ptr*))))
        #+ignore
        (with-cstrs ((text (dialog-item-text item)))
          (when text
            (let ((length (length (dialog-item-text item))))
              (#_MoveTo 4 11)
              (#_DrawText text 0 length)))))))

) ; end


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SIMPLE DEMO

#|

(setq *draw-inactive-dialog-items-as-disabled* T)

(make-instance 'window
  :theme-background T
  :back-color *lighter-gray-color*
  :view-subviews
    (list
      (make-dialog-item 'editable-text-dialog-item  #@(10 35) #@(100 14) "Editable Text")
      (make-dialog-item 'static-text-dialog-item #@(10 10) #@(300 16) "This is a demonstration of Appearance")
      (make-dialog-item 'sequence-dialog-item  #@(150 35) #@(90 80) "Sequence" NIL
        :table-sequence '("table" "dialog" "item" "alpha" "beta" 
           "gamma" "delta" "table" "dialog" "item" "alpha" "beta" "gamma" "delta"))
      (make-dialog-item 'arrow-dialog-item  #@(250 35) #@(90 80) "Arrow" NIL
        :table-vscrollp T
        :table-sequence '("arrow" "dialog" "item" "alpha" "beta" 
           "gamma" "delta" "table" "dialog" "item" "alpha" "beta" "gamma" "delta"))
      (make-dialog-item 'scrolling-fred-view  #@(10 65) #@(100 70) "Scrolling Fred")
))

|#

;;;-----------------------
(provide :modern-mcl)