racket-ansi/rmacs/render.rkt

#lang racket/base

(provide (struct-out absolute-size)
         (struct-out relative-size)
         (struct-out layout)
         layout-windows
         render-windows!)

(require racket/match)

(require "buffer.rkt")
(require "window.rkt")
(require "display.rkt")
(require "rope.rkt")
(require "wrap.rkt")

;; A SizeSpec is either
;; -- (absolute-size PositiveInteger), a specific size in screen rows
;; -- (relative-size PositiveReal), a weighted window size
(struct absolute-size (lines) #:prefab)
(struct relative-size (weight) #:prefab)

;; A Layout is a (layout Window SizeSpec Nat Nat)
(struct layout (window ;; Window
                size-spec ;; SizeSpec
                top ;; Nat, a row
                left ;; Nat, a column
                width ;; Nat
                height ;; Nat
                ) #:prefab)

(define (newline? c) (equal? c #\newline))

;; Finseth's book defines a C routine, Framer(), which is intended to
;; ensure that the `top_of_window` mark, denoting the position where
;; display should begin for the current window, is in a sane position.
;; The mark is left alone unless the cursor is outside the currently
;; displayed window, either above or below. If the mark needs to be
;; moved, it is moved to a line such that the cursor, after redisplay,
;; will end up at a configurable percentage of the way down the
;; window.
;;
;; It is here that we perform soft-wrapping of lines.
;;
;; Window Nat -> (List (Pair Nat Nat))
;; Ensures that window-top is sanely positioned with respect to
;; window-point. Returns wrapped line spans starting at the new
;; window-top.
(define (frame! win available-line-count window-width
                #:preferred-position-fraction [preferred-position-fraction 1/2])
  (define buf (window-buffer win))
  (define old-top-of-window-pos (or (buffer-mark-pos* buf (window-top win)) 0))
  (define preferred-distance-from-bottom
    (ceiling (* available-line-count (- 1 preferred-position-fraction))))
  (define g (buffer-lines-reverse/wrap buf (window-point win) basic-wrap window-width))
  (define spans
    (let loop ((line-count 0)
               (all-spans '())
               (preferred-spans '()))
      (define-values (pos eol-pos) (g))
      (define span (cons pos eol-pos))
      (define new-all-spans (cons span all-spans))
      (define new-preferred-spans (if (= line-count preferred-distance-from-bottom)
                                      new-all-spans
                                      preferred-spans))
      (cond
       [(not pos) all-spans] ;; we hit buffer top before our preferred distance. NB all-spans
       [(= pos old-top-of-window-pos) new-all-spans]
       [(>= line-count (- available-line-count 1)) new-preferred-spans]
       [else (loop (+ line-count 1) new-all-spans new-preferred-spans)])))
  (buffer-mark! buf (window-top win) (caar spans))
  spans)

(define (tty-body-style t is-active?)
  (tty-set-pen! t tty-default-pen))

(define (tty-statusline-style t is-active?)
  (tty-set-pen! t (pen color-black color-white #f #f)))

(define (render-window! t win window-top window-width window-height is-active?)
  (define buf (window-buffer win))
  (define available-line-count (- window-height 1))
  (define spans (frame! win available-line-count window-width))
  (define cursor-pos (buffer-mark-pos buf (window-point win)))
  (tty-goto t window-top 0)
  (tty-body-style t is-active?)

  (define (render-span sol-pos eol-pos line-count cursor-coordinates)
    (define line (rope->string (buffer-region buf sol-pos eol-pos)))
    (tty-display t line)
    (tty-newline t)
    (if (<= sol-pos cursor-pos eol-pos)
        (list (+ line-count window-top)
              (let ((line-to-cursor (substring line 0 (- cursor-pos sol-pos))))
                (buffer-string-column-count buf 0 line-to-cursor)))
        cursor-coordinates))

  (define (render-top-spans spans line-count cursor-coordinates)
    (cond
     [(>= line-count available-line-count) cursor-coordinates]
     [(null? spans)
      (define g (buffer-lines-forward/wrap buf (window-point win) basic-wrap window-width))
      (g) ;; discard first span, since it has already been covered
      (render-bottom-spans g line-count cursor-coordinates)]
     [else
      (render-top-spans (cdr spans)
                        (+ line-count 1)
                        (render-span (caar spans) (cdar spans) line-count cursor-coordinates))]))

  (define (render-bottom-spans g line-count cursor-coordinates)
    (if (>= line-count available-line-count)
        cursor-coordinates
        (let-values (((sol-pos eol-pos) (g)))
          (if sol-pos
              (render-bottom-spans g
                                   (+ line-count 1)
                                   (render-span sol-pos eol-pos line-count cursor-coordinates))
              (begin (for ((i (- available-line-count line-count))) (tty-newline t))
                     cursor-coordinates)))))

  (define cursor-coordinates (render-top-spans spans 0 #f))

  (tty-statusline-style t is-active?)
  (tty-display t "-- " (buffer-title buf) " ")
  (let ((remaining-length (- (tty-columns t) 4 (string-length (buffer-title buf)))))
    (when (positive? remaining-length)
      (tty-display t (make-string remaining-length #\-))))

  cursor-coordinates)

(define (layout-windows ws total-width total-height [minimum-height 4])
  (define total-weight (foldl + 0 (map (lambda (e)
                                         (match (cadr e)
                                           [(absolute-size _) 0]
                                           [(relative-size w) w])) ws)))
  (define reserved-lines (foldl + 0 (map (lambda (e)
                                           (match (cadr e)
                                             [(absolute-size lines) lines]
                                             [(relative-size _) 0])) ws)))
  (define proportional-lines (- total-height reserved-lines))
  (let loop ((ws ws) (offset 0) (remaining proportional-lines))
    (match ws
      ['() '()]
      [(cons (list w (and spec (absolute-size lines))) rest)
       (cons (layout w spec offset 0 total-width lines)
             (loop rest (+ offset lines) remaining))]
      [(cons (list w (and spec (relative-size weight))) rest)
       (define height (max minimum-height
                           (inexact->exact
                            (round (* proportional-lines (/ weight total-weight))))))
       (if (>= remaining height)
           (if (null? rest)
               (list (layout w spec offset 0 total-width remaining))
               (cons (layout w spec offset 0 total-width height)
                     (loop rest (+ offset height) (- remaining height))))
           (if (>= remaining minimum-height)
               (list (layout w spec offset 0 total-width remaining))
               '()))])))

(define (render-windows! t layouts active-window)
  (tty-body-style t #f)
  (tty-goto t 0 0)
  (define active-cursor-position
    (for/fold [(cursor-position #f)] [(e layouts)]
      (match-define (layout w _spec window-top _left window-width window-height) e)
      (define is-active? (eq? w active-window))
      (define window-cursor-position
        (render-window! t w window-top window-width window-height is-active?))
      (if is-active? window-cursor-position cursor-position)))
  (when active-cursor-position
    (tty-goto t (car active-cursor-position) (cadr active-cursor-position)))
  (tty-flush t))