misc-deps
/
racket-ansi
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Line wrap.

This commit is contained in:
Tony Garnock-Jones 2014-12-28 11:25:54 -05:00
parent 791ff539b5
commit 370b35a273
4 changed files with 122 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
rmacs/TODO
View File

@ -8,7 +8,5 @@ The status line isn't cleared away when you C-x 0.
Preserve column on up/down better.
Need line wrap of some kind.
Catch and handle SIGWINCH.
See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html

3
rmacs/display.rkt
View File

@ -242,6 +242,7 @@
(for ((s strings)) (puts tty s)))
(define (tty-newline tty)
(tty-clear-to-eol tty)
(putc tty #\return)
(putc tty #\newline))
@ -304,7 +305,7 @@
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1))
(when (= (screen-cursor-column s) (screen-columns s))
(when (< (screen-cursor-row s) (- (screen-rows s) 1))
(output tty (ansi:clear-to-eol) "\r\n"))
(output tty "\r\n"))
(set-screen-cursor-column! s 0)
(set-screen-cursor-row! s (+ (screen-cursor-row s) 1))))

90
rmacs/render.rkt
View File

@ -12,6 +12,7 @@
(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
@ -29,7 +30,6 @@
) #:prefab)
(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
@ -40,30 +40,36 @@
;; will end up at a configurable percentage of the way down the
;; window.
;;
;; Window Nat -> Nat
;; 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 the new position of window-top.
(define (frame! win available-line-count
;; 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))))
(let loop ((pos (buffer-findf buf (window-point win) newline? #:forward? #f))
(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))
(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
[(= pos old-top-of-window-pos)
old-top-of-window-pos]
[(>= line-count (- available-line-count 1))
(buffer-mark! buf (window-top win) new-top-of-window-pos)
new-top-of-window-pos]
[else
(loop (buffer-findf buf (- pos 1) newline? #:forward? #f)
(+ line-count 1)
new-top-of-window-pos)])))
[(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))
@ -74,36 +80,52 @@
(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 top-of-window-pos (frame! win available-line-count))
(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 cursor-coordinates
(let loop ((line-count 0)
(sol-pos top-of-window-pos)
(cursor-coordinates #f))
(cond
[(>= line-count available-line-count)
cursor-coordinates]
[else
(define eol-pos (buffer-findf buf sol-pos newline?))
(define (render-span sol-pos eol-pos line-count cursor-coordinates)
(define line (rope->string (buffer-region buf sol-pos eol-pos)))
(define formatted-line (substring line 0 (min (string-length line) window-width)))
(tty-display t formatted-line)
(tty-clear-to-eol t)
(tty-display t line)
(tty-newline t)
(loop (+ line-count 1)
(+ eol-pos 1)
(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))])))
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])

57
rmacs/wrap.rkt Normal file
View File

@ -0,0 +1,57 @@
#lang racket/base
(provide (struct-out wrap)
wrap-line-count
basic-wrap
buffer-lines-reverse/wrap
buffer-lines-forward/wrap)
(require racket/generator)
(require "buffer.rkt")
(struct wrap (width ;; Nat
points ;; (List Nat)
eol-pos ;; Nat
) #:prefab)
;; Soft-wraps the line starting at sol-pos to the given width.
(define (basic-wrap buf sol-pos width)
(define eol-pos (buffer-end-of-line buf sol-pos))
(let loop ((soft-sol-pos sol-pos)
(points '()))
(define next-sol (buffer-closest-pos-for-column buf soft-sol-pos 0 width))
(if (< next-sol eol-pos)
(loop next-sol (cons next-sol points))
(wrap width (reverse points) eol-pos))))
(define (wrap-line-count w)
(+ 1 (length (wrap-points w))))
(define (buffer-lines-reverse/wrap buf pos-or-mtype wrap-fn width)
(define start-pos (buffer-pos buf pos-or-mtype))
(generator ()
(let hard-break ((eol-pos (buffer-end-of-line buf start-pos)))
(if (< eol-pos 0)
(values #f #f)
(let* ((sol-pos (buffer-start-of-line buf eol-pos))
(w (wrap-fn buf sol-pos width)))
(let soft-break ((eol eol-pos) (ps (reverse (wrap-points w))))
(if (null? ps)
(begin (yield sol-pos eol)
(hard-break (- sol-pos 1)))
(begin (when (<= (car ps) start-pos) (yield (car ps) eol))
(soft-break (car ps) (cdr ps))))))))))
(define (buffer-lines-forward/wrap buf pos-or-mtype wrap-fn width)
(define start-pos (buffer-pos buf pos-or-mtype))
(generator ()
(let hard-break ((sol-pos (buffer-start-of-line buf start-pos)))
(if (> sol-pos (buffer-size buf))
(values #f #f)
(let* ((w (wrap-fn buf sol-pos width)))
(let soft-break ((sol sol-pos) (ps (wrap-points w)))
(if (null? ps)
(begin (yield sol (wrap-eol-pos w))
(hard-break (+ (wrap-eol-pos w) 1)))
(begin (when (> (car ps) start-pos) (yield sol (car ps)))
(soft-break (car ps) (cdr ps))))))))))