[mcclim-cvs] CVS mcclim/Looks
ahefner
ahefner at common-lisp.net
Sat Dec 23 11:52:27 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Looks
In directory clnet:/tmp/cvs-serv17747/Looks
Modified Files:
pixie.lisp
Log Message:
Further hacking to polish the "pixie" look. Enabled pixie-style menus,
revamped various compose-space and handle-repaint methods. Minor changes
to menu.lisp allowing pixie to customize the decoration of submenu
windows, and to detect when menu buttons are in a vertical menu (versus
the menu bar). Changed drawing of the arrow widget on scroll bars and
submenu buttons to use a small bitmap rather than polygon drawing, as the
polygon drawing was awkward and (due to rounding?) did not look right.
On CLX, Pixie can be invoked as follows:
(setf *default-frame-manager*
(make-instance 'climi::pixie/clx-look :port (find-port)))
--- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/12/19 04:07:15 1.17
+++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2006/12/23 11:52:27 1.18
@@ -14,6 +14,12 @@
;
;;;
+;;; TODO: Add units label to slider pane
+;;; TODO: Matching repaint method for the list pane
+;;; TODO: Is there a locking bug, and does it somehow involve pixie?
+;;; (Or is my computer still haunted?)
+;;; TODO: Colors of buttons in clim-fig are wrong
+
(export '(pixie-look #+clx pixie/clx-look))
(defclass pixie-look (frame-manager) ())
@@ -26,7 +32,6 @@
(type (eql ',abstract-type))
&rest args)
(declare (ignorable fm frame type args))
- (format *trace-output* "~& make-pane-1 ~A => ~A~%" ',abstract-type ',pixie-type)
,(if enabled
`(apply #'make-instance
',pixie-type
@@ -50,13 +55,45 @@
:port (port frame)
args))
+;;; Scroll button patterns
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter +pixie-arrow-pattern+
+ #2a((0 0 0 1 0 0 0)
+ (0 0 1 1 1 0 0)
+ (0 1 1 1 1 1 0)
+ (1 1 1 1 1 1 1)))
+
+ (flet ((rotate (array)
+ (let ((new-array (make-array (reverse (array-dimensions array)))))
+ (dotimes (i (array-dimension array 0))
+ (dotimes (j (array-dimension array 1))
+ (setf (aref new-array j (- (array-dimension array 0) i 1))
+ (aref array i j))))
+ new-array)))
+ (let* ((up +pixie-arrow-pattern+)
+ (right (rotate up))
+ (down (rotate right))
+ (left (rotate down)))
+ (macrolet ((def (var)
+ `(defparameter ,(intern (format nil "~A~A~A"
+ (symbol-name '#:+pixie-)
+ (symbol-name var)
+ (symbol-name '#:-arrow+))
+ (find-package :climi))
+ (make-pattern ,var (list +transparent-ink+ +black+)))))
+ (def up)
+ (def right)
+ (def down)
+ (def left)))))
+
; Standard
; TODO - clean up all of this colour nonsense
; which should involve some sensible ideas about tints vs' inks
-(defclass pixie-gadget () (
- (highlighted :initarg :highlight
+(defclass pixie-gadget ()
+ ((highlighted :initarg :highlight
:initform +gray93+
:reader pane-highlight)
(paper-color :initarg :paper-color
@@ -74,7 +111,6 @@
; Convenience
-
(defun draw-up-box (pane x1 y1 x2 y2 foreground)
(let ((x2 (- x2 1)))
(draw-rectangle* pane x1 y1 x2 y2 :ink foreground)
@@ -112,7 +148,7 @@
(draw-label* pane x1 y1 x2 y2
:ink (pane-inking-color pane)))
-; Highlighting (could the defaults be less horrible?)
+; Highlighting
(defmethod gadget-highlight-background ((gadget pixie-gadget))
+gray93+)
@@ -625,26 +661,17 @@
:border-width 1)
;; draw up arrow
(with-bounding-rectangle* (x1 y1 x2 y2) gadget-up-region
- (if (eq (slot-value pane 'armed) :up)
+ (if (eq (slot-value pane 'armed) :up)
(draw-down-box pane x1 y1 x2 y2 +gray83+)
(draw-up-box pane x1 y1 x2 y2 +gray83+))
;; draw decoration in the region
- ;; for this, we want to have an odd width and height
- (flet ((oddify (v) (let ((v (floor v))) (if (oddp v) v (+ v 1)))))
- (let* ((width (oddify (- x2 x1)))
- (height (oddify (- y2 y1)))
- (arrow (list (make-point (floor (/ (+ x1 x2) 2))
- (floor (+ y1 (* height 5/13))))
- (make-point (floor (+ x1 (* width 4/13)))
- (floor (- y2 (* height 6/13))))
- (make-point (floor (+ x1 (* width 4/13)))
- (floor (- y2 (* height 5/13))))
- (make-point (floor (- x2 (* width 4/13)))
- (floor (- y2 (* height 5/13))))
- (make-point (floor (- x2 (* width 4/13)))
- (floor (- y2 (* height 6/13)))))))
- (draw-polygon pane arrow :filled t :ink +black+))))
- ; old
+ (multiple-value-bind (pattern fudge-x fudge-y)
+ (if (eq (gadget-orientation pane) :vertical)
+ (values +pixie-up-arrow+ -1 1)
+ (values +pixie-left-arrow+ -1 1))
+ (draw-pattern* pane pattern
+ (+ fudge-x (floor (- (+ x1 x2) (pattern-width pattern)) 2))
+ (+ fudge-y (floor (- (+ y1 y2) (pattern-height pattern)) 2)))))
;; draw down arrow
(with-bounding-rectangle* (x1 y1 x2 y2) gadget-down-region
@@ -652,20 +679,13 @@
(draw-down-box pane x1 y1 x2 y2 +gray83+)
(draw-up-box pane x1 y1 x2 y2 +gray83+))
;; draw decoration in the region
- (flet ((oddify (v) (let ((v (floor v))) (if (oddp v) v (+ v 1)))))
- (let* ((width (oddify (- x2 x1)))
- (height (oddify (- y2 y1)))
- (arrow (list (make-point (floor (/ (+ x1 x2) 2))
- (floor (- y2 (* height 5/13))))
- (make-point (floor (+ x1 (* width 4/13)))
- (floor (+ y1 (* height 6/13))))
- (make-point (floor (+ x1 (* width 4/13)))
- (floor (+ y1 (* height 5/13))))
- (make-point (floor (- x2 (* width 4/13)))
- (floor (+ y1 (* height 5/13))))
- (make-point (floor (- x2 (* width 4/13)))
- (floor (+ y1 (* height 6/13)))))))
- (draw-polygon pane arrow :filled t :ink +black+))))
+ (multiple-value-bind (pattern fudge-x fudge-y)
+ (if (eq (gadget-orientation pane) :vertical)
+ (values +pixie-down-arrow+ -1 1)
+ (values +pixie-right-arrow+ -1 2))
+ (draw-pattern* pane pattern
+ (+ fudge-x (floor (- (+ x1 x2) (pattern-width pattern)) 2))
+ (+ fudge-y (floor (- (+ y1 y2) (pattern-height pattern)) 2)))))
;; draw thumb
(with-bounding-rectangle* (x1 y1 x2 y2) gadget-thumb-region
@@ -677,36 +697,43 @@
(defclass pixie-menu-bar-pane (pixie-gadget menu-bar) ())
-; silly menu-bar isn't named pane, so this catches it
-(defclass pixie-menu-bar (pixie-menu-bar-pane) ())
-
-(define-pixie-gadget menu-bar pixie-menu-bar-pane :enabled nil)
+(define-pixie-gadget menu-bar pixie-menu-bar-pane :enabled t)
(defmethod handle-repaint ((pane pixie-menu-bar-pane) region)
(declare (ignore region))
(with-special-choices (pane)
(let* ((region (sheet-region pane))
(frame (polygon-points (bounding-rectangle region))))
- (draw-polygon pane frame :ink +Blue+ :filled t)
+ #+NIL (draw-polygon pane frame :ink +Blue+ :filled t)
(draw-bordered-polygon pane frame :style :outset :border-width 1))))
-(defmethod compose-space ((gadget pixie-menu-bar-pane) &key width height)
- (declare (ignore width height))
- (multiple-value-bind (width min-width max-width height min-height max-height)
- (space-requirement-components (call-next-method))
- (make-space-requirement
- :width width
- :min-width min-width
- :max-width max-width
- :height min-height
- :min-height min-height
- :max-height min-height)))
+(define-pixie-gadget menu-button pixie-menu-button-pane)
-(defclass pixie-menu-button-pane (pixie-gadget menu-button-pane) ()
+(defclass pixie-menu-button-pane (pixie-gadget menu-button-pane)
+ ((left-margin :reader left-margin)
+ (right-margin :reader right-margin))
(:default-initargs
:align-x :left
:align-y :center))
+(defparameter *pixie-menu-button-left-margin* 26)
+(defparameter *pixie-menu-button-right-margin* 26)
+(defparameter *pixie-menubar-item-left-margin* 8)
+(defparameter *pixie-menubar-item-right-margin* 8)
+(defparameter *pixie-menubar-item-spacing* 0)
+
+(defmethod initialize-instance :after ((pane pixie-menu-button-pane)
+ &rest args &key vertical &allow-other-keys)
+ (declare (ignore args))
+ (with-slots (left-margin right-margin) pane
+ (setf (values left-margin right-margin)
+ (if (or (typep (slot-value pane 'client) 'menu-bar)
+ (not vertical))
+ (values *pixie-menubar-item-left-margin* *pixie-menubar-item-right-margin*)
+ (values *pixie-menu-button-left-margin* *pixie-menu-button-right-margin*)))))
+
+;; What even uses this? All the subclasses have their own handle-repaint methods!
+#+NIL
(defmethod handle-repaint ((pane pixie-menu-button-pane) region)
(declare (ignore region))
(with-special-choices (pane)
@@ -724,25 +751,23 @@
:border-width 1)))
(t
(draw-polygon pane frame :filled t :ink (effective-gadget-foreground pane))))
- (draw-label* pane (+ x1 5) y1 x2 y2 :ink (pane-inking-color pane))))))
+ (draw-label* pane (+ x1 (left-margin pane)) y1 (- x2 (right-margin pane)) y2 :ink +red+ #+NIL (pane-inking-color pane))))))
(defmethod compose-space ((gadget pixie-menu-button-pane) &key width height)
(declare (ignore width height))
- (space-requirement+* (space-requirement+* (compose-label-space gadget :wider 5 :higher 10)
- :min-width (* 2 (pane-x-spacing gadget))
- :width (* 2 (pane-x-spacing gadget))
- :max-width +fill+
- :min-height (* 2 (pane-y-spacing gadget))
- :height (* 2 (pane-y-spacing gadget))
- :max-height (* 2 (pane-y-spacing gadget)))
- :min-width (+ 17 (* 2 *3d-border-thickness*))
- :width (+ 17 (* 2 *3d-border-thickness*))
+ (space-requirement+* (compose-label-space gadget
+ :wider (+ (left-margin gadget)
+ (right-margin gadget))
+ :higher (+ 6 (* 2 *3d-border-thickness*)))
+ :min-width 0
+ :width 0
:max-width +fill+
- :min-height (* 2 *3d-border-thickness*)
- :height (* 2 *3d-border-thickness*)
- :max-height (* 2 *3d-border-thickness*)))
+ :min-height 0
+ :height 0
+ :max-height 0))
(defclass pixie-menu-button-leaf-pane (pixie-menu-button-pane menu-button-leaf-pane) ())
+(define-pixie-gadget menu-button-leaf-pane pixie-menu-button-leaf-pane)
(defmethod handle-repaint ((pane pixie-menu-button-leaf-pane) region)
(declare (ignore region))
@@ -759,25 +784,26 @@
:filled t)
(when armed
(draw-edges-lines* pane +white+ 0 0 +black+ (1- w) (1- h)))
- (draw-label* pane (+ x1 8) y1 (- x2 17) y2 :ink +black+))))))))
+ (let ((x1 (+ x1 (left-margin pane)))
+ (x2 (- x2 (right-margin pane))))
+ (if (gadget-active-p pane)
+ (draw-label* pane x1 y1 x2 y2 :ink +black+)
+ (draw-engraved-label* pane x1 y1 x2 y2))))))))))
(defclass pixie-menu-button-submenu-pane (pixie-menu-button-pane menu-button-submenu-pane) ())
+(define-pixie-gadget menu-button-submenu-pane pixie-menu-button-submenu-pane)
+(define-pixie-gadget menu-button-vertical-submenu-pane pixie-menu-button-submenu-pane)
+
+
(defmethod compose-space ((gadget pixie-menu-button-submenu-pane) &key width height)
(declare (ignore width height))
- (space-requirement+* (space-requirement+* (compose-label-space gadget :wider 5 :higher 10)
- :min-width (* 2 (pane-x-spacing gadget))
- :width (* 2 (pane-x-spacing gadget))
- :max-width +fill+
- :min-height (* 2 (pane-y-spacing gadget))
- :height (* 2 (pane-y-spacing gadget))
- :max-height (* 2 (pane-y-spacing gadget)))
- :min-width (+ 17 (* 2 *3d-border-thickness*))
- :width (+ 17 (* 2 *3d-border-thickness*))
- :max-width +fill+
- :min-height (* 2 *3d-border-thickness*)
- :height (* 2 *3d-border-thickness*)
- :max-height (* 2 *3d-border-thickness*)))
+ (if (typep (slot-value gadget 'client) 'menu-bar) ; XXX
+ (compose-label-space gadget
+ :wider (+ (left-margin gadget)
+ (right-margin gadget))
+ :higher 10)
+ (call-next-method)))
(defmethod handle-repaint ((pane pixie-menu-button-submenu-pane) region)
(declare (ignore region))
@@ -793,28 +819,18 @@
:filled t)
(when submenu-frame
(draw-edges-lines* pane +white+ 0 0 +black+ (1- w) (1- h)))
+
+ (if (typep client 'menu-button)
+ (let ((pattern +pixie-right-arrow+))
+ (draw-label* pane (+ x1 (left-margin pane)) y1
+ (- x2 (right-margin pane)) y2 :ink +black+)
+ (draw-pattern* pane pattern (- x2 10) (+ y1 (floor (- h (pattern-height pattern)) 2))))
+ (draw-label* pane
+ (+ x1 (left-margin pane)) y1
+ (- x2 (right-margin pane)) y2
+ :ink +black+)))))))))
+
- (draw-label* pane (+ x1 8) y1 (- x2 17) y2 :ink +black+)
-
- (when (typep client 'menu-button-pane)
- (let* ((x1 (- x2 17))
- (ym (/ (+ y1 y2) 2))
- (y1 (- ym 8))
- (y2 (+ ym 8)))
- (flet ((oddify (v) (let ((v (floor v))) (if (oddp v) v (+ v 1)))))
- (let* ((width (oddify (- x2 x1)))
- (height (oddify (- y2 y1)))
- (arrow (list (make-point (floor (- x2 (* width 5/13)))
- (floor (/ (+ y1 y2) 2)))
- (make-point (floor (+ x1 (* width 6/13)))
- (floor (+ y1 (* height 4/13))))
- (make-point (floor (+ x1 (* width 5/13)))
- (floor (+ y1 (* height 4/13))))
- (make-point (floor (+ x1 (* width 5/13)))
- (floor (- y2 (* height 4/13))))
- (make-point (floor (+ x1 (* width 6/13)))
- (floor (- y2 (* height 4/13)))))))
- (draw-polygon pane arrow :filled t :ink +black+))))))))))))
; Image pane
@@ -823,6 +839,7 @@
; This is just test/proof-of-concept code :]
+#+NIL
(defclass pixie-image-pane (pixie-gadget basic-gadget) (
(image-pathname :initarg :pathname)
(image-mask-pathname :initarg :mask-pathname :initform nil)
@@ -837,6 +854,7 @@
(image-stencil :initform nil)))
; TODO: allow pixmaps to be realized from unrealized media
+#+NIL
(defmethod initialize-instance :after ((pane pixie-image-pane) &rest args)
(declare (ignore args))
(with-slots (image-pathname image-image image-width image-height) pane
@@ -851,6 +869,7 @@
(let* ((data (image:read-image-file image-mask-pathname)))
(setf image-stencil (make-stencil data))))))
+#+NIL
(defmethod handle-repaint ((pane pixie-image-pane) region)
(declare (ignore region))
(with-slots (image-pixmap image-width image-height) pane
@@ -870,6 +889,7 @@
:clipping-region (make-rectangle* 0 0 image-width image-height))))))
(copy-from-pixmap image-pixmap 0 0 image-width image-height pane 0 0)))
+#+NIL
(defmethod compose-space ((pane pixie-image-pane) &key width height)
(declare (ignore width height))
(with-slots (image-width image-height) pane
@@ -1021,13 +1041,30 @@
(pressedp
(draw-down-box pane x1 y1 x2 y2 (effective-gadget-foreground pane)))))))))
+(defclass pixie-submenu-border-pane (submenu-border)
+ ()
+ (:default-initargs :border-width 2))
+
+(define-pixie-gadget submenu-border pixie-submenu-border-pane)
+
+(defmethod handle-repaint ((pane pixie-submenu-border-pane) region)
+ (declare (ignore region))
+ (with-slots (border-width) pane
+ (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)
+ (draw-rectangle* pane x1 y1 x2 y2 :filled nil :ink +black+)
+ ;; Why, having incremented the coordinates, and despite setting
+ ;; the border-width to 2, do I now get a single pixel border ?
+ ;; It's fine, that's the result I want, but an explanation is in order.
+ (draw-bordered-rectangle* pane (1+ x1) (1+ y1) (1- x2) (1- y2)
+ :style :outset
+ :border-width border-width))))
+
; Text Area
(defclass pixie-text-field-pane (text-field-pane) ())
;; Why does pixie need its own text area subclass? Leave it disabled for now.
-; (define-pixie-class text-field-pane pixie-text-field-pane)
-
+(define-pixie-gadget text-field-pane pixie-text-field-pane :enabled nil)
(defmethod initialize-instance :after ((pane pixie-text-field-pane) &rest rest)
(unless (getf rest :normal)
@@ -1052,11 +1089,6 @@
(display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1))
(goatee::redisplay-all (area pane))))))
-
[7 lines skipped]
More information about the Mcclim-cvs
mailing list