window.lisp

   1 (in-package :lice)
   2
   3 (defvar *next-screen-context-lines* 2
   4   "Number of lines of continuity when scrolling by screenfuls.")
   5
   6 (defvar *window-min-height* 4
   7   "Delete any window less than this tall (including its mode line).")
   8
   9 (defvar *window-min-width* 10
  10   "Delete any window less than this wide.")
  11
  12 ;; we just want a fast and easy dumping area for data. start and end
  13 ;; are inclusive.
  14 (defstruct cache-item
  15    (start 0 :type integer)
  16    (end 0 :type integer))
  17
  18 (defun make-empty-cache-item-vector ()
  19 ;;   (make-array 0 :element-type 'cache-item
  20 ;;            :adjustable t
  21 ;;            :fill-pointer 0)
  22   ())
  23
  24 ;; start and end are inclusive and are buffer points
  25 (defclass line-cache ()
  26   ((start :type integer :initform 0 :initarg :start :accessor lc-start)
  27    (end :type integer :initform 0 :initarg :end :accessor lc-end)
  28    (valid :type boolean :initform nil :initarg :valid :accessor lc-valid)
  29    (cache :type list ;;(array cache-item 1)
  30           :initform nil ;; (make-array 0 :element-type 'cache-item
  31 ;;                         :adjustable t
  32 ;;                         :fill-pointer 0)
  33           :initarg :cache :accessor lc-cache)))
  34
  35 (defun item-in-cache (window n)
  36   "Return the Nth item in the cache or NIL if it doesn't exist."
  37   (elt (lc-cache (window-cache window)) n))
  38 ;;   (when (< n (length (lc-cache (window-cache window))))
  39 ;;     (aref (lc-cache (window-cache window)) n)))
  40
  41 (defclass window ()
  42   ((frame :initarg :frame :accessor window-frame)
  43    (x :type integer :initarg :x :accessor window-x)
  44    (y :type integer :initarg :y :accessor window-y)
  45    (w :type integer :initarg :w :documentation
  46       "The width of the window's contents.")
  47    (h :type integer :initarg :h :documentation
  48       "The total height of the window, including the mode-line.")
  49    (seperator :type boolean :initform nil :accessor window-seperator :documentation
  50               "T when the window is to draw a vertical seperator. used in horizontal splits.")
  51    (line-state :type (array integer 1) :initarg :line-state :accessor window-line-state)
  52    (cache :type line-cache :initarg :cache :accessor window-cache)
  53    ;; Indices into cache (inclusive) that describe the range of the
  54    ;; cache that will be displayed.
  55    (top-line :type integer :initarg :top-line :accessor window-top-line)
  56    (bottom-line :type integer :initarg :bottom-line :accessor window-bottom-line)
  57    (point-col :type integer :initarg :point-col :accessor window-point-col)
  58    (point-line :type integer :initarg :point-line :accessor window-point-line)
  59    ;; The rest refer to points in the buffer
  60    (buffer :type buffer :initarg :buffer :accessor window-buffer)
  61    (bpoint :type marker :initarg :bpoint :accessor window-bpoint :documentation
  62            "A marker marking where in the text the window point is.")
  63    (top :type marker :initarg :top :accessor window-top :documentation
  64         "The point in buffer that is the first character displayed in the window")
  65    (bottom :type marker :initarg :bottom :accessor window-bottom :documentation
  66            "The point in buffer that is the last character displayed
  67 in the window. This should only be used if bottom-valid is T.")
  68    (bottom-valid :type boolean :initform nil :accessor window-bottom-valid :documentation
  69                  "When this is T then bottom should be used to
  70 calculate the visible contents of the window. This is used when
  71 scrolling up (towards the beginning of the buffer)."))
  72   (:documentation "A Lice Window."))
  73
  74 ;; (defun update-window-display-arrays (window)
  75 ;;   "Used to update the window display structures for window splits."
  76 ;;   (let* ((rows (window-height window t))
  77 ;;       (cols (window-width window t))
  78 ;;       (l (make-array (* rows cols)
  79 ;;                      :element-type 'character))
  80 ;;       (d (make-array (list rows cols)
  81 ;;                      :element-type 'character
  82 ;;                      :displaced-to l :displaced-index-offset 0)))
  83 ;;     ;; FIXME: This forces needless redraw because the arrays are
  84 ;;     ;; reset.
  85 ;;     (setf (window-display window) l
  86 ;;        (window-2d-display window) d)))
  87
  88 (defun make-window (&key x y cols rows buffer frame
  89                          (top (make-marker 0 buffer))
  90                          (bpoint (make-marker))
  91                          (type 'window))
  92   "Return a new window. This is handy for setting up all the pesky
  93 display structures.
  94
  95 TYPE isn't used yet. it's just there for hype."
  96   (let* ((w (make-instance type
  97                            :frame frame
  98                            :x x :y y :w cols :h rows
  99                            :line-state (make-array rows :element-type 'integer :initial-element -1)
 100                            :cache (make-instance 'line-cache :valid t)
 101                            :top-line 0
 102                            :bottom-line 0
 103                            :point-col 0
 104                            :point-line 0
 105                            :buffer buffer
 106                            :top top
 107                            :bottom (make-marker 0 buffer)
 108                            :bpoint bpoint
 109                            :point-col 0
 110                            :point-line 0)))
 111     w))
 112
 113 (defun make-test-window (buffer)
 114   (make-window :x 0 :y 0 :cols 60 :rows 20 :buffer buffer))
 115
 116 \f
 117 ;;; Other non-display related functions
 118
 119 (defun window-height (w &optional include-mode-line)
 120   "Return the height of the window. By default, the mode-line is not
 121 included in the height."
 122   ;; if the mode-line is nil, then there is no modeline.
 123   (if (or include-mode-line
 124           (null (buffer-mode-line (window-buffer w))))
 125       (slot-value w 'h)
 126     (1- (slot-value w 'h))))
 127
 128 (defun window-width (w &optional include-seperator)
 129   "Return the width of the window. By default, the vertical seperator,
 130 for horizontal splits, is not included in the width."
 131   ;; if the mode-line is nil, then there is no modeline.
 132   (if (or include-seperator
 133           (not (window-seperator w)))
 134       (slot-value w 'w)
 135     (1- (slot-value w 'w))))
 136
 137 (defun get-current-window (&optional (frame (selected-frame)))
 138   "Return the current window in the current frame. If FRAME is
 139 specified, use that frame instead."
 140   (frame-current-window frame))
 141
 142 (defun set-window-buffer (window buffer &optional keep-margins)
 143   "Make WINDOW display BUFFER as its contents.
 144 BUFFER can be a buffer or buffer name.
 145 Optional third arg KEEP-MARGINS non-nil means that WINDOW's current
 146 display margins, fringe widths, and scroll bar settings are maintained;
 147 the default is to reset these from BUFFER's local settings or the frame
 148 defaults."
 149   ;; this is redundant if buffer is a string, since its
 150   ;; looked up already.
 151   (declare (type window window)
 152            (type buffer buffer)
 153            (type boolean keep-margins)
 154            (ignore keep-margins))
 155   (let ((buf (get-buffer buffer)))
 156     (unless buf
 157       (error "No buffer named ~a" buffer))
 158     (unless (eq (window-buffer window) buf)
 159       ;; update buffer time stamps
 160       (incf (buffer-display-count buf))
 161       ;; MOVITZ doesn't have get-universal-time
 162       ;; (setf (buffer-display-time buf) (get-universal-time))
 163       ;; update buffer list
 164       (bring-buffer-to-front buf)
 165       ;; display stuff
 166       (set-marker (window-top window) 0 buf)
 167       (set-marker (window-bottom window) 100 buf)
 168       (set-marker (window-bpoint window) (marker-position (buffer-point buf)) buf)
 169       ;; finally set the buffer
 170       (setf (window-buffer window) buf)
 171       ;; TODO: run hooks
 172       )))
 173
 174 (defgeneric cache-size (object))
 175
 176 (defmethod cache-size ((object line-cache))
 177   (length (lc-cache object)))
 178
 179 (defmethod cache-size ((object window))
 180   (cache-size (window-cache object)))
 181
 182 (defun reset-line-state (window)
 183   (fill (window-line-state window) -1))
 184
 185 (defun window-reset-cache (window)
 186   (with-slots (cache) window
 187     (setf (lc-cache cache) nil
 188           (lc-start cache) 0
 189           (lc-end cache) 0
 190           (lc-valid cache) t)))
 191
 192 (defun point-in-line-cache (line-cache p)
 193   "Return the line in the cache that P is on. NIL if p is not in range"
 194   (declare (type integer p))
 195   (position-if (lambda (l)
 196                  (and (>= p (cache-item-start l))
 197                       (<= p (cache-item-end l))))
 198                line-cache))
 199
 200 \f
 201 ;;; Display related functions. Generate the line cache based on
 202 ;;; character cells, not pixels.
 203
 204 (defun add-line-to-cache (cache from to &optional at-beginning)
 205   "Add a single line to the cache list. Return the new cache list."
 206   (let ((line (make-cache-item :start from :end to)))
 207     (if at-beginning
 208         (cons line cache)
 209       (nconc1 cache line))))
 210 ;;      (progn
 211 ;;        (grow-vector lines 1 line)
 212 ;;        (replace lines lines :start1 1)
 213 ;;        (setf (elt lines 0) line))
 214 ;;       (vector-push-extend line lines))))
 215
 216
 217 ;; (defun generate-lines-region (cache buffer width from to)
 218 ;;   "FROM must not be a newline (It should be the character after a new
 219 ;; line or the beginning of the buffer) and TO must be newline or the
 220 ;; end of the buffer."
 221 ;;   (declare (type line-cache cache)
 222 ;;         (type buffer buffer)
 223 ;;         (type integer width from to))
 224 ;;   (let ((lines (make-array 0 :element-type 'cache-item
 225 ;;                         :adjustable t
 226 ;;                         :fill-pointer 0))
 227 ;;      (rplc-start (= (1+ to) (lc-start cache)))
 228 ;;      (rplc-end (= (1- from) (lc-end cache)))
 229 ;;      (empty-cache (= (length (lc-cache cache)) 0)))
 230 ;;     (dformat +debug-vvv+ "generate-n-lines: ~a ~a~%" from to)
 231 ;;     ;; Make sure either from-1 or to+1 is already in the cache, its
 232 ;;     ;; the first one. A point cannot exist in 2 cache lines because
 233 ;;     ;; points are inclusive.
 234 ;;     (when (or rplc-start rplc-end empty-cache)
 235 ;;       ;; search for newlines until we hit TO
 236 ;;       (do ((last-p from (1+ p))
 237 ;;         (p (buffer-scan-newline buffer from to 1)
 238 ;;            (buffer-scan-newline buffer (1+ p) to 1))
 239 ;;         (l 0 (1+ l)))
 240 ;;        (nil)
 241
 242 ;;      ;; Break the buffer line into chunks that fit on one window line
 243 ;;      (dformat +debug-vvv+ "last-p: ~a p:~a~%" last-p p)
 244 ;;      (loop for i from last-p by width
 245 ;;            do (vector-push-extend (make-cache-item :start i
 246 ;;                                                    :end (if (<= (+ i (1- width)) p)
 247 ;;                                                             (+ i (1- width))
 248 ;;                                                           p))
 249 ;;                                   lines)
 250 ;;            always (< (+ i (1- width)) p))
 251 ;;      ;; Once we've processed the new line, check if we've run out of
 252 ;;      ;; buffer to process.
 253 ;;      (when (= p to)
 254 ;;        (return)))
 255 ;;       ;; Add these new items to the cache
 256 ;;       (let ((carray (lc-cache cache)))
 257 ;;      (adjust-array cache
 258 ;;                    (+ (length carray)
 259 ;;                       (length lines))
 260 ;;                    :initial-element (aref lines 0)
 261 ;;                    :fill-pointer (+ (length carray)
 262 ;;                                     (length lines)))
 263 ;;      (cond (rplc-start
 264 ;;             ;; Put it at the beginning
 265 ;;             (dformat +debug-vvv+ "rplc-start~%")
 266 ;;             (setf (lc-start cache) from)
 267 ;;             (replace carray carray :start1 (length lines))
 268 ;;             (replace carray lines))
 269 ;;            (rplc-end
 270 ;;             (dformat +debug-vvv+ "rplc-end~%")
 271 ;;             (setf (lc-end cache) to)
 272 ;;             (replace carray lines :start1 (- (length carray)
 273 ;;                                             (length lines))))
 274 ;;            (empty-cache
 275 ;;             (dformat +debug-vvv+ "empty-cache~%")
 276 ;;             (setf (lc-start cache) from)
 277 ;;             (setf (lc-end cache) to)
 278 ;;             ;; FIXME: we could just use lines instead of copy them over, right?
 279 ;;             (replace carray lines))))))
 280 ;;   (dformat +debug-vvv+ "after gen-n-lines: ~a~%" (lc-cache cache)))
 281
 282 (defun generate-n-lines-forward (buffer width from n-lines)
 283   "Return an array of cache-items for N-LINES lines in BUFFER rendered
 284 with WIDTH columns starting at FROM. The array will have length at
 285 least N-LINES."
 286   (declare (type buffer buffer)
 287            (type integer width from))
 288   (let ((lines (make-empty-cache-item-vector))
 289         (to (1- (buffer-size buffer))))
 290     (dformat +debug-vvv+ "generate-n-lines: ~a ~a~%" from to)
 291     ;; search for newlines until we hit TO
 292     (do ((last-p from (1+ p))
 293          (p (buffer-scan-newline buffer from to 1)
 294             (buffer-scan-newline buffer (1+ p) to 1))
 295          (l 0 (1+ l)))
 296         (nil)
 297
 298       ;; Break the buffer line into chunks that fit on one window line
 299       (dformat +debug-vvv+ "last-p: ~a p:~a~%" last-p p)
 300       (loop for i from last-p by width
 301             do (setf lines (add-line-to-cache lines i (if (<= (+ i (1- width)) p)
 302                                                           (+ i (1- width))
 303                                                         p)))
 304 ;; (vector-push-extend (make-cache-item :start i
 305 ;;                                                  :end (if (<= (+ i (1- width)) p)
 306 ;;                                                           (+ i (1- width))
 307 ;;                                                         p))
 308 ;;                                 lines)
 309             always (< (+ i (1- width)) p))
 310       ;; Once we've processed the new line, check if we've generated
 311       ;; enough lines. Return LINES we're done.
 312       (when (or (>= (length lines) n-lines)
 313                 (>= p to))
 314         (return lines)))))
 315
 316 (defun generate-n-lines-backward (buffer width from n-lines)
 317   "Return an array of cache-items for N-LINES lines in BUFFER rendered
 318 with WIDTH columns starting at FROM and going backward. The array will
 319 have length at least N-LINES.
 320
 321 FROM is assumed to the char pos of the newline at the end of the
 322 starting line."
 323   (declare (type buffer buffer)
 324            (type integer width from))
 325   (let ((lines (make-empty-cache-item-vector))
 326         (to 0))
 327     (dformat +debug-vvv+ "generate-n-lines: ~a ~a~%" from to)
 328     ;; search for newlines until we hit TO.
 329     (do ((last-p from p)
 330          (p (buffer-scan-newline buffer (1- from) to -1)
 331             (buffer-scan-newline buffer (1- p) to -1))
 332          (l 0 (1+ l)))
 333         (nil)
 334
 335       ;; Break the buffer line into chunks that fit on one window line
 336       (dformat +debug-vvv+ "last-p: ~a p:~a~%" last-p p)
 337       ;; unless we're at the beginning of the buffer, we want the char
 338       ;; after p because p will be a newline. last-p will be the
 339       ;; newline at the end of the line, 1+ p will be the beginning.
 340       ;;
 341       ;; this is a bit hairy because we're going backwards, but we go
 342       ;; through the line forward.
 343       ;;(let ((items (make-empty-cache-item-vector)))
 344       (loop for i from (if (zerop p) 0 (1+ p)) by width
 345             do (setf lines (add-line-to-cache lines
 346                                               i
 347                                               (if (<= (+ i (1- width)) last-p)
 348                                                   (+ i (1- width))
 349                                                 last-p)
 350                                               t))
 351             ;; (vector-push-extend (make-cache-item :start i
 352             ;;                                                :end (if (<= (+ i (1- width)) last-p)
 353             ;;                                                         (+ i (1- width))
 354             ;;                                                       last-p))
 355             ;;                               items)
 356             always (< (+ i (1- width)) last-p))
 357         ;;(vector-append lines (nreverse items)))
 358       ;; Once we've processed the new line, check if we've generated
 359       ;; enough lines. Return LINES we're done.
 360       (when (or (>= (length lines) n-lines)
 361                 (<= p to))
 362         (return  lines ;; (nreverse lines)
 363                  )))))
 364
 365 ;; (defun update-cache (cache buffer width point n-many)
 366 ;;   "Add N-MANY lines to the end of the line cache CACHE unless N-MANY
 367 ;; is negative. In that case add (abs n-many) to the beginning. This
 368 ;; function requires at least 1 line in the cache already.
 369
 370 ;; Lines are WIDTH in length. BUFFER is the data for caching."
 371 ;;   ;; Fill in above the cache
 372 ;;   (dformat +debug-vv+ "update-cache: ~a~%" n-many)
 373 ;;   (if (> n-many 0)
 374 ;;       (let* ((end (1+ (lc-end cache)))
 375 ;;           pt)
 376 ;;      ;; Go forward
 377 ;;      (when (< end (1- (buffer-size buffer)))
 378 ;;          ;; Add cache entries
 379 ;;        (setf pt (buffer-scan-newline buffer
 380 ;;                                      end (1- (buffer-size buffer))
 381 ;;                                      n-many))
 382 ;;        (generate-lines-region cache buffer width end pt)))
 383 ;;     ;; Go backward
 384 ;;     (let* ((start (1- (lc-start cache)))
 385 ;;         pt)
 386 ;;       ;; We need this because start is a newline, which we want to skip over
 387 ;;       (setf n-many (1- n-many))
 388 ;;       (dformat +debug-vvv+ "backward: ~a ~a ~a~%"
 389 ;;             start n-many (lc-cache cache))
 390 ;;       (when (and (> start 0)
 391 ;;               (/= n-many 0))
 392 ;;      ;; Add cache entries
 393 ;;      (setf pt (buffer-scan-newline buffer start 0 n-many))
 394 ;;      (generate-lines-region cache buffer width (if (> pt 0) (1+ pt) pt) start)))))
 395
 396 (defun add-end-of-buffer (buffer lines)
 397   "The point can be at (buffer-size buffer) but we only scan to
 398   1- that. So if we're scanned to the end of the buffer properly
 399   alter LINES to contain that point."
 400   (let ((end (1- (buffer-size buffer)))
 401         (last-elt (elt lines (1- (length lines)))))
 402     (when (= (cache-item-end last-elt) end)
 403       (if (char= (buffer-char-after buffer end) #\Newline)
 404           (add-line-to-cache lines (buffer-size buffer) (buffer-size buffer))
 405         (incf (cache-item-end last-elt))))))
 406
 407 (defun window-framer-from-top (window point &optional always-return-lines)
 408   "Fill in window's line cache from WINDOW-TOP with a full window's
 409 worth of lines and return T if POINT was in the line cache. otherwise
 410 don't change anything and return nil."
 411   (let* ((lines (generate-n-lines-forward (window-buffer window) (window-width window)
 412                                           (marker-position (window-top window))
 413                                           (window-height window))))
 414     (add-end-of-buffer (window-buffer window) lines)
 415     (when (or always-return-lines
 416               (point-in-line-cache lines point))
 417       lines)))
 418
 419 (defun window-framer-from-bottom (window point &optional always-return-lines)
 420   "Fill in window's line cache from WINDOW-BOTTOM with a full window's
 421 worth of lines and return T if POINT was in the line cache. otherwise
 422 don't change anything and return nil."
 423   (let* ((lines (generate-n-lines-backward (window-buffer window) (window-width window)
 424                                            (marker-position (window-bottom window))
 425                                            (window-height window))))
 426     (add-end-of-buffer (window-buffer window) lines)
 427     (when (or always-return-lines
 428               (point-in-line-cache lines point))
 429       lines)))
 430
 431 (defun window-framer-around-point (window point n-many)
 432   "Fill in window's line cache going out from point with n-many lines
 433 above WINDOW-POINT, or as many as possible if we hit the top of the window."
 434   ;; Add the line with the pointer on it
 435   (let* ((max (1- (buffer-size (window-buffer window))))
 436          (b (buffer-scan-newline (window-buffer window) point 0 0))
 437          (e (buffer-scan-newline (window-buffer window) point max 1))
 438          (lines-above (generate-n-lines-backward (window-buffer window) (window-width window)
 439                                                  e n-many))
 440          (lines-below (when (< e max)
 441                         (generate-n-lines-forward (window-buffer window) (window-width window)
 442                                                   (1+ e)
 443                                                   (- (window-height window)
 444                                                      (min n-many
 445                                                           (length lines-above)))))))
 446     (declare (ignore b))
 447     (if lines-below
 448         (add-end-of-buffer (window-buffer window) lines-below)
 449       (add-end-of-buffer (window-buffer window) lines-above))
 450     (when (or (point-in-line-cache lines-above point)
 451               (point-in-line-cache lines-below point))
 452       (if lines-below
 453           (nconc lines-above lines-below)
 454 ;;        (grow-vector lines-above (length lines-below) (elt lines-below 0))
 455 ;;        (replace lines-above lines-below :start1 end))
 456       lines-above))))
 457
 458 (defun window-framer (window point n-many)
 459   "fill in window's line-cache."
 460   ;; first try the top/bottom markers. if point isn't in there then
 461   ;; center the window around point.
 462   (let* ((bot (and (window-bottom-valid window)
 463                    (window-framer-from-bottom window point)))
 464          (top (unless bot
 465                 (window-framer-from-top window point)))
 466          (around (unless top
 467                    (window-framer-around-point window point n-many)))
 468          (lines (or bot top around)))
 469     (assert lines)
 470     ;; set the top marker
 471     (setf (window-bottom-valid window) nil)
 472     (cond (bot
 473            (let* ((tl (max 0 (- (length lines) (window-height window))))
 474                   (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
 475              (setf (marker-position (window-top window))
 476                    (cache-item-start (elt lines tl))
 477                    (window-top-line window) tl
 478                    (marker-position (window-bottom window)) (cache-item-end (elt lines bl)))))
 479           (top
 480            (let* ((tl (point-in-line-cache lines (marker-position (window-top window))))
 481                   (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
 482              (setf (window-top-line window) tl
 483                    (marker-position (window-bottom window)) (cache-item-end (elt lines bl)))))
 484           (around
 485            (let* ((pl (point-in-line-cache lines point))
 486                   (tl (max 0 (- pl n-many)))
 487                   (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
 488              (setf (marker-position (window-top window))
 489                    (cache-item-start (elt lines tl))
 490                    (window-top-line window) tl
 491                    (marker-position (window-bottom window)) (cache-item-end (elt lines bl))))))
 492     ;; fill in window's cache
 493     (with-slots (cache) window
 494       (setf (lc-cache cache) lines
 495             (lc-start cache) (cache-item-start (elt lines 0))
 496             (lc-end cache) (cache-item-end (elt lines (1- (length lines))))
 497             (lc-valid cache) t))))
 498
 499
 500 ;; (defun window-framer (window point n-many)
 501 ;;   "Decide what part of the buffer to display in window. Sets top,
 502 ;; bottom, point-col, and point-line in window. N-MANY is the number of
 503 ;; lines from point to the top of the window."
 504 ;;   ;; Add the line with the pointer on it
 505 ;;   (let ((b (buffer-scan-newline (window-buffer window) point 0 0))
 506 ;;      (e (buffer-scan-newline (window-buffer window)
 507 ;;                              point (1- (buffer-size (window-buffer window))) 1)))
 508 ;;     (dformat +debug-vv+ "point line: ~a ~a~%" b e)
 509 ;;     (generate-lines-region window (if (= b 0) b (1+ b)) e))
 510 ;;   ;; search up n-many the window height
 511 ;;   (update-cache window (- n-many))
 512 ;;   (dformat +debug-vvv+ "cache s/e: ~a ~a~%"
 513 ;;         (lc-start (window-cache window))
 514 ;;         (lc-end (window-cache window)))
 515 ;;   ;; search down height - n-many + 1 (we've already generated the point's line)
 516 ;;   (update-cache window (- (window-height window) n-many -1))
 517 ;;   ;; Special case. if we got to the end of the buffer and it ends with
 518 ;;   ;; a newline. Add an extra cache line for line after that which
 519 ;;   ;; could contain the cursor.
 520 ;;   (when (= (lc-end (window-cache window))
 521 ;;         (1- (buffer-size (window-buffer window))))
 522 ;;     (add-line-to-cache window
 523 ;;                     (buffer-size (window-buffer window))
 524 ;;                     (buffer-size (window-buffer window))
 525 ;;                     nil t nil))
 526 ;;   ;; if we find window-top or window bottom in the cache then we
 527 ;;   ;; should use it as the top/bottom and generate the remaining lines
 528 ;;   (let ((wtop (point-window-line window (marker-position (window-top window))))
 529 ;;      (pline (point-window-line window point))
 530 ;;      (wbot (point-window-line window (marker-position (window-bottom window)))))
 531 ;;     (dformat +debug-vvv+ "cache: ~a~%" (lc-cache (window-cache window)))
 532 ;;     (dformat +debug-vv+ ">>>wtop: ~a ~a pline: ~a ~a wbot: ~a ~a~%"
 533 ;;           wtop (marker-position (window-top window))
 534 ;;           pline point
 535 ;;           wbot (marker-position (window-bottom window)))
 536 ;;     (cond ((and wtop
 537 ;;              (<= wtop pline))
 538 ;;         (dformat +debug-vv+ "wtop. ~a ~%" (cache-size window))
 539 ;;         (let ((lines-left (- (window-height window)
 540 ;;                              (- (cache-size window) wtop))))
 541 ;;           (when (> lines-left 0)
 542 ;;             (update-cache window lines-left))
 543 ;;           (dformat +debug-vvv+ "wtop cache: ~a~%" (lc-cache (window-cache window)))
 544 ;;           (setf (window-top-line window) wtop
 545 ;;                 (marker-position (window-top window)) (cache-item-start
 546 ;;                                                        (aref (lc-cache (window-cache window)) wtop))
 547 ;;                 (window-bottom-line window) (min (1- (cache-size window))
 548 ;;                                                  (+ wtop (window-height window) -1))
 549 ;;                 (marker-position (window-bottom window)) (cache-item-end
 550 ;;                                                           (aref (lc-cache (window-cache window))
 551 ;;                                                                 (window-bottom-line window))))))
 552 ;;        ((and wbot
 553 ;;              (>= wbot pline))
 554 ;;         (dformat +debug-vv+ "wbot. ~a ~%" (cache-size window))
 555 ;;         (let ((lines-left (- (window-height window) wbot 1)))
 556 ;;           (when (> lines-left 0)
 557 ;;             (update-cache window (- lines-left)))
 558 ;;           (dformat +debug-vvv+ "wbot cache: ~a~%" (lc-cache (window-cache window)))
 559 ;;           ;; we need to rescan bottom since lines may have been
 560 ;;           ;; added above it, invalidating wbot
 561 ;;           (setf wbot (point-window-line window (marker-position (window-bottom window)))
 562 ;;                 (window-bottom-line window) wbot
 563 ;;                 (marker-position (window-bottom window)) (cache-item-end (aref
 564 ;;                                                                           (lc-cache (window-cache window))
 565 ;;                                                                           wbot))
 566 ;;                 (window-top-line window) (max 0 (- wbot (window-height window) 1))
 567 ;;                 (marker-position (window-top window)) (cache-item-start (aref
 568 ;;                                                                          (lc-cache (window-cache window))
 569 ;;                                                                          (window-top-line window))))))
 570 ;;         (t
 571 ;;          (dformat +debug-vv+ "we need to scroll. ~a ~%" (cache-size window))
 572 ;;          (setf (window-top-line window) (max 0 (- pline n-many))
 573 ;;                (marker-position (window-top window)) (cache-item-start (aref (lc-cache (window-cache window))
 574 ;;                                                                              (window-top-line window)))
 575 ;;                (window-bottom-line window) (min
 576 ;;                                             (1- (cache-size window))
 577 ;;                                             (+ (window-top-line window) (window-height window) -1))
 578 ;;                (marker-position (window-bottom window)) (cache-item-end
 579 ;;                                                          (aref (lc-cache (window-cache window))
 580 ;;                                                                (window-bottom-line window)))))))
 581 ;;   (setf (window-point-line window) (point-window-line window point))
 582 ;;   (dformat +debug-vv+ "<<<top: ~a ~a pt: ~a ~a bot: ~a ~a~%"
 583 ;;         (window-top-line window) (marker-position (window-top window))
 584 ;;         (window-point-line window) point
 585 ;;         (window-bottom-line window) (marker-position (window-bottom window))))
 586
 587 (defun window-point (&optional window)
 588   "Return current value of point in WINDOW. For a nonselected window,
 589 this is the value point would have if that window were selected."
 590   (if (eq window (get-current-window))
 591       (point (window-buffer window))
 592     (marker-position (window-bpoint window))))
 593
 594 (defun set-window-point (window pos)
 595   (let ((mark (if (eq window (get-current-window))
 596                   (buffer-point (window-buffer window))
 597                 (window-bpoint window))))
 598     (if (and (<= pos (buffer-max (window-buffer window)))
 599              (>= pos (buffer-min (window-buffer window))))
 600         (setf (marker-position mark) pos)
 601       (error "out of range"))))
 602
 603 (defun get-buffer-window (buffer &optional frame)
 604   "Return a window currently displaying BUFFER, or nil if none.
 605 If optional argument FRAME is `visible', search all visible frames.
 606 If optional argument FRAME is 0, search all visible and iconified frames.
 607 If FRAME is t, search all frames.
 608 If FRAME is nil, search only the selected frame.
 609 If FRAME is a frame, search only that frame."
 610   ;; TODO: honour FRAME
 611   (setf frame (selected-frame)
 612         buffer (get-buffer buffer))
 613   (find buffer (frame-window-list frame) :key 'window-buffer))
 614
 615 (defun window-scroll-up (window n-lines)
 616   "scroll the window up (go torwards the end of the buffer) LINES many
 617 lines, moving the window point to be visible."
 618   (let* ((len (+ (window-height window) n-lines))
 619          (lines (generate-n-lines-forward (window-buffer window) (window-width window)
 620                                          (marker-position (window-top window))
 621                                          len)))
 622     ;; if there aren't n-lines left in the buffer then signal
 623     ;; an end-of-buffer error.
 624 ;;     (unless (>= (length lines) n-lines)
 625 ;;       (error "end of buffer"))
 626     (setf (marker-position (window-top window)) (cache-item-start (elt lines
 627                                                                        (1- (min (length lines)
 628                                                                                 n-lines)))))
 629     ;; FIXME: for now, set the point at the top of the window if it
 630     ;; isn't visible.
 631     (when (or (< (window-point window) (marker-position (window-top window)))
 632               (not (point-in-line-cache lines (window-point window))))
 633       (set-window-point window (marker-position (window-top window))))))
 634
 635 (defun window-scroll-down (window n-lines)
 636   "scroll the window down (go torwards the beginning of the buffer)
 637 LINES many lines, moving the window point to be visible."
 638   (let* ((len (+ (window-height window) n-lines))
 639          ;; FIXME: this is basically, gross.
 640          (above (generate-n-lines-backward (window-buffer window) (window-width window)
 641                                            (max (buffer-min (window-buffer window))
 642                                                 (1- (marker-position (window-top window))))
 643                                            n-lines))
 644          (lines (generate-n-lines-forward (window-buffer window) (window-width window)
 645                                           (cache-item-start
 646                                            (elt above (max 0 (- (length above) n-lines))))
 647                                           len)))
 648     ;; if there aren't n-lines left in the buffer then signal
 649     ;; an end-of-buffer error.
 650 ;;     (unless (>= (length above) n-lines)
 651 ;;       (error "beginning of buffer"))
 652     (setf (marker-position (window-top window)) (cache-item-start (elt lines 0)))
 653     ;; FIXME: for now, set the point at the bottom of the window if it
 654     ;; isn't visible.
 655     (let ((eow (elt lines (1- (min (length lines)
 656                                    (window-height window))))))
 657       (when (or (> (window-point window) (cache-item-end eow))
 658                 (not (point-in-line-cache lines (window-point window))))
 659         (set-window-point window (cache-item-start eow))))))
 660
 661 (defun window-save-point (window)
 662   "Save WINDOW's buffer's point to WINDOW-BPOINT."
 663   (setf (marker-position (window-bpoint window)) (point (window-buffer window))))
 664
 665 (defun window-restore-point (window)
 666   "Restore the WINDOW's buffer's point from WINDOW-BPOINT."
 667   ;; restore the point
 668   (setf (marker-position (buffer-point (window-buffer window)))
 669         (marker-position (window-bpoint window))))
 670
 671 (defcommand delete-other-windows ()
 672   (let* ((frame (selected-frame))
 673          (cw (get-current-window))
 674          (mb (window-tree-find-if (lambda (w)
 675                                     (typep w 'minibuffer-window))
 676                                   (frame-window-tree frame)
 677                                   t)))
 678     ;; FIXME: This doesn't properly refresh and the window's display
 679     ;; arrays aren't resized.
 680     (setf (window-x cw) 0
 681           (window-y cw) 0
 682           (window-seperator cw) nil
 683           (slot-value cw 'w) (frame-width frame)
 684           (slot-value cw 'h) (- (frame-height frame) (window-height mb t))
 685           (frame-window-tree frame) (list cw mb))
 686     ;;(update-window-display-arrays cw)
 687     ))
 688
 689 (defun window-parent (window)
 690   "Return the parent list in frame-window-tree for WINDOW."
 691   (labels ((parent-of (tree parent window)
 692              (cond ((listp tree)
 693                     (loop for i in tree
 694                        thereis (parent-of i tree window)))
 695                    (t
 696                     (when (eq tree window)
 697                       parent)))))
 698     (parent-of (frame-window-tree (window-frame window)) nil window)))
 699
 700 (defun delete-window (&optional (window (selected-window)))
 701   (check-type window window)
 702   (when (or (typep window minibuffer-window)
 703             (typep (frame-window-tree frame) 'window))
 704     (error "Attempt to delete minibuffer or sole ordinary window")))
 705
 706
 707 (provide :lice-0.1/window)