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 (defmacro check-live-window (win)
  13   "This macro rejects windows on the interior of the window tree as
  14 \"dead\", which is what we want; this is an argument-checking macro, and
  15 the user should never get access to interior windows.
  16
  17 A window of any sort, leaf or interior, is dead iff the buffer,
  18 vchild, and hchild members are all nil."
  19   `(and
  20     (check-type ,win window)
  21     (not (null (window-buffer ,win)))))
  22
  23 ;; we just want a fast and easy dumping area for data. start and end
  24 ;; are inclusive.
  25 (defstruct cache-item
  26    (start 0 :type integer)
  27    (end 0 :type integer))
  28
  29 (defun make-empty-cache-item-vector ()
  30 ;;   (make-array 0 :element-type 'cache-item
  31 ;;            :adjustable t
  32 ;;            :fill-pointer 0)
  33   ())
  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 ;; (defun update-window-display-arrays (window)
  42 ;;   "Used to update the window display structures for window splits."
  43 ;;   (let* ((rows (window-height window t))
  44 ;;       (cols (window-width window t))
  45 ;;       (l (make-array (* rows cols)
  46 ;;                      :element-type 'character))
  47 ;;       (d (make-array (list rows cols)
  48 ;;                      :element-type 'character
  49 ;;                      :displaced-to l :displaced-index-offset 0)))
  50 ;;     ;; FIXME: This forces needless redraw because the arrays are
  51 ;;     ;; reset.
  52 ;;     (setf (window-display window) l
  53 ;;        (window-2d-display window) d)))
  54
  55 (defun make-window (&key x y cols rows buffer frame
  56                     (top (make-marker))
  57                     (bpoint (make-marker))
  58                     (bottom (make-marker))
  59                     (type 'window))
  60   "Return a new window. This is handy for setting up all the pesky
  61 display structures.
  62
  63 TYPE isn't used yet. it's just there for hype."
  64   (let* ((w (make-instance type
  65                            :frame frame
  66                            :x x :y y :w cols :h rows
  67                            :line-state (make-array rows :element-type 'integer :initial-element -1)
  68                            :cache (make-instance 'line-cache :valid t)
  69                            :top-line 0
  70                            :bottom-line 0
  71                            :point-col 0
  72                            :point-line 0
  73                            :buffer buffer
  74                            :top top
  75                            :bottom bottom
  76                            :bpoint bpoint
  77                            :point-col 0
  78                            :point-line 0)))
  79     (set-marker bpoint (pt buffer) buffer)
  80     (set-marker top (begv buffer) buffer)
  81     (set-marker bottom (begv buffer) buffer)
  82     w))
  83
  84 (defun make-test-window (buffer)
  85   (make-window :x 0 :y 0 :cols 60 :rows 20 :buffer buffer))
  86
  87 \f
  88 ;;; Other non-display related functions
  89
  90 (defun window-height (w &optional include-mode-line)
  91   "Return the height of the window. By default, the mode-line is not
  92 included in the height."
  93   ;; if the mode-line is nil, then there is no modeline.
  94   (if (or include-mode-line
  95           (null (buffer-local '*mode-line-format* (window-buffer w))))
  96       (slot-value w 'h)
  97     (1- (slot-value w 'h))))
  98
  99 (defun window-width (w &optional include-seperator)
 100   "Return the width of the window. By default, the vertical seperator,
 101 for horizontal splits, is not included in the width."
 102   ;; if the mode-line is nil, then there is no modeline.
 103   (if (or include-seperator
 104           (not (window-seperator w)))
 105       (slot-value w 'w)
 106     (1- (slot-value w 'w))))
 107
 108 (defun selected-window ()
 109   "Return the window that the cursor now appears in and commands apply to."
 110   (frame-selected-window (selected-frame)))
 111 ;;  *selected-window*)
 112
 113 (defun set-window-buffer (window buffer &optional keep-margins)
 114   "Make WINDOW display BUFFER as its contents.
 115 BUFFER can be a buffer or buffer name.
 116 Optional third arg KEEP-MARGINS non-nil means that WINDOW's current
 117 display margins, fringe widths, and scroll bar settings are maintained;
 118 the default is to reset these from BUFFER's local settings or the frame
 119 defaults."
 120   ;; this is redundant if buffer is a string, since its
 121   ;; looked up already.
 122   (declare (type window window)
 123            (type buffer buffer)
 124            (type boolean keep-margins)
 125            (ignore keep-margins))
 126   (let ((buf (get-buffer buffer)))
 127     (unless buf
 128       (error "No buffer named ~a" buffer))
 129     (unless (eq (window-buffer window) buf)
 130       ;; update buffer time stamps
 131       (incf (buffer-display-count buf))
 132       ;; MOVITZ doesn't have get-universal-time
 133       ;; (setf (buffer-display-time buf) (get-universal-time))
 134       ;; update buffer list
 135       (bring-buffer-to-front buf)
 136       ;; display stuff
 137       (set-marker (window-top window) 0 buf)
 138       (set-marker (window-bottom window) 100 buf)
 139       (set-marker (window-bpoint window) (marker-position (buffer-point buf)) buf)
 140       ;; finally set the buffer
 141       (setf (window-buffer window) buf)
 142       ;; TODO: run hooks
 143       )))
 144
 145 (defgeneric cache-size (object))
 146
 147 (defmethod cache-size ((object line-cache))
 148   (length (lc-cache object)))
 149
 150 (defmethod cache-size ((object window))
 151   (cache-size (window-cache object)))
 152
 153 (defun reset-line-state (window)
 154   (fill (window-line-state window) -1))
 155
 156 (defun window-reset-cache (window)
 157   (with-slots (cache) window
 158     (setf (lc-cache cache) nil
 159           (lc-start cache) 0
 160           (lc-end cache) 0
 161           (lc-valid cache) t)))
 162
 163 (defun point-in-line-cache (line-cache p)
 164   "Return the line in the cache that P is on. NIL if p is not in range"
 165   (declare (type integer p))
 166   (position-if (lambda (l)
 167                  (and (>= p (cache-item-start l))
 168                       (<= p (cache-item-end l))))
 169                line-cache))
 170
 171 \f
 172 ;;; Display related functions. Generate the line cache based on
 173 ;;; character cells, not pixels.
 174
 175 (defun add-line-to-cache (cache from to &optional at-beginning)
 176   "Add a single line to the cache list. Return the new cache list."
 177   (let ((line (make-cache-item :start from :end to)))
 178     (if at-beginning
 179         (cons line cache)
 180       (nconc1 cache line))))
 181 ;;      (progn
 182 ;;        (grow-vector lines 1 line)
 183 ;;        (replace lines lines :start1 1)
 184 ;;        (setf (elt lines 0) line))
 185 ;;       (vector-push-extend line lines))))
 186
 187
 188 ;; (defun generate-lines-region (cache buffer width from to)
 189 ;;   "FROM must not be a newline (It should be the character after a new
 190 ;; line or the beginning of the buffer) and TO must be newline or the
 191 ;; end of the buffer."
 192 ;;   (declare (type line-cache cache)
 193 ;;         (type buffer buffer)
 194 ;;         (type integer width from to))
 195 ;;   (let ((lines (make-array 0 :element-type 'cache-item
 196 ;;                         :adjustable t
 197 ;;                         :fill-pointer 0))
 198 ;;      (rplc-start (= (1+ to) (lc-start cache)))
 199 ;;      (rplc-end (= (1- from) (lc-end cache)))
 200 ;;      (empty-cache (= (length (lc-cache cache)) 0)))
 201 ;;     (dformat +debug-vvv+ "generate-n-lines: ~a ~a~%" from to)
 202 ;;     ;; Make sure either from-1 or to+1 is already in the cache, its
 203 ;;     ;; the first one. A point cannot exist in 2 cache lines because
 204 ;;     ;; points are inclusive.
 205 ;;     (when (or rplc-start rplc-end empty-cache)
 206 ;;       ;; search for newlines until we hit TO
 207 ;;       (do ((last-p from (1+ p))
 208 ;;         (p (buffer-scan-newline buffer from to 1)
 209 ;;            (buffer-scan-newline buffer (1+ p) to 1))
 210 ;;         (l 0 (1+ l)))
 211 ;;        (nil)
 212
 213 ;;      ;; Break the buffer line into chunks that fit on one window line
 214 ;;      (dformat +debug-vvv+ "last-p: ~a p:~a~%" last-p p)
 215 ;;      (loop for i from last-p by width
 216 ;;            do (vector-push-extend (make-cache-item :start i
 217 ;;                                                    :end (if (<= (+ i (1- width)) p)
 218 ;;                                                             (+ i (1- width))
 219 ;;                                                           p))
 220 ;;                                   lines)
 221 ;;            always (< (+ i (1- width)) p))
 222 ;;      ;; Once we've processed the new line, check if we've run out of
 223 ;;      ;; buffer to process.
 224 ;;      (when (= p to)
 225 ;;        (return)))
 226 ;;       ;; Add these new items to the cache
 227 ;;       (let ((carray (lc-cache cache)))
 228 ;;      (adjust-array cache
 229 ;;                    (+ (length carray)
 230 ;;                       (length lines))
 231 ;;                    :initial-element (aref lines 0)
 232 ;;                    :fill-pointer (+ (length carray)
 233 ;;                                     (length lines)))
 234 ;;      (cond (rplc-start
 235 ;;             ;; Put it at the beginning
 236 ;;             (dformat +debug-vvv+ "rplc-start~%")
 237 ;;             (setf (lc-start cache) from)
 238 ;;             (replace carray carray :start1 (length lines))
 239 ;;             (replace carray lines))
 240 ;;            (rplc-end
 241 ;;             (dformat +debug-vvv+ "rplc-end~%")
 242 ;;             (setf (lc-end cache) to)
 243 ;;             (replace carray lines :start1 (- (length carray)
 244 ;;                                             (length lines))))
 245 ;;            (empty-cache
 246 ;;             (dformat +debug-vvv+ "empty-cache~%")
 247 ;;             (setf (lc-start cache) from)
 248 ;;             (setf (lc-end cache) to)
 249 ;;             ;; FIXME: we could just use lines instead of copy them over, right?
 250 ;;             (replace carray lines))))))
 251 ;;   (dformat +debug-vvv+ "after gen-n-lines: ~a~%" (lc-cache cache)))
 252
 253 (defun generate-n-lines-forward (buffer width from n-lines)
 254   "Return an array of cache-items for N-LINES lines in BUFFER rendered
 255 with WIDTH columns starting at FROM. The array will have length at
 256 least N-LINES."
 257   (declare (type buffer buffer)
 258            (type integer width from))
 259   (let ((lines (make-empty-cache-item-vector))
 260         (to (1- (buffer-size buffer))))
 261     (dformat +debug-vvv+ "generate-n-lines: ~a ~a~%" from to)
 262     ;; search for newlines until we hit TO
 263     (do ((last-p from (1+ p))
 264          (p (buffer-scan-newline buffer from to 1)
 265             (buffer-scan-newline buffer (1+ p) to 1))
 266          (l 0 (1+ l)))
 267         (nil)
 268
 269       ;; Break the buffer line into chunks that fit on one window line
 270       (dformat +debug-vvv+ "last-p: ~a p:~a~%" last-p p)
 271       (loop for i from last-p by width
 272             do (setf lines (add-line-to-cache lines i (if (<= (+ i (1- width)) p)
 273                                                           (+ i (1- width))
 274                                                         p)))
 275 ;; (vector-push-extend (make-cache-item :start i
 276 ;;                                                  :end (if (<= (+ i (1- width)) p)
 277 ;;                                                           (+ i (1- width))
 278 ;;                                                         p))
 279 ;;                                 lines)
 280             always (< (+ i (1- width)) p))
 281       ;; Once we've processed the new line, check if we've generated
 282       ;; enough lines. Return LINES we're done.
 283       (when (or (>= (length lines) n-lines)
 284                 (>= p to))
 285         (return lines)))))
 286
 287 (defun generate-n-lines-backward (buffer width from n-lines)
 288   "Return an array of cache-items for N-LINES lines in BUFFER rendered
 289 with WIDTH columns starting at FROM and going backward. The array will
 290 have length at least N-LINES.
 291
 292 FROM is assumed to the char pos of the newline at the end of the
 293 starting line."
 294   (declare (type buffer buffer)
 295            (type integer width from))
 296   (let ((lines (make-empty-cache-item-vector))
 297         (to 0))
 298     (dformat +debug-vvv+ "generate-n-lines: ~a ~a~%" from to)
 299     ;; search for newlines until we hit TO.
 300     (do ((last-p from p)
 301          (p (buffer-scan-newline buffer (1- 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       ;; unless we're at the beginning of the buffer, we want the char
 309       ;; after p because p will be a newline. last-p will be the
 310       ;; newline at the end of the line, 1+ p will be the beginning.
 311       ;;
 312       ;; this is a bit hairy because we're going backwards, but we go
 313       ;; through the line forward.
 314       ;;(let ((items (make-empty-cache-item-vector)))
 315       (loop for i from (if (zerop p) 0 (1+ p)) by width
 316             do (setf lines (add-line-to-cache lines
 317                                               i
 318                                               (if (<= (+ i (1- width)) last-p)
 319                                                   (+ i (1- width))
 320                                                 last-p)
 321                                               t))
 322             ;; (vector-push-extend (make-cache-item :start i
 323             ;;                                                :end (if (<= (+ i (1- width)) last-p)
 324             ;;                                                         (+ i (1- width))
 325             ;;                                                       last-p))
 326             ;;                               items)
 327             always (< (+ i (1- width)) last-p))
 328         ;;(vector-append lines (nreverse items)))
 329       ;; Once we've processed the new line, check if we've generated
 330       ;; enough lines. Return LINES we're done.
 331       (when (or (>= (length lines) n-lines)
 332                 (<= p to))
 333         (return  lines ;; (nreverse lines)
 334                  )))))
 335
 336 ;; (defun update-cache (cache buffer width point n-many)
 337 ;;   "Add N-MANY lines to the end of the line cache CACHE unless N-MANY
 338 ;; is negative. In that case add (abs n-many) to the beginning. This
 339 ;; function requires at least 1 line in the cache already.
 340
 341 ;; Lines are WIDTH in length. BUFFER is the data for caching."
 342 ;;   ;; Fill in above the cache
 343 ;;   (dformat +debug-vv+ "update-cache: ~a~%" n-many)
 344 ;;   (if (> n-many 0)
 345 ;;       (let* ((end (1+ (lc-end cache)))
 346 ;;           pt)
 347 ;;      ;; Go forward
 348 ;;      (when (< end (1- (buffer-size buffer)))
 349 ;;          ;; Add cache entries
 350 ;;        (setf pt (buffer-scan-newline buffer
 351 ;;                                      end (1- (buffer-size buffer))
 352 ;;                                      n-many))
 353 ;;        (generate-lines-region cache buffer width end pt)))
 354 ;;     ;; Go backward
 355 ;;     (let* ((start (1- (lc-start cache)))
 356 ;;         pt)
 357 ;;       ;; We need this because start is a newline, which we want to skip over
 358 ;;       (setf n-many (1- n-many))
 359 ;;       (dformat +debug-vvv+ "backward: ~a ~a ~a~%"
 360 ;;             start n-many (lc-cache cache))
 361 ;;       (when (and (> start 0)
 362 ;;               (/= n-many 0))
 363 ;;      ;; Add cache entries
 364 ;;      (setf pt (buffer-scan-newline buffer start 0 n-many))
 365 ;;      (generate-lines-region cache buffer width (if (> pt 0) (1+ pt) pt) start)))))
 366
 367 (defun add-end-of-buffer (buffer lines)
 368   "The point can be at (buffer-size buffer) but we only scan to
 369   1- that. So if we're scanned to the end of the buffer properly
 370   alter LINES to contain that point."
 371   (let ((end (1- (buffer-size buffer)))
 372         (last-elt (elt lines (1- (length lines)))))
 373     (when (= (cache-item-end last-elt) end)
 374       (if (char= (buffer-char-after buffer end) #\Newline)
 375           (add-line-to-cache lines (buffer-size buffer) (buffer-size buffer))
 376         (incf (cache-item-end last-elt))))))
 377
 378 (defun window-framer-from-top (window point &optional always-return-lines)
 379   "Fill in window's line cache from WINDOW-TOP with a full window's
 380 worth of lines and return T if POINT was in the line cache. otherwise
 381 don't change anything and return nil."
 382   (let* ((lines (generate-n-lines-forward (window-buffer window) (window-width window)
 383                                           (marker-position (window-top window))
 384                                           (window-height window))))
 385     (add-end-of-buffer (window-buffer window) lines)
 386     (when (or always-return-lines
 387               (point-in-line-cache lines point))
 388       lines)))
 389
 390 (defun window-framer-from-bottom (window point &optional always-return-lines)
 391   "Fill in window's line cache from WINDOW-BOTTOM with a full window's
 392 worth of lines and return T if POINT was in the line cache. otherwise
 393 don't change anything and return nil."
 394   (let* ((lines (generate-n-lines-backward (window-buffer window) (window-width window)
 395                                            (marker-position (window-bottom window))
 396                                            (window-height window))))
 397     (add-end-of-buffer (window-buffer window) lines)
 398     (when (or always-return-lines
 399               (point-in-line-cache lines point))
 400       lines)))
 401
 402 (defun window-framer-around-point (window point n-many)
 403   "Fill in window's line cache going out from point with n-many lines
 404 above WINDOW-POINT, or as many as possible if we hit the top of the window."
 405   ;; Add the line with the pointer on it
 406   (let* ((max (1- (buffer-size (window-buffer window))))
 407          (b (buffer-scan-newline (window-buffer window) point 0 0))
 408          (e (buffer-scan-newline (window-buffer window) point max 1))
 409          (lines-above (generate-n-lines-backward (window-buffer window) (window-width window)
 410                                                  e n-many))
 411          (lines-below (when (< e max)
 412                         (generate-n-lines-forward (window-buffer window) (window-width window)
 413                                                   (1+ e)
 414                                                   (- (window-height window)
 415                                                      (min n-many
 416                                                           (length lines-above)))))))
 417     (declare (ignore b))
 418     (if lines-below
 419         (add-end-of-buffer (window-buffer window) lines-below)
 420       (add-end-of-buffer (window-buffer window) lines-above))
 421     (when (or (point-in-line-cache lines-above point)
 422               (point-in-line-cache lines-below point))
 423       (if lines-below
 424           (nconc lines-above lines-below)
 425 ;;        (grow-vector lines-above (length lines-below) (elt lines-below 0))
 426 ;;        (replace lines-above lines-below :start1 end))
 427       lines-above))))
 428
 429 (defun window-framer (window point n-many)
 430   "fill in window's line-cache."
 431   ;; first try the top/bottom markers. if point isn't in there then
 432   ;; center the window around point.
 433   (let* ((bot (and (window-bottom-valid window)
 434                    (window-framer-from-bottom window point)))
 435          (top (unless bot
 436                 (window-framer-from-top window point)))
 437          (around (unless top
 438                    (window-framer-around-point window point n-many)))
 439          (lines (or bot top around)))
 440     (assert lines)
 441     ;; set the top marker
 442     (setf (window-bottom-valid window) nil)
 443     (cond (bot
 444            (let* ((tl (max 0 (- (length lines) (window-height window))))
 445                   (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
 446              (setf (marker-position (window-top window))
 447                    (cache-item-start (elt lines tl))
 448                    (window-top-line window) tl
 449                    (marker-position (window-bottom window)) (cache-item-end (elt lines bl)))))
 450           (top
 451            (let* ((tl (point-in-line-cache lines (marker-position (window-top window))))
 452                   (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
 453              (setf (window-top-line window) tl
 454                    (marker-position (window-bottom window)) (cache-item-end (elt lines bl)))))
 455           (around
 456            (let* ((pl (point-in-line-cache lines point))
 457                   (tl (max 0 (- pl n-many)))
 458                   (bl (min (1- (length lines)) (+ tl (1- (window-height window))))))
 459              (setf (marker-position (window-top window))
 460                    (cache-item-start (elt lines tl))
 461                    (window-top-line window) tl
 462                    (marker-position (window-bottom window)) (cache-item-end (elt lines bl))))))
 463     ;; fill in window's cache
 464     (with-slots (cache) window
 465       (setf (lc-cache cache) lines
 466             (lc-start cache) (cache-item-start (elt lines 0))
 467             (lc-end cache) (cache-item-end (elt lines (1- (length lines))))
 468             (lc-valid cache) t))))
 469
 470
 471 ;; (defun window-framer (window point n-many)
 472 ;;   "Decide what part of the buffer to display in window. Sets top,
 473 ;; bottom, point-col, and point-line in window. N-MANY is the number of
 474 ;; lines from point to the top of the window."
 475 ;;   ;; Add the line with the pointer on it
 476 ;;   (let ((b (buffer-scan-newline (window-buffer window) point 0 0))
 477 ;;      (e (buffer-scan-newline (window-buffer window)
 478 ;;                              point (1- (buffer-size (window-buffer window))) 1)))
 479 ;;     (dformat +debug-vv+ "point line: ~a ~a~%" b e)
 480 ;;     (generate-lines-region window (if (= b 0) b (1+ b)) e))
 481 ;;   ;; search up n-many the window height
 482 ;;   (update-cache window (- n-many))
 483 ;;   (dformat +debug-vvv+ "cache s/e: ~a ~a~%"
 484 ;;         (lc-start (window-cache window))
 485 ;;         (lc-end (window-cache window)))
 486 ;;   ;; search down height - n-many + 1 (we've already generated the point's line)
 487 ;;   (update-cache window (- (window-height window) n-many -1))
 488 ;;   ;; Special case. if we got to the end of the buffer and it ends with
 489 ;;   ;; a newline. Add an extra cache line for line after that which
 490 ;;   ;; could contain the cursor.
 491 ;;   (when (= (lc-end (window-cache window))
 492 ;;         (1- (buffer-size (window-buffer window))))
 493 ;;     (add-line-to-cache window
 494 ;;                     (buffer-size (window-buffer window))
 495 ;;                     (buffer-size (window-buffer window))
 496 ;;                     nil t nil))
 497 ;;   ;; if we find window-top or window bottom in the cache then we
 498 ;;   ;; should use it as the top/bottom and generate the remaining lines
 499 ;;   (let ((wtop (point-window-line window (marker-position (window-top window))))
 500 ;;      (pline (point-window-line window point))
 501 ;;      (wbot (point-window-line window (marker-position (window-bottom window)))))
 502 ;;     (dformat +debug-vvv+ "cache: ~a~%" (lc-cache (window-cache window)))
 503 ;;     (dformat +debug-vv+ ">>>wtop: ~a ~a pline: ~a ~a wbot: ~a ~a~%"
 504 ;;           wtop (marker-position (window-top window))
 505 ;;           pline point
 506 ;;           wbot (marker-position (window-bottom window)))
 507 ;;     (cond ((and wtop
 508 ;;              (<= wtop pline))
 509 ;;         (dformat +debug-vv+ "wtop. ~a ~%" (cache-size window))
 510 ;;         (let ((lines-left (- (window-height window)
 511 ;;                              (- (cache-size window) wtop))))
 512 ;;           (when (> lines-left 0)
 513 ;;             (update-cache window lines-left))
 514 ;;           (dformat +debug-vvv+ "wtop cache: ~a~%" (lc-cache (window-cache window)))
 515 ;;           (setf (window-top-line window) wtop
 516 ;;                 (marker-position (window-top window)) (cache-item-start
 517 ;;                                                        (aref (lc-cache (window-cache window)) wtop))
 518 ;;                 (window-bottom-line window) (min (1- (cache-size window))
 519 ;;                                                  (+ wtop (window-height window) -1))
 520 ;;                 (marker-position (window-bottom window)) (cache-item-end
 521 ;;                                                           (aref (lc-cache (window-cache window))
 522 ;;                                                                 (window-bottom-line window))))))
 523 ;;        ((and wbot
 524 ;;              (>= wbot pline))
 525 ;;         (dformat +debug-vv+ "wbot. ~a ~%" (cache-size window))
 526 ;;         (let ((lines-left (- (window-height window) wbot 1)))
 527 ;;           (when (> lines-left 0)
 528 ;;             (update-cache window (- lines-left)))
 529 ;;           (dformat +debug-vvv+ "wbot cache: ~a~%" (lc-cache (window-cache window)))
 530 ;;           ;; we need to rescan bottom since lines may have been
 531 ;;           ;; added above it, invalidating wbot
 532 ;;           (setf wbot (point-window-line window (marker-position (window-bottom window)))
 533 ;;                 (window-bottom-line window) wbot
 534 ;;                 (marker-position (window-bottom window)) (cache-item-end (aref
 535 ;;                                                                           (lc-cache (window-cache window))
 536 ;;                                                                           wbot))
 537 ;;                 (window-top-line window) (max 0 (- wbot (window-height window) 1))
 538 ;;                 (marker-position (window-top window)) (cache-item-start (aref
 539 ;;                                                                          (lc-cache (window-cache window))
 540 ;;                                                                          (window-top-line window))))))
 541 ;;         (t
 542 ;;          (dformat +debug-vv+ "we need to scroll. ~a ~%" (cache-size window))
 543 ;;          (setf (window-top-line window) (max 0 (- pline n-many))
 544 ;;                (marker-position (window-top window)) (cache-item-start (aref (lc-cache (window-cache window))
 545 ;;                                                                              (window-top-line window)))
 546 ;;                (window-bottom-line window) (min
 547 ;;                                             (1- (cache-size window))
 548 ;;                                             (+ (window-top-line window) (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 ;;   (setf (window-point-line window) (point-window-line window point))
 553 ;;   (dformat +debug-vv+ "<<<top: ~a ~a pt: ~a ~a bot: ~a ~a~%"
 554 ;;         (window-top-line window) (marker-position (window-top window))
 555 ;;         (window-point-line window) point
 556 ;;         (window-bottom-line window) (marker-position (window-bottom window))))
 557
 558 (defun window-point (&optional window)
 559   "Return current value of point in WINDOW. For a nonselected window,
 560 this is the value point would have if that window were selected."
 561   (if (eq window (selected-window))
 562       (pt (window-buffer window))
 563     (marker-position (window-bpoint window))))
 564
 565 (defun set-window-point (window pos)
 566   (let ((mark (if (eq window (selected-window))
 567                   (buffer-point (window-buffer window))
 568                 (window-bpoint window))))
 569     (if (and (<= pos (buffer-max (window-buffer window)))
 570              (>= pos (buffer-min (window-buffer window))))
 571         (setf (marker-position mark) pos)
 572       (error "out of range"))))
 573
 574 (defun get-buffer-window (buffer &optional frame)
 575   "Return a window currently displaying BUFFER, or nil if none.
 576 If optional argument FRAME is `visible', search all visible frames.
 577 If optional argument FRAME is 0, search all visible and iconified frames.
 578 If FRAME is t, search all frames.
 579 If FRAME is nil, search only the selected frame.
 580 If FRAME is a frame, search only that frame."
 581   ;; TODO: honour FRAME
 582   (setf frame (selected-frame)
 583         buffer (get-buffer buffer))
 584   (find buffer (frame-window-list frame) :key 'window-buffer))
 585
 586 (defun window-scroll-up (window n-lines)
 587   "scroll the window up (go torwards the end of the buffer) LINES many
 588 lines, moving the window point to be visible."
 589   (let* ((len (+ (window-height window) n-lines))
 590          (lines (generate-n-lines-forward (window-buffer window) (window-width window)
 591                                          (marker-position (window-top window))
 592                                          len)))
 593     ;; if there aren't n-lines left in the buffer then signal
 594     ;; an end-of-buffer error.
 595 ;;     (unless (>= (length lines) n-lines)
 596 ;;       (error "end of buffer"))
 597     (setf (marker-position (window-top window)) (cache-item-start (elt lines
 598                                                                        (1- (min (length lines)
 599                                                                                 n-lines)))))
 600     ;; FIXME: for now, set the point at the top of the window if it
 601     ;; isn't visible.
 602     (when (or (< (window-point window) (marker-position (window-top window)))
 603               (not (point-in-line-cache lines (window-point window))))
 604       (set-window-point window (marker-position (window-top window))))))
 605
 606 (defun window-scroll-down (window n-lines)
 607   "scroll the window down (go torwards the beginning of the buffer)
 608 LINES many lines, moving the window point to be visible."
 609   (let* ((len (+ (window-height window) n-lines))
 610          ;; FIXME: this is basically, gross.
 611          (above (generate-n-lines-backward (window-buffer window) (window-width window)
 612                                            (max (buffer-min (window-buffer window))
 613                                                 (1- (marker-position (window-top window))))
 614                                            n-lines))
 615          (lines (generate-n-lines-forward (window-buffer window) (window-width window)
 616                                           (cache-item-start
 617                                            (elt above (max 0 (- (length above) n-lines))))
 618                                           len)))
 619     ;; if there aren't n-lines left in the buffer then signal
 620     ;; an end-of-buffer error.
 621 ;;     (unless (>= (length above) n-lines)
 622 ;;       (error "beginning of buffer"))
 623     (setf (marker-position (window-top window)) (cache-item-start (elt lines 0)))
 624     ;; FIXME: for now, set the point at the bottom of the window if it
 625     ;; isn't visible.
 626     (let ((eow (elt lines (1- (min (length lines)
 627                                    (window-height window))))))
 628       (when (or (> (window-point window) (cache-item-end eow))
 629                 (not (point-in-line-cache lines (window-point window))))
 630         (set-window-point window (cache-item-start eow))))))
 631
 632 (defun window-save-point (window)
 633   "Save WINDOW's buffer's point to WINDOW-BPOINT."
 634   (setf (marker-position (window-bpoint window)) (pt (window-buffer window))))
 635
 636 (defun window-restore-point (window)
 637   "Restore the WINDOW's buffer's point from WINDOW-BPOINT."
 638   ;; restore the point
 639   (setf (marker-position (buffer-point (window-buffer window)))
 640         (marker-position (window-bpoint window))))
 641
 642 (defun window-tree-find-if (fn tree &optional minibuf)
 643   "depth first search the tree. Return the element that satisfies FN."
 644   (cond ((listp tree)
 645          (loop for i in tree
 646                thereis (window-tree-find-if fn i minibuf)))
 647         ((typep tree 'minibuffer-window)
 648          (when (and minibuf
 649                     (funcall fn tree))
 650            tree))
 651         (t
 652          (when (funcall fn tree)
 653            tree))))
 654
 655 (defcommand delete-other-windows ()
 656   (let* ((frame (selected-frame))
 657          (cw (selected-window))
 658          (mb (window-tree-find-if (lambda (w)
 659                                     (typep w 'minibuffer-window))
 660                                   (frame-window-tree frame)
 661                                   t)))
 662     ;; FIXME: This doesn't properly refresh and the window's display
 663     ;; arrays aren't resized.
 664     (setf (window-x cw) 0
 665           (window-y cw) 0
 666           (window-seperator cw) nil
 667           (slot-value cw 'w) (frame-width frame)
 668           (slot-value cw 'h) (- (frame-height frame) (window-height mb t))
 669           (frame-window-tree frame) (list cw mb))
 670     ;;(update-window-display-arrays cw)
 671     ))
 672
 673 (defun window-parent (window)
 674   "Return the parent list in frame-window-tree for WINDOW."
 675   (labels ((parent-of (tree parent window)
 676              (cond ((listp tree)
 677                     (loop for i in tree
 678                        thereis (parent-of i tree window)))
 679                    (t
 680                     (when (eq tree window)
 681                       parent)))))
 682     (parent-of (frame-window-tree (window-frame window)) nil window)))
 683
 684 (defun delete-window (&optional (window (selected-window)))
 685   (check-type window window)
 686   (when (or (typep window 'minibuffer-window)
 687             (typep (frame-window-tree (window-frame window)) 'window))
 688     (error "Attempt to delete minibuffer or sole ordinary window")))
 689
 690 (defun pos-visible-in-window-p (&optional (pos (pt)) (window (selected-window)) partially)
 691   "Return non-nil if position POS is currently on the frame in WINDOW.
 692 Return nil if that position is scrolled vertically out of view.
 693 If a character is only partially visible, nil is returned, unless the
 694 optional argument PARTIALLY is non-nil.
 695 If POS is only out of view because of horizontal scrolling, return non-nil.
 696 If POS is t, it specifies the position of the last visible glyph in WINDOW.
 697 POS defaults to point in WINDOW; WINDOW defaults to the selected window.
 698
 699 If POS is visible, return t if PARTIALLY is nil; if PARTIALLY is non-nil,
 700 return value is a list of 2 or 6 elements (X Y [RTOP RBOT ROWH VPOS]),
 701 where X and Y are the pixel coordinates relative to the top left corner
 702 of the window.  The remaining elements are omitted if the character after
 703 POS is fully visible; otherwise, RTOP and RBOT are the number of pixels
 704 off-window at the top and bottom of the row, ROWH is the height of the
 705 display row, and VPOS is the row number (0-based) containing POS."
 706   (declare (ignore partially))
 707   (check-type pos number)
 708   (check-type window window)
 709   ;; FIXME: horizontal scrolling. and all the partial stuff aint there
 710   (or (< pos (marker-position (window-top window)))
 711       (> pos (marker-position (window-bottom window)))))
 712
 713 (defun select-window (window &optional norecord)
 714   "Select WINDOW.  Most editing will apply to WINDOW's buffer.
 715 If WINDOW is not already selected, also make WINDOW's buffer current.
 716 Also make WINDOW the frame's selected window.
 717 Optional second arg NORECORD non-nil means
 718 do not put this buffer at the front of the list of recently selected ones.
 719
 720 **Note that the main editor command loop
 721 **selects the buffer of the selected window before each command."
 722   (declare (ignore norecord))
 723   (check-live-window window)
 724   (when (eq window (selected-window))
 725     (return-from select-window window))
 726
 727   (window-save-point (selected-window))
 728   (setf *selected-window* window)
 729   (let ((sf (selected-frame)))
 730     (if (eq sf (window-frame window))
 731         (progn
 732           (setf (frame-selected-window (window-frame window)) window)
 733           ;; (select-frame (window-frame window))
 734           )
 735         (setf (frame-selected-window sf) window))
 736     ;; FIXME: get NORECORD working
 737     (set-buffer (window-buffer window))
 738     (window-restore-point window)
 739     window))
 740
 741 (defun replace-window-in-frame-tree (window new)
 742   (labels ((doit (tree window new)
 743              (let ((p (position window tree)))
 744                (if p
 745                    (setf (nth p tree) new)
 746                  (loop for w in tree
 747                        until (and (listp w)
 748                                   (doit w window new)))))))
 749     (doit (frame-window-tree (window-frame window))
 750           window
 751           new)))
 752
 753 (defun split-window (&optional (window (selected-window)) size horflag)
 754   (when (typep window 'minibuffer-window)
 755     (error "Attempt to split minibuffer window"))
 756   (when (null size)
 757     (setf size (if horflag
 758                    (ceiling (window-width window t) 2)
 759                  (ceiling (window-height window t) 2))))
 760   (let (new)
 761     (if horflag
 762         (progn
 763           (when (< size *window-min-width*)
 764             (error "Window width ~a too small (after splitting)" size))
 765           ;; will the other window be too big?
 766           (when (> (+ size *window-min-width*)
 767                    (window-width window t))
 768             (error "Window width ~a too small (after splitting)" (- (window-width window t) size)))
 769           (setf new (make-window :x (+ (window-x window) size)
 770                                  :y (window-y window)
 771                                  :cols (- (window-width window t) size)
 772                                  :rows (window-height window t)
 773                                  :buffer (window-buffer window)
 774                                  :frame (window-frame window))
 775                 (window-seperator new) (window-seperator window)
 776                 (window-seperator window) t
 777                 (slot-value window 'w) size)
 778           ;;(update-window-display-arrays window)
 779           )
 780       (progn
 781         (when (< size *window-min-height*)
 782           (error "Window height ~a too small (after splitting)" size))
 783         ;; will the other window be too big?
 784         (when (> (+ size *window-min-height*)
 785                  (window-height window t))
 786           (error "Window width ~a too small (after splitting)" (- (window-height window t) size)))
 787         (setf new (make-window :x (window-x window)
 788                                :y (+ (window-y window) size)
 789                                :cols (window-width window t)
 790                                :rows (- (window-height window t) size)
 791                                :buffer (window-buffer window)
 792                                :frame (window-frame window))
 793               (window-seperator new) (window-seperator window)
 794               (slot-value window 'h) size)
 795         ;;(update-window-display-arrays window)
 796         ))
 797     (replace-window-in-frame-tree window (list window new))
 798     new))
 799
 800 (defun next-window (window &optional minibuf)
 801   "Return next window after WINDOW in canonical ordering of windows.
 802 FIXME: make this the same as Emacs' next-window."
 803   (let* ((frame (window-frame window))
 804          (tree (frame-window-tree frame))
 805          bit
 806          ;; when we find WINDOW, set BIT to T and return the next window.
 807          (w (window-tree-find-if (lambda (w)
 808                                    (cond (bit w)
 809                                          ((eq w window)
 810                                           (setf bit t)
 811                                           nil)))
 812                                  tree
 813                                  (and minibuf (> (frame-minibuffers-active frame) 0)))))
 814     ;; if we didn't find the next one, maybe it's the first one
 815     (if (not w)
 816         (let ((other (window-tree-find-if #'identity tree)))
 817           (unless (eq window other)
 818             other))
 819       w)))
 820
 821 (defun previous-window (&optional window minibuf all-frames)
 822   "Return the window preceding WINDOW in canonical ordering of windows.
 823 If omitted, WINDOW defaults to the selected window.
 824
 825 Optional second arg MINIBUF t means count the minibuffer window even
 826 if not active.  MINIBUF nil or omitted means count the minibuffer iff
 827 it is active.  MINIBUF neither t nor nil means not to count the
 828 minibuffer even if it is active.
 829
 830 Several frames may share a single minibuffer; if the minibuffer
 831 counts, all windows on all frames that share that minibuffer count
 832 too.  Therefore, `previous-window' can be used to iterate through
 833 the set of windows even when the minibuffer is on another frame.  If
 834 the minibuffer does not count, only windows from WINDOW's frame count
 835
 836 Optional third arg ALL-FRAMES t means include windows on all frames.
 837 ALL-FRAMES nil or omitted means cycle within the frames as specified
 838 above.  ALL-FRAMES = `visible' means include windows on all visible frames.
 839 ALL-FRAMES = 0 means include windows on all visible and iconified frames.
 840 If ALL-FRAMES is a frame, restrict search to windows on that frame.
 841 Anything else means restrict to WINDOW's frame.
 842
 843 If you use consistent values for MINIBUF and ALL-FRAMES, you can use
 844 `previous-window' to iterate through the entire cycle of acceptable
 845 windows, eventually ending up back at the window you started with.
 846 `next-window' traverses the same cycle, in the reverse order."
 847   (declare (ignore window minibuf all-frames))
 848   (error "unimplemented"))
 849
 850 (defcommand other-window ((arg &optional all-frames)
 851                           :prefix)
 852   "Select the ARG'th different window on this frame.
 853 All windows on current frame are arranged in a cyclic order.
 854 This command selects the window ARG steps away in that order.
 855 A negative ARG moves in the opposite order.  The optional second
 856 argument ALL-FRAMES has the same meaning as in `next-window', which see."
 857   (declare (ignore all-frames))
 858   (check-type arg number)
 859   (let ((w (cond
 860              ((plusp arg)
 861               (loop
 862                  for i from 1 to arg
 863                  for w = (next-window (selected-window) t) then (next-window w t)
 864                  finally (return w)))
 865              ((minusp arg)
 866               (loop
 867                  for i from arg downto 1
 868                  for w = (previous-window (selected-window) t) then (previous-window w t)
 869                  finally (return w)))
 870              (t (selected-window)))))
 871     (when w
 872       (select-window w))))
 873
 874 (defun display-buffer (buffer &optional not-this-window frame)
 875   "Make BUFFER appear in some window but don't select it.
 876 BUFFER can be a buffer or a buffer name.
 877 If BUFFER is shown already in some window, just use that one,
 878 unless the window is the selected window and the optional second
 879 argument NOT-THIS-WINDOW is non-nil (interactively, with prefix arg).
 880 **If `pop-up-frames' is non-nil, make a new frame if no window shows BUFFER.
 881 **Returns the window displaying BUFFER.
 882 **If `display-buffer-reuse-frames' is non-nil, and another frame is currently
 883 **displaying BUFFER, then simply raise that frame."
 884   (declare (ignore frame))
 885   (setf buffer (get-buffer buffer))
 886   (let* ((cw (selected-window))
 887          (w (or (window-tree-find-if (lambda (w)
 888                                        (and (not (and not-this-window
 889                                                       (eq w cw)))
 890                                             (eq (window-buffer w) buffer)))
 891                                      (frame-window-tree (selected-frame)))
 892                 (next-window cw)
 893                 (split-window cw))))
 894     (set-window-buffer w buffer)
 895     (window-restore-point w)
 896     w))
 897
 898 (defun other-buffer (&optional (buffer (current-buffer)) visible-ok frame)
 899   "Return most recently selected buffer other than BUFFER.
 900 Buffers not visible in windows are preferred to visible buffers,
 901 unless optional second argument VISIBLE-OK is non-nil.
 902 If the optional third argument FRAME is non-nil, use that frame's
 903 buffer list instead of the selected frame's buffer list.
 904 If no other buffer exists, the buffer `*scratch*' is returned.
 905 If BUFFER is omitted or nil, some interesting buffer is returned."
 906   (declare (ignore frame))
 907   ;; TODO: honour FRAME argument
 908   (let* (vis
 909          (match (loop for b in *buffer-list*
 910                       unless (or (eq b buffer)
 911                                  (char= (char (buffer-name b) 0) #\Space))
 912                       if (and (not visible-ok)
 913                               (get-buffer-window b))
 914                       do (setf vis b)
 915                       else return b)))
 916     (or match
 917         vis
 918         (get-buffer-create "*scratch*"))))
 919
 920 (defcommand kill-buffer ((buffer)
 921                          (:buffer "Kill buffer: " (buffer-name (current-buffer)) t))
 922   "Kill the buffer BUFFER.
 923 The argument may be a buffer or may be the name of a buffer.
 924 defaults to the current buffer.
 925
 926 Value is t if the buffer is actually killed, nil if user says no.
 927
 928 The value of `kill-buffer-hook' (which may be local to that buffer),
 929 if not void, is a list of functions to be called, with no arguments,
 930 before the buffer is actually killed.  The buffer to be killed is current
 931 when the hook functions are called.
 932
 933 Any processes that have this buffer as the `process-buffer' are killed
 934 with SIGHUP."
 935   (let* ((target (get-buffer buffer))
 936          (other (other-buffer target)))
 937     (if target
 938         (progn
 939           ;; all windows carrying the buffer need a new buffer
 940           (loop for w in (frame-window-list (selected-frame))
 941                 do (when (eq (window-buffer w) target)
 942                      (set-window-buffer w other)))
 943           (setf *buffer-list* (delete target *buffer-list*)))
 944       (error "No such buffer ~a" buffer))))
 945
 946 (defun pop-to-buffer (buffer &optional other-window norecord)
 947   "Select buffer BUFFER in some window, preferably a different one.
 948 If `pop-up-windows' is non-nil, windows can be split to do this.
 949 If optional second arg OTHER-WINDOW is non-nil, insist on finding another
 950 window even if BUFFER is already visible in the selected window.
 951 This uses the function `display-buffer' as a subroutine; see the documentation
 952 of `display-buffer' for additional customization information.
 953
 954 **Optional third arg NORECORD non-nil means
 955 **do not put this buffer at the front of the list of recently selected ones."
 956   (declare (ignore norecord))
 957   ;; FIXME: honour NORECORD
 958   (setf buffer (if buffer
 959                    (or (get-buffer buffer)
 960                        (progn
 961                          (get-buffer-create buffer)))
 962                          ;; FIXME: (set-buffer-major-mode buffer)
 963                  (other-buffer (current-buffer))))
 964   (select-window (display-buffer buffer other-window)))
 965
 966 (provide :lice-0.1/window)