frame.lisp

   1 (in-package :lice)
   2
   3 (defvar *frame-list* nil
   4   "List of frames lice frames.")
   5
   6 ;; XXX: This is only temporary
   7 (defvar *current-frame* nil
   8   "The frame that accepts input.")
   9
  10 (defun selected-frame ()
  11   "Return the frame that is now selected."
  12   *current-frame*)
  13
  14 (defclass frame ()
  15   ((window-tree :type (or list window) :initarg :window-tree :accessor frame-window-tree)
  16    (width :type fixnum :initarg :width :accessor frame-width)
  17    (height :type fixnum :initarg :height :accessor frame-height)
  18    (minibuffer-window :type window :initarg :minibuffer-window :accessor frame-minibuffer-window)
  19    (minibuffers-active :type fixnum :initform 0 :initarg minibuffers-active :accessor frame-minibuffers-active)
  20    (current-window :type window :initarg :current-window :accessor frame-current-window))
  21   (:documentation "A Lice frame is super cool."))
  22
  23 (defun set-frame-minibuffer (frame minibuffer)
  24   "Make MINIBUFFER the minibuffer for FRAME."
  25   (setf (window-buffer (frame-minibuffer-window frame)) minibuffer))
  26
  27 ;; The defmethods are found in the *-render.lisp files
  28 (defgeneric frame-start-render (frame)
  29   (:documentation "Do any setup we need before we beginning rendering the frame."))
  30
  31 (defgeneric frame-end-render (frame)
  32   (:documentation "Do any cleanup or refreshing after the frame is rendered."))
  33
  34 ;; the defmethods are found in the *-render.lisp files
  35 (defgeneric window-render (window frame)
  36   (:documentation "Render the window in the given frame."))
  37
  38 (defgeneric frame-read-event (frame)
  39   (:documentation "Read a keyboard event for the specified frame."))
  40
  41 (defgeneric frame-move-cursor (frame window x y)
  42   (:documentation "Move the cursor to the X,Y location in WINDOW on the frame, FRAME."))
  43
  44 (defun frame-render (frame)
  45   "Render a frame."
  46   (let (cursor-x cursor-y win)
  47     (labels ((render (tree)
  48                      (cond ((null tree) nil)
  49                            ((atom tree)
  50                             ;; reset the cache
  51                             (window-reset-cache tree)
  52                             ;; Figure out what part to display
  53                             (window-framer tree
  54                                            (window-point tree)
  55                                            (truncate (window-height tree) 2))
  56                             (dformat +debug-vvv+ "after framer: ~a~%"
  57                                      (lc-cache (window-cache tree)))
  58                             ;; display it
  59                             (multiple-value-bind (x y) (window-render tree frame)
  60                               (when (eq tree (frame-current-window frame))
  61                                 (setf win tree cursor-x x cursor-y y))))
  62                            (t (cons (render (car tree))
  63                                     (render (cdr tree)))))))
  64       (frame-start-render frame)
  65       (render (frame-window-tree frame))
  66       (when (and win cursor-x cursor-y)
  67         (frame-move-cursor frame win cursor-x cursor-y))
  68       (frame-end-render frame))))
  69
  70
  71 (defun resize-window (window amount &optional (dir :height))
  72   "grow or shrink window, resizing dependant windows as well."
  73   (declare (ignore window amount dir))
  74 ;;   (let* ((frame (frame-window-tree (frame-for-window window)))
  75 ;;       (sibling (tree-sibling frame window)))
  76 ;;     )
  77   )
  78
  79 (defun current-buffer ()
  80   "Return the current buffer."
  81   ;; FIXME: maybe this should just return *current-buffer*
  82   (or *current-buffer*
  83       ;;(window-buffer (frame-current-window (selected-frame)))
  84       ))
  85
  86 (defun active-minibuffer-window ()
  87   "Return the currently active minibuffer window or nil if there isn't
  88 one."
  89   (let ((frame (selected-frame)))
  90     (unless (zerop (frame-minibuffers-active frame))
  91       (frame-minibuffer-window frame))))
  92
  93 (defun frame-window-list (frame &optional minibuf)
  94   "Return the list of windows in FRAME. If MINIBUF is true then include the minibuffer window."
  95 ;;   (declare (type frame frame))
  96   ;; FIXME: The reason we need to pass MB into flatten is because movitz can't "lend optional right now"
  97   (labels ((flatten (tree mb)
  98              (if (atom tree)
  99                  (unless (and (typep tree 'minibuffer-window)
 100                               (not mb))
 101                    (list tree))
 102                (nconc (flatten (first tree) mb)
 103                       (flatten (second tree) mb)))))
 104     (flatten (frame-window-tree frame) minibuf)))
 105
 106 (defun window-tree-find-if (fn tree &optional minibuf)
 107   "depth first search the tree. Return the element that satisfies FN."
 108   (cond ((listp tree)
 109          (loop for i in tree
 110                thereis (window-tree-find-if fn i minibuf)))
 111         ((typep tree 'minibuffer-window)
 112          (when (and minibuf
 113                     (funcall fn tree))
 114            tree))
 115         (t
 116          (when (funcall fn tree)
 117            tree))))
 118
 119 (defun replace-window-in-frame-tree (window new)
 120   (labels ((doit (tree window new)
 121              (let ((p (position window tree)))
 122                (if p
 123                    (setf (nth p tree) new)
 124                  (loop for w in tree
 125                        until (and (listp w)
 126                                   (doit w window new)))))))
 127     (doit (frame-window-tree (window-frame window))
 128           window
 129           new)))
 130
 131 ;; (defun replace-window-parent-in-frame-tree (window new)
 132 ;;   (labels ((doit (tree parent window new)
 133 ;;           (when (listp tree)
 134 ;;             (let (loop for i in (remove-if-not 'listp tree)
 135 ;;                    thereis (find window i))
 136 ;;                 (parent
 137 ;;                 (
 138 ;;                 )))
 139 ;;     (doit (frame-window-tree (window-frame window))
 140 ;;        window
 141 ;;        new)))
 142
 143 (defun split-window (&optional (window (get-current-window)) size horflag)
 144   (when (typep window 'minibuffer-window)
 145     (error "Attempt to split minibuffer window"))
 146   (when (null size)
 147     (setf size (if horflag
 148                    (ceiling (window-width window t) 2)
 149                  (ceiling (window-height window t) 2))))
 150   (let (new)
 151     (if horflag
 152         (progn
 153           (when (< size *window-min-width*)
 154             (error "Window width ~a too small (after splitting)" size))
 155           ;; will the other window be too big?
 156           (when (> (+ size *window-min-width*)
 157                    (window-width window t))
 158             (error "Window width ~a too small (after splitting)" (- (window-width window t) size)))
 159           (setf new (make-window :x (+ (window-x window) size)
 160                                  :y (window-y window)
 161                                  :cols (- (window-width window t) size)
 162                                  :rows (window-height window t)
 163                                  :buffer (window-buffer window)
 164                                  :frame (window-frame window))
 165                 (window-seperator new) (window-seperator window)
 166                 (window-seperator window) t
 167                 (slot-value window 'w) size)
 168           ;;(update-window-display-arrays window)
 169           )
 170       (progn
 171         (when (< size *window-min-height*)
 172           (error "Window height ~a too small (after splitting)" size))
 173         ;; will the other window be too big?
 174         (when (> (+ size *window-min-height*)
 175                  (window-height window t))
 176           (error "Window width ~a too small (after splitting)" (- (window-height window t) size)))
 177         (setf new (make-window :x (window-x window)
 178                                :y (+ (window-y window) size)
 179                                :cols (window-width window t)
 180                                :rows (- (window-height window t) size)
 181                                :buffer (window-buffer window)
 182                                :frame (window-frame window))
 183               (window-seperator new) (window-seperator window)
 184               (slot-value window 'h) size)
 185         ;;(update-window-display-arrays window)
 186         ))
 187     (replace-window-in-frame-tree window (list window new))
 188     new))
 189
 190 (defun next-window (window &optional minibuf)
 191   "Return next window after WINDOW in canonical ordering of windows.
 192 FIXME: make this the same as Emacs' next-window."
 193   (let* ((frame (window-frame window))
 194          (tree (frame-window-tree frame))
 195          bit
 196          ;; when we find WINDOW, set BIT to T and return the next window.
 197          (w (window-tree-find-if (lambda (w)
 198                                    (cond (bit w)
 199                                          ((eq w window)
 200                                           (setf bit t)
 201                                           nil)))
 202                                  tree
 203                                  (and minibuf (> (frame-minibuffers-active frame) 0)))))
 204     ;; if we didn't find the next one, maybe it's the first one
 205     (if (not w)
 206         (let ((other (window-tree-find-if #'identity tree)))
 207           (unless (eq window other)
 208             other))
 209       w)))
 210
 211
 212 (defun select-window (window &optional norecord)
 213   "Select WINDOW.  Most editing will apply to WINDOW's buffer.
 214 If WINDOW is not already selected, also make WINDOW's buffer current.
 215 Also make WINDOW the frame's selected window.
 216 Optional second arg NORECORD non-nil means
 217 do not put this buffer at the front of the list of recently selected ones.
 218
 219 **Note that the main editor command loop
 220 **selects the buffer of the selected window before each command."
 221   (declare (ignore norecord))
 222   ;; FIXME: get NORECORD working
 223   (window-save-point (get-current-window))
 224   ;; FIXME: this doesn't make sure window-frame is current.
 225   (setf (frame-current-window (window-frame window)) window)
 226   (set-buffer (window-buffer window))
 227   (window-restore-point window))
 228
 229 (defun display-buffer (buffer &optional not-this-window frame)
 230   "Make BUFFER appear in some window but don't select it.
 231 BUFFER can be a buffer or a buffer name.
 232 If BUFFER is shown already in some window, just use that one,
 233 unless the window is the selected window and the optional second
 234 argument NOT-THIS-WINDOW is non-nil (interactively, with prefix arg).
 235 **If `pop-up-frames' is non-nil, make a new frame if no window shows BUFFER.
 236 **Returns the window displaying BUFFER.
 237 **If `display-buffer-reuse-frames' is non-nil, and another frame is currently
 238 **displaying BUFFER, then simply raise that frame."
 239   (declare (ignore frame))
 240   (setf buffer (get-buffer buffer))
 241   (let* ((cw (get-current-window))
 242          (w (or (window-tree-find-if (lambda (w)
 243                                        (and (not (and not-this-window
 244                                                       (eq w cw)))
 245                                             (eq (window-buffer w) buffer)))
 246                                      (frame-window-tree (selected-frame)))
 247                 (next-window cw)
 248                 (split-window cw))))
 249     (set-window-buffer w buffer)
 250     (window-restore-point w)
 251     w))
 252
 253 (defun pop-to-buffer (buffer &optional other-window norecord)
 254   "Select buffer BUFFER in some window, preferably a different one.
 255 If `pop-up-windows' is non-nil, windows can be split to do this.
 256 If optional second arg OTHER-WINDOW is non-nil, insist on finding another
 257 window even if BUFFER is already visible in the selected window.
 258 This uses the function `display-buffer' as a subroutine; see the documentation
 259 of `display-buffer' for additional customization information.
 260
 261 **Optional third arg NORECORD non-nil means
 262 **do not put this buffer at the front of the list of recently selected ones."
 263   (declare (ignore norecord))
 264   ;; FIXME: honour NORECORD
 265   (setf buffer (if buffer
 266                    (or (get-buffer buffer)
 267                        (progn
 268                          (get-buffer-create buffer)))
 269                          ;; FIXME: (set-buffer-major-mode buffer)
 270                  (other-buffer (current-buffer))))
 271   (select-window (display-buffer buffer other-window)))
 272
 273 (defun sit-for (seconds &optional nodisp)
 274   "Perform redisplay, then wait for seconds seconds or until input is available.
 275 seconds may be a floating-point value, meaning that you can wait for a
 276 fraction of a second.
 277  (Not all operating systems support waiting for a fraction of a second.)
 278 Optional arg nodisp non-nil means don't redisplay, just wait for input.
 279 Redisplay is preempted as always if input arrives, and does not happen
 280 if input is available before it starts.
 281 Value is t if waited the full time with no input arriving."
 282   (declare (ignore seconds nodisp))
 283   ;; FIXME: actually sleep
 284   (frame-render (selected-frame)))
 285
 286 (provide :lice-0.1/frame)