source: trunk/source/contrib/foy/window-parking-cm/window-parking.lisp @ 12783

Last change on this file since 12783 was 12783, checked in by gfoy, 10 years ago

New tool: window-parking-cm

File size: 21.8 KB
Line 
1;;;-*- Mode: Lisp; Package: WINDOW-PARKING -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      window-parking.lisp
6;;;
7;;;      copyright (c) 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      This code provides a Hemlock window manager and is part of the Context-Menu
11;;;      tool set.  See the ReadMe file for details.
12;;;
13;;;      This software is offered "as is", without warranty of any kind.
14;;;
15;;;      Mod History (most recent edit first)
16;;;      9/14/9  first cut
17;;;
18;;; ----------------------------------------------------------------------------
19
20(defpackage "WINDOW-PARKING" (:nicknames "WP") (:use :cl :ccl))
21(in-package "WINDOW-PARKING")
22
23(require :context-menu-cm)
24(require :list-definitions-cm)
25
26(defparameter *window-parker* nil "The window-parker instance.")
27(defparameter *window-parking-menu* nil "The window-parking-menu instance.")
28
29;;; ----------------------------------------------------------------------------
30;;;
31(defClass WINDOW-PARKING-MENU (ns:ns-menu) 
32  ((tool-menu :initform nil :accessor tool-menu)
33   (doc-path :initform (merge-pathnames ";ReadMe.rtf" cl-user::*window-parking-directory*) :reader doc-path))
34  (:documentation "A menu for adding and deleting parking spots.")
35  (:metaclass ns:+ns-object))
36
37;;; This can be called to add a new parking spot or adjust an existing spot.
38(objc:defmethod (#/defineAction: :void) ((m window-parking-menu) (sender :id))
39  (declare (ignore sender))
40  (let* ((window (cmenu:active-hemlock-window))
41         (path (when window (cmenu:window-path window)))
42         ;; Possibly a re-definition.
43         (current-function-key (get-function-key *window-parker* window))
44         (defined-function-key
45             (when path
46               (if current-function-key
47                 (open-define-parking-spot-dialog path current-function-key)
48                 (open-define-parking-spot-dialog path)))))
49    (when defined-function-key
50      (cond (current-function-key 
51             (cond ((= current-function-key defined-function-key)
52                    ;; Adjusting an existing spot.
53                    (let ((spot (parking-spot-with-function-key *window-parker* current-function-key)))
54                      (init-parking-spot-values spot window current-function-key))
55                    (cmenu:echo-msg "Parking spot ~S modified." current-function-key))
56                   (t
57                    (vacate-current-location *window-parker* window)
58                    (add-parking-spot *window-parker* window defined-function-key)
59                    (cmenu:echo-msg "Parking spot ~S defined." current-function-key))))
60            (t
61             (add-parking-spot *window-parker* window defined-function-key))
62            (cmenu:echo-msg "Parking spot ~S defined." defined-function-key)))))
63
64(objc:defmethod (#/deleteAction: :void) ((m window-parking-menu) (sender :id))
65  (declare (ignore sender))
66  (let ((function-key (open-delete-parking-spot-dialog)))
67    (when function-key
68      (delete-parking-spot *window-parker* function-key))))
69
70(objc:defmethod (#/update :void) ((m window-parking-menu))
71  (cmenu:update-tool-menu m (tool-menu m))
72  (call-next-method))
73
74(defmethod initialize-instance :after ((m window-parking-menu) &key)
75  (setf (tool-menu m) (cmenu:add-default-tool-menu m :doc-file (doc-path m)))
76  (flet ((create-menu-item (name action)
77           (let ((menu-item (make-instance 'ns:ns-menu-item))
78                 (attributed-string (#/initWithString:attributes:
79                                     (#/alloc ns:ns-attributed-string) 
80                                     (ccl::%make-nsstring name)
81                                     cmenu:*hemlock-menu-dictionary*)))
82             (#/setAttributedTitle: menu-item attributed-string)
83             (#/setAction: menu-item action)
84             (#/setTarget: menu-item  m)
85             (#/addItem: m menu-item))))
86    (create-menu-item "Define Parking Spot..." 
87                      (ccl::@selector "defineAction:"))
88    (create-menu-item "Delete Parking Spot..." 
89                      (ccl::@selector "deleteAction:"))))
90 
91(setq *window-parking-menu* (make-instance 'window-parking-menu))
92
93(defun get-window-parking-menu (view event) 
94  (declare (ignore view event))
95  *window-parking-menu*)
96
97(cmenu:register-tool "Window-Parking-CM" #'get-window-parking-menu)
98
99
100;;; ----------------------------------------------------------------------------
101;;;
102(defclass PARKABLE-HEMLOCK-FRAME (gui::hemlock-frame)
103  ((parked-p :initform nil :accessor parked-p))
104  (:metaclass ns:+ns-object))
105
106(defmethod h-position ((w parkable-hemlock-frame))
107  (let ((rect (#/frame w)))
108    (pref rect :<NSR>ect.origin.x)))
109
110(defmethod v-position ((w parkable-hemlock-frame))
111  (let ((rect (#/frame w)))
112    (pref rect :<NSR>ect.origin.y)))
113
114(defmethod h-dimension ((w parkable-hemlock-frame))
115  (let ((rect (#/frame w)))
116    (pref rect :<NSR>ect.size.width)))
117
118(defmethod v-dimension ((w parkable-hemlock-frame))
119  (let ((rect (#/frame w)))
120    (pref rect :<NSR>ect.size.height)))
121
122(objc:defmethod (#/close :void) ((w parkable-hemlock-frame))
123  (vacate-current-location *window-parker* w)
124  (call-next-method))
125
126(defmethod print-object ((w parkable-hemlock-frame) stream)
127  (format stream "<parkable-hemlock-frame: ~S>" (namestring (cmenu:window-path w))))
128
129
130;;; ----------------------------------------------------------------------------
131;;; *** redefinition ***
132;;; Need the equivalent of: (setf ccl::*default-editor-class* 'parkable-hemlock-frame)
133(defun gui::new-hemlock-document-window (class)
134  (let* ((w (gui::new-cocoa-window :class (if (or (eq class 'gui::hemlock-listener-frame)
135                                                  (eq class (find-class 'gui::hemlock-listener-frame)))
136                                            'gui::hemlock-listener-frame
137                                            'parkable-hemlock-frame)
138                                   :auto-display t
139                                   :activate nil))
140         (echo-area-height (+ 1 (gui::size-of-char-in-font gui::*editor-font*))))
141      (values w (gui::add-pane-to-window w :reserve-below echo-area-height))))
142
143(objc:defmethod (#/makeKeyAndOrderFront: :void) ((w parkable-hemlock-frame) (sender :id))
144  (setf (parked-p w) t) ; only park it once
145  (call-next-method sender))
146
147(objc:defmethod (#/setFrame:display: :void) ((w parkable-hemlock-frame) (rect :<NSR>ect) (display-p :<BOOL>))
148  (cond ((parked-p w)
149         (call-next-method rect display-p))
150        (t
151         (multiple-value-bind (h-position v-position h-dimension v-dimension)
152                              (park *window-parker* w)
153           (if (and h-position v-position h-dimension v-dimension)
154             (ns:with-ns-rect (r h-position v-position h-dimension v-dimension)
155               (call-next-method r display-p))
156             (call-next-method rect display-p))))))
157
158;;; ----------------------------------------------------------------------------
159;;;
160(defClass PARKING-SPOT ()
161  ((h-dimension :initform nil :initarg :h-dimension :accessor ps-h-dimension)
162   (v-dimension :initform nil :initarg :v-dimension :accessor ps-v-dimension)
163   (h-position :initform nil :initarg :h-position :accessor ps-h-position)
164   (v-position :initform nil :initarg :v-position :accessor ps-v-position)
165   (tenant :initform nil :initarg :tenant :accessor ps-tenant)
166   (function-key :initform nil :initarg :function-key :accessor ps-function-key))
167  (:documentation "Parking spot position, size, tenant and function key information."))
168
169(defMethod print-object ((ps parking-spot) stream)
170  (format stream "<~a ~a ~a>" (type-of ps) (ps-function-key ps)
171          (if (ps-tenant ps) (ps-tenant ps) "empty")))
172
173(defMethod apply-parking-spot-values ((ps parking-spot) window)
174  (setf (ps-tenant ps) window)
175  (when (or (neq (ps-h-dimension ps) (h-dimension window))
176            (neq (ps-v-dimension ps) (v-dimension window))
177            (neq (ps-h-position ps) (h-position window))
178            (neq (ps-v-position ps) (v-position window)))
179    ;; park it
180    (setf (parked-p window) nil)
181    (ns:with-ns-rect (r (ps-h-position ps) (ps-v-position ps) (ps-h-dimension ps) (ps-v-dimension ps))
182      (#/setFrame:display: window r t))
183    (#/makeKeyAndOrderFront: window nil)))
184
185;;; *** i-i :after?
186(defMethod init-parking-spot-values ((ps parking-spot) window function-key)
187  (setf (ps-tenant ps) window)
188  (setf (ps-h-dimension ps) (h-dimension window))
189  (setf (ps-v-dimension ps) (v-dimension window))
190  (setf (ps-h-position ps) (h-position window))
191  (setf (ps-v-position ps) (v-position window))
192  (setf (ps-function-key ps) function-key))
193
194(defMethod init-parking-spot-values-2 ((ps parking-spot) function-key
195                                       h-dimension v-dimension h-position v-position)
196  (setf (ps-tenant ps) nil)
197  (setf (ps-h-dimension ps) h-dimension)
198  (setf (ps-v-dimension ps) v-dimension)
199  (setf (ps-h-position ps) h-position)
200  (setf (ps-v-position ps) v-position)
201  (setf (ps-function-key ps) function-key))
202
203;;; ----------------------------------------------------------------------------
204;;;
205(defClass WINDOW-PARKER ()
206  ((parking-spots :initform nil :accessor wp-parking-spots)
207   (parking-lot-path :initform (merge-pathnames ";Library;Preferences;org.clairvaux;window-parking;parking-lot" 
208                                                 (hemlock::user-homedir-pathname))
209                      :accessor wp-parking-lot-path))
210  (:documentation "A window manager."))
211
212(setf *window-parker* (make-instance 'window-parker))
213
214(defMethod park ((wp window-parker) (window parkable-hemlock-frame))
215  (when (wp-parking-spots wp)
216    ;; Already parked?
217    (let* ((position (position window (wp-parking-spots wp) :key #'ps-tenant))
218           spot)
219      (when (null position)
220        (or (setf position (get-empty-position wp))
221            (setf position (bump-position wp (1- (length (wp-parking-spots wp)))))))
222      (when position
223        (setq spot (nth position (wp-parking-spots wp)))
224        (move-position-to-front wp position)
225        (setf (ps-tenant spot) window)
226        (values (ps-h-position spot) (ps-v-position spot)
227                (ps-h-dimension spot) (ps-v-dimension spot))))))
228
229;;; Test to make sure that POSITION is on screen.  If not, call recursively with
230;;; (1- position).  Return POSITION or NIL
231(defMethod bump-position ((wp window-parker) position)
232  ;; has the recursive call run out of positions?
233  (when (< position 0)
234    (cmenu:echo-msg "There are no on-screen parking spots.")
235    (return-from bump-position nil))
236  (let ((bump-location (nth position (wp-parking-spots wp))))
237    (cond ((and bump-location (parking-spot-on-screen-p bump-location))
238           (let ((window-to-close (ps-tenant bump-location)))
239             (when window-to-close (#/close window-to-close))
240             position))   
241          (t ; location is off-screen or not defined, recursive call
242           (bump-position wp (1- position))))))
243
244(defMethod bump-location-and-set-location-values ((wp window-parker) location window)
245  (let ((window-to-close (ps-tenant location)))
246    (when window-to-close
247      (#/close window-to-close))
248    (apply-parking-spot-values location window)))
249
250(defMethod move-position-to-front ((wp window-parker) position)
251  (let ((current-location (nth position (wp-parking-spots wp))))
252    (setf (wp-parking-spots wp) 
253          (cons current-location (delete current-location (wp-parking-spots wp))))))
254
255(defMethod parking-spot-with-function-key ((wp window-parker) function-key)
256  (find  function-key (wp-parking-spots wp) :test #'= :key #'ps-function-key))
257
258;;; (defMethod parking-spot-on-screen-p ((ps parking-spot)) t)
259
260;;; This is untested
261(defMethod parking-spot-on-screen-p ((ps parking-spot) &optional window)
262  (let* ((screen (if window 
263                   (#/screen window)
264                   (#/mainScreen ns:ns-screen)))
265         (screen-rect (if (%null-ptr-p screen)
266                        (#/visibleFrame (#/mainScreen ns:ns-screen))
267                        (#/visibleFrame screen)))
268         (screen-left (pref screen-rect :<NSR>ect.origin.x))
269         (screen-right (+ screen-left (pref screen-rect :<NSR>ect.size.width)))
270         (screen-bottom (pref screen-rect :<NSR>ect.origin.y))
271         (screen-top (+ screen-bottom (pref screen-rect :<NSR>ect.size.height))))
272    (and (>= (ps-h-position ps) screen-left)
273         (<= (+ (ps-h-position ps) (ps-h-dimension ps)) screen-right)
274         (>= (ps-v-position ps) screen-bottom)
275         (<= (+ (ps-v-position ps) (ps-v-dimension ps)) screen-top))))
276
277;;; Find the lowest number parking-spot that has no tenant.
278(defMethod get-empty-position ((wp window-parker))
279  (let ((parking-spots (sort (copy-list (wp-parking-spots wp))
280                             #'(lambda (s1 s2)
281                                 (< (ps-function-key s1) (ps-function-key s2))))))
282    (dolist (spot parking-spots)
283      (when (and (null (ps-tenant spot))
284                 (parking-spot-on-screen-p spot))
285        ;; Return the position in the unsorted list.
286        (return (position spot (wp-parking-spots wp)))))))
287
288(defMethod add-parking-spot ((wp window-parker) window function-key)
289  (let ((new-parking-spot (make-instance 'parking-spot)))
290    (init-parking-spot-values new-parking-spot window function-key)
291    (setf (wp-parking-spots wp) (cons new-parking-spot (wp-parking-spots wp)))
292    (cmenu:echo-msg "Parking Spot ~a defined." function-key)))
293
294(defMethod add-parking-spot-2 ((wp window-parker) function-key
295                               h-dimension v-dimension h-position v-position)
296  (cond ((and (wp-parking-spots wp)
297              (find-if #'(lambda (spot) (= function-key (ps-function-key spot)))
298                       (wp-parking-spots wp)))
299         (cmenu:notify "Duplicate parking-spot ignored."))
300        (t
301         (let ((new-parking-spot (make-instance 'parking-spot)))
302           (init-parking-spot-values-2 new-parking-spot function-key
303                                       h-dimension v-dimension h-position v-position)
304           (setf (wp-parking-spots wp) (cons new-parking-spot (wp-parking-spots wp)))))))
305
306(defMethod delete-parking-spot ((wp window-parker) function-key)
307  (let ((parking-spot (find function-key (wp-parking-spots wp) :key #'ps-function-key)))
308    (cond (parking-spot
309           (setf (wp-parking-spots wp) (delete parking-spot (wp-parking-spots wp))) 
310           (when (ps-tenant parking-spot) (#/close (ps-tenant parking-spot)))
311           (cmenu:echo-msg "Parking Spot ~a deleted." function-key))
312          (t 
313           (cmenu:notify (format nil "Parking Spot ~a is not currently defined." function-key))))))
314
315(defMethod get-function-key ((wp window-parker) window)
316  (dolist (spot (wp-parking-spots wp))
317    (when (eql window (ps-tenant spot)) (return (ps-function-key spot)))))
318
319(defMethod vacate-current-location ((wp window-parker) window)
320  (let ((location (find window (wp-parking-spots wp) :key #'ps-tenant)))
321    (when location 
322      (setf (ps-tenant location) nil)
323      t)))
324
325;;; Called when the parking lot file is bad.
326(defMethod clear-parking-lot ((wp window-parker))
327  (setf (wp-parking-spots wp) nil))
328
329;;; Move WINDOW to the parking-spot corresponding to the pressed function key,
330;;; unless the parking-spot is not on screen or the window is already in that location.
331(defMethod move-window-to-position ((wp window-parker) (window parkable-hemlock-frame) function-key)
332  (let ((parking-spot (find function-key (wp-parking-spots wp) :key #'ps-function-key)))
333    (cond (parking-spot
334           (cond ((and (ps-tenant parking-spot)
335                       ;; Why not (eq window (ps-tenant parking-spot)) ?
336                       (eq (cmenu:window-path window) (cmenu:window-path (ps-tenant parking-spot))))
337                  (cmenu:echo-msg "That window is currently already in parking-spot ~a." function-key))
338                 (t 
339                  (cond ((parking-spot-on-screen-p parking-spot window)
340                         (vacate-current-location wp window)
341                         (bump-location-and-set-location-values wp parking-spot window)
342                         (#/makeKeyAndOrderFront: window nil)
343                         (cmenu:echo-msg "Moved to parking-spot ~a." function-key))
344                        (t 
345                         (cmenu:notify (format nil "Parking-spot ~a is currently off screen." function-key)))))))
346          (t
347           (cmenu:notify (format nil "Parking-spot ~a is not defined." function-key))))))
348
349;;; ----------------------------------------------------------------------------
350;;; file I/O
351;;;
352(defMethod read-parking-spot-entries ((wp window-parker) stream)
353  (let (length h-dimension v-dimension h-position v-position function-key input)
354    (setf input (read stream nil :eof))
355    (when (not (numberp input))
356      (return-from read-parking-spot-entries))
357    (setf length input)
358    (dotimes (count length t)
359      (setf input (read stream nil :eof))
360      (when (not (or (numberp input) (null input))) (return nil))
361      (setf function-key input)
362      (setf input (read stream nil :eof))
363      (when (not (or (numberp input) (null input))) (return nil))
364      (setf h-dimension input)
365      (setf input (read stream nil :eof))
366      (when (not (or (numberp input) (null input))) (return nil))
367      (setf v-dimension input)
368      (setf input (read stream nil :eof))
369      (when (not (or (numberp input) (null input))) (return nil))
370      (setf h-position input)
371      (setf input (read stream nil :eof))
372      (when (not (or (numberp input) (null input))) (return nil))
373      (setf v-position input)
374      (add-parking-spot-2 wp function-key h-dimension v-dimension
375                            h-position v-position))))
376
377(defMethod write-parking-spot-entries ((wp window-parker) stream)
378  (let (;; write the positions in reverse order based on their function key order
379        (sorted-parking-spots (sort (copy-list (wp-parking-spots wp)) #'> :key #'ps-function-key)))
380    (format stream "~s~%" (length sorted-parking-spots))
381    (dolist (entry sorted-parking-spots)
382      (format stream "~s~%" (ps-function-key entry))
383      (format stream "~s~%" (ps-h-dimension entry))
384      (format stream "~s~%" (ps-v-dimension entry))
385      (format stream "~s~%" (ps-h-position entry)) 
386      (format stream "~s~%" (ps-v-position entry)))))
387
388(defun read-parking-lot-file ()
389  "Read the parking-lot file."
390  (let ((path (wp-parking-lot-path *window-parker*)))
391    (when (probe-file path)
392      (with-open-file (stream path :direction :input)
393        (unless (read-parking-spot-entries *window-parker* stream)
394          (cmenu:notify "There is a problem with the parking-lot file.  You will have to redefine your parking spots.")
395          (clear-parking-lot *window-parker*))))))
396
397(defun write-parking-lot-file (&rest args)
398  "Writing function pushed into *lisp-cleanup-functions*."
399  (declare (ignore args))
400  (let ((path (wp-parking-lot-path *window-parker*)))
401    (with-open-file (stream path :direction :output :if-exists :supersede)
402      (write-parking-spot-entries *window-parker* stream))))
403
404(pushnew 'write-parking-lot-file ccl::*lisp-cleanup-functions*)
405
406;;; To Do:
407;;; Heap issues involved in saving an image with the utility loaded.
408;;; (pushnew 'read-parking-lot-file ccl::*lisp-startup-functions*)
409
410;;; ----------------------------------------------------------------------------
411;;; Function commands and bindings:
412;;;
413(hemlock::defcommand "Move Window to Position 1" (p)
414  "Move the front Hemlock window to parking spot 1."
415  (declare (ignore p))
416  (let ((window (cmenu:active-hemlock-window)))
417    (cond (window
418           (move-window-to-position *window-parker* window 1))
419          (t
420           (hi::editor-error "There is no active Hemlock window to move.")))))
421
422(hi::bind-key "Move Window to Position 1" #k"F1")
423
424(hemlock::defcommand "Move Window to Position 2" (p)
425  "Move the front Hemlock window to parking spot 2."
426  (declare (ignore p))
427  (let ((window (cmenu:active-hemlock-window)))
428    (cond (window
429           (move-window-to-position *window-parker* window 2))
430          (t
431           (hi::editor-error "There is no active Hemlock window to move.")))))
432
433(hi::bind-key "Move Window to Position 2" #k"F2")
434
435(hemlock::defcommand "Move Window to Position 3" (p)
436  "Move the front Hemlock window to parking spot 3."
437  (declare (ignore p))
438  (let ((window (cmenu:active-hemlock-window)))
439    (cond (window
440           (move-window-to-position *window-parker* window 3))
441          (t
442           (hi::editor-error "There is no active Hemlock window to move.")))))
443
444(hi::bind-key "Move Window to Position 3" #k"F3")
445
446(hemlock::defcommand "Move Window to Position 4" (p)
447  "Move the front Hemlock window to parking spot 4."
448  (declare (ignore p))
449  (let ((window (cmenu:active-hemlock-window)))
450    (cond (window
451           (move-window-to-position *window-parker* window 4))
452          (t
453           (hi::editor-error "There is no active Hemlock window to move.")))))
454
455(hi::bind-key "Move Window to Position 4" #k"F4")
456
457(hemlock::defcommand "Move Window to Position 5" (p)
458  "Move the front Hemlock window to parking spot 5."
459  (declare (ignore p))
460  (let ((window (cmenu:active-hemlock-window)))
461    (cond (window
462           (move-window-to-position *window-parker* window 5))
463          (t
464           (hi::editor-error "There is no active Hemlock window to move.")))))
465
466(hi::bind-key "Move Window to Position 5" #k"F5")
467
468(hemlock::defcommand "Move Window to Position 6" (p)
469  "Move the front Hemlock window to parking spot 6."
470  (declare (ignore p))
471  (let ((window (cmenu:active-hemlock-window)))
472    (cond (window
473           (move-window-to-position *window-parker* window 6))
474          (t
475           (hi::editor-error "There is no active Hemlock window to move.")))))
476
477(hi::bind-key "Move Window to Position 6" #k"F6")
478
479(hemlock::defcommand "Move Window to Position 7" (p)
480  "Move the front Hemlock window to parking spot 7."
481  (declare (ignore p))
482  (let ((window (cmenu:active-hemlock-window)))
483    (cond (window
484           (move-window-to-position *window-parker* window 7))
485          (t
486           (hi::editor-error "There is no active Hemlock window to move.")))))
487
488(hi::bind-key "Move Window to Position 7" #k"F7")
489
490
491(read-parking-lot-file)
492
493
494
495
496
Note: See TracBrowser for help on using the repository browser.