Much interesting progress
This commit is contained in:
Tony Garnock-Jones
parent
3c17ddd755
commit
f59080e6bf
|
|
@ -0,0 +1 @@
|
|||
Make it reloadable
|
||||
127
rmacs/buffer.rkt
127
rmacs/buffer.rkt
|
|
@ -1,8 +1,19 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide main-mark-type
|
||||
(provide make-buffergroup
|
||||
main-mark-type
|
||||
buffer?
|
||||
make-buffer
|
||||
register-buffer!
|
||||
lookup-buffer
|
||||
file->buffer
|
||||
buffer-rename!
|
||||
buffer-reorder!
|
||||
buffer-next
|
||||
buffer-prev
|
||||
buffer-pos
|
||||
buffer-title
|
||||
buffer-group
|
||||
buffer-size
|
||||
buffer-move-to!
|
||||
buffer-move-by!
|
||||
|
|
@ -14,20 +25,114 @@
|
|||
buffer-region-update!
|
||||
call-with-excursion
|
||||
buffer-search
|
||||
buffer-find)
|
||||
buffer-findf)
|
||||
|
||||
(require "rope.rkt")
|
||||
(require "search.rkt")
|
||||
(require "circular-list.rkt")
|
||||
|
||||
(require (only-in racket/string string-join))
|
||||
(require (only-in racket/path normalize-path))
|
||||
(require (only-in racket/file file->string))
|
||||
|
||||
(define main-mark-type (mark-type "main" 'right))
|
||||
|
||||
(struct buffergroup ([members #:mutable] ;; (CircularList Buffer)
|
||||
) #:transparent)
|
||||
|
||||
(struct buffer ([rope #:mutable]
|
||||
[pos #:mutable]
|
||||
[title #:mutable]
|
||||
[group #:mutable] ;; (Option BufferGroup)
|
||||
) #:transparent)
|
||||
|
||||
(define (make-buffer #:initial-contents [initial-contents ""])
|
||||
(buffer (string->rope initial-contents)
|
||||
0))
|
||||
(define (make-buffergroup)
|
||||
(buffergroup circular-empty))
|
||||
|
||||
(define (make-buffer group ;; (Option BufferGroup)
|
||||
title ;; String
|
||||
#:initial-contents [initial-contents ""])
|
||||
(register-buffer! group (buffer (string->rope initial-contents)
|
||||
0
|
||||
title
|
||||
#f)))
|
||||
|
||||
(define (register-buffer! group buf)
|
||||
(define old-group (buffer-group buf))
|
||||
(when old-group
|
||||
(set-buffergroup-members! old-group
|
||||
(circular-list-remove buf (buffergroup-members old-group) eq?))
|
||||
(set-buffer-group! buf #f))
|
||||
(cond
|
||||
[(not group) buf]
|
||||
[(title->buffer* group (buffer-title buf)) #f]
|
||||
[else
|
||||
(set-buffer-group! buf group)
|
||||
(set-buffergroup-members! group (circular-cons buf (buffergroup-members group)))
|
||||
buf]))
|
||||
|
||||
(define (title->buffer* group title)
|
||||
(and group
|
||||
(circular-list-memf (lambda (b) (equal? (buffer-title b) title)) (buffergroup-members group))))
|
||||
|
||||
(define (buffer->buffer* group b)
|
||||
(and group
|
||||
(circular-list-memf (lambda (b1) (eq? b b1)) (buffergroup-members group))))
|
||||
|
||||
(define (lookup-buffer group title)
|
||||
(cond [(title->buffer* group title) => circular-car] [else #f]))
|
||||
|
||||
(define (title-exists-in-group? group title)
|
||||
(and (title->buffer* group title) #t))
|
||||
|
||||
;; (Option Group) Path -> String
|
||||
(define (filename->unique-buffer-title group filename)
|
||||
(define pieces (reverse (map path->string (explode-path filename))))
|
||||
(define primary-piece (car pieces))
|
||||
(define uniquifiers (cdr pieces))
|
||||
(if (not group)
|
||||
primary-piece
|
||||
(let search ((used '()) (remaining uniquifiers))
|
||||
(define candidate
|
||||
(if (null? used)
|
||||
primary-piece
|
||||
(format "~a<~a>" primary-piece (string-join used "/"))))
|
||||
(if (title-exists-in-group? group candidate)
|
||||
(if (pair? remaining)
|
||||
(search (cons (car remaining) used) (cdr remaining))
|
||||
(let search ((counter 2))
|
||||
(define candidate (format "~a<~a>" primary-piece counter))
|
||||
(if (title-exists-in-group? group candidate)
|
||||
(search (+ counter 1))
|
||||
candidate)))
|
||||
candidate))))
|
||||
|
||||
(define (file->buffer group filename)
|
||||
(let* ((filename (normalize-path (simplify-path filename)))
|
||||
(title (filename->unique-buffer-title group filename))
|
||||
(b (make-buffer group title)))
|
||||
(buffer-region-update! b
|
||||
(lambda (_dontcare) (string->rope (file->string filename)))
|
||||
#:point 0
|
||||
#:mark (buffer-size b))))
|
||||
|
||||
(define (buffer-rename! b new-title)
|
||||
(if (title-exists-in-group? (buffer-group b) new-title)
|
||||
#f
|
||||
(begin (set-buffer-title! b new-title)
|
||||
b)))
|
||||
|
||||
(define (buffer-reorder! b)
|
||||
;; Reorders b to the top of the group as a side-effect
|
||||
(register-buffer! (buffer-group b) b))
|
||||
|
||||
(define (buffer-next b)
|
||||
(cond [(buffer->buffer* (buffer-group b) b) => (compose circular-car circular-list-rotate-forward)]
|
||||
[else #f]))
|
||||
|
||||
(define (buffer-prev b)
|
||||
(cond [(buffer->buffer* (buffer-group b) b) => (compose circular-car circular-list-rotate-backward)]
|
||||
[else #f]))
|
||||
|
||||
(define (buffer-size buf) (rope-size (buffer-rope buf)))
|
||||
|
||||
|
|
@ -111,16 +216,16 @@
|
|||
(define (buffer-search buf needle
|
||||
#:position [start-pos (buffer-pos buf)]
|
||||
#:forward? [forward? #t]
|
||||
#:move? [move? #t])
|
||||
#:move? [move? #f])
|
||||
(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])
|
||||
(define (buffer-findf buf f
|
||||
#:position [start-pos (buffer-pos buf)]
|
||||
#:forward? [forward? #t]
|
||||
#:move? [move? #f])
|
||||
(buffer-search* buf start-pos forward? move?
|
||||
(lambda (piece) (find-in-rope delims piece #:forward? forward?))))
|
||||
(lambda (piece) (findf-in-rope f piece #:forward? forward?))))
|
||||
|
||||
(define (buffer-lift f buf . args)
|
||||
(define new-rope (apply f (buffer-rope buf) args))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,170 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide circular-list?
|
||||
circular-empty
|
||||
circular-null?
|
||||
circular-pair?
|
||||
circular-cons
|
||||
circular-car
|
||||
circular-cdr
|
||||
circular-length
|
||||
circular-list-rotate-forward
|
||||
circular-list-rotate-backward
|
||||
list->circular-list
|
||||
circular-list->list
|
||||
circular-list-map
|
||||
circular-list-filter
|
||||
circular-list-remove
|
||||
circular-list-memf)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(struct circular-list ([front #:mutable]
|
||||
[back #:mutable]
|
||||
) #:prefab)
|
||||
|
||||
(define circular-empty (circular-list '() '()))
|
||||
|
||||
(define (circular-null? xs)
|
||||
(equal? xs circular-empty))
|
||||
|
||||
(define (circular-pair? xs)
|
||||
(and (circular-list? xs)
|
||||
(not (circular-null? xs))))
|
||||
|
||||
(define (circular-cons->cons xs)
|
||||
(cons (circular-car xs)
|
||||
(circular-cdr xs)))
|
||||
|
||||
(define (circular-cons* x xs)
|
||||
(circular-list (cons x (circular-list-front xs)) (circular-list-back xs)))
|
||||
|
||||
(define-match-expander circular-cons
|
||||
(syntax-rules ()
|
||||
[(_ a d) (? circular-pair? (app circular-cons->cons (cons a d)))])
|
||||
(syntax-rules ()
|
||||
[(_ a d) (circular-cons* a d)]))
|
||||
|
||||
(define (prime! xs)
|
||||
(match xs
|
||||
[(circular-list '() back)
|
||||
(set-circular-list-front! xs (reverse back))
|
||||
(set-circular-list-back! xs '())]
|
||||
[_ (void)])
|
||||
xs)
|
||||
|
||||
(define (anti-prime! xs)
|
||||
(match xs
|
||||
[(circular-list front '())
|
||||
(set-circular-list-front! xs '())
|
||||
(set-circular-list-back! xs (reverse front))]
|
||||
[_ (void)])
|
||||
xs)
|
||||
|
||||
(define (circular-car xs)
|
||||
(if (circular-null? xs)
|
||||
(error 'circular-car "Empty circular list")
|
||||
(car (circular-list-front (prime! xs)))))
|
||||
|
||||
(define (circular-cdr xs)
|
||||
(if (circular-null? xs)
|
||||
(error 'circular-cdr "Empty circular list")
|
||||
(begin (prime! xs)
|
||||
(circular-list (cdr (circular-list-front xs)) (circular-list-back xs)))))
|
||||
|
||||
(define (circular-length xs)
|
||||
(+ (length (circular-list-front xs))
|
||||
(length (circular-list-back xs))))
|
||||
|
||||
(define (circular-list-rotate-forward xs)
|
||||
(if (circular-null? xs)
|
||||
xs
|
||||
(begin (prime! xs)
|
||||
(circular-list (cdr (circular-list-front xs))
|
||||
(cons (car (circular-list-front xs))
|
||||
(circular-list-back xs))))))
|
||||
|
||||
(define (circular-list-rotate-backward xs)
|
||||
(if (circular-null? xs)
|
||||
xs
|
||||
(begin (anti-prime! xs)
|
||||
(circular-list (cons (car (circular-list-back xs))
|
||||
(circular-list-front xs))
|
||||
(cdr (circular-list-back xs))))))
|
||||
|
||||
(define (list->circular-list xs)
|
||||
(circular-list xs '()))
|
||||
|
||||
(define (circular-list->list xs)
|
||||
(append (circular-list-front xs) (reverse (circular-list-back xs))))
|
||||
|
||||
(define (map/reversed-order f xs)
|
||||
(if (null? xs)
|
||||
'()
|
||||
(let ((tail (map/reversed-order f (cdr xs))))
|
||||
(cons (f (car xs)) tail))))
|
||||
|
||||
(define (circular-list-map f xs)
|
||||
(circular-list (map f (circular-list-front xs))
|
||||
(map/reversed-order f (circular-list-back xs))))
|
||||
|
||||
;; WARNING: does not preserve order of evaluation wrt back
|
||||
(define (circular-list-filter f xs)
|
||||
(circular-list (filter f (circular-list-front xs))
|
||||
(filter f (circular-list-back xs))))
|
||||
|
||||
(define (circular-list-remove item xs [comparison equal?])
|
||||
(define new-front (remove item (circular-list-front xs) comparison))
|
||||
(if (= (length new-front) (length (circular-list-front xs)))
|
||||
(circular-list (circular-list-front xs)
|
||||
(reverse (remove item (reverse (circular-list-back xs)) comparison)))
|
||||
(circular-list new-front (circular-list-back xs))))
|
||||
|
||||
(define (circular-list-memf f xs)
|
||||
(let loop ((seen '()) (xs xs))
|
||||
(if (circular-null? xs)
|
||||
#f
|
||||
(let ((a (circular-car xs)))
|
||||
(if (f a)
|
||||
(circular-list (circular-list-front xs)
|
||||
(append seen (circular-list-back xs)))
|
||||
(loop (cons a seen) (circular-cdr xs)))))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define (check-abcdef abcdef)
|
||||
(define bcdefa (circular-list-rotate-forward abcdef))
|
||||
(check-equal? (circular-length abcdef) 6)
|
||||
(check-equal? (circular-list->list abcdef) '(a b c d e f))
|
||||
(check-equal? (circular-list->list bcdefa) '(b c d e f a))
|
||||
(check-equal? (circular-list->list (for/fold [(xs abcdef)] [(i (circular-length abcdef))]
|
||||
(circular-list-rotate-forward xs)))
|
||||
(circular-list->list abcdef))
|
||||
(check-equal? (circular-list->list (for/fold [(xs abcdef)] [(i (circular-length abcdef))]
|
||||
(circular-list-rotate-backward xs)))
|
||||
(circular-list->list abcdef)))
|
||||
|
||||
(check-abcdef (circular-list '(a b c) '(f e d)))
|
||||
(check-abcdef (circular-list '(a b c d e f) '()))
|
||||
(check-abcdef (circular-list '() '(f e d c b a)))
|
||||
|
||||
(check-equal? (match (circular-cons 1 circular-empty)
|
||||
[(circular-cons a d) (cons a d)])
|
||||
(cons 1 circular-empty))
|
||||
(check-equal? (match (circular-list-rotate-forward (circular-cons 1 circular-empty))
|
||||
[(circular-cons a d) (cons a d)])
|
||||
(cons 1 circular-empty))
|
||||
(check-equal? (match (circular-list-rotate-forward
|
||||
(circular-cons 1 (circular-cons 2 circular-empty)))
|
||||
[(circular-cons a d) (cons a (circular-list->list d))])
|
||||
(list 2 1))
|
||||
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1 2 3) '(6 5 4))))
|
||||
'(1 3 4 5 6))
|
||||
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1) '(6 5 4 3 2))))
|
||||
'(1 3 4 5 6))
|
||||
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1 2 3 2) '(6 5 2 4))))
|
||||
'(1 3 2 4 2 5 6))
|
||||
(check-equal? (circular-list->list (circular-list-remove 2 (circular-list '(1) '(6 5 2 4 2 3 2))))
|
||||
'(1 3 2 4 2 5 6)))
|
||||
|
||||
|
|
@ -1,9 +1,13 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out tty)
|
||||
tty-last-row
|
||||
tty-last-column
|
||||
stdin-tty
|
||||
tty-display
|
||||
tty-newline
|
||||
tty-clear
|
||||
tty-clear-to-eol
|
||||
tty-reset
|
||||
tty-goto
|
||||
tty-style
|
||||
|
|
@ -35,6 +39,9 @@
|
|||
[italic? #:mutable] ;; Boolean
|
||||
) #:transparent)
|
||||
|
||||
(define (tty-last-row t) (- (tty-rows t) 1))
|
||||
(define (tty-last-column t) (- (tty-columns t) 1))
|
||||
|
||||
(define *stdin-tty* #f)
|
||||
(define (stdin-tty)
|
||||
(when (not *stdin-tty*)
|
||||
|
|
@ -55,16 +62,19 @@
|
|||
(plumber-add-flush! (current-plumber)
|
||||
(lambda (h)
|
||||
(tty-style-reset *stdin-tty*)
|
||||
(tty-goto *stdin-tty* (- (tty-rows *stdin-tty*) 1) 0))))
|
||||
(tty-goto *stdin-tty* (tty-last-row *stdin-tty*) 0))))
|
||||
*stdin-tty*)
|
||||
|
||||
(define (tty-display tty . items)
|
||||
(for ((i items)) (display i (tty-output tty)))
|
||||
(flush-output (tty-output tty)))
|
||||
|
||||
(define (tty-newline tty)
|
||||
(tty-display tty "\r\n"))
|
||||
|
||||
(define (tty-goto tty row0 column0)
|
||||
(define row (max 0 (min (- (tty-rows tty) 1) row0)))
|
||||
(define column (max 0 (min (- (tty-columns tty) 1) column0)))
|
||||
(define row (max 0 (min (tty-last-row tty) row0)))
|
||||
(define column (max 0 (min (tty-last-column tty) column0)))
|
||||
(tty-display tty (goto (+ row 1) (+ column 1)))
|
||||
(set-tty-cursor-row! tty row)
|
||||
(set-tty-cursor-column! tty column)
|
||||
|
|
@ -77,6 +87,10 @@
|
|||
(set-tty-cursor-column! tty 0)
|
||||
tty)
|
||||
|
||||
(define (tty-clear-to-eol tty)
|
||||
(tty-display tty (clear-to-eol))
|
||||
tty)
|
||||
|
||||
(define (tty-style tty
|
||||
#:foreground-color [fgcolor (tty-foreground-color tty)]
|
||||
#:background-color [bgcolor (tty-background-color tty)]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,32 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (except-out (struct-out editor) editor)
|
||||
make-editor
|
||||
visit-file!
|
||||
render-editor!
|
||||
)
|
||||
|
||||
(require "buffer.rkt")
|
||||
(require "display.rkt")
|
||||
(require "window.rkt")
|
||||
(require "render.rkt")
|
||||
|
||||
(struct editor (buffers ;; BufferGroup
|
||||
[windows #:mutable] ;; (List (List Window SizeSpec)), abstract window layout
|
||||
[active-window #:mutable] ;; (Option Window)
|
||||
) #:transparent)
|
||||
|
||||
(define (make-editor)
|
||||
(define g (make-buffergroup))
|
||||
(define scratch (make-buffer g "*scratch*" #:initial-contents ";; This is the scratch buffer."))
|
||||
(define w (make-window scratch))
|
||||
(editor g (list (list w (relative-size 1))) w))
|
||||
|
||||
(define (visit-file! editor filename)
|
||||
(set-window-buffer! (editor-active-window editor)
|
||||
(file->buffer (editor-buffers editor)
|
||||
filename)))
|
||||
|
||||
(define (render-editor! editor)
|
||||
(render-windows! (editor-windows editor)
|
||||
(editor-active-window editor)))
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
#lang racket/base
|
||||
;; List utilities :-(
|
||||
|
||||
(provide replacef)
|
||||
|
||||
(require racket/list)
|
||||
|
||||
(define (replacef lst finder replacer)
|
||||
(define-values (head tail) (splitf-at lst (lambda (e) (not (finder e)))))
|
||||
(if (null? tail)
|
||||
head
|
||||
(append head
|
||||
(replacer (car tail))
|
||||
(cdr tail))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(check-equal? (replacef '(1 2 3 4 5) even? (lambda (n) (list n n n)))
|
||||
'(1 2 2 2 3 4 5)))
|
||||
|
|
@ -1,20 +1,19 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "display.rkt")
|
||||
(require "editor.rkt")
|
||||
(require "render.rkt")
|
||||
(require racket/match)
|
||||
|
||||
(define (main)
|
||||
(define t (stdin-tty))
|
||||
(tty-style t #:bold? #t #:background-color color-blue)
|
||||
(tty-display t (format "Your screen is ~a rows and ~a columns.\r\n"
|
||||
(tty-rows t)
|
||||
(tty-columns t)))
|
||||
(tty-style t #:bold? #f #:italic? #t)
|
||||
(tty-display t "Italic.\r\n")
|
||||
(tty-style t #:bold? #t)
|
||||
(tty-display t "Bold and italic.\r\n")
|
||||
(tty-style t #:bold? #f #:italic? #f)
|
||||
(tty-display t "Neither.\r\n"))
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(local-require ansi)
|
||||
(tty-restore!)
|
||||
(raise e))])
|
||||
(define e (make-editor))
|
||||
(visit-file! e (build-path (collection-file-path "main.rkt" "rmacs")
|
||||
'up 'up "doc" "xterm_controls.txt"))
|
||||
(render-editor! e))
|
||||
(sleep 2))
|
||||
|
||||
(module+ main
|
||||
(void (main)))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,131 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide render-windows!)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(require "buffer.rkt")
|
||||
(require "window.rkt")
|
||||
(require "display.rkt")
|
||||
(require "rope.rkt")
|
||||
|
||||
(define top-of-window-mtype (mark-type "top-of-window" 'right))
|
||||
|
||||
(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.
|
||||
;;
|
||||
;; Buffer Nat -> Nat
|
||||
;; Ensures the given mark is sanely positioned as a top-of-window mark
|
||||
;; with respect to the given cursor position. Returns the
|
||||
;; top-of-window position.
|
||||
(define (frame-buffer! buf window-height
|
||||
#:preferred-position-fraction [preferred-position-fraction 1/2])
|
||||
(define old-top-of-window-pos (or (buffer-mark-pos buf top-of-window-mtype) 0))
|
||||
(define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction))))
|
||||
(let loop ((pos (buffer-findf buf 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))
|
||||
(cond
|
||||
[(<= pos old-top-of-window-pos)
|
||||
old-top-of-window-pos]
|
||||
[(= line-count window-height)
|
||||
(buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos)
|
||||
new-top-of-window-pos]
|
||||
[else
|
||||
(loop (buffer-findf buf newline? #:forward? #f #:position (- pos 1))
|
||||
(+ line-count 1)
|
||||
new-top-of-window-pos)])))
|
||||
|
||||
(define (tty-body-style t is-active?)
|
||||
(tty-style t
|
||||
#:foreground-color color-white
|
||||
#:background-color color-blue
|
||||
#:bold? #f))
|
||||
|
||||
(define (tty-statusline-style t is-active?)
|
||||
(tty-style t
|
||||
#:foreground-color color-black
|
||||
#:background-color color-white))
|
||||
|
||||
(define (render-buffer! t b window-top window-height is-active?)
|
||||
(define top-of-window-pos (frame-buffer! b window-height))
|
||||
(define cursor-pos (buffer-pos b))
|
||||
(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 (- window-height 1))
|
||||
cursor-coordinates]
|
||||
[else
|
||||
(define eol-pos (buffer-findf b newline? #:position sol-pos))
|
||||
(define line (rope->string (buffer-region b #:point eol-pos #:mark sol-pos)))
|
||||
(tty-display t line)
|
||||
(tty-clear-to-eol t)
|
||||
(tty-newline t)
|
||||
(loop (+ line-count 1)
|
||||
(+ eol-pos 1)
|
||||
(if (<= sol-pos cursor-pos eol-pos)
|
||||
(list (+ line-count window-top)
|
||||
(- cursor-pos sol-pos))
|
||||
cursor-coordinates))])))
|
||||
(tty-statusline-style t is-active?)
|
||||
(tty-display t (if is-active? "== " "-- ") (buffer-title b) " ")
|
||||
(tty-display t (make-string (- (tty-columns t) 4 (string-length (buffer-title b)))
|
||||
(if is-active? #\= #\-)))
|
||||
cursor-coordinates)
|
||||
|
||||
(define (layout-windows ws 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 (absolute-size lines)) rest)
|
||||
(cons (list w offset lines) (loop rest (+ offset lines) remaining))]
|
||||
[(cons (list w (relative-size weight)) rest)
|
||||
(define height (max minimum-height
|
||||
(inexact->exact
|
||||
(round (* proportional-lines (/ weight total-weight))))))
|
||||
(if (>= remaining height)
|
||||
(if (null? rest)
|
||||
(list (list w offset remaining))
|
||||
(cons (list w offset height) (loop rest (+ offset height) (- remaining height))))
|
||||
(if (>= remaining minimum-height)
|
||||
(list (list w offset remaining))
|
||||
'()))])))
|
||||
|
||||
(define (render-windows! ws active-window)
|
||||
(define t (stdin-tty))
|
||||
(define layout (layout-windows ws (tty-rows t)))
|
||||
(tty-body-style t #f)
|
||||
(tty-clear t)
|
||||
(define active-cursor-position
|
||||
(for/fold [(cursor-position #f)] [(e layout)]
|
||||
(match-define (list w window-top window-height) e)
|
||||
(define is-active? (eq? w active-window))
|
||||
(define b (window-buffer w))
|
||||
(define window-cursor-position (render-buffer! t b window-top 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))))
|
||||
|
|
@ -4,8 +4,8 @@
|
|||
(provide search-generator
|
||||
search-string
|
||||
search-rope
|
||||
find-in-generator
|
||||
find-in-rope)
|
||||
findf-in-generator
|
||||
findf-in-rope)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
|
@ -81,20 +81,19 @@
|
|||
(rope-generator haystack #:forward? #f))))
|
||||
(and reversed-result (- (rope-size haystack) reversed-result (string-length needle))))))
|
||||
|
||||
(define (find-in-generator delims0 gen)
|
||||
(define delims (if (set? delims0) delims0 (list->set (string->list delims0))))
|
||||
(define (findf-in-generator f gen)
|
||||
(let loop ((count 0))
|
||||
(match (gen)
|
||||
[(? char? c)
|
||||
(if (set-member? delims c)
|
||||
(if (f c)
|
||||
count
|
||||
(loop (+ count 1)))]
|
||||
[_ count])))
|
||||
|
||||
(define (find-in-rope delims r #:forward? [forward? #t])
|
||||
(define (findf-in-rope f r #:forward? [forward? #t])
|
||||
(if forward?
|
||||
(find-in-generator delims (rope-generator r))
|
||||
(- (rope-size r) (find-in-generator delims (rope-generator r #:forward? #f)))))
|
||||
(findf-in-generator f (rope-generator r))
|
||||
(- (rope-size r) (findf-in-generator f (rope-generator r #:forward? #f)))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
|
@ -127,6 +126,10 @@
|
|||
(check-equal? (search-rope "xylophone" prejudice-rope) #f)
|
||||
(check-equal? (search-rope "xylophone" prejudice-rope #:forward? #f) #f)
|
||||
|
||||
(define (find-in-rope delims r)
|
||||
(define chs (list->set (string->list delims)))
|
||||
(findf-in-rope (lambda (c) (set-member? chs c)) r))
|
||||
|
||||
(check-equal? (find-in-rope "\n" prejudice-rope) 116)
|
||||
(check-equal? (find-in-rope "at" prejudice-rope) 1)
|
||||
(check-equal? (find-in-rope "z" prejudice-rope) (rope-size prejudice-rope))
|
||||
|
|
|
|||
|
|
@ -1,34 +1,40 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "buffer.rkt")
|
||||
(provide (except-out (struct-out window) window)
|
||||
(struct-out absolute-size)
|
||||
(struct-out relative-size)
|
||||
make-window
|
||||
window-split
|
||||
)
|
||||
|
||||
;; 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 (buffer-mark-pos 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)])))
|
||||
(require racket/match)
|
||||
|
||||
(require "buffer.rkt")
|
||||
(require "lists.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)
|
||||
|
||||
(struct window (id ;; Symbol
|
||||
[buffer #:mutable] ;; Buffer
|
||||
) #:transparent)
|
||||
|
||||
(define (make-window initial-buffer)
|
||||
(window (gensym 'window)
|
||||
initial-buffer))
|
||||
|
||||
(define (scale-size s)
|
||||
(match s
|
||||
[(absolute-size _) s] ;; can't scale fixed-size windows
|
||||
[(relative-size w) (relative-size (/ w 2))]))
|
||||
|
||||
(define (window-split w ws #:proportional? [proportional? #f])
|
||||
(replacef ws
|
||||
(lambda (e) (eq? (car e) w))
|
||||
(lambda (e)
|
||||
(define new-size (if proportional? (cadr e) (scale-size (cadr e))))
|
||||
(list (list w new-size)
|
||||
(list (make-window (window-buffer w)) new-size)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue