racket-ansi/rmacs/render.rkt

151 lines
6.3 KiB
Racket
Raw Normal View History

2014-12-22 22:14:13 +00:00
#lang racket/base
(provide (struct-out absolute-size)
(struct-out relative-size)
2014-12-28 13:16:09 +00:00
(struct-out layout)
layout-windows
render-windows!)
2014-12-22 22:14:13 +00:00
(require racket/match)
(require "buffer.rkt")
(require "window.rkt")
(require "display.rkt")
(require "rope.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)
2014-12-22 22:14:13 +00:00
2014-12-28 13:16:09 +00:00
;; 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)
2014-12-22 22:14:13 +00:00
(define (newline? c) (equal? c #\newline))
(define (not-newline? c) (not (newline? c)))
;; 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.
;;
;; Window Nat -> Nat
;; Ensures that window-top is sanely positioned with respect to
;; window-point. Returns the new position of window-top.
(define (frame! win available-line-count
#: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))
2014-12-23 06:43:01 +00:00
(define preferred-distance-from-bottom
(ceiling (* available-line-count (- 1 preferred-position-fraction))))
(let loop ((pos (buffer-findf buf (window-point win) newline? #:forward? #f))
2014-12-22 22:14:13 +00:00
(line-count 0)
(top-of-window-pos old-top-of-window-pos))
(define new-top-of-window-pos
(if (= line-count preferred-distance-from-bottom) pos top-of-window-pos))
(cond
2014-12-23 06:43:01 +00:00
[(= pos old-top-of-window-pos)
2014-12-22 22:14:13 +00:00
old-top-of-window-pos]
2014-12-23 06:43:01 +00:00
[(>= line-count (- available-line-count 1))
(buffer-mark! buf (window-top win) new-top-of-window-pos)
2014-12-22 22:14:13 +00:00
new-top-of-window-pos]
[else
(loop (buffer-findf buf (- pos 1) newline? #:forward? #f)
2014-12-22 22:14:13 +00:00
(+ line-count 1)
new-top-of-window-pos)])))
(define (tty-body-style t is-active?)
(tty-set-pen! t tty-default-pen))
2014-12-22 22:14:13 +00:00
(define (tty-statusline-style t is-active?)
2014-12-24 03:01:18 +00:00
(tty-set-pen! t (pen color-black color-white #f #f)))
2014-12-22 22:14:13 +00:00
2014-12-28 13:16:09 +00:00
(define (render-window! t win window-top window-width window-height is-active?)
(define buf (window-buffer win))
2014-12-23 06:43:01 +00:00
(define available-line-count (- window-height 1))
(define top-of-window-pos (frame! win available-line-count))
(define cursor-pos (buffer-mark-pos buf (window-point win)))
2014-12-22 22:14:13 +00:00
(tty-goto t window-top 0)
(tty-body-style t is-active?)
(define cursor-coordinates
(let loop ((line-count 0)
(sol-pos top-of-window-pos)
(cursor-coordinates #f))
(cond
2014-12-23 06:43:01 +00:00
[(>= line-count available-line-count)
2014-12-22 22:14:13 +00:00
cursor-coordinates]
[else
(define eol-pos (buffer-findf buf sol-pos newline?))
(define line (rope->string (buffer-region buf sol-pos eol-pos)))
2014-12-28 13:55:41 +00:00
(define formatted-line (substring line 0 (min (string-length line) window-width)))
2014-12-23 16:09:22 +00:00
(tty-display t formatted-line)
2014-12-22 22:14:13 +00:00
(tty-clear-to-eol t)
(tty-newline t)
(loop (+ line-count 1)
(+ eol-pos 1)
2014-12-28 13:55:41 +00:00
(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)))
2014-12-22 22:14:13 +00:00
cursor-coordinates))])))
(tty-statusline-style t is-active?)
(tty-display t "-- " (buffer-title buf) " ")
(let ((remaining-length (- (tty-columns t) 4 (string-length (buffer-title buf)))))
2014-12-24 03:01:18 +00:00
(when (positive? remaining-length)
(tty-display t (make-string remaining-length #\-))))
2014-12-22 22:14:13 +00:00
cursor-coordinates)
2014-12-28 13:16:09 +00:00
(define (layout-windows ws total-width total-height [minimum-height 4])
2014-12-22 22:14:13 +00:00
(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
['() '()]
2014-12-28 13:16:09 +00:00
[(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)
2014-12-22 22:14:13 +00:00
(define height (max minimum-height
(inexact->exact
(round (* proportional-lines (/ weight total-weight))))))
(if (>= remaining height)
(if (null? rest)
2014-12-28 13:16:09 +00:00
(list (layout w spec offset 0 total-width remaining))
(cons (layout w spec offset 0 total-width height)
(loop rest (+ offset height) (- remaining height))))
2014-12-22 22:14:13 +00:00
(if (>= remaining minimum-height)
2014-12-28 13:16:09 +00:00
(list (layout w spec offset 0 total-width remaining))
2014-12-22 22:14:13 +00:00
'()))])))
2014-12-28 13:16:09 +00:00
(define (render-windows! t layouts active-window)
2014-12-22 22:14:13 +00:00
(tty-body-style t #f)
2014-12-23 06:43:01 +00:00
(tty-goto t 0 0)
2014-12-22 22:14:13 +00:00
(define active-cursor-position
2014-12-28 13:16:09 +00:00
(for/fold [(cursor-position #f)] [(e layouts)]
(match-define (layout w _spec window-top _left window-width window-height) e)
2014-12-22 22:14:13 +00:00
(define is-active? (eq? w active-window))
2014-12-28 13:16:09 +00:00
(define window-cursor-position
(render-window! t w window-top window-width window-height is-active?))
2014-12-22 22:14:13 +00:00
(if is-active? window-cursor-position cursor-position)))
(when active-cursor-position
2014-12-24 03:01:18 +00:00
(tty-goto t (car active-cursor-position) (cadr active-cursor-position)))
(tty-flush t))