From f59080e6bfcaa2c2d3a835a3fd9f5dc5b623f1e3 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 22 Dec 2014 17:14:13 -0500
Subject: [PATCH] Much interesting progress

---
 rmacs/TODO              |   1 +
 rmacs/buffer.rkt        | 127 +++++++++++++++++++++++++++---
 rmacs/circular-list.rkt | 170 ++++++++++++++++++++++++++++++++++++++++
 rmacs/display.rkt       |  20 ++++-
 rmacs/editor.rkt        |  32 ++++++++
 rmacs/lists.rkt         |  20 +++++
 rmacs/main.rkt          |  23 +++---
 rmacs/render.rkt        | 131 +++++++++++++++++++++++++++++++
 rmacs/search.rkt        |  19 +++--
 rmacs/window.rkt        |  68 ++++++++--------
 10 files changed, 546 insertions(+), 65 deletions(-)
 create mode 100644 rmacs/TODO
 create mode 100644 rmacs/circular-list.rkt
 create mode 100644 rmacs/editor.rkt
 create mode 100644 rmacs/lists.rkt
 create mode 100644 rmacs/render.rkt

diff --git a/rmacs/TODO b/rmacs/TODO
new file mode 100644
index 0000000..bb6af38
--- /dev/null
+++ b/rmacs/TODO
@@ -0,0 +1 @@
+Make it reloadable
diff --git a/rmacs/buffer.rkt b/rmacs/buffer.rkt
index f90f860..eff431d 100644
--- a/rmacs/buffer.rkt
+++ b/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))
diff --git a/rmacs/circular-list.rkt b/rmacs/circular-list.rkt
new file mode 100644
index 0000000..cb37f9d
--- /dev/null
+++ b/rmacs/circular-list.rkt
@@ -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)))
+
diff --git a/rmacs/display.rkt b/rmacs/display.rkt
index 82d41eb..36e8a40 100644
--- a/rmacs/display.rkt
+++ b/rmacs/display.rkt
@@ -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)]
diff --git a/rmacs/editor.rkt b/rmacs/editor.rkt
new file mode 100644
index 0000000..928247a
--- /dev/null
+++ b/rmacs/editor.rkt
@@ -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)))
diff --git a/rmacs/lists.rkt b/rmacs/lists.rkt
new file mode 100644
index 0000000..e334180
--- /dev/null
+++ b/rmacs/lists.rkt
@@ -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)))
diff --git a/rmacs/main.rkt b/rmacs/main.rkt
index 6008b65..d8bcc71 100644
--- a/rmacs/main.rkt
+++ b/rmacs/main.rkt
@@ -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)))
diff --git a/rmacs/render.rkt b/rmacs/render.rkt
new file mode 100644
index 0000000..ce449d7
--- /dev/null
+++ b/rmacs/render.rkt
@@ -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))))
diff --git a/rmacs/search.rkt b/rmacs/search.rkt
index 5d4c8a9..3e5946c 100644
--- a/rmacs/search.rkt
+++ b/rmacs/search.rkt
@@ -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))
diff --git a/rmacs/window.rkt b/rmacs/window.rkt
index 7c15404..aa8a899 100644
--- a/rmacs/window.rkt
+++ b/rmacs/window.rkt
@@ -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)))))