95 lines
3.6 KiB
Racket
95 lines
3.6 KiB
Racket
#lang racket/base
|
|
|
|
(require "rope.rkt")
|
|
(require "search.rkt")
|
|
|
|
(define main-mark-type (mark-type "main" 'right))
|
|
|
|
(struct buffer ([rope #:mutable]
|
|
[pos #:mutable]
|
|
) #:transparent)
|
|
|
|
(define (make-buffer #:initial-contents [initial-contents ""])
|
|
(buffer (string->rope initial-contents)
|
|
0))
|
|
|
|
(define (buffer-size buf) (rope-size (buffer-rope buf)))
|
|
|
|
(define (buffer-move-to! buf pos)
|
|
(set-buffer-pos! buf (max 0 (min (buffer-size buf) pos)))
|
|
(buffer-seek! buf pos))
|
|
|
|
(define (buffer-seek! buf pos)
|
|
(buffer-lift0 rope-seek buf pos))
|
|
|
|
(define (buffer-move-by! buf delta)
|
|
(buffer-move-to! buf (+ (buffer-pos buf) delta)))
|
|
|
|
(define (buffer-mark! buf [mtype main-mark-type] #:position [pos (buffer-pos buf)] #:value [value #t])
|
|
(buffer-lift0 replace-mark buf mtype pos value))
|
|
|
|
(define (buffer-search* buf start-pos forward? move? find-delta)
|
|
(define-values (l r) (rope-split (buffer-rope buf) start-pos))
|
|
(define delta (find-delta (if forward? r l)))
|
|
(define new-pos (+ start-pos (cond [(not delta) 0] [forward? delta] [else (- delta)])))
|
|
(when delta
|
|
(if move?
|
|
(buffer-move-to! buf new-pos)
|
|
(buffer-seek! buf new-pos)))
|
|
new-pos)
|
|
|
|
(define (buffer-search buf needle
|
|
#:position [start-pos (buffer-pos buf)]
|
|
#:forward? [forward? #t]
|
|
#:move? [move? #t])
|
|
(buffer-search* buf start-pos forward? move?
|
|
(lambda (piece) (search-rope needle piece #:forward? forward?))))
|
|
|
|
(define (buffer-find buf delims
|
|
#:position [start-pos (buffer-pos buf)]
|
|
#:forward? [forward? #t]
|
|
#:move? [move? #t])
|
|
(buffer-search* buf start-pos forward? move?
|
|
(lambda (piece) (find-in-rope delims piece #:forward? forward?))))
|
|
|
|
(define (buffer-lift0 f buf . args)
|
|
(define new-rope (apply f (buffer-rope buf) args))
|
|
(set-buffer-rope! buf new-rope)
|
|
buf)
|
|
|
|
(define (buffer-lift1 f buf . args)
|
|
(define-values (result new-rope) (apply f (buffer-rope buf) args))
|
|
(set-buffer-rope! buf new-rope)
|
|
result)
|
|
|
|
;; 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.
|
|
;;
|
|
;; MarkType Location Buffer -> Buffer
|
|
;; Ensures the given mark is sanely positioned as a top-of-window mark
|
|
;; with respect to the given cursor position.
|
|
(define (frame-buffer! top-of-window-mtype cursor-position window-height buf
|
|
#:preferred-position-fraction [preferred-position-fraction 1/2])
|
|
(define old-top-of-window-pos (find-next-mark-pos (buffer-rope buf) top-of-window-mtype))
|
|
(define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction))))
|
|
(let loop ((pos (buffer-find buf "\n" #:forward? #f #:move? #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))
|
|
(cond
|
|
[(<= pos old-top-of-window-pos)
|
|
buf]
|
|
[(= line-count window-height)
|
|
(buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos)]
|
|
[else
|
|
(loop (buffer-find buf "\n" #:forward? #f #:move? #f #:position (- pos 1))
|
|
(+ line-count 1)
|
|
new-top-of-window-pos)])))
|