Changeset 12795


Ignore:
Timestamp:
Sep 9, 2009, 12:57:46 AM (10 years ago)
Author:
gfoy
Message:

Miscellaneous

Location:
trunk/source/contrib/foy/window-parking-cm
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/contrib/foy/window-parking-cm/window-parking-dialogs.lisp

    r12783 r12795  
    1313;;;
    1414;;;      Mod History (most recent edit first)
    15 ;;;      9/14/9  version 0.1b1
    16 ;;;              first cut
     15;;;      9/9/9  first cut
    1716;;;
    1817;;; ----------------------------------------------------------------------------
  • trunk/source/contrib/foy/window-parking-cm/window-parking.lisp

    r12783 r12795  
    1414;;;
    1515;;;      Mod History (most recent edit first)
    16 ;;;      9/14/9  first cut
     16;;;      9/9/9  first cut
    1717;;;
    1818;;; ----------------------------------------------------------------------------
     
    124124  (call-next-method))
    125125
     126(defmethod modified-p ((w parkable-hemlock-frame))
     127  (when w
     128    (let* ((pane (slot-value w 'gui::pane))
     129           (hemlock-view (when pane (gui::text-pane-hemlock-view pane)))
     130           (buffer (when hemlock-view (hi::hemlock-view-buffer hemlock-view))))
     131      (when buffer
     132        (hi::buffer-modified buffer)))))
     133
    126134(defmethod print-object ((w parkable-hemlock-frame) stream)
    127135  (format stream "<parkable-hemlock-frame: ~S>" (namestring (cmenu:window-path w))))
     
    167175  (:documentation "Parking spot position, size, tenant and function key information."))
    168176
    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?
     177(defMethod initialize-instance :after ((ps parking-spot) &key window
     178                                       function-key h-dimension v-dimension
     179                                       h-position v-position)
     180  (cond ((and h-dimension v-dimension h-position v-position function-key)
     181         (setf (ps-tenant ps) window)
     182         (setf (ps-h-dimension ps) h-dimension)
     183         (setf (ps-v-dimension ps) v-dimension)
     184         (setf (ps-h-position ps) h-position)
     185         (setf (ps-v-position ps) v-position)
     186         (setf (ps-function-key ps) function-key))
     187        ((and window function-key)
     188         (init-parking-spot-values ps window function-key))
     189        (t
     190         (error "Bogus condition in parking-spot i-i :after"))))
     191
    186192(defMethod init-parking-spot-values ((ps parking-spot) window function-key)
    187193  (setf (ps-tenant ps) window)
     
    191197  (setf (ps-v-position ps) (v-position window))
    192198  (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)
    259199
    260200;;; This is untested
     
    275215         (<= (+ (ps-v-position ps) (ps-v-dimension ps)) screen-top))))
    276216
     217(defMethod print-object ((ps parking-spot) stream)
     218  (format stream "<~a ~a ~a>" (type-of ps) (ps-function-key ps)
     219          (if (ps-tenant ps) (ps-tenant ps) "empty")))
     220
     221(defMethod apply-parking-spot-values ((ps parking-spot) window)
     222  (setf (ps-tenant ps) window)
     223  (when (or (neq (ps-h-dimension ps) (h-dimension window))
     224            (neq (ps-v-dimension ps) (v-dimension window))
     225            (neq (ps-h-position ps) (h-position window))
     226            (neq (ps-v-position ps) (v-position window)))
     227    ;; park it
     228    (setf (parked-p window) nil)
     229    (ns:with-ns-rect (r (ps-h-position ps) (ps-v-position ps) (ps-h-dimension ps) (ps-v-dimension ps))
     230      (#/setFrame:display: window r t))
     231    (#/makeKeyAndOrderFront: window nil)))
     232
     233;;; ----------------------------------------------------------------------------
     234;;;
     235(defClass WINDOW-PARKER ()
     236  ((parking-spots :initform nil :accessor wp-parking-spots)
     237   (parking-lot-path :initform (merge-pathnames ";Library;Preferences;org.clairvaux;window-parking;parking-lot"
     238                                                 (hemlock::user-homedir-pathname))
     239                      :reader wp-parking-lot-path))
     240  (:documentation "A window manager."))
     241
     242(setf *window-parker* (make-instance 'window-parker))
     243
     244(defMethod park ((wp window-parker) (window parkable-hemlock-frame))
     245  (when (wp-parking-spots wp)
     246    ;; Already parked?
     247    (let* ((position (position window (wp-parking-spots wp) :key #'ps-tenant))
     248           spot)
     249      (when (null position)
     250        (or (setf position (get-empty-position wp))
     251            (setf position (bump-position wp (1- (length (wp-parking-spots wp)))))))
     252      (cond (position
     253             (setq spot (nth position (wp-parking-spots wp)))
     254             (move-position-to-front wp position)
     255             (setf (ps-tenant spot) window)
     256             (values (ps-h-position spot) (ps-v-position spot)
     257                     (ps-h-dimension spot) (ps-v-dimension spot)))
     258            (t
     259             ;; only try to park it once
     260             (setf (parked-p window) t))))))
     261
     262;;; Test to make sure that POSITION is on screen.  If not, call recursively with
     263;;; (1- position).  Return POSITION or NIL
     264(defMethod bump-position ((wp window-parker) position)
     265  ;; has the recursive call run out of positions?
     266  (when (< position 0)
     267    (cmenu:notify "There are no on-screen parking spots with unmodified buffers.")
     268    (return-from bump-position nil))
     269  (let* ((bump-location (nth position (wp-parking-spots wp)))
     270         (tenant (when bump-location (ps-tenant bump-location))))
     271    (cond ((and bump-location
     272                (parking-spot-on-screen-p bump-location)
     273                (not (modified-p tenant)))
     274             (when tenant (#/close tenant))
     275             position)
     276          (t ; location is off-screen or not defined, recursive call
     277           (bump-position wp (1- position))))))
     278
     279;;; Assumes that WINDOW's buffer is unmodified.
     280(defMethod bump-location-and-set-location-values ((wp window-parker) location window)
     281  (let ((tenant (ps-tenant location)))
     282    (when tenant
     283      (#/close tenant))
     284    (apply-parking-spot-values location window)))
     285
     286(defMethod move-position-to-front ((wp window-parker) position)
     287  (let ((current-location (nth position (wp-parking-spots wp))))
     288    (setf (wp-parking-spots wp)
     289          (cons current-location (delete current-location (wp-parking-spots wp))))))
     290
     291(defMethod parking-spot-with-function-key ((wp window-parker) function-key)
     292  (find  function-key (wp-parking-spots wp) :test #'= :key #'ps-function-key))
     293
    277294;;; Find the lowest number parking-spot that has no tenant.
    278295(defMethod get-empty-position ((wp window-parker))
     
    287304
    288305(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)
     306  (let ((new-parking-spot (make-instance 'parking-spot :window window :function-key function-key)))
    291307    (setf (wp-parking-spots wp) (cons new-parking-spot (wp-parking-spots wp)))
    292308    (cmenu:echo-msg "Parking Spot ~a defined." function-key)))
     
    299315         (cmenu:notify "Duplicate parking-spot ignored."))
    300316        (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)
     317         (let ((new-parking-spot (make-instance 'parking-spot
     318                                   :function-key function-key
     319                                   :h-dimension h-dimension :v-dimension v-dimension
     320                                   :h-position h-position :v-position v-position)))
    304321           (setf (wp-parking-spots wp) (cons new-parking-spot (wp-parking-spots wp)))))))
    305322
     
    307324  (let ((parking-spot (find function-key (wp-parking-spots wp) :key #'ps-function-key)))
    308325    (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))
     326           (let ((tenant (ps-tenant parking-spot)))
     327             (cond (tenant
     328                    (cond ((modified-p tenant)
     329                           (cmenu:notify (format nil "First save: ~S.  Then try again."
     330                                                 (cmenu:window-path tenant))))
     331                          (t
     332                           (setf (wp-parking-spots wp) (delete parking-spot (wp-parking-spots wp))) 
     333                           (#/close tenant)
     334                           (cmenu:echo-msg "Parking Spot ~a deleted." function-key))))
     335                   (t
     336                    (setf (wp-parking-spots wp) (delete parking-spot (wp-parking-spots wp))) 
     337                    (cmenu:echo-msg "Parking Spot ~a deleted." function-key)))))                   
    312338          (t
    313339           (cmenu:notify (format nil "Parking Spot ~a is not currently defined." function-key))))))
     
    323349      t)))
    324350
    325 ;;; Called when the parking lot file is bad.
    326351(defMethod clear-parking-lot ((wp window-parker))
    327352  (setf (wp-parking-spots wp) nil))
     
    329354;;; Move WINDOW to the parking-spot corresponding to the pressed function key,
    330355;;; 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))
     356(defMethod move-window-to-position ((wp window-parker) window function-key)
     357  (let* ((parking-spot (find function-key (wp-parking-spots wp) :key #'ps-function-key))
     358         (tenant (when parking-spot (ps-tenant parking-spot))))
     359    (cond ((and parking-spot (parking-spot-on-screen-p parking-spot window))
     360           (cond (tenant
     361                  (cond ((eql window tenant)
     362                         (cmenu:echo-msg "Already in parking-spot ~a." function-key))
     363                        (t
     364                         (cond ((modified-p tenant)
     365                                (cmenu:notify (format nil "First save: ~S. Then try again."
     366                                                      (cmenu:window-path tenant)))
     367                                (setf (parked-p tenant) nil)) ; *** ?
     368                               (t
     369                                (vacate-current-location wp window)
     370                                (bump-location-and-set-location-values wp parking-spot window)
     371                                (#/makeKeyAndOrderFront: window nil)
     372                                (cmenu:echo-msg "Moved to parking-spot ~a." function-key))))))
    338373                 (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))))))
     374                  (vacate-current-location wp window)
     375                  (apply-parking-spot-values parking-spot window)
     376                  (#/makeKeyAndOrderFront: window nil)
     377                  (cmenu:echo-msg "Moved to parking-spot ~a." function-key))))
     378          (t
     379           (if (null parking-spot)
     380             (cmenu:notify (format nil "Parking-spot ~a is not defined." function-key))
     381             (cmenu:notify (format nil "Parking-spot ~a is off screen." function-key)))))))
    348382
    349383;;; ----------------------------------------------------------------------------
     
    358392    (dotimes (count length t)
    359393      (setf input (read stream nil :eof))
     394      ;; *** null ?
    360395      (when (not (or (numberp input) (null input))) (return nil))
    361396      (setf function-key input)
Note: See TracChangeset for help on using the changeset viewer.