* xyzzy lisp : 位置とサイズの操作

また勢いだけで使いそうに無いものを作ってしまった。

---

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "wip/winapi")
  (require "api"))

(provide "geometry")

(in-package "editor")
(export '(maximize-height-window maximize-width-window
          move-to-left-window move-to-top-window move-to-right-window move-to-bottom-window
          move-window
          *geometry-presets-size* *geometry-presets*))

(defvar *geometry-presets-size* *menu-history-max*)
(defvar *geometry-popup-menu* nil)
(unless *geometry-popup-menu*
  (setq *geometry-popup-menu* (create-popup-menu :geometry-popup)))
(define-history-variable *geometry-presets* nil)

; 上下に最大化
(defun maximize-height-window ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (winapi:MoveWindow (get-window-handle)
                       (winapi:RECT-left wr)
                       0
                       (- (winapi:RECT-right wr) (winapi:RECT-left wr))
                       (- (winapi:GetSystemMetrics winapi:SM_CYMAXIMIZED) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME)))
                       1))
  t)

; 左右に最大化
(defun maximize-width-window ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (winapi:MoveWindow (get-window-handle)
                       0
                       (winapi:RECT-top wr)
                       (- (winapi:GetSystemMetrics winapi:SM_CXMAXIMIZED) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME)))
                       (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))
                       1))
  t)

; 左に寄せる
(defun move-to-left-window ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (winapi:MoveWindow (get-window-handle)
                       0
                       (winapi:RECT-top wr)
                       (- (winapi:RECT-right wr) (winapi:RECT-left wr))
                       (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))
                       1))
  t)

; 上に寄せる
(defun move-to-top-window ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (winapi:MoveWindow (get-window-handle)
                       (winapi:RECT-left wr)
                       0
                       (- (winapi:RECT-right wr) (winapi:RECT-left wr))
                       (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))
                       1))
  t)

; 右に寄せる
(defun move-to-right-window ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (winapi:MoveWindow (get-window-handle)
                       (- (winapi:GetSystemMetrics winapi:SM_CXMAXIMIZED) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME)))
                       (winapi:RECT-top wr)
                       (- (winapi:RECT-right wr) (winapi:RECT-left wr))
                       (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))
                       1))
  t)

; 下に寄せる
(defun move-to-bottom-window ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (winapi:MoveWindow (get-window-handle)
                       (winapi:RECT-left wr)
                       (- (winapi:GetSystemMetrics winapi:SM_CYMAXIMIZED) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME)))
                       (- (winapi:RECT-right wr) (winapi:RECT-left wr))
                       (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))
                       1))
  t)

(defun move-window ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (let ((left (winapi:RECT-left wr))
          (top (winapi:RECT-top wr))
          (width (- (winapi:RECT-right wr) (winapi:RECT-left wr)))
          (height (- (winapi:RECT-bottom wr) (winapi:RECT-top wr))))
      (winapi:MoveWindow (get-window-handle)
                         (parse-integer (read-string (format nil "left(~D): " left) :default (format nil "~D" left)))
                         (parse-integer (read-string (format nil "top(~D): " top) :default (format nil "~D" top)))
                         (parse-integer (read-string (format nil "width(~D): " width) :default (format nil "~D" width)))
                         (parse-integer (read-string (format nil "height(~D): " height) :default (format nil "~D" height)))
                         1)))
  t)

(defun set-geometry (text)
  (string-match "(\\([0-9]+\\),\\([0-9]+\\))-(\\([0-9]+\\),\\([0-9]+\\))" text)
  (let ((left (parse-integer (match-string 1)))
        (top (parse-integer (match-string 2)))
        (right (parse-integer (match-string 3)))
        (bottom (parse-integer (match-string 4))))
    (winapi:MoveWindow (get-window-handle) left top (- right left) (- bottom top) 1))
  t)

(defun recode-geometry ()
  (interactive)
  (let ((wr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (let ((text (format nil "(~D,~D)-(~D,~D)" (winapi:RECT-left wr) (winapi:RECT-top wr) (winapi:RECT-right wr) (winapi:RECT-bottom wr))))
      (setq *geometry-presets* (delete text *geometry-presets* :test #'string= :key #'car))
      (push (list text (winapi:RECT-left wr) (winapi:RECT-top wr) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)))
            *geometry-presets*)
      (when (< *geometry-presets-size* (length *geometry-presets*))
        (setq *geometry-presets* (nbutlast *geometry-presets*)))))
  (add-geometry-presets-to-menu))

(defun add-geometry-presets-menu (menu texts fn)
  (when (menup menu)
    (while (delete-menu menu 0 t))
    (do ((text texts (cdr text))
         (count 1))
        ((or (null text)
             (> count *menu-history-max*))
         t)
      (insert-menu-item menu (1- count) nil
                        (format nil "&~:(~35r~): ~a"
                                (rem count 36)
                                (quote-string (car text) #\& #\&))
                        (funcall fn (car text)))
      (incf count))))

(defun add-geometry-presets-to-menu ()
  (when (menup *app-menu*)
    (when *geometry-presets*
      (add-geometry-presets-menu *geometry-popup-menu*
                    (mapcar #'car *geometry-presets*)
                    #'(lambda (text)
                        #'(lambda ()
                            (interactive)
                            (let ((item (cdr (assoc text *geometry-presets* :test #'string=))))
                              (if item
                                  (winapi:MoveWindow (get-window-handle) (first item) (second item) (third item) (fourth item) 1)
                                (set-geometry text))))))
      (add-menu-separator *geometry-popup-menu* :above-recode-geometry))
    (add-menu-item *geometry-popup-menu* nil "現在の位置とサイズを保存(&S)" 'recode-geometry)))

(defun insert-menu-for-move-window (&optional (tag :above-next-xyzzy))
  (when (menup *app-menu*)
    (let ((window-menu (get-menu *app-menu* 'window)))
      (insert-menu-separator window-menu (get-menu-position window-menu tag) :above-maximize-height-window)
      (insert-menu-item window-menu (get-menu-position window-menu tag) nil "上下に最大化(&H)" 'maximize-height-window)
      (insert-menu-item window-menu (get-menu-position window-menu tag) nil "左右に最大化(&W)" 'maximize-width-window)
      (insert-menu-item window-menu (get-menu-position window-menu tag) nil "左に寄せる(&<)" 'move-to-left-window)
      (insert-menu-item window-menu (get-menu-position window-menu tag) nil "右に寄せる(&>)" 'move-to-right-window)
      (insert-menu-item window-menu (get-menu-position window-menu tag) nil "上に寄せる(&^)" 'move-to-top-window)
      (insert-menu-item window-menu (get-menu-position window-menu tag) nil "下に寄せる(&_)" 'move-to-bottom-window)
      (insert-popup-menu window-menu (get-menu-position window-menu :above-next-xyzzy) *geometry-popup-menu* "既定"))))

(defun init-geometry-menu ()
  (add-geometry-presets-to-menu)
  (insert-menu-for-move-window))

(add-hook '*init-app-menus-hook* 'init-geometry-menu)

#|
(defun set-geometry (text)
  (string-match "\\([0-9]+\\)x\\([0-9]+\\)\\([---+][0-9]+\\)\\([---+][0-9]+\\)" text)
  (let ((w (match-string 1))
        (h (match-string 2))
        (x (match-string 3))
        (y (match-string 4))
        (cr (winapi:make-RECT))
        width height left top)
    (winapi:GetClientRect (get-window-handle) cr)
    (setq width (+ (* (truncate (- (winapi:RECT-right cr) (winapi:RECT-left cr)) (screen-width)) (parse-integer w)) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME))))
    (setq height (+ (* (truncate (- (winapi:RECT-bottom cr) (winapi:RECT-top cr)) (screen-height)) (parse-integer h)) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME))))
    (setq left (if (char= #\+ (char x 0))
                   (parse-integer x)
                 (- (winapi:GetSystemMetrics winapi:SM_CXMAXIMIZED) (abs (parse-integer x)) width (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME)))))
    (setq top (if (char= #\+ (char y 0))
                  (parse-integer y)
                (- (winapi:GetSystemMetrics winapi:SM_CYMAXIMIZED) (abs (parse-integer y)) height (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME)))))
    (winapi:MoveWindow (get-window-handle)
                       left
                       top
                       width
                       height
                       1))
  t)

(defun get-geometry (wr cr)
  (let ((w (truncate (- (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CXSIZEFRAME)))
                     (truncate (- (winapi:RECT-right cr) (winapi:RECT-left cr)) (screen-width))))
        (h (truncate (- (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)) (* 2 (winapi:GetSystemMetrics winapi:SM_CYSIZEFRAME)))
                     (truncate (- (winapi:RECT-bottom cr) (winapi:RECT-top cr)) (screen-height))))
        (x (winapi:RECT-left wr))
        (y (winapi:RECT-top wr)))
    (values (format nil "~Dx~D~@D~@D" w h x y) (list w h x y))))

(defun recode-geometry ()
  (interactive)
  (let ((wr (winapi:make-RECT))
        (cr (winapi:make-RECT)))
    (winapi:GetWindowRect (get-window-handle) wr)
    (winapi:GetClientRect (get-window-handle) cr)
    (let ((text (get-geometry wr cr)))
      (setq *geometry-presets* (delete text *geometry-presets* :test #'string= :key #'car))
      (push (list text (winapi:RECT-left wr) (winapi:RECT-top wr) (- (winapi:RECT-right wr) (winapi:RECT-left wr)) (- (winapi:RECT-bottom wr) (winapi:RECT-top wr)))
            *geometry-presets*)
      (when (< *geometry-presets-size* (length *geometry-presets*))
        (setq *geometry-presets* (nbutlast *geometry-presets*)))))
  (add-geometry-presets-to-menu))
|#

---

メニュー周りの関数を使ったのは初めてかもしれない。

update : 2006-07-30 (Sun) 01:56:27