Split out rmacs into its own package.

Makefile

@@ -1,5 +1,5 @@
 PACKAGENAME=ansi
-COLLECTS=ansi rmacs
+COLLECTS=ansi
 
 all: setup
 

rmacs/TODO

@@ -1,4 +0,0 @@
-Make it reloadable
-
-Catch and handle SIGWINCH.
-See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html

rmacs/api.rkt

@@ -1,18 +0,0 @@
-#lang racket/base
-;; API for writing modes/commands/etc.
-
-(require "mode.rkt")
-(require "editor.rkt")
-(require "buffer.rkt")
-(require "keys.rkt")
-(require "rope.rkt")
-(require "window.rkt")
-(require "minibuf.rkt")
-
-(provide (all-from-out "mode.rkt"
-                       "editor.rkt"
-                       "buffer.rkt"
-                       "keys.rkt"
-                       "rope.rkt"
-                       "window.rkt"
-                       "minibuf.rkt"))

rmacs/buffer.rkt

@@ -1,504 +0,0 @@
-#lang racket/base
-
-(provide (struct-out buffer-mark-type)
-         make-buffergroup
-         initialize-buffergroup!
-         buffergroup-buffer-titles
-         buffer?
-         make-buffer
-         register-buffer!
-         lookup-buffer
-         unused-buffer-title
-         load-buffer
-         revert-buffer!
-         save-buffer!
-         buffer-rename!
-         buffer-reorder!
-         buffer-next
-         buffer-prev
-         buffer-title
-         buffer-dirty?
-         buffer-source
-         buffer-rope
-         buffer-group
-         buffer-locals
-         mark-buffer-clean!
-         buffer-editor
-         buffer-modeset
-         buffer-string-column-count
-         buffer-column
-         buffer-closest-pos-for-column
-         buffer-apply-modeset!
-         buffer-add-mode!
-         buffer-remove-mode!
-         buffer-toggle-mode!
-         buffer-size
-         buffer-start-of-line
-         buffer-end-of-line
-         buffer-mark-types
-         buffer-mark*
-         buffer-mark
-         buffer-mark-pos*
-         buffer-mark-pos
-         buffer-pos
-         buffer-mark!
-         buffer-clear-mark!
-         buffer-move-mark!
-         buffer-move-mark-to-start-of-line!
-         buffer-move-mark-to-end-of-line!
-         buffer-region-split
-         buffer-region
-         buffer-region-update!
-         buffer-insert!
-         buffer-replace-contents!
-         buffer-search
-         buffer-findf
-         buffer-local
-         define-buffer-local
-
-         (except-out (struct-out command) command)
-         (struct-out exn:abort)
-         abort
-         copy-command
-         (rename-out [make-command command])
-         invoke
-
-         define-key
-         define-command)
-
-(require racket/match)
-(require (for-syntax syntax/parse))
-(require (for-syntax racket/base))
-(require (only-in racket/string string-join))
-(require (only-in racket/path normalize-path))
-(require (only-in racket/file file->string))
-
-(require "rope.rkt")
-(require "search.rkt")
-(require "circular-list.rkt")
-(require "mode.rkt")
-(require "keys.rkt")
-(require "file.rkt")
-
-(struct buffer-mark-type (kind ;; Symbol
-                          window-id ;; Symbol
-                          preserve? ;; Boolean
-                          ) #:prefab)
-
-(struct buffergroup ([members #:mutable] ;; (CircularList Buffer)
-                     [editor #:mutable] ;; (Option Editor), for bidirectional editor/group linkage
-                     ) #:prefab)
-
-(struct buffer ([rope #:mutable]
-                [title #:mutable]
-                [group #:mutable] ;; (Option BufferGroup)
-                [modeset #:mutable] ;; ModeSet
-                [dirty? #:mutable] ;; Boolean
-                [source #:mutable] ;; (Option BufferSource)
-                [locals #:mutable] ;; (HashEqTable Symbol Any)
-                ) #:prefab)
-
-(struct exn:abort exn (detail duration) #:transparent)
-
-(struct command (selector ;; Symbol
-                 buffer ;; Buffer
-                 window ;; (Option Window)
-                 editor ;; Editor
-                 keyseq ;; (Option Keyseq)
-                 prefix-arg ;; Any
-                 ) #:prefab)
-
-(define (make-buffergroup)
-  (buffergroup circular-empty #f))
-
-(define (initialize-buffergroup! g editor)
-  (when (buffergroup-editor g)
-    (error 'initialize-buffergroup! "Duplicate initialization of buffergroup"))
-  (set-buffergroup-editor! g editor)
-  g)
-
-(define (buffergroup-buffer-titles g)
-  (map buffer-title (circular-list->list (buffergroup-members g))))
-
-(define (initial-contents-rope initial-contents)
-  (cond
-   [(string? initial-contents) (string->rope initial-contents)]
-   [(rope? initial-contents) initial-contents]
-   [(procedure? initial-contents) (initial-contents-rope (initial-contents))]
-   [else (error 'initial-contents-rope "Invalid initial-contents: ~v" initial-contents)]))
-
-(define (make-buffer group ;; (Option BufferGroup)
-                     title ;; String
-                     #:initial-contents [initial-contents ""])
-  (register-buffer! group (buffer (initial-contents-rope initial-contents)
-                                  title
-                                  #f
-                                  kernel-modeset
-                                  #f
-                                  #f
-                                  (hasheq))))
-
-(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))
-
-(define (unused-buffer-title group context-pieces)
-  (define primary-piece (if (null? context-pieces) "*anonymous*" (car context-pieces)))
-  (define uniquifiers (if (null? context-pieces) '() (cdr context-pieces)))
-  (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 (load-buffer group src)
-  (define pieces (buffer-source-title-pieces src))
-  (define title (if (not group) (car pieces) (unused-buffer-title group pieces)))
-  (define b (make-buffer group title))
-  (set-buffer-source! b src)
-  (revert-buffer! b)
-  b)
-
-(define (revert-buffer! buf)
-  (buffer-replace-contents! buf (string->rope (buffer-source-read (buffer-source buf))))
-  (mark-buffer-clean! buf))
-
-(define (save-buffer! buf)
-  (buffer-source-write (buffer-source buf) (rope->string (buffer-rope buf)))
-  (mark-buffer-clean! buf))
-
-(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)))
-
-(define (mark-buffer-clean! buf)
-  (set-buffer-dirty?! buf #f))
-
-(define (buffer-editor b)
-  (define g (buffer-group b))
-  (and g (buffergroup-editor g)))
-
-(define (buffer-string-column-count buf start-column str)
-  (for/fold [(count 0)] [(ch str)]
-    (match ch
-      [#\tab (+ count (- 8 (modulo (+ start-column count) 8)))]
-      [#\newline (- start-column)]
-      [_ (+ count 1)])))
-
-(define (buffer-column buf pos-or-mtype)
-  (define pos (->pos buf pos-or-mtype 'buffer-column))
-  (define str (rope->string (buffer-region buf (buffer-start-of-line buf pos) pos)))
-  (buffer-string-column-count buf 0 str))
-
-(define (buffer-closest-pos-for-column buf sol-pos column-offset column)
-  (define g (rope-generator (subrope (buffer-rope buf) sol-pos)))
-  (let loop ((column-count column-offset) (pos sol-pos))
-    (cond
-     [(< column-count column)
-      (match (g)
-        [#\tab (loop (+ column-count (- 8 (modulo column-count 8))) (+ pos 1))]
-        [#\newline pos]
-        [(? char?) (loop (+ column-count 1) (+ pos 1))]
-        [_ pos])]
-     [(= column-count column) pos]
-     [(> column-count column) (- pos 1)])))
-
-(define (buffer-apply-modeset! buf modeset)
-  (set-buffer-modeset! buf modeset))
-
-(define (buffer-add-mode! buf mode)
-  (set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode)))
-(define (buffer-remove-mode! buf mode)
-  (set-buffer-modeset! buf (modeset-remove-mode (buffer-modeset buf) mode)))
-(define (buffer-toggle-mode! buf mode)
-  (set-buffer-modeset! buf (modeset-toggle-mode (buffer-modeset buf) mode)))
-
-(define (clamp pos buf)
-  (max 0 (min (buffer-size buf) pos)))
-
-(define (buffer-seek! buf pos)
-  (buffer-lift rope-seek buf (clamp pos buf)))
-
-(define (newline? ch) (equal? ch #\newline))
-(define (buffer-start-of-line buf pm) (buffer-findf buf pm newline? #:forward? #f))
-(define (buffer-end-of-line buf pm)   (buffer-findf buf pm newline? #:forward? #t))
-
-(define (->pos buf pos-or-mtype what)
-  (clamp (if (number? pos-or-mtype)
-             pos-or-mtype
-             (buffer-mark-pos buf pos-or-mtype what))
-         buf))
-
-(define (buffer-mark-types buf)
-  (rope-marks (buffer-rope buf)))
-
-(define (buffer-mark* buf mtype)
-  (find-mark (buffer-rope buf) mtype))
-
-(define (buffer-mark buf mtype [what 'buffer-mark])
-  (or (buffer-mark* buf mtype)
-      (error what "Mark type ~v not found; available mark types ~v" mtype (buffer-mark-types buf))))
-
-(define (buffer-mark-pos* buf mtype)
-  (find-mark-pos (buffer-rope buf) mtype))
-
-(define (buffer-mark-pos buf mtype [what 'buffer-mark-pos])
-  (or (buffer-mark-pos* buf mtype)
-      (error what "Mark type ~v not found; available mark types ~v" mtype (buffer-mark-types buf))))
-
-(define (buffer-pos buf pos-or-mtype)
-  (->pos buf pos-or-mtype 'buffer-pos))
-
-(define (buffer-mark! buf mtype pos-or-mtype #:value [value #t])
-  (buffer-lift replace-mark buf mtype (->pos buf pos-or-mtype 'buffer-mark!) value))
-
-(define (buffer-clear-mark! buf mtype)
-  (define pos (buffer-mark-pos* buf mtype))
-  (if pos
-      (buffer-lift clear-mark buf mtype pos)
-      buf))
-
-(define (buffer-move-mark! buf mtype delta)
-  (match-define (cons pos val) (buffer-mark buf mtype 'buffer-move-mark!))
-  (buffer-mark! buf mtype (+ pos delta) #:value val))
-
-(define (buffer-move-mark-to-start-of-line! buf mtype)
-  (define pos (buffer-mark-pos buf mtype 'buffer-move-mark-to-start-of-line!))
-  (buffer-mark! buf mtype (buffer-start-of-line buf pos)))
-
-(define (buffer-move-mark-to-end-of-line! buf mtype)
-  (define pos (buffer-mark-pos buf mtype 'buffer-move-mark-to-end-of-line!))
-  (buffer-mark! buf mtype (buffer-end-of-line buf pos)))
-
-(define (buffer-region-split buf pm1 pm2)
-  (define p1 (->pos buf pm1 'buffer-region-split))
-  (define p2 (->pos buf pm2 'buffer-region-split))
-  (define lo (min p1 p2))
-  (define hi (max p1 p2))
-  (define-values (l mr) (rope-split (buffer-rope buf) lo))
-  (define-values (m r) (rope-split mr (- hi lo)))
-  (values l lo m hi r))
-
-(define (buffer-region buf pm1 pm2)
-  (define-values (_l _lo m _hi _r) (buffer-region-split buf pm1 pm2))
-  m)
-
-(define (transfer-marks ro rn)
-  (define mtypes-to-transfer
-    (for/list ((mtype (rope-marks ro))
-               #:when (and (buffer-mark-type? (mark-type-info mtype))
-                           (buffer-mark-type-preserve? (mark-type-info mtype))))
-      mtype))
-  (for/fold [(rn rn)] [(mtype mtypes-to-transfer)]
-    (define pos (case (mark-type-stickiness mtype)
-                  [(left) 0]
-                  [(right) (rope-size rn)]))
-    (set-mark rn mtype pos #t)))
-
-(define (buffer-region-update! buf pm1 pm2 updater)
-  (define-values (l lo old-m hi r) (buffer-region-split buf pm1 pm2))
-  (define new-m (transfer-marks old-m (updater old-m)))
-  (define delta (- (rope-size new-m) (rope-size old-m)))
-  (set-buffer-rope! buf (rope-append (rope-append l new-m) r))
-  (when (buffer-source buf) (set-buffer-dirty?! buf #t))
-  buf)
-
-(define (buffer-insert! buf pos-or-mtype content-rope)
-  (define pos (->pos buf pos-or-mtype 'buffer-insert!))
-  (define-values (l r) (rope-split (buffer-rope buf) pos))
-  (set-buffer-rope! buf (rope-append (rope-append l content-rope) r))
-  (when (buffer-source buf) (set-buffer-dirty?! buf #t))
-  buf)
-
-(define (buffer-replace-contents! buf content-rope)
-  (buffer-region-update! buf 0 (buffer-size buf) (lambda (_dontcare) content-rope)))
-
-(define (buffer-search* buf start-pos-or-mtype forward? find-delta)
-  (define start-pos (->pos buf start-pos-or-mtype 'buffer-search*))
-  (define-values (l r) (rope-split (buffer-rope buf) start-pos))
-  (define delta (find-delta (if forward? r l)))
-  (and delta
-       (let ((new-pos (clamp (+ start-pos (cond [(not delta) 0]
-                                                [forward? delta]
-                                                [else (- delta (rope-size l))]))
-                             buf)))
-         (buffer-seek! buf new-pos)
-         new-pos)))
-
-(define (buffer-search buf start-pos-or-mtype needle #:forward? [forward? #t])
-  (buffer-search* buf start-pos-or-mtype forward?
-                  (lambda (piece) (search-rope needle piece #:forward? forward?))))
-
-(define (buffer-findf buf start-pos-or-mtype f #:forward? [forward? #t])
-  (buffer-search* buf start-pos-or-mtype forward?
-                  (lambda (piece) (findf-in-rope f piece #:forward? forward?))))
-
-(define (buffer-local name [default #f])
-  (case-lambda
-    [(buf)
-     (hash-ref (buffer-locals buf) name (lambda () default))]
-    [(buf val)
-     (set-buffer-locals! buf (if (equal? val default)
-                                 (hash-remove (buffer-locals buf) name)
-                                 (hash-set (buffer-locals buf) name val)))
-     val]))
-
-(define-syntax define-buffer-local
-  (syntax-rules ()
-    ((_ name) (define name (buffer-local 'name)))
-    ((_ name default) (define name (buffer-local 'name default)))))
-
-(define (buffer-lift f buf . args)
-  (define new-rope (apply f (buffer-rope buf) args))
-  (set-buffer-rope! buf new-rope)
-  buf)
-
-;;---------------------------------------------------------------------------
-
-(define (abort #:detail [detail #f]
-               #:duration [duration #f]
-               fmt . args)
-  (raise (exn:abort (apply format fmt args)
-                    (current-continuation-marks)
-                    detail
-                    duration)))
-
-(define (make-command selector buffer-or-command
-                      #:window [window #f]
-                      #:editor [editor #f]
-                      #:keyseq [keyseq #f]
-                      #:prefix-arg [prefix-arg '#:default])
-  (define buffer (cond
-                  [(buffer? buffer-or-command) buffer-or-command]
-                  [(command? buffer-or-command) (command-buffer buffer-or-command)]))
-  (command selector buffer window (or editor (buffer-editor buffer)) keyseq prefix-arg))
-
-(define (copy-command cmd
-                      #:selector [selector (command-selector cmd)]
-                      #:buffer [buffer (command-buffer cmd)]
-                      #:window [window (command-window cmd)]
-                      #:editor [editor (command-editor cmd)]
-                      #:keyseq [keyseq (command-keyseq cmd)]
-                      #:prefix-arg [prefix-arg (command-prefix-arg cmd)])
-  (struct-copy command cmd
-               [selector selector]
-               [buffer buffer]
-               [window window]
-               [editor editor]
-               [keyseq keyseq]
-               [prefix-arg prefix-arg]))
-
-(define (invoke cmd)
-  (match-define (command selector buf _ _ keyseq _) cmd)
-  (define handler (modeset-lookup-command (buffer-modeset buf) selector))
-  (when (not handler)
-    (abort "Unhandled command ~a (key sequence: ~a)"
-           selector
-           (if keyseq (keyseq->keyspec keyseq) "N/A")))
-  (handler cmd))
-
-(define-syntax-rule (define-key mode-exp keyspec-exp command-symbol)
-  (void (mode-keymap-bind! mode-exp keyspec-exp 'command-symbol)))
-
-(define-syntax define-command
-  (lambda (stx)
-    (syntax-parse stx
-      [(_ mode-exp
-          (selector buffer
-                    (~or (~optional (~seq #:next-method next-method)
-                                    #:defaults ([next-method #'nm])
-                                    #:name "#:next-method")
-                         (~optional (~seq #:command cmd)
-                                    #:defaults ([cmd #'cmd])
-                                    #:name "#:command")
-                         (~optional (~seq #:selector self-selector)
-                                    #:defaults ([self-selector #'self])
-                                    #:name "#:selector")
-                         (~optional (~seq #:window window)
-                                    #:defaults ([window #'win])
-                                    #:name "#:window")
-                         (~optional (~seq #:editor editor)
-                                    #:defaults ([editor #'ed])
-                                    #:name "#:editor")
-                         (~optional (~seq #:keyseq keyseq)
-                                    #:defaults ([keyseq #'keyseq])
-                                    #:name "#:keyseq")
-                         (~optional (~seq #:prefix-arg
-                                          (~or (~seq [prefix-arg prefix-default prefix-prefix])
-                                               (~seq [prefix-arg prefix-default])
-                                               prefix-arg))
-                                    #:defaults ([prefix-arg #'pa]
-                                                [prefix-default #''#:default]
-                                                [prefix-prefix #''#:prefix])
-                                    #:name "#:prefix-arg"))
-                    ...)
-          (~seq #:bind-key bind-keyspec-exps) ...
-          body ...)
-       #`(let ((mode mode-exp))
-           (mode-define-command! mode
-                                 'selector
-                                 (lambda (cmd next-method)
-                                   (match-define (command self-selector
-                                                          buffer
-                                                          window
-                                                          editor
-                                                          keyseq
-                                                          prefix-arg) cmd)
-                                   (let ((prefix-arg (match prefix-arg
-                                                       ['#:default prefix-default]
-                                                       ['#:prefix prefix-prefix]
-                                                       [_ prefix-arg])))
-                                     body ...)))
-           #,@(for/list ((bind-keyspec-exp (syntax->list #'(bind-keyspec-exps ...))))
-                #`(mode-keymap-bind! mode #,bind-keyspec-exp 'selector))
-           (void))])))

rmacs/circular-list.rkt

@@ -1,244 +0,0 @@
-#lang racket/base
-
-(provide circular-list?
-         circular-empty
-         circular-null?
-         circular-pair?
-         circular-cons
-         circular-snoc
-         circular-car
-         circular-cdr
-         circular-last
-         circular-butlast
-         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
-         circular-list-replacef)
-
-(require racket/match)
-(require (only-in racket/list splitf-at))
-
-(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-uncons xs)
-  (cons (circular-car xs)
-        (circular-cdr xs)))
-
-(define (circular-unsnoc xs)
-  (cons (circular-butlast xs)
-        (circular-last xs)))
-
-(define (circular-cons* x xs)
-  (circular-list (cons x (circular-list-front xs)) (circular-list-back xs)))
-
-(define (circular-snoc* xs x)
-  (circular-list (circular-list-front xs) (cons x (circular-list-back xs))))
-
-(define-match-expander circular-cons
-  (syntax-rules () [(_ a d) (? circular-pair? (app circular-uncons (cons a d)))])
-  (syntax-rules () [(_ a d) (circular-cons* a d)]))
-
-(define-match-expander circular-snoc
-  (syntax-rules () [(_ d a) (? circular-pair? (app circular-unsnoc (cons d a)))])
-  (syntax-rules () [(_ d a) (circular-snoc* d a)]))
-
-(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-last xs)
-  (if (circular-null? xs)
-      (error 'circular-last "Empty circular list")
-      (car (circular-list-back (anti-prime! xs)))))
-
-(define (circular-butlast xs)
-  (if (circular-null? xs)
-      (error 'circular-butlast "Empty circular list")
-      (begin (anti-prime! xs)
-             (circular-list (circular-list-front xs) (cdr (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)))))))
-
-(define (circular-list-replacef xs finder replacer)
-  (define (rejecter e) (not (finder e)))
-  (define-values (head tail) (splitf-at (circular-list-front xs) rejecter))
-  (if (null? tail)
-      (let-values (((head tail) (splitf-at (reverse (circular-list-back xs)) rejecter)))
-        (if (null? tail)
-            xs
-            (circular-list (circular-list-front xs)
-                           (reverse (append head (replacer (car tail)) (cdr tail))))))
-      (circular-list (append head (replacer (car tail)) (cdr tail))
-                     (circular-list-back 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? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
-                                                             (lambda (x) (eq? x 'e))
-                                                             (lambda (x) (list 111))))
-                '(a b c d 111 f))
-  (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
-                                                             (lambda (x) (eq? x 'e))
-                                                             (lambda (x) (list 111 222))))
-                '(a b c d 111 222 f))
-  (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
-                                                             (lambda (x) (eq? x 'b))
-                                                             (lambda (x) (list 111))))
-                '(a 111 c d e f))
-  (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
-                                                             (lambda (x) (eq? x 'b))
-                                                             (lambda (x) (list 111 222))))
-                '(a 111 222 c d e f))
-  (check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
-                                                             (lambda (x) (eq? x 'x))
-                                                             (lambda (x) (list 111 222))))
-                '(a b c d e f))
-
-  (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? (match (circular-snoc circular-empty 1)
-                  [(circular-snoc d a) (cons d a)])
-                (cons circular-empty 1))
-  (check-equal? (match (circular-list-rotate-forward (circular-snoc circular-empty 1))
-                  [(circular-snoc d a) (cons d a)])
-                (cons circular-empty 1))
-  (check-equal? (match (circular-list-rotate-forward
-                        (circular-snoc (circular-snoc circular-empty 2) 1))
-                  [(circular-snoc d a) (cons a (circular-list->list d))])
-                (list 2 1))
-
-  (check-equal? (match (circular-snoc (circular-snoc circular-empty 1) 2)
-                  [(circular-cons x (circular-cons y z)) (cons x (cons y (circular-list->list z)))])
-                (list 1 2))
-
-  (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)))
-

rmacs/diff.rkt

@@ -1,129 +0,0 @@
-#lang racket/base
-;; Text diff algorithm after Myers 1986 and Ukkonen 1985, following
-;; Levente Uzonyi's Squeak Smalltalk implementation at
-;; http://squeaksource.com/DiffMerge.html
-;;
-;; E. W. Myers, “An O(ND) difference algorithm and its variations,”
-;; Algorithmica, vol. 1, no. 1–4, pp. 251–266, Nov. 1986.
-;;
-;; E. Ukkonen, “Algorithms for approximate string matching,” Inf.
-;; Control, vol. 64, no. 1–3, pp. 100–118, Jan. 1985.
-
-(provide diff-indices
-         apply-patch!)
-
-(require racket/match)
-
-(define (longest-common-subsequence* xs ys)
-  (define xs-length (vector-length xs))
-  (define ys-length (vector-length ys))
-  (define total-length (+ xs-length ys-length))
-  (define storage-length (+ 1 (* 2 total-length)))
-  (define frontier (make-vector storage-length 0))
-  (define candidates (make-vector storage-length '()))
-  (let/ec return
-    (for ((d (in-range 0 (+ total-length 1))))
-      (for ((k (in-range (- d) (+ d 1) 2)))
-        (define-values (index x)
-          (if (or (= k (- d))
-                  (and (not (= k d))
-                       (< (vector-ref frontier (+ total-length k -1))
-                          (vector-ref frontier (+ total-length k 1)))))
-              (values (+ total-length k 1) (vector-ref frontier (+ total-length k 1)))
-              (values (+ total-length k -1) (+ (vector-ref frontier (+ total-length k -1)) 1))))
-        (let loop ((x x) (y (- x k)) (chain (vector-ref candidates index)))
-          (cond
-           [(and (< x xs-length) (< y ys-length) (equal? (vector-ref xs x) (vector-ref ys y)))
-            (loop (+ x 1) (+ y 1) (cons (cons x y) chain))]
-           [(and (>= x xs-length) (>= y ys-length))
-            (return (reverse chain))]
-           [else
-            (vector-set! frontier (+ total-length k) x)
-            (vector-set! candidates (+ total-length k) chain)]))))))
-
-(define (sequence->vector xs) (for/vector ((x xs)) x))
-
-(define (longest-common-subsequence xs ys)
-  (longest-common-subsequence* (sequence->vector xs) (sequence->vector ys)))
-
-(define (diff-indices xs0 ys0)
-  (define xs (sequence->vector xs0))
-  (define ys (sequence->vector ys0))
-  (let loop ((i -1)
-             (j -1)
-             (matches (append (longest-common-subsequence* xs ys)
-                              (list (cons (vector-length xs) (vector-length ys))))))
-    (match matches
-      ['() '()]
-      [(cons (cons mi mj) rest)
-       (define li (- mi i 1))
-       (define lj (- mj j 1))
-       (if (or (positive? li) (positive? lj))
-           (cons (list (+ i 1) li (+ j 1) lj) (loop mi mj rest))
-           (loop mi mj rest))])))
-
-;; patch-indices is a result from a call to diff-indices
-(define (apply-patch! patch-indices ;; DiffIndices
-                      remove-elements! ;; Nat Nat -> Void
-                      insert-elements! ;; Nat Nat Nat -> Void
-                      )
-  (for/fold [(skew 0)] [(patch patch-indices)]
-    (match-define (list old-i old-n new-i new-n) patch)
-    (define delta (- new-n old-n))
-    (if (negative? delta)
-        (begin (remove-elements! (+ old-i skew) (- delta))
-               (+ skew delta))
-        skew))
-  (for/fold [(skew 0)] [(patch patch-indices)]
-    (match-define (list old-i old-n new-i new-n) patch)
-    (define delta (- new-n old-n))
-    (insert-elements! (+ old-i skew) (max 0 delta) new-n)
-    (+ skew delta))
-  (void))
-
-(module+ test
-  (require rackunit)
-
-  ;; (define (test-example xs ys)
-  ;;   (printf "~v\n" (longest-common-subsequence xs ys))
-  ;;   (printf "~v\n" (diff-indices xs ys)))
-  ;; (test-example "The red brown fox jumped over the rolling log"
-  ;;               "The brown spotted fox leaped over the rolling log")
-
-  (check-equal? (diff-indices "The red brown fox jumped over the rolling log"
-                              "The brown spotted fox leaped over the rolling log")
-                '((4 4 4 0) (14 0 10 8) (18 3 22 3)))
-
-  (check-equal? (longest-common-subsequence "acbcaca" "bcbcacb")
-                '((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)))
-  (check-equal? (longest-common-subsequence "bcbcacb" "acbcaca")
-                '((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)))
-  (check-equal? (longest-common-subsequence "acba" "bcbb")
-                '((1 . 1) (2 . 2)))
-  (check-equal? (longest-common-subsequence "abcabba" "cbabac")
-                '((2 . 0) (3 . 2) (4 . 3) (6 . 4)))
-  (check-equal? (longest-common-subsequence "cbabac" "abcabba")
-                '((1 . 1) (2 . 3) (3 . 4) (4 . 6)))
-
-  (check-equal? (longest-common-subsequence
-                 (vector (vector 1 1 1) (vector 1 1 1) (vector 1 1 1) (vector 1 1 1))
-                 (vector (vector 1 1 1) (vector 2 2 2) (vector 1 1 1) (vector 4 4 4)))
-                '((0 . 0) (1 . 2)))
-  (check-equal? (diff-indices
-                 (vector (vector 1 1 1) (vector 1 1 1) (vector 1 1 1) (vector 1 1 1))
-                 (vector (vector 1 1 1) (vector 2 2 2) (vector 1 1 1) (vector 4 4 4)))
-                '((1 0 1 1) (2 2 3 1)))
-
-  (check-equal? (longest-common-subsequence '(a b c) '(d e f)) '())
-  (check-equal? (diff-indices '(a b c) '(d e f)) '((0 3 0 3)))
-
-  (let ((size 400))
-    (local-require profile)
-    (profile-thunk
-     (lambda ()
-       (diff-indices (make-vector size 'x)
-                     (let ((v (make-vector size 'x)))
-                       (vector-set! v 0 'a)
-                       (vector-set! v 1 'b)
-                       (vector-set! v 2 'c)
-                       v))))))

rmacs/display.rkt

@@ -1,386 +0,0 @@
-#lang racket/base
-
-(provide (struct-out tty)
-         (struct-out pen)
-         stdin-tty
-         tty-rows
-         tty-columns
-         tty-last-row
-         tty-last-column
-         tty-cursor-row
-         tty-cursor-column
-         tty-display
-         tty-newline
-         tty-clear
-         tty-clear-to-eol
-         tty-reset
-         tty-goto
-         tty-set-pen!
-         tty-default-pen
-         tty-pen
-         tty-flush
-         tty-next-key
-         tty-next-key-evt
-
-         ;; From ansi
-         (rename-out [ansi:color-black color-black]
-                     [ansi:color-red color-red]
-                     [ansi:color-green color-green]
-                     [ansi:color-yellow color-yellow]
-                     [ansi:color-blue color-blue]
-                     [ansi:color-magenta color-magenta]
-                     [ansi:color-cyan color-cyan]
-                     [ansi:color-white color-white]))
-
-(require racket/set)
-(require racket/match)
-(require (only-in racket/vector vector-copy))
-(require (prefix-in ansi: ansi))
-
-(require "diff.rkt")
-
-(struct pen (foreground-color ;; Nat
-             background-color ;; Nat
-             bold? ;; Boolean
-             italic? ;; Boolean
-             ) #:prefab)
-
-(struct screen (rows ;; Nat
-                columns ;; Nat
-                [cursor-row #:mutable] ;; Nat
-                [cursor-column #:mutable] ;; Nat
-                [pen #:mutable] ;; Pen
-                contents ;; (Vector[rows] (Vector[columns] (Cons Pen Character)))
-                ) #:prefab)
-
-(struct tty (input ;; InputPort
-             output ;; OutputPort
-             key-reader ;; InputPort -> Key
-             [displayed-screen #:mutable] ;; Screen
-             [pending-screen #:mutable] ;; Screen
-             [utf-8-input? #:mutable] ;; Boolean
-             ) #:prefab)
-
-(define (make-screen rows columns pen)
-  (define contents (for/vector ((row rows)) (make-vector columns (cons pen 'empty))))
-  (screen rows columns 0 0 pen contents))
-
-(define (copy-screen s)
-  (match-define (screen rows columns cursor-row cursor-column pen contents) s)
-  (define new-contents (for/vector ((row rows)) (vector-copy (vector-ref contents row))))
-  (screen rows columns cursor-row cursor-column pen new-contents))
-
-(define tty-default-pen 'default)
-
-(define *stdin-tty* #f)
-(define (stdin-tty)
-  (when (not *stdin-tty*)
-    (ansi:tty-raw!)
-    (set! *stdin-tty*
-          (tty (current-input-port)
-               (current-output-port)
-               ansi:lex-lcd-input
-               (make-screen 24 80 tty-default-pen)
-               (make-screen 24 80 tty-default-pen)
-               (match (getenv "RMACS_UTF8_INPUT")
-                 [(or #f "yes" "true" "1") #t]
-                 [(or "no" "false" "0") #f]
-                 [v (error 'RMACS_UTF8_INPUT
-                           "Environment variable RMACS_UTF8_INPUT value ~v invalid: must be in ~v"
-                           v
-                           (list "yes" "true" "1" "no" "false" "0"))])))
-    (reset *stdin-tty*)
-    (plumber-add-flush! (current-plumber)
-                        (lambda (h)
-                          (output *stdin-tty*
-                                  (ansi:select-graphic-rendition ansi:style-normal)
-                                  (ansi:goto (tty-rows *stdin-tty*) 1))
-                          (flush *stdin-tty*))))
-  *stdin-tty*)
-
-;;---------------------------------------------------------------------------
-;; Actually send changes to the display
-
-(define (collect-position-report tty)
-  (let loop ()
-    (sync/timeout 0.5
-                  (handle-evt (tty-input tty)
-                              (lambda (p)
-                                (match ((tty-key-reader tty) p)
-                                  [(? ansi:position-report? r) r]
-                                  [_ (loop)]))))))
-
-(define (reset tty)
-  (output tty
-          (ansi:clear-screen)
-          (ansi:goto 999 999)
-          (ansi:position-report-request))
-  (flush tty)
-  (define report (or (collect-position-report tty)
-                     (ansi:position-report 24 80))) ;; TODO: have a more flexible fallback
-  ;; (set! report (ansi:position-report 5 10))
-  (define rows (ansi:position-report-row report))
-  (define columns (ansi:position-report-column report))
-  (set-pen tty tty-default-pen #:force #t)
-  (clear tty)
-  (flush tty)
-  (set-tty-displayed-screen! tty (make-screen rows columns tty-default-pen))
-  (set-tty-pending-screen! tty (make-screen rows columns tty-default-pen))
-  tty)
-
-(define (set-pen tty p #:force [force #f])
-  (when (or force (not (equal? p (screen-pen (tty-displayed-screen tty)))))
-    (match p
-      [(pen fgcolor bgcolor bold? italic?)
-       (output tty
-               (apply ansi:select-graphic-rendition
-                      `(,@(if bold? (list ansi:style-bold) (list))
-                        ,@(if italic? (list ansi:style-italic/inverse) (list))
-                        ,(ansi:style-text-color fgcolor)
-                        ,(ansi:style-background-color bgcolor))))]
-      ['default
-       (output tty (ansi:select-graphic-rendition ansi:style-normal))])
-    (set-screen-pen! (tty-displayed-screen tty) p))
-  tty)
-
-(define (clear tty)
-  (output tty (ansi:clear-screen/home))
-  (set-screen-cursor-row! (tty-displayed-screen tty) 0)
-  (set-screen-cursor-column! (tty-displayed-screen tty) 0)
-  tty)
-
-(define (color-near-cursor s row-delta column-delta)
-  (define r (max 0 (min (- (screen-rows s) 1) (+ (screen-cursor-row s) row-delta))))
-  (define c (max 0 (min (- (screen-columns s) 1) (+ (screen-cursor-column s) column-delta))))
-  (car (vector-ref (vector-ref (screen-contents s) r) c)))
-
-(define (vector-delete! v base count fill)
-  (vector-copy! v base v (+ base count) (vector-length v))
-  (for ((i (in-range (- (vector-length v) count) (vector-length v)))) (vector-set! v i fill)))
-
-(define (vector-insert! v base count fill)
-  (vector-copy! v (+ base count) v base (- (vector-length v) count))
-  (for ((i (in-range base (+ base count)))) (vector-set! v i fill)))
-
-(define (delete-lines tty n)
-  (define s (tty-displayed-screen tty))
-  (set-pen tty tty-default-pen)
-  (output tty (ansi:delete-lines n))
-  (define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
-  (vector-delete! (screen-contents s) (screen-cursor-row s) n blank-line)
-  tty)
-
-(define (insert-lines tty n)
-  (define s (tty-displayed-screen tty))
-  (set-pen tty tty-default-pen)
-  (output tty (ansi:insert-lines n))
-  (define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
-  (vector-insert! (screen-contents s) (screen-cursor-row s) n blank-line)
-  tty)
-
-(define (delete-columns tty n)
-  (define s (tty-displayed-screen tty))
-  (set-pen tty tty-default-pen)
-  (output tty (ansi:delete-characters n))
-  (define blank-cell (cons (screen-pen s) 'empty))
-  (define line (vector-ref (screen-contents s) (screen-cursor-row s)))
-  (vector-delete! line (screen-cursor-column s) n blank-cell)
-  tty)
-
-(define (insert-columns tty n)
-  (define s (tty-displayed-screen tty))
-  (set-pen tty (color-near-cursor s 0 -1))
-  (output tty (ansi:insert-characters n))
-  (define blank-cell (cons (screen-pen s) 'empty))
-  (define line (vector-ref (screen-contents s) (screen-cursor-row s)))
-  (vector-insert! line (screen-cursor-column s) n blank-cell)
-  tty)
-
-(define (output tty . items)
-  (for ((i items)) (display i (tty-output tty))))
-
-(define (flush tty)
-  (flush-output (tty-output tty)))
-
-;;---------------------------------------------------------------------------
-;; Display to buffered screen
-
-(define (tty-rows t) (screen-rows (tty-pending-screen t)))
-(define (tty-columns t) (screen-columns (tty-pending-screen t)))
-
-(define (tty-last-row t) (- (tty-rows t) 1))
-(define (tty-last-column t) (- (tty-columns t) 1))
-
-(define (tty-cursor-row t) (screen-cursor-row (tty-pending-screen t)))
-(define (tty-cursor-column t) (screen-cursor-column (tty-pending-screen t)))
-
-(define (non-empty? ch) (not (equal? ch 'empty)))
-
-(define (putc tty ch)
-  (define s (tty-pending-screen tty))
-  (match ch
-    [#\return
-     (tty-goto tty (screen-cursor-row s) 0)]
-    [#\newline
-     (tty-goto tty (+ (screen-cursor-row s) 1) (screen-cursor-column s))]
-    [#\tab
-     (for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (putc tty #\space))]
-    [(and (? non-empty?) (? char-iso-control?))
-     (puts tty (format "[~x]" (char->integer ch)))]
-    [_
-     (when (< (screen-cursor-column s) (screen-columns s))
-       ;; (tty-goto tty (+ (screen-cursor-row s) 1) 0)
-       (vector-set! (vector-ref (screen-contents s) (screen-cursor-row s))
-                    (screen-cursor-column s)
-                    (cons (screen-pen s) ch)))
-     (set-screen-cursor-column! s (+ (screen-cursor-column s) 1))]))
-
-(define (puts tty s)
-  (for ((ch s)) (putc tty ch)))
-
-(define (tty-display tty . strings)
-  (for ((s strings)) (puts tty s)))
-
-(define (tty-newline tty)
-  (tty-clear-to-eol tty)
-  (putc tty #\return)
-  (putc tty #\newline))
-
-(define (tty-clear tty)
-  (set-tty-pending-screen! tty (make-screen (tty-rows tty) (tty-columns tty) (tty-pen tty)))
-  tty)
-
-(define (tty-clear-to-eol tty)
-  (define start-column (tty-cursor-column tty))
-  (define pen (screen-pen (tty-pending-screen tty)))
-  (tty-set-pen! tty tty-default-pen)
-  (for ((i (max 0 (- (tty-columns tty) (tty-cursor-column tty))))) (putc tty 'empty))
-  (tty-set-pen! tty pen)
-  (tty-goto tty (tty-cursor-row tty) start-column)
-  tty)
-
-(define (tty-reset tty)
-  (reset tty)
-  tty)
-
-(define (tty-goto tty row0 column0)
-  (define row (max 0 (min (tty-last-row tty) row0)))
-  (define column (max 0 (min (tty-last-column tty) column0)))
-  (set-screen-cursor-row! (tty-pending-screen tty) row)
-  (set-screen-cursor-column! (tty-pending-screen tty) column)
-  tty)
-
-(define (tty-set-pen! tty pen)
-  (set-screen-pen! (tty-pending-screen tty) pen)
-  tty)
-
-(define (tty-pen tty)
-  (screen-pen (tty-pending-screen tty)))
-
-;; (define (dump-screen s)
-;;   (list 'screen
-;;         (screen-rows s)
-;;         (screen-columns s)
-;;         (screen-cursor-row s)
-;;         (screen-cursor-column s)
-;;         (list->string
-;;          (for*/list ((line (screen-contents s))
-;;                      (cell line)
-;;                      #:when (non-empty? (cdr cell)))
-;;            (cdr cell)))))
-
-(define (goto-if-needed s row column)
-  (cond
-   [(and (= (screen-cursor-row s) row) (= (screen-cursor-column s) column))
-    ""]
-   [(= (screen-cursor-row s) row)
-    (begin0 (ansi:goto-column (+ column 1))
-      (set-screen-cursor-column! s column))]
-   [else
-    (begin0 (ansi:goto (+ row 1) (+ column 1))
-      (set-screen-cursor-row! s row)
-      (set-screen-cursor-column! s column))]))
-
-(define (advance-cursor! tty s)
-  (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 "\r\n"))
-    (set-screen-cursor-column! s 0)
-    (set-screen-cursor-row! s (+ (screen-cursor-row s) 1))))
-
-;; Answers #t when an edit to a line would produce a visible effect.
-(define (interesting-change? old-line new-line column right-margin)
-  (for/or [(i (in-range column right-margin))]
-    (not (equal? (vector-ref old-line i) (vector-ref new-line i)))))
-
-(define (repair-span! tty old new-line row first-col cell-count)
-  (define trailing-empty-count
-    (for/fold [(empty-count 0)] [(column (in-range first-col (+ first-col cell-count)))]
-      (match-define (cons new-pen new-ch) (vector-ref new-line column))
-      (if (non-empty? new-ch)
-          (begin (set-pen tty new-pen)
-                 (output tty (goto-if-needed old row column) new-ch)
-                 (advance-cursor! tty old)
-                 0)
-          (+ empty-count 1))))
-  (when (and (positive? trailing-empty-count) (= (+ first-col cell-count) (tty-columns tty)))
-    (output tty (ansi:clear-to-eol))))
-
-(define (repair-line! tty old new row)
-  (define columns (screen-columns new))
-  (define old-line (vector-ref (screen-contents old) row))
-  (define new-line (vector-ref (screen-contents new) row))
-  (define patches (diff-indices old-line new-line))
-  (if (<= (length patches) 3)
-      (apply-patch! patches
-                    (lambda (first-col cols-to-remove)
-                      (when (interesting-change? old-line new-line first-col columns)
-                        (output tty (goto-if-needed old row first-col))
-                        (delete-columns tty cols-to-remove)))
-                    (lambda (first-col cols-to-insert cell-count)
-                      (when (interesting-change? old-line new-line first-col columns)
-                        (output tty (goto-if-needed old row first-col))
-                        (when (and (positive? cols-to-insert)
-                                   (interesting-change? old-line
-                                                        new-line
-                                                        (+ first-col cols-to-insert)
-                                                        columns))
-                          (insert-columns tty cols-to-insert))
-                        (repair-span! tty old new-line row first-col cell-count))))
-      (repair-span! tty old new-line row 0 columns)))
-
-(define (tty-flush tty)
-  (define old (tty-displayed-screen tty))
-  (define new (tty-pending-screen tty))
-  (apply-patch! (diff-indices (screen-contents old) (screen-contents new))
-                (lambda (first-row lines-to-remove)
-                  (output tty (goto-if-needed old first-row (screen-cursor-column old)))
-                  (delete-lines tty lines-to-remove))
-                (lambda (first-row lines-to-insert line-count)
-                  (when (positive? lines-to-insert)
-                    (output tty (goto-if-needed old first-row (screen-cursor-column old)))
-                    (insert-lines tty lines-to-insert))
-                  (for ((row (in-range first-row (+ first-row line-count))))
-                    (repair-line! tty old new row))))
-  (output tty (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new)))
-  (flush tty)
-  (set-tty-displayed-screen! tty (struct-copy screen new [pen (screen-pen old)]))
-  (set-tty-pending-screen! tty (copy-screen new))
-  tty)
-
-;;---------------------------------------------------------------------------
-;; Input
-
-(define (tty-next-key tty)
-  (define k (ansi:lex-lcd-input (tty-input tty) #:utf-8? (tty-utf-8-input? tty)))
-  (if (equal? k (ansi:key #\[ (set 'control))) ;; ESC
-      (or (sync/timeout 0.5
-                        (handle-evt (tty-next-key-evt tty)
-                                    (lambda (k) (ansi:add-modifier 'meta k))))
-          k)
-      k))
-
-(define (tty-next-key-evt tty)
-  (handle-evt (tty-input tty)
-              (lambda (_) (tty-next-key tty))))

rmacs/editor.rkt

@@ -1,407 +0,0 @@
-#lang racket/base
-
-(provide (except-out (struct-out editor) editor)
-         make-editor
-         configure-fresh-buffer!
-         find-buffer
-         window-layout
-         window-width
-         window-height
-         open-window
-         close-other-windows
-         close-window
-         resize-window
-         select-window
-         windows-for-buffer
-         window-for-buffer
-         visit-file!
-         render-editor!
-         editor-next-window
-         editor-prev-window
-         editor-command
-         invoke/history
-         editor-last-command?
-         editor-active-buffer
-         editor-active-modeset
-         editor-mainloop
-         editor-request-shutdown!
-         editor-force-redisplay!
-         clear-message
-         message
-         start-recursive-edit
-         abandon-recursive-edit)
-
-(require racket/match)
-
-(require "buffer.rkt")
-(require "display.rkt")
-(require "window.rkt")
-(require "render.rkt")
-(require "mode.rkt")
-(require "keys.rkt")
-(require "rope.rkt")
-(require "circular-list.rkt")
-(require "file.rkt")
-
-(struct editor (buffers ;; BufferGroup
-                [tty #:mutable] ;; Tty
-                [windows #:mutable] ;; (CircularList (List Window SizeSpec)), abstract window layout
-                [active-window #:mutable] ;; (Option Window)
-                [running? #:mutable] ;; Boolean
-                [default-modeset #:mutable] ;; ModeSet
-                [layout #:mutable] ;; (Option (List Layout))
-                [last-command #:mutable] ;; (Option Command)
-                echo-area ;; Buffer
-                mini-window ;; Window
-                [message-expiry-time #:mutable] ;; (Option Number)
-                [recursive-edit #:mutable] ;; (Option Buffer)
-                ) #:prefab)
-
-(define (make-editor #:tty [tty (stdin-tty)]
-                     #:default-modeset [default-modeset (make-modeset)])
-  (define g (make-buffergroup))
-  (define scratch (make-buffer g "*scratch*"
-                               #:initial-contents ";; This is the scratch buffer.\n\n"))
-  (define echo-area (make-buffer #f "*echo-area*"))
-  (define w (make-window scratch))
-  (define ws (list->circular-list (list (list w (relative-size 1)))))
-  (define miniwin (make-window echo-area))
-  (define e (editor g tty ws w #f default-modeset #f #f echo-area miniwin #f #f))
-  (initialize-buffergroup! g e)
-  (configure-fresh-buffer! e scratch)
-  (window-move-to! w (buffer-size scratch))
-  (set-window-status-line?! miniwin #f)
-  e)
-
-(define (configure-fresh-buffer! editor buffer)
-  (buffer-apply-modeset! buffer (editor-default-modeset editor))
-  buffer)
-
-(define (find-buffer editor [title0 #f] #:initial-contents [initial-contents ""])
-  (define g (editor-buffers editor))
-  (define title (or title0 (unused-buffer-title g '())))
-  (or (lookup-buffer g title)
-      (configure-fresh-buffer! editor (make-buffer g title #:initial-contents initial-contents))))
-
-(define (split-size s)
-  (match s
-    [(absolute-size _) (relative-size 1)] ;; can't scale fixed-size windows
-    [(relative-size w) (relative-size (/ w 2))]))
-
-(define (merge-sizes surviving disappearing)
-  (match* (surviving disappearing)
-    [((relative-size a) (relative-size b)) (relative-size (+ a b))]
-    [(_ _) surviving]))
-
-(define (windows-for-buffer editor buffer)
-  (map car (filter (lambda (e) (eq? (window-buffer (car e)) buffer))
-                   (circular-list->list (editor-windows editor)))))
-
-(define (window-for-buffer editor buffer)
-  (define ws (windows-for-buffer editor buffer))
-  (and (pair? ws) (car ws)))
-
-(define (entry-for? window) (lambda (e) (eq? (car e) window)))
-
-(define (invalidate-layout! editor)
-  (set-editor-layout! editor #f))
-
-(define (layout! editor)
-  (when (not (editor-layout editor))
-    (set-editor-layout! editor (layout-windows (circular-list->list (editor-windows editor))
-                                               (editor-mini-window editor)
-                                               (tty-columns (editor-tty editor))
-                                               (tty-rows (editor-tty editor)))))
-  (editor-layout editor))
-
-(define (window-layout editor win)
-  (cond [(memf (lambda (l) (eq? (layout-window l) win)) (layout! editor)) => car]
-        [else #f]))
-
-(define ((-layout-accessor- getter) editor window)
-  (cond [(window-layout editor window) => getter]
-        [else #f]))
-
-(define window-size-spec (-layout-accessor- layout-size-spec))
-(define window-width (-layout-accessor- layout-width))
-(define window-height (-layout-accessor- layout-height))
-
-(define (update-window-entry editor win updater)
-  (set-editor-windows! editor (circular-list-replacef (editor-windows editor)
-                                                      (entry-for? win)
-                                                      updater))
-  (invalidate-layout! editor))
-
-(define (open-window editor buffer
-                     #:after-window [after-window (editor-active-window editor)]
-                     #:proportional? [proportional? #f]
-                     #:activate? [activate? #t])
-  (define existing-w (window-for-buffer editor buffer))
-  (define existing-size (window-size-spec editor after-window))
-  (define new-size (if proportional? existing-size (split-size existing-size)))
-  (define new-point (or (and existing-w (buffer-mark-pos* buffer (window-point existing-w))) 0))
-  (define new-window (make-window buffer #:point new-point))
-  (update-window-entry editor after-window
-                       (lambda (e) (list (list after-window new-size)
-                                         (list new-window new-size))))
-  (when activate? (set-editor-active-window! editor new-window))
-  new-window)
-
-(define (close-other-windows editor win)
-  (for ((entry (circular-list->list (editor-windows editor))) #:when (not (eq? (car entry) win)))
-    (set-window-buffer! (car entry) #f))
-  (set-editor-windows! editor (list->circular-list (list (list win (relative-size 1)))))
-  (set-editor-active-window! editor win)
-  (invalidate-layout! editor))
-
-(define (close-window editor win)
-  (define prev (editor-prev-window editor win))
-  (define prev-size (window-size-spec editor prev))
-  (define win-size (window-size-spec editor win))
-  (when (and prev (> (circular-length (editor-windows editor)) 1))
-    (when (eq? (editor-active-window editor) win) (set-editor-active-window! editor prev))
-    (update-window-entry editor win (lambda (e) '()))
-    (resize-window editor prev (merge-sizes prev-size win-size))))
-
-(define (resize-window editor win size)
-  (update-window-entry editor win (lambda (e) (list (list win size)))))
-
-(define (select-window editor win)
-  (when (window-layout editor win)
-    (set-editor-active-window! editor win)))
-
-(define (visit-file! editor filename)
-  (set-window-buffer! (editor-active-window editor)
-                      (configure-fresh-buffer! editor
-                                               (load-buffer (editor-buffers editor)
-                                                            (local-file-buffer-source filename)))))
-
-(define (render-editor! editor)
-  (render-windows! (editor-tty editor)
-                   (layout! editor)
-                   (editor-active-window editor)))
-
-(define (editor-active-buffer editor)
-  (define w (editor-active-window editor))
-  (and w (window-buffer w)))
-
-(define (editor-active-modeset editor)
-  (let* ((b (editor-active-buffer editor))
-         (b (if (eq? b (editor-echo-area editor)) (editor-recursive-edit editor) b)))
-    (and b (buffer-modeset b))))
-
-(define (editor-next-window editor win)
-  (cond [(circular-list-memf (entry-for? win)
-                             (editor-windows editor)) => (compose car
-                                                                  circular-car
-                                                                  circular-list-rotate-forward)]
-        [else #f]))
-
-(define (editor-prev-window editor win)
-  (cond [(circular-list-memf (entry-for? win)
-                             (editor-windows editor)) => (compose car
-                                                                  circular-car
-                                                                  circular-list-rotate-backward)]
-        [else #f]))
-
-(define (editor-command selector editor
-                        #:keyseq [keyseq #f]
-                        #:prefix-arg [prefix-arg '#:default])
-  (window-command selector (editor-active-window editor)
-                  #:editor editor
-                  #:keyseq keyseq
-                  #:prefix-arg prefix-arg))
-
-(define (invoke/history cmd)
-  (define editor (command-editor cmd))
-  (with-handlers* ([exn:abort? (lambda (e)
-                                 (message editor "~a" (exn-message e)
-                                          #:duration (exn:abort-duration e))
-                                 (void))])
-    (define result (invoke cmd))
-    (set-editor-last-command! editor cmd)
-    result))
-
-(define (editor-last-command? editor . possible-selectors)
-  (and (editor-last-command editor)
-       (for/or ((selector (in-list possible-selectors)))
-         (eq? (command-selector (editor-last-command editor)) selector))))
-
-(define (root-keyseq-handler editor)
-  (modeset-keyseq-handler (editor-active-modeset editor)))
-
-(define *error-count* 0)
-(define (open-debugger editor exc)
-  (local-require (only-in web-server/private/util exn->string))
-  (define error-report (exn->string exc))
-  (log-error "Exception:\n~a\n" error-report)
-  (set! *error-count* (+ *error-count* 1))
-  (when (>= *error-count* 3) (exit))
-  (define b (find-buffer editor "*Error*"))
-  (buffer-replace-contents! b (string->rope error-report))
-  (open-window editor b))
-
-(define (editor-mainloop editor)
-  (when (editor-running? editor) (error 'editor-mainloop "Nested mainloop"))
-  (set-editor-running?! editor #t)
-  (with-handlers* ([exn? (lambda (exc)
-                           (set-editor-running?! editor #f)
-                           (open-debugger editor exc)
-                           (editor-mainloop editor))])
-    (let loop ((total-keyseq '())
-               (input '())
-               (handler (root-keyseq-handler editor))
-               (next-repaint-deadline 0))
-      (define (request-repaint) (or next-repaint-deadline (+ (current-inexact-milliseconds) 20)))
-      (define (wait-for-input next-handler)
-        (when (editor-running? editor)
-          (sync (if next-repaint-deadline
-                    (handle-evt (alarm-evt next-repaint-deadline)
-                                (lambda (_)
-                                  (loop total-keyseq '() next-handler next-repaint-deadline)))
-                    never-evt)
-                (let ((expiry-time (editor-message-expiry-time editor)))
-                  (if expiry-time
-                      (handle-evt (alarm-evt expiry-time)
-                                  (lambda (_)
-                                    (clear-message editor)
-                                    (loop total-keyseq '() next-handler 0)))
-                      never-evt))
-                (handle-evt (tty-next-key-evt (editor-tty editor))
-                            (lambda (new-key)
-                              (define new-input (list new-key))
-                              (clear-message editor)
-                              (loop (append total-keyseq new-input)
-                                    new-input
-                                    next-handler
-                                    next-repaint-deadline))))))
-      (cond
-       [(and next-repaint-deadline (>= (current-inexact-milliseconds) next-repaint-deadline))
-        (render-editor! editor)
-        (loop total-keyseq input handler #f)]
-       [(null? input)
-        (wait-for-input handler)]
-       [else
-        (match (handler editor input)
-          [(unbound-key-sequence)
-           (when (not (invoke/history (editor-command 'unbound-key-sequence editor
-                                                      #:keyseq total-keyseq)))
-             (message editor "Unbound key sequence: ~a" (keyseq->keyspec total-keyseq)))
-           (loop '() '() (root-keyseq-handler editor) (request-repaint))]
-          [(incomplete-key-sequence next-handler)
-           (message #:log? #f editor "~a-" (keyseq->keyspec total-keyseq))
-           (wait-for-input next-handler)]
-          [(command-invocation selector prefix-arg remaining-input)
-           (define accepted-input
-             (let remove-tail ((keyseq total-keyseq))
-               (if (equal? keyseq remaining-input)
-                   '()
-                   (cons (car keyseq) (remove-tail (cdr keyseq))))))
-           (invoke/history (editor-command selector editor
-                                           #:keyseq accepted-input
-                                           #:prefix-arg prefix-arg))
-           (loop '() remaining-input (root-keyseq-handler editor) (request-repaint))])]))))
-
-(define (editor-request-shutdown! editor)
-  (set-editor-running?! editor #f))
-
-(define (editor-force-redisplay! editor)
-  (tty-reset (editor-tty editor))
-  (invalidate-layout! editor))
-
-(define (clear-message editor)
-  (when (positive? (buffer-size (editor-echo-area editor)))
-    (buffer-replace-contents! (editor-echo-area editor) (empty-rope))
-    (define re (editor-recursive-edit editor))
-    (when (and re (not (eq? (window-buffer (editor-mini-window editor)) re)))
-      (set-window-buffer! (editor-mini-window editor) re (buffer-size re)))
-    (set-editor-message-expiry-time! editor #f)
-    (invalidate-layout! editor)))
-
-(define (message #:duration [duration0 #f]
-                 #:log? [log? #t]
-                 editor fmt . args)
-  (define duration (or duration0 (and (editor-recursive-edit editor) 2)))
-  (define msg (string->rope (apply format fmt args)))
-  (define echo-area (editor-echo-area editor))
-  (when log?
-    (let* ((msgbuf (find-buffer editor "*Messages*"))
-           (msgwins (filter (lambda (w) (equal? (buffer-mark-pos msgbuf (window-point w))
-                                                (buffer-size msgbuf)))
-                            (windows-for-buffer editor msgbuf))))
-      (buffer-insert! msgbuf (buffer-size msgbuf) (rope-append msg (string->rope "\n")))
-      (for ((w msgwins)) (buffer-mark! msgbuf (window-point w) (buffer-size msgbuf)))))
-  (buffer-replace-contents! echo-area msg)
-  (set-window-buffer! (editor-mini-window editor) echo-area (buffer-size echo-area))
-  (invalidate-layout! editor)
-  (when duration
-    (set-editor-message-expiry-time! editor (+ (current-inexact-milliseconds) (* duration 1000.0))))
-  (render-editor! editor))
-
-(define (start-recursive-edit editor buf)
-  (when (editor-recursive-edit editor)
-    (abort "Command attempted to use minibuffer while in minibuffer"))
-  (set-editor-recursive-edit! editor buf)
-  (define miniwin (editor-mini-window editor))
-  (set-window-buffer! miniwin buf (buffer-size buf))
-  (set-editor-windows! editor
-                       (circular-snoc (editor-windows editor)
-                                      (list miniwin (absolute-size 0))))
-  (set-editor-active-window! editor miniwin)
-  (invalidate-layout! editor))
-
-(define (abandon-recursive-edit editor)
-  (set-editor-recursive-edit! editor #f)
-  (define echo-area (editor-echo-area editor))
-  (define miniwin (editor-mini-window editor))
-  (set-window-buffer! miniwin echo-area (buffer-size echo-area))
-  (when (eq? (editor-active-window editor) miniwin)
-    (set-editor-active-window! editor (car (circular-car (editor-windows editor)))))
-  (update-window-entry editor miniwin (lambda (e) '()))
-  (invalidate-layout! editor))
-
-;;---------------------------------------------------------------------------
-
-(define-command kernel-mode (save-buffers-kill-terminal buf #:editor ed)
-  #:bind-key "C-x C-c"
-  (editor-request-shutdown! ed))
-
-(define-command kernel-mode (force-redisplay buf #:editor ed)
-  #:bind-key "C-l"
-  (editor-force-redisplay! ed))
-
-(define-command kernel-mode (keyboard-quit buf)
-  #:bind-key "C-g"
-  (abort "Quit"))
-
-(define-command kernel-mode (dump-buffer-to-stderr buf #:window win #:editor ed)
-  #:bind-key "C-M-x"
-  (local-require racket/pretty)
-  (log-info "")
-  (log-info "--------------------------------------------------------------------------------")
-  (log-info "--------------------------------------------------------------------------------")
-  (log-info "========================================================================= WINDOW")
-  (log-info "id ~v" (window-id win))
-  (log-info "top ~v ~v" (window-top win) (buffer-mark-pos* buf (window-top win)))
-  (log-info "point ~v ~v" (window-point win) (buffer-mark-pos* buf (window-point win)))
-  (log-info "mark ~v ~v" (window-mark win) (buffer-mark-pos* buf (window-mark win)))
-  (log-info "title ~v" (buffer-title buf))
-  (log-info "rope:")
-  (pretty-write (buffer-rope buf) (current-error-port))
-  (log-info "modeset:")
-  (pretty-write (buffer-modeset buf) (current-error-port))
-  (let ((t (editor-tty ed)))
-    (log-info "terminal width ~v height ~v cursor-row ~v -col ~v"
-              (tty-columns t) (tty-rows t) (tty-cursor-row t) (tty-cursor-column t)))
-  (log-info "editor layout:")
-  (cond [(editor-layout ed) =>
-         (lambda (layouts)
-           (for ((l layouts))
-             (match-define (layout w s tt ll ww hh) l)
-             (log-info " - ~a ~v top ~a left ~a width ~a height ~a"
-                       (window-id w) s tt ll ww hh)))]
-        [else (log-info " - not cached")])
-  (log-info "editor size-specs: ~v"
-            (for/list ((e (circular-list->list (editor-windows ed))))
-              (list (window-id (car e)) (cadr e))))
-  (log-info "--------------------------------------------------------------------------------"))

rmacs/file.rkt

@@ -1,37 +0,0 @@
-#lang racket/base
-
-(provide gen:buffer-source
-         buffer-source-title-pieces
-         buffer-source-mtime
-         buffer-source-read
-         buffer-source-write
-
-         (struct-out local-file-buffer-source)
-         local-file-buffer-source-path)
-
-(require racket/generic)
-(require (only-in racket/file file->string))
-(require (only-in racket/path normalize-path))
-
-(define-generics buffer-source
-  (buffer-source-title-pieces buffer-source)
-  (buffer-source-mtime buffer-source)
-  (buffer-source-read buffer-source)
-  (buffer-source-write buffer-source content))
-
-(struct local-file-buffer-source (filename)
-        #:transparent
-        #:methods gen:buffer-source
-        [(define (buffer-source-title-pieces src)
-           (reverse (map path->string (explode-path (local-file-buffer-source-path src)))))
-         (define (buffer-source-mtime src)
-           (file-or-directory-modify-seconds (local-file-buffer-source-path src)))
-         (define (buffer-source-read src)
-           (file->string (local-file-buffer-source-path src)))
-         (define (buffer-source-write src content)
-           (call-with-output-file (local-file-buffer-source-path src)
-             (lambda (p) (write-string content p))
-             #:exists 'replace))])
-
-(define (local-file-buffer-source-path src)
-  (normalize-path (simplify-path (local-file-buffer-source-filename src))))

rmacs/info.rkt

@@ -1,11 +0,0 @@
-#lang setup/infotab
-
-(define name "editor")
-(define blurb
-  (list
-   `(p "Emacs-like editor.")))
-(define homepage "https://github.com/tonyg/racket-ansi")
-(define primary-file "main.rkt")
-
-(define racket-launcher-names '("rmacs"))
-(define racket-launcher-libraries '("main.rkt"))

rmacs/keys.rkt

@@ -1,235 +0,0 @@
-#lang racket/base
-;; Keyspecs, keyseqs and keymaps
-
-(provide parse-key-sequence
-         keyspec->keyseq
-         key->keyspec
-         keyseq->keyspec
-         (struct-out keymap)
-         empty-keymap
-         keymap-update
-         keymap-bind
-         keymap-unbind
-         keymap-lookup
-
-         ;; From ansi/lcd-terminal
-         (struct-out key)
-         (struct-out unknown-escape-sequence)
-         add-modifier)
-
-(require racket/set)
-(require racket/match)
-(require (only-in racket/list append-map))
-(require (only-in racket/string
-                  string-join
-                  string-split
-                  string-trim))
-
-(require ansi/lcd-terminal)
-
-;;---------------------------------------------------------------------------
-;; Key sequence parsing
-
-(define (read-string-to-end s)
-  (define p (open-input-string s))
-  (define result (read p))
-  (and (eof-object? (peek-char p))
-       result))
-
-(define (bad-key lexeme fmt . args)
-  (error 'parse-key-sequence "~a in key ~v" (apply format fmt args) (string-trim lexeme)))
-
-(define (parse-modifiers modifiers lexeme)
-  (for/set ((mod (string-split (string-upcase modifiers) "-")))
-    (match mod
-      ["C" 'control]
-      ["S" 'shift]
-      ["M" 'meta]
-      [_ (bad-key lexeme "Unknown modifier ~a" mod)])))
-
-(define (parse-key-sequence s)
-  (match s
-    [(pregexp "^ *#:default(( +.*)|$)" (list lexeme rest _))
-     (cons '#:default (parse-key-sequence rest))]
-    [(pregexp "^ *(([cCsSmM]-)*)\"([^\"]*)\"(.*)" (list lexeme modifiers _ stringspec rest))
-     (define mods (parse-modifiers modifiers lexeme))
-     (define seq (unknown-escape-sequence (or (read-string-to-end (format "#\"~a\"" stringspec))
-                                              (bad-key lexeme "Bad raw input sequence"))))
-     (cons (key seq mods) (parse-key-sequence rest))]
-    [(pregexp "^ *(([cCsSmM]-)*)<([^>]+)>(( +.*)|$)" (list lexeme modifiers _ symname rest _))
-     (define mods (parse-modifiers modifiers lexeme))
-     (cons (key (string->symbol symname) mods)
-           (parse-key-sequence rest))]
-    [(pregexp "^ *(([cCsSmM]-)*)(?i:esc)(( +.*)|$)" (list lexeme modifiers _ rest _))
-     (define mods (parse-modifiers modifiers lexeme))
-     (cons (key #\[ (set-add mods 'control)) (parse-key-sequence rest))]
-    [(pregexp "^ *(([cCsSmM]-)*)([^ ]+)(( +.*)|$)" (list lexeme modifiers _ keystr rest _))
-     (define mods (parse-modifiers modifiers lexeme))
-     (define keychar (or (read-string-to-end (format "#\\~a" keystr))
-                         (bad-key lexeme "Bad single-character key")))
-     (cons (key (if (set-member? mods 'control)
-                    (char-upcase keychar)
-                    keychar)
-                mods)
-           (parse-key-sequence rest))]
-    [(pregexp "^ *$")
-     '()]
-    [_ (bad-key s "Unexpected junk")]))
-
-(define (keyspec->keyseq what original-keyspec)
-  (let convert ((keyspec original-keyspec))
-    (cond
-     [(key? keyspec) (list keyspec)]
-     [(keyword? keyspec) (list keyspec)]
-     [(string? keyspec) (parse-key-sequence keyspec)]
-     [(list? keyspec) (append-map convert keyspec)]
-     [else (error what "Invalid key specification: ~v" original-keyspec)])))
-
-(define (format-modifiers mods suffix)
-  (if (set-empty? mods)
-      suffix
-      (string-append (string-join (map (lambda (m)
-                                         (match m
-                                           ['control "C"]
-                                           ['shift "S"]
-                                           ['meta "M"]))
-                                       (set->list mods))
-                                  "-")
-                     "-"
-                     suffix)))
-
-(define (key->keyspec k)
-  (match k
-    [(? keyword?) (format "~a" k)]
-    [(key value modifiers)
-     (define-values (str updated-modifiers)
-       (match value
-         [(unknown-escape-sequence bs)
-          (define s (format "~v" bs))
-          (values (substring s 1 (string-length s)) modifiers)]
-         [(? symbol? s)
-          (values (format "<~a>" s) modifiers)]
-         [#\[ #:when (set-member? modifiers 'control)
-          (values "ESC" (set-remove modifiers 'control))]
-         [(? char? c)
-          (define s (format "~v" c))
-          (define maybe-downcase (if (set-member? modifiers 'control) string-downcase values))
-          (values (maybe-downcase (substring s 2 (string-length s))) modifiers)]))
-     (format-modifiers updated-modifiers str)]))
-
-(define (keyseq->keyspec keyseq)
-  (and keyseq (string-join (map key->keyspec keyseq) " ")))
-
-;;---------------------------------------------------------------------------
-;; Keymaps
-
-(struct keymap (table
-                ) #:prefab)
-
-(define (empty-keymap)
-  (keymap (hash)))
-
-(define (keymap-update km keyspec updater)
-  (define original-keyseq (keyspec->keyseq 'keymap-bind keyspec))
-  (let loop ((prefix-rev '())
-             (keyseq original-keyseq)
-             (km km))
-    (match keyseq
-      ['() (updater (reverse prefix-rev) km original-keyseq)]
-      [(cons k rest)
-       (cond
-        [(keymap? km)
-         (let* ((new (loop (cons k prefix-rev) rest (hash-ref (keymap-table km) k #f)))
-                (newtab (if new
-                            (hash-set (keymap-table km) k new)
-                            (hash-remove (keymap-table km) k))))
-           (if (hash-empty? newtab)
-               #f
-               (struct-copy keymap km [table newtab])))]
-        [(not km)
-         (loop prefix-rev keyseq (empty-keymap))]
-        [else
-         (error 'keymap-update
-                "Cannot update keyspec ~v, as a shorter prefix ~v exists"
-                (keyseq->keyspec original-keyseq)
-                (keyseq->keyspec (reverse prefix-rev)))])])))
-
-(define (keymap-bind km keyspec command)
-  (keymap-update km keyspec (lambda (prefix oldval newseq)
-                              (if oldval
-                                  (error 'keymap-bind "Cannot bind ~v, as prefix ~v exists"
-                                         (keyseq->keyspec newseq)
-                                         (keyseq->keyspec prefix))
-                                  command))))
-
-(define (keymap-bind* km specs-and-commands)
-  (match specs-and-commands
-    ['() km]
-    [(cons (list keyspec command) rest) (keymap-bind* (keymap-bind km keyspec command) rest)]))
-
-(define (keymap-unbind km keyspec)
-  (or (keymap-update km keyspec (lambda (prefix oldval newseq) #f))
-      (empty-keymap)))
-
-(define (keymap-lookup km keyspec)
-  (define original-keyseq (keyspec->keyseq 'keymap-lookup keyspec))
-  (let loop ((keyseq original-keyseq)
-             (km km))
-    (match keyseq
-      ['() (values km keyseq)]
-      [(cons k rest)
-       (match km
-         [(keymap table) (loop rest (or (hash-ref table k #f)
-                                        (hash-ref table '#:default #f)))]
-         [_ (values km keyseq)])])))
-
-;;---------------------------------------------------------------------------
-
-(module+ test
-  (require rackunit racket/pretty)
-
-  (check-equal? (parse-key-sequence "<") (list (key #\< (set))))
-  (check-equal? (parse-key-sequence ">") (list (key #\> (set))))
-  (check-equal? (parse-key-sequence "#:default #:default")
-                (list '#:default '#:default))
-  (check-equal? (parse-key-sequence "esc ESC")
-                (list (key #\[ (set 'control))
-                      (key #\[ (set 'control))))
-
-  (define km (keymap-bind* (empty-keymap) (list (list "C-x o" 'other-window)
-                                                (list "C-x 2" 'split-window)
-                                                (list "C-x 1" 'delete-other-windows)
-                                                (list "C-x 0" 'delete-window))))
-  (check-equal? km
-                (keymap (hash (key #\X (set 'control))
-                              (keymap (hash (key #\o (set)) 'other-window
-                                            (key #\2 (set)) 'split-window
-                                            (key #\1 (set)) 'delete-other-windows
-                                            (key #\0 (set)) 'delete-window)))))
-  (set! km (keymap-unbind km "C-x 1"))
-  (check-equal? km
-                (keymap (hash (key #\X (set 'control))
-                              (keymap (hash (key #\o (set)) 'other-window
-                                            (key #\2 (set)) 'split-window
-                                            (key #\0 (set)) 'delete-window)))))
-  (check-equal? (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0")
-                (keymap (hash (key #\X (set 'control))
-                              (keymap (hash (key #\o (set)) 'other-window)))))
-  (check-equal? (keymap-unbind (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0") "C-x o")
-                (empty-keymap))
-  (check-equal? (keymap-unbind km "C-x")
-                (empty-keymap))
-
-  (define (lookup s)
-    (define-values (result remaining-input) (keymap-lookup km s))
-    (list result remaining-input))
-
-  (check-equal? (lookup "C-x") (list (keymap (hash (key #\o (set)) 'other-window
-                                                   (key #\2 (set)) 'split-window
-                                                   (key #\0 (set)) 'delete-window))
-                                     '()))
-  (check-equal? (lookup "C-x 1") (list #f '()))
-  (check-equal? (lookup "C-x 2") (list 'split-window '()))
-  (check-equal? (lookup "C-c") (list #f '()))
-  (check-equal? (lookup "C-c C-c") (list #f (list (key #\C (set 'control)))))
-  )

rmacs/lists.rkt

@@ -1,20 +0,0 @@
-#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)))

rmacs/main.rkt

@@ -1,36 +0,0 @@
-#lang racket/base
-
-(provide rmacs)
-
-(require racket/match)
-
-(require "editor.rkt")
-(require "buffer.rkt")
-(require "mode.rkt")
-(require "mode/fundamental.rkt")
-
-(define (rmacs #:initial-files [initial-files '()])
-  (define e (make-editor #:default-modeset (modeset-add-mode kernel-modeset
-                                                             fundamental-mode)))
-  (for ((file initial-files)) (visit-file! e file))
-  (editor-mainloop e))
-
-(module+ main
-  (require racket/trace)
-  (current-trace-notify (lambda (s) (log-info "TRACE: ~a" s)))
-  (void
-   (rmacs #:initial-files (match (current-command-line-arguments)
-                            ['#()
-                             (list
-                              (build-path (collection-file-path "main.rkt" "rmacs")
-                                          'up 'up "doc" "xterm_controls.txt"))]
-                            [(vector files ...)
-                             files])))
-  ;; (require profile)
-  ;; (require ansi)
-  ;; (void (profile-thunk (lambda () (begin0 (main)
-  ;;                                   (tty-restore!)
-  ;;                                   (display (select-graphic-rendition style-normal))
-  ;;                                   (display (clear-screen))
-  ;;                                   (flush-output)))))
-  )

rmacs/minibuf.rkt

@@ -1,151 +0,0 @@
-#lang racket/base
-
-(provide read-from-minibuffer
-         recursive-edit-field-start
-         recursive-edit-mode
-         recursive-edit-accept-hook
-         recursive-edit-cancel-hook
-         completing-read
-         simple-completion
-         completing-read-mode
-         completing-read-string=?-hook
-         completing-read-completion-hook
-         completing-read-acceptable-hook)
-
-(require "buffer.rkt")
-(require "editor.rkt")
-(require "mode.rkt")
-(require "keys.rkt")
-(require "rope.rkt")
-(require "window.rkt")
-(require "strings.rkt")
-
-;;---------------------------------------------------------------------------
-
-(define (read-from-minibuffer editor
-                              prompt
-                              #:initial [initial ""]
-                              #:on-accept k-accept
-                              #:on-cancel [k-cancel void])
-  (define buf (make-buffer #f "*minibuf*"))
-  (configure-fresh-buffer! editor buf)
-  (buffer-add-mode! buf recursive-edit-mode)
-  (buffer-replace-contents! buf (string->rope prompt))
-  (buffer-mark! buf recursive-edit-field-start (buffer-size buf))
-  (buffer-insert! buf (buffer-size buf) (string->rope initial))
-  (recursive-edit-selected-window buf (editor-active-window editor))
-  (recursive-edit-accept-hook buf k-accept)
-  (recursive-edit-cancel-hook buf k-cancel)
-  (start-recursive-edit editor buf)
-  buf)
-
-(define recursive-edit-field-start (mark-type (buffer-mark-type 'recursive-edit-field-start
-                                                                '*minibuf*
-                                                                #t)
-                                              'left))
-
-(define recursive-edit-mode (make-mode "recursive-edit"))
-
-(define-buffer-local recursive-edit-selected-window)
-(define-buffer-local recursive-edit-accept-hook (lambda (content) (void)))
-(define-buffer-local recursive-edit-cancel-hook (lambda () (void)))
-
-(define-command recursive-edit-mode (abort-recursive-edit buf #:editor ed)
-  #:bind-key "C-g"
-  (abandon-recursive-edit ed)
-  (select-window ed (recursive-edit-selected-window buf))
-  ((recursive-edit-cancel-hook buf)))
-
-(define (recursive-edit-contents buf)
-  (rope->string (buffer-region buf recursive-edit-field-start (buffer-size buf))))
-
-(define-command recursive-edit-mode (exit-minibuffer buf #:editor ed)
-  #:bind-key "C-m"
-  #:bind-key "C-j"
-  (abandon-recursive-edit ed)
-  (select-window ed (recursive-edit-selected-window buf))
-  ((recursive-edit-accept-hook buf) (recursive-edit-contents buf)))
-
-(define-command recursive-edit-mode (minibuf-beginning-of-line buf #:window win)
-  #:bind-key "C-a"
-  #:bind-key "<home>"
-  (define limit (buffer-mark-pos* buf recursive-edit-field-start))
-  (if (and limit (> (buffer-mark-pos buf (window-point win)) limit))
-      (window-move-to! win limit)
-      (buffer-move-mark-to-start-of-line! buf (window-point win))))
-
-;;---------------------------------------------------------------------------
-
-(define (completing-read editor
-                         prompt
-                         completion-fn
-                         #:string=? [string=? string=?]
-                         #:initial [initial ""]
-                         #:acceptable? [acceptable? (lambda (v) #t)]
-                         #:on-accept k-accept
-                         #:on-cancel [k-cancel void])
-  (define buf (read-from-minibuffer editor prompt
-                                    #:initial initial
-                                    #:on-accept k-accept
-                                    #:on-cancel k-cancel))
-  (buffer-add-mode! buf completing-read-mode)
-  (completing-read-string=?-hook buf string=?)
-  (completing-read-completion-hook buf completion-fn)
-  (completing-read-acceptable-hook buf acceptable?)
-  buf)
-
-(define (simple-completion collection)
-  (define collection-strings (for/list ((c collection)) (format "~a" c)))
-  (lambda (prefix string=?)
-    (for/list ((c collection-strings) #:when (string-prefix? prefix c string=?)) c)))
-
-(define completing-read-mode (make-mode "completing"))
-
-(define-buffer-local completing-read-string=?-hook
-  string=?)
-(define-buffer-local completing-read-completion-hook
-  (lambda (v) (abort "completing-read-completion-hook not set")))
-(define-buffer-local completing-read-acceptable-hook
-  (lambda (v) #t))
-
-(define (common-string-prefix strs string=?)
-  (if (null? (cdr strs))
-      (car strs)
-      (let ((len (let loop ((i 1))
-                   (if (for/and ((c (cdr strs)))
-                         (and (>= (string-length c) i)
-                              (string=? (substring (car strs) 0 i) (substring c 0 i))))
-                       (loop (+ i 1))
-                       (- i 1)))))
-        (substring (car strs) 0 len))))
-
-(define-command completing-read-mode (minibuffer-complete buf #:editor ed)
-  #:bind-key "C-i"
-  #:bind-key "tab"
-  (define string=? (completing-read-string=?-hook buf))
-  (define prefix (recursive-edit-contents buf))
-  (define unfiltered-completions ((completing-read-completion-hook buf) prefix string=?))
-  (define completions (filter (lambda (s) (string-prefix? prefix s string=?))
-                              unfiltered-completions))
-  (if (pair? completions)
-      (let ((common-prefix (common-string-prefix completions string=?))
-            (complete? (null? (cdr completions))))
-        (if (string=? common-prefix prefix)
-            ;; No progress.
-            (if complete?
-                (message ed "Sole completion")
-                (message ed "Completions: ~a" completions))
-            ;; Some progress
-            (buffer-region-update! buf
-                                   recursive-edit-field-start
-                                   (buffer-size buf)
-                                   (lambda (_old)
-                                     (string->rope common-prefix)))))
-      (message ed "No match")))
-
-(define-command completing-read-mode (exit-minibuffer buf
-                                                      #:next-method next-method
-                                                      #:command cmd
-                                                      #:editor ed)
-  (when ((completing-read-acceptable-hook buf) (recursive-edit-contents buf))
-    (next-method cmd)))

rmacs/mode.rkt

@@ -1,215 +0,0 @@
-#lang racket/base
-;; Modes and modesets.
-
-(provide (struct-out mode)
-         (struct-out modeset)
-         (struct-out incomplete-key-sequence)
-         (struct-out unbound-key-sequence)
-         (struct-out command-invocation)
-
-         make-raw-mode
-         make-mode
-         mode-add-constraints
-         mode-keymap-bind!
-         mode-keymap-unbind!
-         mode-keymap-rebind!
-         mode-define-command!
-         mode-undefine-command!
-         mode-redefine-command!
-         mode-command-selectors
-
-         make-modeset
-         modeset-add-mode
-         modeset-remove-mode
-         modeset-toggle-mode
-         modeset-keyseq-handler
-         modeset-lookup-command
-         modeset-command-selectors
-
-         kernel-mode
-         kernel-modeset)
-
-(require racket/set)
-(require racket/match)
-(require (only-in racket/list filter-map))
-
-(require "keys.rkt")
-(require "topsort.rkt")
-
-(struct mode (id
-              name
-              [keymap #:mutable]
-              [commands #:mutable]
-              dispatch-keys-before
-              dispatch-keys-after
-              interpret-commands-before
-              interpret-commands-after
-              ) #:prefab)
-
-(struct modeset (modes
-                 key-dispatch-order
-                 command-interpretation-order
-                 ) #:prefab)
-
-(struct incomplete-key-sequence (handler) #:prefab)
-(struct unbound-key-sequence () #:prefab)
-(struct command-invocation (selector prefix-arg remaining-input) #:prefab)
-
-(define (make-raw-mode name)
-  (mode (gensym name)
-        name
-        (empty-keymap)
-        (hasheq)
-        (seteq)
-        (seteq)
-        (seteq)
-        (seteq)))
-
-(define (mode-add-constraints m
-                              #:dispatch-keys-before [kb '()]
-                              #:dispatch-keys-after [ka '()]
-                              #:interpret-commands-before [cb '()]
-                              #:interpret-commands-after [ca '()])
-  (define (convert modes) (list->seteq (for/list ((m modes))
-                                         (if (keyword? m)
-                                             m
-                                             (mode-id m)))))
-  (struct-copy mode m
-               [dispatch-keys-before
-                (set-union (mode-dispatch-keys-before m) (convert kb))]
-               [dispatch-keys-after
-                (set-union (mode-dispatch-keys-after m) (convert ka))]
-               [interpret-commands-before
-                (set-union (mode-interpret-commands-before m) (convert cb))]
-               [interpret-commands-after
-                (set-union (mode-interpret-commands-after m) (convert ca))]))
-
-(define (make-mode name)
-  (mode-add-constraints (make-raw-mode name)
-                        #:dispatch-keys-before '(#:kernel)
-                        #:interpret-commands-before '(#:kernel)))
-
-(define (mode-keymap-bind! m keyspec command)
-  (set-mode-keymap! m (keymap-bind (mode-keymap m) keyspec command))
-  m)
-
-(define (mode-keymap-unbind! m keyspec)
-  (set-mode-keymap! m (keymap-unbind (mode-keymap m) keyspec))
-  m)
-
-(define (mode-keymap-rebind! m keyspec command)
-  (mode-keymap-bind! (mode-keymap-unbind! m keyspec) keyspec command))
-
-(define (mode-define-command! m selector handler)
-  (when (hash-has-key? (mode-commands m) selector)
-    (error 'mode-define-command!
-           "Duplicate command handler for ~a in mode ~a"
-           selector
-           (mode-id m)))
-  (set-mode-commands! m (hash-set (mode-commands m) selector handler))
-  m)
-
-(define (mode-undefine-command! m selector)
-  (set-mode-commands! m (hash-remove (mode-commands m) selector))
-  m)
-
-(define (mode-redefine-command! m selector handler)
-  (mode-define-command! (mode-undefine-command! m selector) selector handler))
-
-(define (mode-command-selectors m)
-  (list->seteq (hash-keys (mode-commands m))))
-
-(define (make-modeset)
-  (modeset (hasheq)
-           '()
-           '()))
-
-(define (modeset-add-mode ms m)
-  (compute-modeset-orders
-   (struct-copy modeset ms [modes (hash-set (modeset-modes ms)
-                                            (mode-id m)
-                                            m)])))
-
-(define (modeset-remove-mode ms m)
-  (compute-modeset-orders
-   (struct-copy modeset ms [modes (hash-remove (modeset-modes ms) (mode-id m))])))
-
-(define (modeset-toggle-mode ms m)
-  ((if (hash-has-key? (modeset-modes ms) (mode-id m)) modeset-remove-mode modeset-add-mode)
-   ms
-   m))
-
-(define (edges ms before-getter after-getter)
-  (for/fold [(es '())]
-            [(m (in-hash-values (modeset-modes ms)))]
-    (define mid (mode-id m))
-    (append (for/list [(nid (before-getter m))] (list mid nid))
-            (for/list [(nid (after-getter m))] (list nid mid))
-            es)))
-
-(define (compute-modeset-order ms what before-getter after-getter)
-  (or (topsort (edges ms before-getter after-getter) #:comparison eq?)
-      (error 'compute-modeset-orders "Inconsistent ~a order: ~v"
-             (hash-keys (modeset-modes ms)))))
-
-(define (compute-modeset-orders ms)
-  (struct-copy modeset ms
-   [key-dispatch-order (compute-modeset-order ms
-                                              "key dispatch"
-                                              mode-dispatch-keys-before
-                                              mode-dispatch-keys-after)]
-   [command-interpretation-order (compute-modeset-order ms
-                                                        "command interpretation"
-                                                        mode-interpret-commands-before
-                                                        mode-interpret-commands-after)]))
-
-(define (order->modes ms order-getter)
-  (define modes (modeset-modes ms))
-  (filter-map (lambda (id) (hash-ref modes id #f)) (order-getter ms)))
-
-(define (modeset-keyseq-handler ms)
-  (let handler-for-maps ((maps (map mode-keymap (order->modes ms modeset-key-dispatch-order))))
-    (lambda (e ks)
-      (define results (map (lambda (km)
-                             (define-values (result remaining-input) (keymap-lookup km ks))
-                             (list result remaining-input)) maps))
-      (let process-results ((results results))
-        (match results
-          ['() (unbound-key-sequence)]
-          [(cons (list result remaining-input) rest)
-           (cond
-            [(not result) (process-results rest)]
-            [(keymap? result) (incomplete-key-sequence
-                               (handler-for-maps (filter keymap? (map car results))))]
-            [(procedure? result)
-             (if (null? remaining-input)
-                 (incomplete-key-sequence result)
-                 (result e remaining-input))]
-            [else (command-invocation result '#:default remaining-input)])])))))
-
-(define (modeset-lookup-command ms selector)
-  (let search ((tables (map mode-commands
-                            (order->modes ms modeset-command-interpretation-order))))
-    (match tables
-      ['() #f]
-      [(cons table rest)
-       (define handler (hash-ref table selector #f))
-       (if handler
-           (lambda (cmd)
-             (handler cmd
-                      (lambda ([cmd cmd])
-                        (define next-method (search rest))
-                        (when next-method (next-method cmd)))))
-           (search rest))])))
-
-(define (modeset-command-selectors ms)
-  (for/fold [(selectors (seteq))] [(m (hash-values (modeset-modes ms)))]
-    (set-union selectors (mode-command-selectors m))))
-
-(define kernel-mode
-  (mode-add-constraints (make-raw-mode "kernel")
-                        #:dispatch-keys-after '(#:kernel)
-                        #:interpret-commands-after '(#:kernel)))
-
-(define kernel-modeset
-  (modeset-add-mode (make-modeset) kernel-mode))

rmacs/mode/fundamental.rkt

@@ -1,190 +0,0 @@
-#lang racket/base
-
-(provide fundamental-mode)
-
-(require racket/set)
-(require racket/match)
-(require racket/string)
-(require "../api.rkt")
-
-(define fundamental-mode (make-mode "fundamental"))
-
-(define-command fundamental-mode (self-insert-command buf #:window win #:keyseq keyseq)
-  (match keyseq
-    [(list (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift))
-     (buffer-insert! buf (window-point win) (string->rope (string ch)))]
-    [_ #f]))
-
-(define-command fundamental-mode (unbound-key-sequence buf #:command cmd #:keyseq keyseq)
-  (invoke (copy-command cmd #:selector 'self-insert-command)))
-
-(define-command fundamental-mode (quoted-insert buf #:window win #:keyseq keyseq)
-  #:bind-key "C-q #:default"
-  (match keyseq
-    [(list _ (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift))
-     (buffer-insert! buf (window-point win) (string->rope (string ch)))]
-    [(list _ (key (? char? ch0) modifiers)) #:when (equal? modifiers (set 'control))
-     (define ch (integer->char (- (char->integer (char-upcase ch0)) (char->integer #\A) -1)))
-     (buffer-insert! buf (window-point win) (string->rope (string ch)))]
-    [_ #f]))
-
-(define-command fundamental-mode (newline buf #:window win)
-  #:bind-key "C-m"
-  #:bind-key "C-j"
-  (buffer-insert! buf (window-point win) (string->rope "\n")))
-
-(define (move-forward-n-lines win count)
-  (define buf (window-buffer win))
-  (for ((i count))
-    (buffer-move-mark-to-end-of-line! buf (window-point win))
-    (buffer-move-mark! buf (window-point win) 1)))
-
-(define (move-backward-n-lines win count)
-  (define buf (window-buffer win))
-  (for ((i count))
-    (buffer-move-mark-to-start-of-line! buf (window-point win))
-    (buffer-move-mark! buf (window-point win) -1)))
-
-(define (move-to-column win col)
-  (define buf (window-buffer win))
-  (define sol (buffer-start-of-line buf (window-point win)))
-  (buffer-mark! buf (window-point win) (buffer-closest-pos-for-column buf sol 0 col)))
-
-(define-command fundamental-mode (forward-char buf #:window win #:prefix-arg [count 1])
-  #:bind-key "C-f"
-  #:bind-key "<right>"
-  (buffer-move-mark! buf (window-point win) count))
-
-(define-command fundamental-mode (backward-char buf #:window win #:prefix-arg [count 1])
-  #:bind-key "C-b"
-  #:bind-key "<left>"
-  (buffer-move-mark! buf (window-point win) (- count)))
-
-(define-buffer-local last-vertical-movement-preferred-column)
-
-(define (vertical-movement-preferred-column editor win)
-  (define buf (window-buffer win))
-  (last-vertical-movement-preferred-column
-   buf
-   (or (and (editor-last-command? editor
-                                  'next-line
-                                  'prev-line)
-            (last-vertical-movement-preferred-column buf))
-       (buffer-column buf (window-point win)))))
-
-(define-command fundamental-mode (next-line buf #:window win #:editor ed #:prefix-arg [count 1])
-  #:bind-key "C-n"
-  #:bind-key "<down>"
-  (define col (vertical-movement-preferred-column ed win))
-  (move-forward-n-lines win count)
-  (move-to-column win col))
-
-(define-command fundamental-mode (prev-line buf #:window win #:editor ed #:prefix-arg [count 1])
-  #:bind-key "C-p"
-  #:bind-key "<up>"
-  (define col (vertical-movement-preferred-column ed win))
-  (move-backward-n-lines win count)
-  (move-to-column win col))
-
-(define-command fundamental-mode (move-end-of-line buf #:window win #:prefix-arg [count 1])
-  #:bind-key "C-e"
-  #:bind-key "<end>"
-  (when (positive? count) (move-forward-n-lines win (- count 1)))
-  (buffer-move-mark-to-end-of-line! buf (window-point win)))
-
-(define-command fundamental-mode (move-beginning-of-line buf #:window win #:prefix-arg [count 1])
-  #:bind-key "C-a"
-  #:bind-key "<home>"
-  (when (positive? count) (move-forward-n-lines win (- count 1)))
-  (buffer-move-mark-to-start-of-line! buf (window-point win)))
-
-(define-command fundamental-mode (delete-backward-char buf #:window win #:prefix-arg [count 1])
-  #:bind-key "<backspace>"
-  #:bind-key "C-h" ;; differs from GNU emacs
-  (define pos (buffer-mark-pos buf (window-point win)))
-  (buffer-region-update! buf (- pos 1) pos (lambda (_deleted) (empty-rope))))
-
-(define-command fundamental-mode (delete-forward-char buf #:window win #:prefix-arg [count 1])
-  #:bind-key "<delete>"
-  #:bind-key "C-d"
-  (define pos (buffer-mark-pos buf (window-point win)))
-  (buffer-region-update! buf pos (+ pos 1) (lambda (_deleted) (empty-rope))))
-
-(define (set-window-mark! win [pos (window-point win)])
-  (window-mark! win pos)
-  (message (window-editor win) "Mark set")
-  pos)
-
-(define-command fundamental-mode (beginning-of-buffer buf #:window win #:prefix-arg [tenths 0])
-  #:bind-key "M-<"
-  #:bind-key "C-<home>"
-  #:bind-key "<begin>"
-  (if (eq? tenths '#:prefix) (set! tenths 0) (set-window-mark! win))
-  (window-move-to! win (* (buffer-size buf) (max 0 (min 10 tenths)) 1/10)))
-
-(define-command fundamental-mode (end-of-buffer buf #:window win #:prefix-arg [tenths 0])
-  #:bind-key "M->"
-  #:bind-key "C-<end>"
-  (if (eq? tenths '#:prefix) (set! tenths 0) (set-window-mark! win))
-  (window-move-to! win (* (buffer-size buf) (- 10 (max 0 (min 10 tenths))) 1/10)))
-
-(define-command fundamental-mode (exchange-point-and-mark buf #:window win)
-  #:bind-key "C-x C-x"
-  (define m (buffer-mark-pos* buf (window-mark win)))
-  (when m
-    (window-mark! win)
-    (window-move-to! win m)))
-
-(define-command fundamental-mode (set-mark-command buf #:window win #:prefix-arg arg)
-  #:bind-key "C-@"
-  #:bind-key "C-space"
-  (if (eq? arg '#:prefix)
-      (let ((m (buffer-mark-pos* buf (window-mark win))))
-        (and m (window-move-to! win m)))
-      (set-window-mark! win)))
-
-(define-command fundamental-mode (split-window-below buf #:window win #:editor ed)
-  #:bind-key "C-x 2"
-  (open-window ed buf #:after-window win #:activate? #f))
-
-(define-command fundamental-mode (delete-other-windows buf #:window win #:editor ed)
-  #:bind-key "C-x 1"
-  (close-other-windows ed win))
-
-(define-command fundamental-mode (delete-window buf #:window win #:editor ed)
-  #:bind-key "C-x 0"
-  (close-window ed win))
-
-(define-command fundamental-mode (other-window buf #:window win #:editor ed)
-  #:bind-key "C-tab"
-  #:bind-key "C-x o"
-  (select-window ed (editor-next-window ed win)))
-
-(define-command fundamental-mode (save-buffer buf)
-  #:bind-key "C-x C-s"
-  (save-buffer! buf))
-
-(define-command fundamental-mode (execute-extended-command buf #:command cmd #:editor ed)
-  #:bind-key "M-x"
-  (completing-read ed "M-x "
-                   (simple-completion (modeset-command-selectors (buffer-modeset buf)))
-                   #:on-accept (lambda (content)
-                                 (define selector (string->symbol content))
-                                 (invoke (copy-command cmd
-                                                       #:selector (string->symbol content)
-                                                       #:keyseq #f)))))
-
-(define-command fundamental-mode (switch-to-buffer buf #:window win #:editor ed)
-  #:bind-key "C-x b"
-  (define default-target (buffer-next buf))
-  (completing-read ed
-                   (format "Switch to buffer~a: "
-                           (if default-target
-                               (format " (default ~a)" (buffer-title default-target))
-                               ""))
-                   (simple-completion (buffergroup-buffer-titles (editor-buffers ed)))
-                   #:on-accept (lambda (title0)
-                                 (define title1 (string-trim title0))
-                                 (define title (if (equal? title1 "") #f title1))
-                                 (define target (if title (find-buffer ed title) default-target))
-                                 (set-window-buffer! win target))))

rmacs/render.rkt

@@ -1,186 +0,0 @@
-#lang racket/base
-
-(provide (struct-out absolute-size)
-         (struct-out relative-size)
-         (struct-out layout)
-         layout-windows
-         render-windows!)
-
-(require racket/match)
-
-(require "buffer.rkt")
-(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
-;; -- (relative-size PositiveReal), a weighted window size
-(struct absolute-size (lines) #:prefab)
-(struct relative-size (weight) #:prefab)
-
-;; 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)
-
-(define (newline? c) (equal? c #\newline))
-
-;; 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.
-;;
-;; 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 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))))
-  (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
-       [(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))
-
-(define (tty-statusline-style t is-active?)
-  (tty-set-pen! t (pen color-black color-white #f #f)))
-
-(define (render-window! t win window-top window-width window-height is-active?)
-  (define buf (window-buffer win))
-  (define available-line-count (if (window-status-line? win) (- window-height 1) window-height))
-  (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 (render-span sol-pos eol-pos line-count cursor-coordinates)
-    (define line (rope->string (buffer-region buf sol-pos eol-pos)))
-    (tty-display t line)
-    (tty-newline t)
-    (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))
-
-  (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))
-
-  (when (window-status-line? win)
-    (tty-statusline-style t is-active?)
-    (let* ((prefix (format "-:~a- ~a " (if (buffer-dirty? buf) "**" "--") (buffer-title buf)))
-           (remaining-length (- (tty-columns t) (string-length prefix))))
-      (tty-display t prefix)
-      (when (positive? remaining-length) (tty-display t (make-string remaining-length #\-)))))
-
-  cursor-coordinates)
-
-(define (layout-windows ws miniwin total-width total-height [minimum-height 4])
-  (define miniwin-spans
-    (frame! miniwin (min 4 total-height) total-width #:preferred-position-fraction 1))
-  (define miniwin-height (length miniwin-spans))
-  (define total-weight (foldl + 0 (map (lambda (e)
-                                         (match (cadr e)
-                                           [(absolute-size _) 0]
-                                           [(relative-size w) w])) ws)))
-  (define reserved-lines (foldl + miniwin-height (map (lambda (e)
-                                                        (match (cadr e)
-                                                          [(absolute-size lines) lines]
-                                                          [(relative-size _) 0])) ws)))
-  (define proportional-lines (- total-height reserved-lines))
-  (define ws-without-miniwin ;; miniwin is in ws when minibuffer active; otherwise, not
-    (filter (lambda (e) (not (eq? (car e) miniwin))) ws))
-  (append (let loop ((ws ws-without-miniwin) (offset 0) (remaining proportional-lines))
-            (match ws
-              ['() '()]
-              [(cons (list (== miniwin eq?) _) rest)
-               (loop rest offset remaining)]
-              [(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)
-               (define height (max minimum-height
-                                   (inexact->exact
-                                    (round (* proportional-lines (/ weight total-weight))))))
-               (if (>= remaining height)
-                   (if (null? rest)
-                       (list (layout w spec offset 0 total-width remaining))
-                       (cons (layout w spec offset 0 total-width height)
-                             (loop rest (+ offset height) (- remaining height))))
-                   (if (>= remaining minimum-height)
-                       (list (layout w spec offset 0 total-width remaining))
-                       '()))]))
-          (list (layout miniwin
-                        (absolute-size miniwin-height)
-                        (- total-height miniwin-height)
-                        0
-                        total-width
-                        miniwin-height))))
-
-(define (render-windows! t layouts active-window)
-  (tty-body-style t #f)
-  (tty-goto t 0 0)
-  (define active-cursor-position
-    (for/fold [(cursor-position #f)] [(e layouts)]
-      (match-define (layout w _spec window-top _left window-width window-height) e)
-      (define is-active? (eq? w active-window))
-      (define window-cursor-position
-        (render-window! t w window-top window-width 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)))
-  (tty-flush t))

rmacs/rope.rkt

@@ -1,587 +0,0 @@
-#lang racket/base
-;; Ropes for text editing
-
-(provide empty-strand
-         string->strand
-         strand->string
-         substrand
-         strand-equal?
-         strand-empty?
-
-         (rename-out [rope?* rope?])
-         rope-empty?
-         empty-rope
-         strand->rope
-         string->rope
-         rope->string
-
-         rope-size
-         rope-marks
-         rope-split
-         rope-append
-         rope-concat
-         subrope
-         rope-generator
-         rope-seek
-
-         (struct-out mark-type)
-
-         has-mark?
-         find-mark
-         find-mark-pos
-         find-all-marks/type
-         set-mark
-         clear-mark
-         replace-mark
-         clear-all-marks)
-
-(require racket/set)
-(require racket/match)
-(require racket/generator)
-
-(module+ test (require rackunit racket/pretty))
-
-;; A Stickiness is one of
-;; -- 'left or
-;; -- 'right
-;; and indicates the side after a rope-split to which a mark with this
-;; Stickiness adheres. What Finseth calls a "normal mark" has 'right
-;; stickiness, and what he calls a "fixed mark" has 'left stickiness.
-
-;; A MarkType is a (mark-type Any Stickiness). MarkTypes can be
-;; associated with a set of Any values at each position in the rope.
-(struct mark-type (info stickiness) #:prefab)
-
-;; A Strand is a (strand String Number Number), representing a
-;; substring of a string.
-(struct strand (text offset count) #:prefab)
-
-;; A Rope is a splay tree representing a long piece of text.
-;; #f is the empty Rope; otherwise a (rope) struct instance.
-;; INVARIANT: Adjacent ropes will be merged to maximize sharing.
-(struct rope (strand ;; Strand
-              left ;; Rope or #f
-              right ;; Rope or #f
-              size* ;; Number, total length of this rope
-              marks* ;; (Seteq MarkType)
-              mark-index ;; (Hasheq MarkType (Hash Number (Set Any))), marks in this span
-              ) #:prefab)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Strands
-
-(define *glom-up-to* 128)
-
-(define (empty-strand) (strand "" 0 0))
-
-(define (string->strand s)
-  (strand s 0 (string-length s)))
-
-(define (strand->string t)
-  (match-define (strand text offset count) t)
-  (if (and (zero? offset) (= count (string-length text)))
-      text
-      (substring text offset (+ offset count))))
-
-(define (compute-range-index index default limit)
-  (cond [(not index) default]
-        [(zero? limit) 0]
-        [else (max 0 (min limit (if (negative? index) (+ index limit) index)))]))
-
-(define (substrand t0 [lo0 #f] [hi0 #f])
-  (define t (if (string? t0) (string->strand t0) t0))
-  (define lo (compute-range-index lo0 0 (strand-count t)))
-  (define hi (compute-range-index hi0 (strand-count t) (strand-count t)))
-  (strand (strand-text t)
-          (+ (strand-offset t) lo)
-          (- hi lo)))
-
-(define (strand-maybe-append t1 t2)
-  (match-define (strand text1 offset1 count1) t1)
-  (match-define (strand text2 offset2 count2) t2)
-  (or (and (zero? count1) t2)
-      (and (zero? count2) t1)
-      (and (eq? text1 text2)
-           (= (+ offset1 count1) offset2)
-           (strand text1 offset1 (+ count1 count2)))
-      ;; TODO: measure to see if the following improves or worsens memory usage
-      (and (< (+ count1 count2) *glom-up-to*)
-           (string->strand (string-append (strand->string t1) (strand->string t2))))))
-
-(define (strand-equal? t1 t2)
-  (string=? (strand->string t1)
-            (strand->string t2)))
-
-(define (strand-empty? t)
-  (zero? (strand-count t)))
-
-(module+ test
-  (check-equal? (strand-count (empty-strand)) 0)
-  (check-equal? (strand-count (string->strand "")) 0)
-  (check-true (strand-equal? (empty-strand) (string->strand ""))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Ropes
-
-(define (empty-rope) #f)
-
-(define (rope-empty? r)
-  (equal? r (empty-rope)))
-
-(define (rope?* r)
-  (or (rope-empty? r)
-      (rope? r)))
-
-(define (strand->rope t)
-  (rope t (empty-rope) (empty-rope) (strand-count t) (seteq) (hasheq)))
-
-(define (string->rope s)
-  (strand->rope (string->strand s)))
-
-(define (rope->string r)
-  (define buf (make-string (rope-size r)))
-  (let fill! ((r r) (offset 0))
-    (when r
-      (fill! (rope-left r) offset)
-      (define lo (rope-lo r))
-      (define s (rope-strand r))
-      (string-copy! buf
-                    (+ offset lo)
-                    (strand-text s)
-                    (strand-offset s)
-                    (+ (strand-offset s) (strand-count s)))
-      (fill! (rope-right r) (+ offset lo (strand-count s)))))
-  buf)
-
-(define (replace-left r n) (if r (reindex (struct-copy rope r [left n])) n))
-(define (replace-right r n) (if r (reindex (struct-copy rope r [right n])) n))
-(define (replace-both r rl rr) (reindex (struct-copy rope r [left rl] [right rr])))
-
-(define (splay-to r direction-finder arg0)
-  ;; zig: last. desired position is a direct (left/right) child of r.
-  ;; zig-zig: desired position is within a (left-left/right-right) grandchild of r.
-  ;; zig-zag: desired position is within a (left-right/right-left) grandchild of r.
-  (define-values (where arg1) (direction-finder arg0 r))
-  (match where
-    ['here (values arg1 r)]
-    ['left
-     (define rl (rope-left r))
-     (define-values (where arg2) (direction-finder arg1 rl))
-     (match where
-       ['here ;; zig.
-        (values arg2 (replace-right rl (replace-left r (and rl (rope-right rl)))))]
-       ['left ;; zig-zig
-        (define-values (v rll) (splay-to (rope-left rl) direction-finder arg2))
-        (values v (replace-right rll (replace-both rl
-                                                   (and rll (rope-right rll))
-                                                   (replace-left r (rope-right rl)))))]
-       ['right ;; zig-zag
-        (define-values (v rlr) (splay-to (rope-right rl) direction-finder arg2))
-        (values v (replace-both rlr
-                                (replace-right rl (rope-left rlr))
-                                (replace-left r (rope-right rlr))))])]
-    ['right
-     (define rr (rope-right r))
-     (define-values (where arg2) (direction-finder arg1 rr))
-     (match where
-       ['here ;; zig.
-        (values arg2 (replace-left rr (replace-right r (and rr (rope-left rr)))))]
-       ['left ;; zig-zag
-        (define-values (v rrl) (splay-to (rope-left rr) direction-finder arg2))
-        (values v (replace-both rrl
-                                (replace-right r (rope-left rrl))
-                                (replace-left rr (rope-right rrl))))]
-       ['right ;; zig-zig
-        (define-values (v rrr) (splay-to (rope-right rr) direction-finder arg2))
-        (values v (replace-left rrr (replace-both rr
-                                                  (replace-right r (rope-left rr))
-                                                  (and rrr (rope-left rrr)))))])]))
-
-(define (rope-lo r)
-  (rope-size (rope-left r)))
-
-(define (rope-lo+hi r)
-  (define lo (rope-lo r))
-  (values lo (+ lo (strand-count (rope-strand r)))))
-
-(define (find-position pos r)
-  (if (rope-empty? r)
-      (values 'here (zero? pos))
-      (let-values (((lo hi) (rope-lo+hi r)))
-        (cond
-         [(< pos lo) (values 'left pos)]
-         [(< pos hi) (values 'here #t)]
-         [else (values 'right (- pos hi))]))))
-
-;; (define (dump-mark-tree r)
-;;   (define (-> r)
-;;     (if r
-;;         (list (set->list (rope-marks* r))
-;;               (hash->list (rope-mark-index r))
-;;               (-> (rope-left r))
-;;               (-> (rope-right r)))
-;;         '()))
-;;   (local-require racket/pretty)
-;;   (pretty-print (-> r) (current-error-port)))
-
-;; Searches from pos (inclusive) in the direction indicated.
-;; Pos points to a mark-position, not a character-position.
-(define (find-mark* r forward? mtype start-pos)
-  (define (search-here r offset start-pos)
-    (define marks (hash-ref (rope-mark-index r) mtype #f))
-    (define lo (rope-lo r))
-    (if (not marks)
-        #f
-        (let ((pos-comparer (if forward? < >))
-              (boundary-comparer (if forward? >= <=)))
-          (for/fold [(candidate #f)] [((pos value) (in-hash marks))]
-            (if (and (or (not candidate)
-                         (pos-comparer pos (car candidate)))
-                     (boundary-comparer pos start-pos))
-                (cons (+ pos offset lo) value)
-                candidate)))))
-  (define (search r offset start-pos)
-    (and r
-         (set-member? (rope-marks r) mtype)
-         (let-values (((lo hi) (rope-lo+hi r)))
-           (if forward?
-               (or (and (< start-pos lo) (search (rope-left r) offset start-pos))
-                   (and (<= start-pos hi) (search-here r offset (- start-pos lo)))
-                   (search (rope-right r) (+ offset hi) (- start-pos hi)))
-               (or (and (> start-pos hi) (search (rope-right r) (+ offset hi) (- start-pos hi)))
-                   (and (>= start-pos lo) (search-here r offset (- start-pos lo)))
-                   (search (rope-left r) offset start-pos)))
-           )))
-  (search r 0 start-pos))
-
-(define (has-mark? r mtype)
-  (and r (set-member? (rope-marks r) mtype)))
-
-(define (find-mark r mtype
-                   #:forward? [forward? #t]
-                   #:position [start-pos (if forward? 0 (rope-size r))])
-  (find-mark* r forward? mtype start-pos))
-
-(define (find-mark-pos r mtype
-                       #:forward? [forward? #t]
-                       #:position [start-pos (if forward? 0 (rope-size r))])
-  (cond [(find-mark* r forward? mtype start-pos) => car]
-        [else #f]))
-
-(define (mark-union h1 h2 offset)
-  (for/fold [(h h1)] [((pos val) (in-hash h2))] (hash-set h (+ offset pos) val)))
-
-(define (find-all-marks/type r mtype)
-  (define (walk r)
-    (if (set-member? (rope-marks r) mtype)
-        (let-values (((lo hi) (rope-lo+hi r)))
-          (mark-union (walk (rope-left r))
-                      (mark-union (hash-ref (rope-mark-index r) mtype (lambda () (hash)))
-                                  (walk (rope-right r))
-                                  hi)
-                      lo))
-        (hash)))
-  (walk r))
-
-(define (splay-to-pos what r0 pos [extra (lambda () "")])
-  (define-values (found? r1) (splay-to r0 find-position pos))
-  (when (not found?) (error what "Invalid position ~a~a" pos (extra)))
-  r1)
-
-(define (add-mark-to-table old-marks mtype pos value)
-  (define old-mark (hash-ref old-marks mtype (lambda () (hash))))
-  (hash-set old-marks mtype (hash-set old-mark pos value)))
-
-(define (set-mark r0 mtype position value)
-  (define r (splay-to-pos 'set-mark r0 position (lambda () (format " setting mark ~a" mtype))))
-  (reindex
-   (if (rope-empty? r)
-       (rope (empty-strand)
-             (empty-rope)
-             (empty-rope)
-             'will-be-recomputed
-             'will-be-recomputed
-             (hasheq mtype (hash position value)))
-       (struct-copy rope r [mark-index (add-mark-to-table (rope-mark-index r)
-                                                          mtype
-                                                          (- position (rope-lo r))
-                                                          value)]))))
-
-(define (clear-mark r0 mtype position)
-  (let walk ((r (splay-to-pos 'clear-mark
-                              r0
-                              position
-                              (lambda () (format " clearing mark ~a" mtype)))))
-    (if (not (has-mark? r mtype))
-        r
-        (reindex
-         (struct-copy rope r
-                      [left (walk (rope-left r))]
-                      [right (walk (rope-right r))]
-                      [mark-index
-                       (let* ((old-marks (rope-mark-index r))
-                              (old-mark (hash-ref old-marks mtype (lambda () (hash)))))
-                         (define new-mark (hash-remove old-mark (- position (rope-lo r))))
-                         (if (hash-empty? new-mark)
-                             (hash-remove old-marks mtype)
-                             (hash-set old-marks mtype new-mark)))])))))
-
-(define (replace-mark r0 mtype new-pos new-value)
-  (define pos (find-mark-pos r0 mtype))
-  (set-mark (if pos (clear-mark r0 mtype pos) r0) mtype new-pos new-value))
-
-(define (clear-all-marks r)
-  (and r
-       (struct-copy rope r
-                    [marks* (seteq)]
-                    [mark-index (hasheq)]
-                    [left (clear-all-marks (rope-left r))]
-                    [right (clear-all-marks (rope-right r))])))
-
-(define (rope-size r)
-  (if r (rope-size* r) 0))
-
-(define (rope-marks r)
-  (if r (rope-marks* r) (seteq)))
-
-(define (reindex r)
-  (struct-copy rope r
-               [size* (+ (rope-size (rope-left r))
-                         (rope-size (rope-right r))
-                         (strand-count (rope-strand r)))]
-               [marks* (set-union (rope-marks (rope-left r))
-                                  (rope-marks (rope-right r))
-                                  (list->seteq (hash-keys (rope-mark-index r))))]))
-
-(define (rope-split r0 position)
-  (match (splay-to-pos 'rope-split r0 position)
-    [(? rope-empty?) (values (empty-rope) (empty-rope))]
-    [(and r (rope t rl rr size marks mark-index))
-     ;; We know the position is in the root of r.
-     (define-values (lo hi) (rope-lo+hi r))
-     (define offset (- position lo))
-     (define-values (left-index right-index) (partition-mark-index mark-index offset))
-     (define left-strand (substrand t 0 offset))
-     (define right-strand (substrand t offset))
-     (values (if (and (strand-empty? left-strand) (hash-empty? left-index))
-                 rl
-                 (reindex
-                  (rope left-strand rl (empty-rope) 'will-be-recomputed (seteq) left-index)))
-             (if (and (strand-empty? right-strand) (hash-empty? right-index))
-                 rr
-                 (reindex
-                  (rope right-strand (empty-rope) rr 'will-be-recomputed (seteq) right-index))))]))
-
-(define (partition-mark-index index offset)
-  (for*/fold [(l (hasheq)) (r (hasheq))]
-             [((mtype posvals) (in-hash index))
-              ((pos val) (in-hash posvals))]
-    (values (if (or (< pos offset) (and (= pos offset) (eq? (mark-type-stickiness mtype) 'left)))
-                (add-mark-to-table l mtype pos val)
-                l)
-            (if (or (> pos offset) (and (= pos offset) (eq? (mark-type-stickiness mtype) 'right)))
-                (add-mark-to-table r mtype (- pos offset) val)
-                r))))
-
-(define (rope-append rl0 rr0)
-  (cond
-   [(rope-empty? rl0) rr0]
-   [(rope-empty? rr0) rl0]
-   [else
-    (define-values (_l rl) (splay-to rl0 find-position (rope-size rl0)))
-    (define-values (_r rr) (splay-to rr0 find-position 0))
-    ;; Both rl's right and rr's left are (empty-rope).
-    (define t (strand-maybe-append (rope-strand rl) (rope-strand rr)))
-    (if t
-        (let ((merged-index (merge-mark-indexes (rope-mark-index rl)
-                                                (rope-mark-index rr)
-                                                (strand-count (rope-strand rl)))))
-          (reindex (rope t (rope-left rl) (rope-right rr) 'will-be-recomputed (seteq) merged-index)))
-        (replace-right rl rr))]))
-
-(define (rope-concat rs)
-  (foldr rope-append (empty-rope) rs))
-
-(define (merge-mark-indexes li ri offset)
-  (for*/fold [(i li)]
-             [((mtype posvals) (in-hash ri))
-              ((pos val) (in-hash posvals))]
-    (add-mark-to-table i mtype (+ pos offset) val)))
-
-(define (subrope r0 [lo0 #f] [hi0 #f])
-  (define lo (compute-range-index lo0 0 (rope-size r0)))
-  (define hi (compute-range-index hi0 (rope-size r0) (rope-size r0)))
-  (define-values (_l mr) (rope-split r0 lo))
-  (define-values (m _r) (rope-split mr (- hi lo)))
-  m)
-
-(define (rope-generator r #:forward? [forward? #t])
-  (if forward?
-      (generator ()
-        (let outer ((r r))
-          (and r
-               (begin (outer (rope-left r))
-                      (match-let (((strand text offset count) (rope-strand r)))
-                        (do ((i 0 (+ i 1)))
-                            ((= i count))
-                          (yield (string-ref text (+ offset i)))))
-                      (outer (rope-right r))))))
-      (generator ()
-        (let outer ((r r))
-          (and r
-               (begin (outer (rope-right r))
-                      (match-let (((strand text offset count) (rope-strand r)))
-                        (do ((i (- count 1) (- i 1)))
-                            ((negative? i))
-                          (yield (string-ref text (+ offset i)))))
-                      (outer (rope-left r))))))))
-
-(define (rope-seek r0 pos)
-  (splay-to-pos 'rope-seek r0 pos))
-
-;; (require racket/trace)
-;; (trace splay-to find-position rope-concat rope-append rope-split rope->string)
-
-(module+ test
-  (require (only-in racket/string string-append*))
-
-  (check-equal? (rope-size (empty-rope)) 0)
-
-  (define-syntax-rule (find-mark/values arg ...)
-    (match (find-mark arg ...)
-      [(cons p v) (values p v)]
-      [#f (values #f #f)]))
-
-  (define mtype1 (mark-type "Mark1" 'left))
-  (define mtype2 (mark-type "Mark2" 'right))
-
-  (define (test-with-pieces string-pieces)
-    (define rope-pieces (map string->rope string-pieces))
-    (define text (string-append* string-pieces))
-    (check-equal? (rope->string (car rope-pieces)) (car string-pieces))
-    (check-equal? (rope->string (rope-concat rope-pieces)) text)
-    (check-equal? (rope-size (rope-concat rope-pieces)) (string-length text))
-
-    (check-eq? (rope-append (empty-rope) (car rope-pieces)) (car rope-pieces))
-    (check-eq? (rope-append (car rope-pieces) (empty-rope)) (car rope-pieces))
-
-    (let loop ((n 1000) (r0 (rope-concat rope-pieces)))
-      (when (positive? n)
-        (define pos (random (+ (rope-size r0) 1)))
-        ;; (pretty-print (list pos r0))
-        (define-values (found? r) (splay-to r0 find-position pos))
-        (check-true found?)
-        (check-equal? (rope->string r) text)
-        (loop (- n 1) r)))
-
-    (let*-values (((r) (set-mark (rope-concat rope-pieces) mtype1 9 "original"))
-                  ((_) (check-equal? (rope->string r) text))
-                  ((pos val) (find-mark/values r mtype1))
-                  ((_) (check-equal? pos 9))
-                  ((_) (check-equal? val "original"))
-                  ((r) (clear-mark r mtype1 pos))
-                  ((_) (check-equal? (find-all-marks/type r mtype1) (hash)))
-                  ((pos val) (find-mark/values r mtype1))
-                  ((_) (check-false pos))
-                  ((_) (check-false val))
-                  ((r) (set-mark r mtype1 9 "second"))
-                  ((pos val) (find-mark/values r mtype1))
-                  ((_) (check-equal? pos 9))
-                  ((_) (check-equal? val "second"))
-                  ((r) (set-mark r mtype1 6 "first"))
-                  ((r) (set-mark r mtype2 6 "third"))
-                  ((_) (check-equal? (find-all-marks/type r mtype1) (hash 6 "first" 9 "second")))
-                  ((_) (check-equal? (find-all-marks/type r mtype2) (hash 6 "third")))
-                  ((pos val) (find-mark/values r mtype1 #:forward? #f))
-                  ((_) (check-equal? pos 9))
-                  ((_) (check-equal? val "second"))
-                  ((pos val) (find-mark/values r mtype1))
-                  ((_) (check-equal? pos 6))
-                  ((_) (check-equal? val "first"))
-                  ((l r) (rope-split r pos))
-                  ((_) (check-equal? (find-all-marks/type r mtype1) (hash 3 "second")))
-                  ((_) (check-equal? (find-all-marks/type l mtype1) (hash 6 "first")))
-                  ((_) (check-equal? (find-all-marks/type r mtype2) (hash 0 "third")))
-                  ((_) (check-equal? (find-all-marks/type l mtype2) (hash)))
-                  ((_) (check-equal? (rope->string l) (substring text 0 6)))
-                  ((_) (check-equal? (rope->string r) (substring text 6 (string-length text))))
-                  ((_) (check-equal? (rope-marks l) (seteq mtype1)))
-                  ((_) (check-equal? (rope-marks r) (seteq mtype1 mtype2)))
-                  ((l r) (rope-split r 3))
-                  ((_) (check-equal? (find-all-marks/type r mtype1) (hash)))
-                  ((_) (check-equal? (find-all-marks/type l mtype1) (hash 3 "second")))
-                  ((_) (check-equal? (find-all-marks/type r mtype2) (hash)))
-                  ((_) (check-equal? (find-all-marks/type l mtype2) (hash 0 "third")))
-                  ((_) (check-equal? (rope->string l) (substring text 6 9)))
-                  ((_) (check-equal? (rope->string r) (substring text 9 (string-length text)))))
-      (void)))
-
-  (define prejudice-pieces
-    (list "It is a truth universally acknowledged, that a single man in possession of a good fortune must be in want of a wife.\n"
-          "\n"
-          "However little known the feelings or views of such a man may be on his first entering a neighbourhood, this truth is so well fixed in the minds of the surrounding families, that he is considered as the rightful property of some one or other of their daughters.\n"
-          "\n"
-          "``My dear Mr. Bennet,'' said his lady to him one day, ``have you heard that Netherfield Park is let at last?''\n"
-          "\n"
-          "Mr. Bennet replied that he had not.\n"))
-
-  (define (atomize-pieces pieces)
-    (map string (string->list (string-append* pieces))))
-
-  (test-with-pieces (list "hello" ", " "world"))
-  (test-with-pieces prejudice-pieces)
-  (test-with-pieces (atomize-pieces prejudice-pieces))
-
-  (check-equal? (call-with-values (lambda () (rope-split (empty-rope) 0)) list)
-                (list (empty-rope) (empty-rope)))
-
-  (check-equal? (map rope->string
-                     (call-with-values (lambda () (rope-split (string->rope "abc") 0)) list))
-                (list "" "abc"))
-  (check-equal? (map rope->string
-                     (call-with-values (lambda () (rope-split (string->rope "abc") 2)) list))
-                (list "ab" "c"))
-  (check-equal? (map rope->string
-                     (call-with-values (lambda () (rope-split (string->rope "abc") 3)) list))
-                (list "abc" ""))
-
-  (check-equal? (map (lambda (i) (compute-range-index i 'default 10))
-                     (list 0 10 3 -1 -2 11 12 -8 -9 -10 -11 -12))
-                (list      0 10 3  9  8 10 10  2  1   0   0   0))
-
-  (let* ((r (rope-append (string->rope (make-string 10 #\a))
-                         (string->rope (make-string (* 2 *glom-up-to*) #\z))))
-         (_ (check-equal? (rope-size r) (+ 10 (* 2 *glom-up-to*))))
-         (r (set-mark r mtype1 (rope-size r) #t))
-         (r (splay-to-pos 'testing r 0))
-         (pos (find-mark-pos r mtype1)))
-    (check-equal? pos 266))
-
-  (let*-values (((r) (string->rope "hello"))
-                ((r) (set-mark r mtype2 (rope-size r) #t))
-                ((l r) (rope-split r (find-mark-pos r mtype2)))
-                ((_) (check-equal? (rope->string l) "hello"))
-                ((_) (check-equal? (rope->string r) ""))
-                ((_) (check-equal? (rope-marks l) (seteq)))
-                ((_) (check-equal? (rope-marks r) (seteq mtype2))))
-    (void))
-
-  (let*-values (((xs) (make-string 128 #\x))
-                ((r) (string->rope (string-append "hello " xs)))
-                ((r) (set-mark r mtype2 3 #t))
-                ((l mr) (rope-split r (find-mark-pos r mtype2)))
-                ((m r) (rope-split mr 1))
-                ((_) (check-equal? (rope->string l) "hel"))
-                ((_) (check-equal? (rope->string m) "l"))
-                ((_) (check-equal? (rope->string r) (string-append "o " xs)))
-                ((_) (check-equal? (rope-marks l) (seteq)))
-                ((_) (check-equal? (rope-marks m) (seteq mtype2)))
-                ((_) (check-equal? (rope-marks r) (seteq)))
-                ((new-m) (set-mark (empty-rope) mtype2 0 #t))
-                ((r) (rope-append (rope-append l new-m) r))
-                ((_) (check-equal? (rope->string r) (string-append "helo " xs)))
-                ((_) (check-equal? (find-mark-pos r mtype2) 3))
-                ((r) (clear-mark r mtype2 (find-mark-pos r mtype2)))
-                ((_) (check-equal? (find-mark-pos r mtype2) #f)))
-    (void))
-  )

rmacs/search.rkt

@@ -1,138 +0,0 @@
-#lang racket/base
-;; Knuth-Morris-Pratt string & rope search.
-
-(provide search-generator
-         search-string
-         search-rope
-         findf-in-generator
-         findf-in-rope)
-
-(require racket/set)
-(require racket/match)
-(require racket/generator)
-(require "rope.rkt")
-
-(define (table pattern)
-  (define t (make-vector (- (string-length pattern) 1)))
-  (vector-set! t 0 0)
-  (let loop ((pos 1) (candidate 0))
-    (cond
-     [(= pos (- (string-length pattern) 1))
-      t]
-     [(equal? (string-ref pattern pos)
-              (string-ref pattern candidate))
-      (vector-set! t pos (+ candidate 1))
-      (loop (+ pos 1)
-            (+ candidate 1))]
-     [(> candidate 0)
-      (loop pos
-            (vector-ref t candidate))]
-     [else
-      (vector-set! t pos 0)
-      (loop (+ pos 1)
-            0)])))
-
-;; String (Generator Char) -> (Option Index)
-(define (search-generator needle haystack)
-  (define t (table needle))
-  (define cache #f)
-  (define (advance!)
-    (define next (haystack))
-    (set! cache (and (char? next) next)))
-  (advance!)
-  (let loop ((m 0) (i 0))
-    (cond
-     [(not cache)
-      #f]
-     [(equal? (string-ref needle i) cache)
-      (if (= i (- (string-length needle) 1))
-          m
-          (begin (advance!)
-                 (loop m (+ i 1))))]
-     [(> i 0)
-      (define ti (vector-ref t (- i 1)))
-      (loop (- (+ m i) ti) ti)]
-     [else
-      (advance!)
-      (loop (+ m 1) i)])))
-
-;; String String -> (Option Index)
-(define (search-string needle haystack)
-  (define t (table needle))
-  (let loop ((m 0) (i 0))
-    (cond
-     [(= (+ m i) (string-length haystack))
-      #f]
-     [(equal? (string-ref needle i) (string-ref haystack (+ m i)))
-      (if (= i (- (string-length needle) 1))
-          m
-          (loop m (+ i 1)))]
-     [(> i 0)
-      (define ti (vector-ref t (- i 1)))
-      (loop (- (+ m i) ti) ti)]
-     [else
-      (loop (+ m 1) i)])))
-
-;; String Rope -> (Option Index)
-(define (search-rope needle haystack #:forward? [forward? #t])
-  (if forward?
-      (search-generator needle (rope-generator haystack))
-      (let ((reversed-result (search-generator (list->string (reverse (string->list needle)))
-                                               (rope-generator haystack #:forward? #f))))
-        (and reversed-result (- (rope-size haystack) reversed-result (string-length needle))))))
-
-(define (findf-in-generator f gen)
-  (let loop ((count 0))
-    (match (gen)
-      [(? char? c)
-       (if (f c)
-           count
-           (loop (+ count 1)))]
-      [_ count])))
-
-(define (findf-in-rope f r #:forward? [forward? #t])
-  (if forward?
-      (findf-in-generator f (rope-generator r))
-      (- (rope-size r) (findf-in-generator f (rope-generator r #:forward? #f)))))
-
-(module+ test
-  (require rackunit)
-  (check-equal? (table "ABCDABD")
-                (vector 0 0 0 0 1 2))
-  (check-equal? (table "PARTICIPATE IN PARACHUTE")
-                (vector 0 0 0 0 0 0 0 1 2 0 0 0 0 0 0 1 2 3 0 0 0 0 0))
-  (check-equal? (search-string "ABCDABD" "ABC ABCDAB ABCDABCDABDE") 15)
-  (check-equal? (search-string "AAAA" "AAABAAABAAABAAABAAAB") #f)
-
-  (check-equal? (search-generator "ABCDABD" (sequence->generator "ABC ABCDAB ABCDABCDABDE")) 15)
-  (check-equal? (search-generator "AAAA" (sequence->generator "AAABAAABAAABAAABAAAB")) #f)
-
-  (define prejudice-rope
-    (rope-concat
-     (map string->rope
-          (list "It is a truth universally acknowledged, that a single man in possession of a good fortune must be in want of a wife.\n"
-                "\n"
-                "However little known the feelings or views of such a man may be on his first entering a neighbourhood, this truth is so well fixed in the minds of the surrounding families, that he is considered as the rightful property of some one or other of their daughters.\n"
-                "\n"
-                "``My dear Mr. Bennet,'' said his lady to him one day, ``have you heard that Netherfield Park is let at last?''\n"
-                "\n"
-                "Mr. Bennet replied that he had not.\n"))))
-
-  (check-equal? (search-rope "man" prejudice-rope) 54)
-  (check-equal? (search-rope "man" prejudice-rope #:forward? #f) 171)
-  (check-equal? (search-rope "man in" prejudice-rope) 54)
-  (check-equal? (search-rope "man may" prejudice-rope) 171)
-  (check-equal? (search-rope "man may" prejudice-rope #:forward? #f) 171)
-  (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))
-  (check-equal? (find-in-rope "\n" prejudice-rope #:forward? #f) (rope-size prejudice-rope))
-  (check-equal? (find-in-rope "at" prejudice-rope #:forward? #f) (- (rope-size prejudice-rope) 2))
-  (check-equal? (find-in-rope "z" prejudice-rope #:forward? #f) 0))

rmacs/strings.rkt

@@ -1,18 +0,0 @@
-#lang racket/base
-;; String utilities :-(
-
-(provide string-prefix?)
-
-(define (string-prefix? a b [string=? string=?])
-  (define a-len (string-length a))
-  (and (>= (string-length b) a-len)
-       (string=? (substring b 0 a-len) a)))
-
-(module+ test
-  (require rackunit)
-  (check-true (string-prefix? "aaa" "aaaa"))
-  (check-false (string-prefix? "aaaa" "aaa"))
-  (check-false (string-prefix? "a" "z"))
-  (check-false (string-prefix? "z" "a"))
-  (check-true (string-prefix? "a" "a"))
-  )

rmacs/topsort.rkt

@@ -1,54 +0,0 @@
-#lang racket/base
-
-(provide topsort)
-
-(require racket/match)
-
-(define (topsort edges
-                 #:comparison [comparison equal?])
-  (define hash-ctor (cond [(eq? comparison equal?) hash]
-                          [(eq? comparison eq?) hasheq]
-                          [else (error 'topsort "Invalid comparison ~v" comparison)]))
-  (define-values (fwd rev)
-    (for/fold [(fwd (hash-ctor)) (rev (hash-ctor))]
-              [(edge edges)]
-      (match-define (list source target) edge)
-      (values (hash-set fwd source (hash-set (hash-ref fwd source hash-ctor) target #t))
-              (hash-set rev target (hash-set (hash-ref rev target hash-ctor) source #t)))))
-  (define roots (for/fold [(roots (hash-ctor))]
-                          [(source (in-hash-keys fwd))]
-                  (if (hash-has-key? rev source)
-                      roots
-                      (hash-set roots source #t))))
-
-  (if (hash-empty? roots)
-      (if (and (hash-empty? fwd) (hash-empty? rev))
-          '() ;; no nodes at all
-          #f) ;; no nodes without incoming edges -> cycle
-      (let/ec return
-        (define seen (hash-ctor))
-        (define busy (hash-ctor))
-        (define acc '())
-
-        (define (visit-nodes nodes)
-          (for ((n nodes))
-            (when (hash-has-key? busy n) (return #f)) ;; cycle
-            (when (not (hash-has-key? seen n))
-              (set! busy (hash-set busy n #t))
-              (visit-nodes (hash-keys (hash-ref fwd n hash-ctor)))
-              (set! seen (hash-set seen n #t))
-              (set! busy (hash-remove busy n))
-              (set! acc (cons n acc)))))
-
-        (visit-nodes (hash-keys roots))
-        acc)))
-
-(module+ test
-  (require rackunit)
-  (check-equal? (topsort '()) '())
-  (check-equal? (topsort '((1 1))) #f)
-  (check-equal? (topsort '((1 0) (0 1))) #f)
-  (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 0) (0 1))) #f)
-  (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 1) (0 1))) #f)
-  (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (0 1))) '(0 1 3 4 2)) ;; others also valid
-  )

rmacs/window.rkt

@@ -1,67 +0,0 @@
-#lang racket/base
-
-(provide (except-out (struct-out window) window set-window-buffer!)
-         (rename-out [set-window-buffer!* set-window-buffer!])
-         make-window
-         window-editor
-         window-command
-         window-mark!
-         window-move-to!
-         )
-
-(require racket/match)
-
-(require "buffer.rkt")
-(require "rope.rkt")
-
-(struct window (id ;; Symbol
-                top ;; MarkType
-                point ;; MarkType
-                mark ;; MarkType
-                [buffer #:mutable] ;; (Option Buffer)
-                [status-line? #:mutable] ;; Boolean
-                ) #:prefab)
-
-(define (make-window initial-buffer #:point [initial-point-or-mark 0])
-  (define id (gensym 'window))
-  (define w (window id
-                    (mark-type (buffer-mark-type 'top id #f) 'left)
-                    (mark-type (buffer-mark-type 'point id #t) 'right)
-                    (mark-type (buffer-mark-type 'mark id #f) 'left)
-                    #f
-                    #t))
-  (set-window-buffer!* w initial-buffer initial-point-or-mark) ;; sets initial marks
-  w)
-
-(define (window-editor w)
-  (and (window-buffer w)
-       (buffer-editor (window-buffer w))))
-
-(define (set-window-buffer!* win new [point-or-mark 0])
-  (define old (window-buffer win))
-  (when old
-    (buffer-clear-mark! old (window-top win))
-    (buffer-clear-mark! old (window-point win))
-    (buffer-clear-mark! old (window-mark win)))
-  (set-window-buffer! win new)
-  (when new
-    (buffer-mark! new (window-point win) point-or-mark))
-  (void))
-
-(define (window-command selector window
-                        #:editor [editor #f]
-                        #:keyseq [keyseq #f]
-                        #:prefix-arg [prefix-arg '#:default])
-  (command selector (window-buffer window)
-           #:window window
-           #:editor editor
-           #:keyseq keyseq
-           #:prefix-arg prefix-arg))
-
-(define (window-mark! win [pos (window-point win)])
-  (buffer-mark! (window-buffer win) (window-mark win) pos)
-  win)
-
-(define (window-move-to! win pos)
-  (buffer-mark! (window-buffer win) (window-point win) pos)
-  win)

rmacs/wrap.rkt

@@ -1,57 +0,0 @@
-#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))))))))))