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