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