;
; ARSE is a Recursive Scheme Editor
; by Nils M Holm, 2010
; See the LICENSE file of the S9fES package for terms of use
;
; (arse string)  ==>  unspecific
; (arse)         ==>  unspecific
;
; The ARSE procedure implements a vi-style editor. If specified,
; it loads the file STRING into an editing buffer.
;
; (Example): (arse "foo.scm")

; Todo:
;  ^C interrupt
; ? long line editor

(require-extension sys-unix curses)

(load-from-library "syntax-rules.scm")
(load-from-library "define-structure.scm")
(load-from-library "sort.scm")
(load-from-library "hash-table.scm")
(load-from-library "list-to-set.scm")
(load-from-library "remove.scm")
(load-from-library "split.scm")
(load-from-library "string-case.scm")
(load-from-library "string-expand.scm")
(load-from-library "string-scan.scm")
(load-from-library "string-split.scm")
(load-from-library "string-unsplit.scm")
(load-from-library "string-parse.scm")
(load-from-library "string-locate.scm")
(load-from-library "string-find.scm")
(load-from-library "string-find-last.scm")
(load-from-library "string-position.scm")
(load-from-library "string-last-position.scm")
(load-from-library "read-line.scm")
(load-from-library "read-file.scm")
(load-from-library "format.scm")
(load-from-library "regex.scm")
(load-from-library "basename.scm")
(load-from-library "dirname.scm")
(load-from-library "search-path.scm")
(load-from-library "spawn-command.scm")
(load-from-library "spawn-shell-command.scm")
(load-from-library "flush-output-port.scm")
(load-from-library "find-help-path.scm")
(load-from-library "name-to-file-name.scm")
(load-from-library "mode-to-string.scm")
(load-from-library "format-time.scm")
(load-from-library "unix-time-to-time.scm")
(load-from-library "pretty-print.scm")

; ----- Curses abstraction layer -----

(define addch    curs:addch)
(define addstr   curs:addstr)
(define attrset  curs:attrset)
(define beep     curs:beep)
(define cbreak   curs:cbreak)
(define clear    curs:clear)
(define clrtoeol curs:clrtoeol)
(define cols     curs:cols)
(define deleteln curs:deleteln)
(define echo     curs:echo)
(define endwin   curs:endwin)
(define flash    curs:flash)
(define getch    curs:getch)
(define idlok    curs:idlok)
(define initscr  curs:initscr)
(define insertln curs:insertln)
(define keypad   curs:keypad)
(define lines    curs:lines)
(define move     curs:move)
(define mvaddstr curs:mvaddstr)
(define nl       curs:nl)
(define noecho   curs:noecho)
(define nodelay  curs:nodelay)
(define nonl     curs:nonl)
(define noraw    curs:noraw)
(define raw      curs:raw)
(define refresh  curs:refresh)
(define scrollok curs:scrollok)
(define standend curs:standend)
(define standout curs:standout)
(define unctrl   curs:unctrl)
(define ungetch  curs:ungetch)

(define (attr-underline)
  (attrset curs:attr-underline))

(define (attr-bold)
  (attrset curs:attr-bold))

(define (attr-normal)
  (attrset curs:attr-normal))

(define *key-up*        curs:key-up)
(define *key-down*      curs:key-down)
(define *key-left*      curs:key-left)
(define *key-right*     curs:key-right)
(define *key-ppage*     curs:key-ppage)
(define *key-npage*     curs:key-npage)
(define *key-home*      curs:key-home)
(define *key-backspace* curs:key-backspace)

; ----- System abstraction layer -----

(define catch-errors      sys:catch-errors)
(define chmod             sys:chmod)
(define directory?        sys:stat-directory?)
(define make-output-port  sys:make-output-port)
(define fd-creat          sys:creat)
(define fd-read           sys:read)
(define fd-select         sys:select)
(define errno             sys:errno)
(define errno->string     sys:strerror)
(define getcwd            sys:getcwd)
(define getenv            sys:getenv)
(define getpid            sys:getpid)
(define read-directory    sys:readdir)
(define remove-file       sys:unlink)
(define rename-file       sys:rename)
(define run-shell-command sys:system)
(define send-signal       sys:notify)
(define stat-file         sys:stat)
(define unix-time         sys:time)
(define wait-for-process  sys:wait)

(define (file-exists? path)
    (sys:access path sys:access-f-ok))

(define (file-readable? path)
  (sys:access path sys:access-r-ok))

(define (file-writable? path)
  (sys:access path sys:access-w-ok))

; ----- Main program -----

(define *Mode*      "command")
(define *Message*   #f)
(define *Update*    #t)
(define *Repeat*    #f)

(define *Buffers*    '())
(define *Help-Stack* '())
(define *Session*    #f)

(define *Completion-symbols* '())

(define *Chunksize* 1000)

(define bp-autocenter   'bp-autocenter)
(define bp-autoindent   'bp-autoindent)
(define bp-autoload     'bp-autoload)
(define bp-crlfmode     'bp-crlfmode)
(define bp-errorbells   'bp-errorbells)
(define bp-ignorecase   'bp-ignorecase)
(define bp-modified     'bp-modified)
(define bp-readonly     'bp-readonly)
(define bp-regex        'bp-regex)
(define bp-saveintbuf   'bp-saveintbuf)
(define bp-sharebuffers 'bp-sharebuffers)
(define bp-showmatch    'bp-showmatch)
(define bp-showmode     'bp-showmode)
(define bp-standout     'bp-standout)
(define bp-unexpand     'bp-unexpand)
(define bp-tag-help     'bp-tag-help)
(define bp-tag-scmint   'bp-tag-scmint)
(define bp-tag-scmhelp  'bp-tag-scmhelp)
(define bp-transient    'bp-transient)

(define *prop-table*
  `((,bp-autocenter   boolean ("autocenter"   "ac"))
    (,bp-autoindent   boolean ("autoindent"   "ai"))
    (,bp-autoload     boolean ("autoload"     "al"))
    (,bp-crlfmode     boolean ("crlfmode"     "cr"))
    (,bp-errorbells   boolean ("errorbells"   "eb"))
    (,bp-ignorecase   boolean ("ignorecase"   "ic"))
    (,bp-regex        boolean ("regex"        "re"))
    (,bp-readonly     boolean ("readonly"     "ro"))
    (,bp-saveintbuf   boolean ("saveintbuf"   "sib"))
    (,bp-sharebuffers boolean ("sharebuffers" "sb"))
    (,bp-showmatch    boolean ("showmatch"    "sm"))
    (,bp-showmode     boolean ("showmode"     "smd"))
    (,bp-standout     boolean ("standout"     "so"))
    (,bp-unexpand     boolean ("unexpand"     "ue"))))

(define pt-prop  car)
(define pt-type  cadr)
(define pt-names caddr)

(define *default-prop*
  (list bp-autoindent
        bp-errorbells
        bp-regex
        bp-saveintbuf
        bp-sharebuffers
        bp-showmatch
        bp-showmode
        bp-standout))

(define bv-code-marker  'bv-code-marker)
(define bv-indent       'bv-indent)
(define bv-scheme-init  'bv-scheme-init)
(define bv-scheme-repl  'bv-scheme-repl)
(define bv-repl-timeout 'bv-repl-timeout)
(define bv-scroll       'bv-scroll)
(define bv-wordset      'bv-wordset)

(define *val-table*
  `((,bv-code-marker  string  ("code-marker"  "cm"))
    (,bv-indent       integer ("indent"       "in"))
    (,bv-repl-timeout integer ("repl-timeout" "rt"))
    (,bv-scheme-init  string  ("scheme-init"  "si"))
    (,bv-scheme-repl  string  ("scheme-repl"  "sr"))
    (,bv-scroll       integer ("scroll"       "sc"))
    (,bv-wordset      integer ("wordset"      "ws"))))

(define (default-values)
  (list (cons bv-code-marker  "")
        (cons bv-indent       2)
        (cons bv-repl-timeout 2)
        (cons bv-scheme-init  "")
        (cons bv-scheme-repl  "s9 -q")
        (cons bv-scroll       (quotient (text-lines) 2))
        (cons bv-wordset      2)))

(define-structure buf
  (name      #f)
  (length    0)
  (prop      *default-prop*)
  (values    (default-values))
  (y         0)
  (x         0)
  (top       0)
  (mark      #f)
  (yanked    '())
  (searchbuf "")
  (revsearch #f)
  (lastcmd   #f)
  (scanchr   #f)
  (revscan   #f)
  (scan-onto #f)
  (log       (list 'undo '() '()))
  (buffer    (make-vector *Chunksize* "")))

(define (fresh-buffer . prop)
  (let ((buf (make-buf)))
    (if (not (null? prop))
        (buf-set-prop! buf (car prop)))
    (if (and (not (null? prop))
             (not (null? (cdr prop))))
        (buf-set-values! buf (cadr prop)))
    buf))

(define (new-buffer . prop)
  (set! *Buffers* (cons (apply fresh-buffer prop) *Buffers*))
  (car *Buffers*))

(define (delete-buffer buf)
  (set! *Buffers* (remq buf *Buffers*))
  (car *Buffers*))

(define (rotate-buffers!)
  (set! *Buffers* (append (cdr *Buffers*)
                          (list (car *Buffers*))))
  (car *Buffers*))

(define (swap-buffers!)
  (set! *Buffers* (append (list (cadr *Buffers*))
                          (list (car *Buffers*))
                          (cddr *Buffers*)))
  (car *Buffers*))

(define (buf-log-dir buf)  (car   (buf-log buf)))
(define (buf-undo-log buf) (cadr  (buf-log buf)))
(define (buf-redo-log buf) (caddr (buf-log buf)))

(define (buf-set-log-dir! buf log)  (set-car!       (buf-log buf)  log))
(define (buf-set-undo-log! buf log) (set-car! (cdr  (buf-log buf)) log))
(define (buf-set-redo-log! buf log) (set-car! (cddr (buf-log buf)) log))

(define (buf-line buf n)
  (vector-ref (buf-buffer buf) n))

(define (buf-cur-line buf)
  (vector-ref (buf-buffer buf) (buf-y buf)))

(define (buf-cur-length buf)
  (string-length (buf-cur-line buf)))

(define (buf-set-line! buf n line)
  (vector-set! (buf-buffer buf) n line))

(define (buf-set-cur-line! buf line)
  (vector-set! (buf-buffer buf) (buf-y buf) line))

(define (buf-char buf i)
  (let ((line (buf-cur-line buf)))
    (if (< -1 i (string-length line))
        (string-ref line i)
        #f)))

(define (buf-cur-char buf)
  (buf-char buf (buf-x buf)))

(define (buf-next-char buf)
  (and (buf-cur-char buf)
       (buf-char buf (+ 1 (buf-x buf)))))

(define (buf-prev-char buf)
  (and (positive? (buf-x buf))
       (buf-char buf (- (buf-x buf) 1))))

(define (buf-size buf)
  (vector-length (buf-buffer buf)))

(define (buf-prop? buf prop)
  (and (memq prop (buf-prop buf))
       #t))

(define (buf-val buf val)
  (cdr (assq val (buf-values buf))))

(define (buf-set-val! buf prop val)
  (set-cdr! (assq prop (buf-values buf)) val))

(define (buf-transient? buf) (buf-prop? buf bp-transient))
(define (buf-modified? buf)  (and (buf-prop? buf bp-modified)
                                  (not (buf-transient? buf))))
(define (buf-readonly? buf)  (buf-prop? buf bp-readonly))

(define (buf-add-prop! buf prop)
  (if (not (buf-prop? buf prop))
      (buf-set-prop! buf (cons prop (buf-prop buf)))))

(define (buf-rem-prop! buf prop)
  (buf-set-prop! buf (remq prop (buf-prop buf))))

(define (clean-up-props buf)
  (let loop ((b (buf-prop buf))
             (p (list bp-modified
                      bp-readonly
                      bp-autoload
                      bp-transient
                      bp-tag-scmint
                      bp-tag-help
                      bp-tag-scmhelp)))
   (if (null? p)
       b
       (loop (remq (car p) b)
             (cdr p)))))

(define (buf-modified! buf)
  (buf-add-prop! buf bp-modified)
  (buf-set-mark! buf #f)
  (buf-set-log-dir! buf 'undo))

(define (buf-add-yanked! buf x)
  (buf-set-yanked! buf (cons x (buf-yanked buf))))

(define (buf-clear-yanked! buf)
  (buf-set-yanked! buf '()))

(define make-pos list)

(define (save-pos buf)
  (make-pos (buf-y buf) (buf-x buf) (buf-top buf)))

(define (saved-y s)
  (car s))

(define (saved-x s)
  (cadr s))

(define (saved-top s)
  (caddr s))

(define (reset-pos buf saved)
  (buf-set-y! buf (saved-y saved))
  (buf-set-x! buf (saved-x saved))
  (buf-set-top! buf (saved-top saved)))

(define (restore-pos buf saved)
  (if (< (saved-y saved) (buf-length buf))
      (begin (reset-pos buf saved)
             (buf-display buf))))

(define (log-entry op where what)
  (vector op where what))

(define (log-op log)    (vector-ref log 0))
(define (log-where log) (vector-ref log 1))
(define (log-what log)  (vector-ref log 2))

(define (add-to-log buf act)
  (buf-set-undo-log! buf (cons act (buf-undo-log buf)))
  (buf-set-redo-log! buf '()))

(define here save-pos)

(define (log-new buf)
  (if (or (null? (buf-undo-log buf))
          (not (eq? 'NEXT (log-op (car (buf-undo-log buf))))))
      (add-to-log buf (log-entry 'NEXT (here buf) #f))))

(define (log-del-chars buf what)
  (add-to-log buf (log-entry 'DELC (here buf) what)))

(define (log-insert buf what)
  (add-to-log buf (log-entry 'INSC (here buf) what)))

(define (log-join buf log)
  (add-to-log buf (log-entry 'JOIN (here buf) log)))

(define (log-break buf what)
  (add-to-log buf (log-entry 'BRKL (here buf) what)))

(define (log-replace buf what)
  (add-to-log buf (log-entry 'REPC (here buf) what)))

(define (log-del-lines buf what)
  (add-to-log buf (log-entry 'DELN (here buf) what)))

(define-syntax ctl
  (syntax-rules ()
    ((_ c)
       (integer->char (- (char->integer c)
                         (char->integer #\@))))))

(define ^A  (ctl #\A))
(define ^B  (ctl #\B))
(define ^C  (ctl #\C))
(define ^D  (ctl #\D))
(define ^F  (ctl #\F))
(define ^G  (ctl #\G))
(define ^H  (ctl #\H))
(define TAB (ctl #\I))
(define ^J  (ctl #\J))
(define ^L  (ctl #\L))
(define CR  (ctl #\M))
(define ^N  (ctl #\N))
(define ^R  (ctl #\R))
(define ^T  (ctl #\T))
(define ^U  (ctl #\U))
(define ^V  (ctl #\V))
(define ^X  (ctl #\X))
(define ESC (ctl #\[))
(define ^^  (ctl #\^))
(define LP  #\()
(define RP  #\))
(define SP  #\space)

(define (text-lines)
  (- (lines) 1))

(define (screen-line buf)
  (- (buf-y buf) (buf-top buf)))

(define (clip-right s lim)
  (if (> (string-length s) lim)
      (substring s 0 lim)
      s))

(define (clip-left s lim)
  (let ((k (string-length s)))
    (if (> k lim)
        (substring s (- k lim) k)
        s)))

(define (last-line buf)
  (max 0 (- (buf-length buf) 1)))

(define (at-last-line? buf)
  (>= (buf-y buf) (- (buf-length buf) 1)))

(define (at-eof? buf)
  (and (at-last-line? buf)
       (not (buf-cur-char buf))))

(define (char-symbolic? c)
  (or (char-alphabetic? c)
      (char-numeric? c)
      (and (memv c '(#\! #\@ #\$ #\% #\^ #\& #\* #\- #\/
                     #\_ #\+ #\= #\~ #\. #\? #\< #\> #\:))
           #t)))

(define (char-non-whitespace? c)
  (not (char-whitespace? c)))

(define (char-alphanumeric? c)
  (or (char-alphabetic? c)
      (char-numeric? c)))

(define (insert-into-buf! buf pos line)
  (if (>= pos (buf-size buf))
      (let ((src-lines  (buf-buffer buf))
            (src-length (buf-size buf)))
        (buf-set-buffer! buf (make-vector
                               (* (quotient (+ pos *Chunksize*)
                                            *Chunksize*)
                                  *Chunksize*)))
        (let loop ((i 0))
          (if (< i src-length)
              (begin (vector-set! (buf-buffer buf)
                                  i
                                  (vector-ref src-lines i))
                     (loop (+ 1 i)))
              (let loop ((i i))
                (if (< i (buf-size buf))
                    (begin (vector-set! (buf-buffer buf) i "")
                           (loop (+ 1 i)))))))))
  (vector-set! (buf-buffer buf) pos line))

(define (info buf msg)
  (set! *Message* msg)
  (buf-status buf)
  (refresh))

(define (mode buf m)
  (set! *Mode* m)
  (buf-status buf)
  (refresh))

(define (command-mode buf)
  (mode buf "command"))

(define *got-cr* #f)

(define (expand-tabs s)
  (if (not (string-scan TAB s))
      s
      (string-expand s)))

(define (read-line/expand)
  (letrec
    ((collect-chars
       (lambda (c s)
         (cond ((eof-object? c)
                 (if (null? s)
                     c
                     (expand-tabs (list->string (reverse! s)))))
               ((char=? c #\newline)
                 (expand-tabs (list->string (reverse! s))))
               ((char=? c CR)
                 (set! *got-cr* #t)
                 (collect-chars (read-char) s))
               (else
                 (collect-chars (read-char)
                                (cons c s)))))))
    (collect-chars (read-char) '())))

(define (buf-load! buf path)
  (and (file-readable? path)
       (with-input-from-file
         path
         (lambda ()
           (set! *got-cr* #f)
           (buf-set-log! buf (list 'undo '() '()))
           (let loop ((line (read-line/expand))
                      (pos  0))
             (cond ((eof-object? line)
                     (buf-set-length! buf pos)
                     (buf-set-name! buf path)
                     (if (not (file-writable? path))
                         (buf-add-prop! buf bp-readonly))
                     (info buf (format #f "~D line~:P~A"
                                          (buf-length buf)
                                          (if (buf-prop? buf bp-readonly)
                                              ", read-only"
                                              "")))
                     (if *got-cr*
                         (buf-add-prop! buf bp-crlfmode)
                         (buf-rem-prop! buf bp-crlfmode))
                     #t)
                   (else
                     (if (zero? (remainder pos 100))
                         (info buf (format #f "loading: ~D" pos)))
                     (insert-into-buf! buf pos line)
                     (loop (read-line/expand) (+ 1 pos)))))))))

(define (end-of-buffer buf)
  (max 0 (- (buf-length buf) 1)))

(define (unexpand-tabs s)
  (let* ((k (string-length s))
         (n (make-string k)))
    (let loop ((i 0)
               (j 0)
               (c 0))
      (cond ((>= i k)
              (substring n 0 j))
            ((and c (char=? #\space (string-ref s i)))
              (string-set! n j #\space)
              (if (= c 7)
                  (begin (string-set! n (- j 7) TAB)
                         (loop (+ 1 i) (- j 6) 0))
                  (loop (+ 1 i) (+ 1 j) (+ 1 c))))
            (else
              (string-set! n j (string-ref s i))
              (loop (+ 1 i) (+ 1 j) #f))))))

(define (buf-write! buf path . range)
  (catch-errors #t)
  (let* ((tmpname (string-append path
                                 "."
                                 (number->string (getpid))
                                 ".tmp")))
    (if (file-exists? tmpname)
        (remove-file tmpname))
    (if (not (fd-creat tmpname))
        (err buf (format #f "error writing file: ~A"
                            (errno->string (errno))))
        (let ((from (if (null? range)
                        0
                        (car range)))
              (to   (if (null? range)
                        (end-of-buffer buf)
                        (cadr range))))
          (remove-file tmpname)
          (with-output-to-file
            tmpname
            (lambda ()
              (let loop ((i from))
                (if (<= i to)
                    (begin (if (zero? (remainder i 100))
                               (info buf (format #f "saving: ~D" i)))
                           (if (buf-prop? buf bp-unexpand)
                               (display (unexpand-tabs (buf-line buf i)))
                               (display (buf-line buf i)))
                           (if (buf-prop? buf bp-crlfmode)
                               (write-char CR))
                           (newline)
                           (loop (+ 1 i)))))))
          (let ((mode (cond ((stat-file path)
                              => (lambda (x) (cdr (assq 'mode x))))
                            (else
                              (errno)
                              #f))))
            (if (file-exists? path) 
                (remove-file path))
            (rename-file tmpname path)
            (if mode
                (chmod path mode))
            (catch-errors #f)
        (let ((e (errno)))
          (if (not (zero? e))
              (err buf (format #f "error writing file: ~A"
                                  (errno->string e)))
                  (info buf
                        (format #f "~D lines written"
                                   (+ 1 (- to from)))))))))))

(define (buf-save! buf yes!)
  (cond ((buf-transient? buf)
          (err "buffer is transient!"))
        ((buf-readonly? buf)
          (if yes!
              (begin (buf-write! buf (buf-name buf))
                     (buf-rem-prop! buf bp-modified)
                     'ok)
              (err buf
                   "buffer is read-only! use :w! or :x! to write anyway.")))
        ((not (buf-name buf))
          (err buf "buffer has no name! use \":w name\" to supply one"))
        (else
          (buf-write! buf (buf-name buf))
          (buf-rem-prop! buf bp-modified)
          'ok)))

(define (fast-mode buf)
  (mode buf "busy")
  (set! *Update* #f))

(define (slow-mode buf)
  (set! *Update* #t)
  (buf-display buf)
  (command-mode buf))

(define (underline on)
  (if on
      (attr-underline)
      (attr-normal)))

(define (so buf)
  (if (buf-prop? buf bp-standout)
      (standout)))

(define (se buf)
  (if (buf-prop? buf bp-standout)
      (standend)))

(define (advance buf)
  (buf-set-x! buf (+ 1 (buf-x buf)))
  (cond ((buf-cur-char buf)
          => (lambda (x) x))
        ((at-last-line? buf)
          #f)
        (else
          (buf-set-y! buf (+ 1 (buf-y buf)))
          (buf-set-x! buf -1)
          #\space)))

(define (backup buf)
  (buf-set-x! buf (- (buf-x buf) 1))
  (cond ((buf-cur-char buf)
          => (lambda (x) x))
        ((zero? (buf-y buf))
          #f)
        (else
          (buf-set-y! buf (- (buf-y buf) 1))
          (move-to-eol buf)
          (buf-set-x! buf (+ 1 (buf-x buf)))
          #\space)))

(define (adjust-screen-top buf)
  (cond ((>= (screen-line buf)
             (text-lines))
          (buf-set-top! buf (- (buf-y buf)
                               (text-lines)
                               -1)))
        ((< (buf-y buf) (buf-top buf))
          (buf-set-top! buf (buf-y buf)))))

(define (buf-display buf)
  (adjust-screen-top buf)
  (cond (*Update*
          (let loop ((i (buf-top buf))
                       (y 0))
            (if (< y (text-lines))
                (begin (move y 0)
                       (clrtoeol)
                       (if (< i (buf-length buf))
                           (addstr (clip-right (buf-line buf i) (cols)))
                           (addstr "~"))
                       (loop (+ 1 i) (+ 1 y)))
                (refresh))))))

(define (buf-status buf)
  (let ((lim  (- (cols) 42))
        (lb   #\[)
        (rb   #\])
        (name (if (buf-name buf)
                  (buf-name buf)
                  " *anonymous* ")))
    (move (- (lines) 1) 0)
    (so buf)
    (cond (*Message*
            (addstr (make-string (cols) #\space))
            (mvaddstr (- (lines) 1) 0 *Message*))
          ((not (buf-prop? buf bp-showmode))
            (clrtoeol)
            'ok)
          (else
            (addstr (make-string (cols) #\=))
            (let* ((name-len (string-length name))
                   (base-len (string-length (basename name)))
                   (name     (cond ((> base-len lim)
                                     (set! rb #\>)
                                     (if (string-find "/" name)
                                         (set! lb #\<))
                                     (clip-right (basename name) lim))
                                   ((> name-len lim)
                                     (set! lb #\<)
                                     (clip-left name lim))
                                   (else
                                     name))))
              (mvaddstr (- (lines) 1)
                        5
                        (format #f " L~A/~A C~A ~C~C ~C~@A~C (~A) "
                                   (+ 1 (buf-y buf))
                                   (buf-length buf)
                                   (+ 1 (buf-x buf))
                                   (cond ((buf-modified? buf)  #\M)
                                         ((buf-transient? buf) #\T)
                                         (else                 #\-))
                                   (if (buf-readonly? buf) #\R #\-)
                                   lb
                                   name
                                   rb
                                   *Mode*)))))
      (se buf)))

(define (set-cursor buf)
  (let ((x (max (min (- (buf-cur-length buf) 1)
                     (buf-x buf))
                0)))
    (move (screen-line buf) x)))

(define (hl-matching-rp buf on)
  (let ((here (save-pos buf))
        (lim  (+ (text-lines) (buf-top buf))))
    (let loop ((ch (advance buf))
               (n  0))
      (cond ((or (not ch) (>= (buf-y buf) lim))
              (restore-pos buf here)
              #f)
            ((char=? ch LP)
              (loop (advance buf) (+ 1 n)))
            ((char=? ch RP)
              (cond ((zero? n)
                      (set-cursor buf)
                      (if on (underline #t))
                      (addch RP)
                      (if on (underline #f))
                      (reset-pos buf here)
                      #t)
                    (else
                      (loop (advance buf) (- n 1)))))
            (else
              (loop (advance buf) n))))))

(define (hl-matching-lp buf on)
  (let ((here (save-pos buf))
        (lim  (buf-top buf)))
    (let loop ((ch (backup buf))
               (n  0))
      (cond ((or (not ch) (< (buf-y buf) lim))
              (restore-pos buf here)
              #f)
            ((char=? ch RP)
              (loop (backup buf) (+ 1 n)))
            ((char=? ch LP)
              (cond ((zero? n)
                      (set-cursor buf)
                      (if on (underline #t))
                      (addch LP)
                      (if on (underline #f))
                      (reset-pos buf here)
                      #t)
                    (else
                      (loop (backup buf) (- n 1)))))
            (else
              (loop (backup buf) n))))))

(define (sync buf on)
  (if (>= (buf-x buf) (cols))
      (buf-set-x! buf (- (cols) 1)))
  (let ((hl (if (buf-prop? buf bp-showmatch)
                (case (buf-cur-char buf)
                      ((#\() (hl-matching-rp buf on))
                      ((#\)) (hl-matching-lp buf on))))))
    (set-cursor buf)
    hl))

(define (key-pending?)
  (nodelay #t)
  (let ((k (getch)))
    (nodelay #f)
    (if k
        (begin (ungetch k)
               #t)
        #f)))

(define (get-key buf do-sync)
  (let ((hl (and (not (key-pending?))
                      do-sync
                      (sync buf #t))))
    (let ((k (getch)))
      (if hl (sync buf #f))
      (set! *Message* #f)
      (cond ((= k *key-up*)        #\k)
            ((= k *key-down*)      #\j)
            ((= k *key-left*)      #\h)
            ((= k *key-right*)     #\l)
            ((= k *key-ppage*)     ^B)
            ((= k *key-npage*)     ^F)
            ((= k *key-home*)      #\^)
            ((= k *key-backspace*) ^H)
            ((> k 126)             (integer->char 0))
            (else                  (integer->char k))))))

(define (get-arg buf k)
  (let loop ((k k)
             (s '()))
    (if (and (char-numeric? k)
             (or (not (char=? #\0 k))
                 (not (null? s))))
        (loop (get-key buf #f) (cons k s))
        (list k (string->number (list->string (reverse! s)))))))

(define (get-cmd buf)
  (get-arg buf (get-key buf #t)))

(define (get-line y buf prompt repc)
  (let* ((lim 256)
         (rk  (if repc
                  (string-length repc)
                  0))
         (s   "")
         (o   (string-length prompt))
         (t   0)
         (i   0)
         (z   0))
    (move y 0)
    (clrtoeol)
    (so buf)
    (addstr prompt)
    (se buf)
    (let loop ()
      (if (> (- i t) (- (cols) o 2))
          (set! t (- i (- (cols) o 2))))
      (if (< i t)
          (set! t i))
      (mvaddstr y o (substring s t (+ t (min (- z t)
                                             (- (cols) o 2)))))
      (clrtoeol)
      (if (and repc (< z rk))
          (addstr (substring repc z rk)))
      (move y (+ o (- i t)))
      (let ((k (getch)))
        (cond ((= k 27)
                (info buf #f)
                s)
              ((and (not repc)
                    (= k 13))
                (info buf #f)
                s)
              ((and (<= 32 k 126)
                    (< z (- lim 1)))
                (set! s (string-append (substring s 0 i)
                                       (string (integer->char k))
                                       (substring s i z)))
                (set! i (+ 1 i))
                (set! z (+ 1 z))
                (loop))
              ((= k *key-backspace*)
                (cond ((zero? i)
                        (cond ((zero? z)
                                #f)
                              (else
                                (ring-bell buf)
                                (loop))))
                      (else
                        (set! i (- i 1))
                        (set! s (string-append (substring s 0 i)
                                               (substring s (+ 1 i) z)))
                        (set! z (- z 1))
                        (loop))))
              ((and (not repc)
                    (= k 1))
                (set! i 0)
                (loop))
              ((and (not repc)
                    (= k 5))
                (set! i z)
                (loop))
              ((= k 21)
                (set! i 0)
                (set! z 0)
                (set! s "")
                (loop))
              ((and (not repc)
                    (< i z)
                    (or (= k *key-right*)
                        (= k 6)))
                (set! i (+ 1 i))
                (loop))
              ((and (not repc)
                    (positive? i)
                    (or (= k *key-left*)
                        (= k 2)))
                (set! i (- i 1))
                (loop))
              (else
                (beep)
                (loop)))))))

(define (ok? x)
  (eq? x 'ok))

(define (failed? x)
  (eq? x 'failed))

(define (ring-bell buf)
  (if (buf-prop? buf 'bp-errorbells)
      (beep)))

(define (err buf . args)
  (ring-bell buf)
  (if (not (null? args))
      (set! *Message* (apply format #f args)))
  'failed)

(define (goto-line buf n)
  (if (< n (buf-length buf))
      (begin (buf-set-y! buf n)
             (buf-set-x! buf 0)
             (buf-display buf)
             'ok)
      (err buf "~D: no such line" (+ 1 n))))

(define (move-to-line buf n)
  (let ((n (if (not n)
               (last-line buf)
               (- n 1))))
    (goto-line buf n)))

(define (goto-col buf n)
  (if (or (zero? n)
          (< n (min (cols) (buf-cur-length buf))))
      (begin (buf-set-x! buf n)
             'ok)
      (err buf "~D: no such column" (+ 1 n))))

(define (move-to-col buf n)
  (goto-col buf (- n 1)))

(define (move-to-eol buf)
  (buf-set-x! buf (max 0 (- (min (cols) (buf-cur-length buf)) 1)))
  (if (buf-next-char buf)
      'failed
      'ok))

(define (real-pos! buf)
  (if (not (buf-cur-char buf))
      (begin (move-to-eol buf)
             (buf-status buf))))

(define (move-right buf c)
  (real-pos! buf)
  (let* ((lim (string-length (buf-cur-line buf)))
         (lim (min lim (cols))))
    (if (>= (+ c (buf-x buf)) lim)
        (err buf)
        (begin (buf-set-x! buf (+ c (buf-x buf)))
               'ok))))

(define (move-left buf c)
  (real-pos! buf)
  (if (negative? (- (buf-x buf) c))
      (err buf)
      (begin (buf-set-x! buf (- (buf-x buf) c))
             'ok)))

(define (move-down buf c)
  (if (>= (+ c (buf-y buf))
          (buf-length buf))
      (err buf)
      (begin (buf-set-y! buf (+ c (buf-y buf)))
             (buf-display buf)
             'ok)))

(define (move-up buf c)
  (if (negative? (- (buf-y buf) c))
      (err buf)
      (begin (buf-set-y! buf (- (buf-y buf) c))
             (buf-display buf)
             'ok)))

(define (move-bottom buf c)
  (if (> c (text-lines))
      (err buf)
      (let ((bot (+ (buf-top buf)
                    (text-lines)
                    (- c))))
        (goto-line buf (min bot (last-line buf))))))

(define (move-top buf c)
  (if (> c (text-lines))
      (err buf)
      (let ((top (+ (buf-top buf) (- c 1))))
        (if (>= top (buf-length buf))
            (err buf)
            (goto-line buf top)))))

(define (move-middle buf)
  (move-top buf (quotient (text-lines) 2)))

(define (move-next-word buf c big half)
  (real-pos! buf)
  (let ((word? (if big
                   (case (buf-val buf bv-wordset)
                         ((1)  char-symbolic?)
                         ((2)  char-non-whitespace?)
                         ((3)  char-non-whitespace?)
                         (else char-non-whitespace?))
                   (case (buf-val buf bv-wordset)
                         ((1)  char-alphanumeric?)
                         ((2)  char-alphanumeric?)
                         ((3)  char-symbolic?)
                         (else char-alphanumeric?))))
        (pos   (save-pos buf)))
    (let c-loop ((c (- c 1)))
      (let* ((ch    (if (buf-cur-char buf)
                    (buf-cur-char buf)
                    #\space))
             (skip? (cond ((word? ch)
                            word?)
                          ((char-whitespace? ch)
                            (lambda (x) #f))
                          (else
                            (lambda (x)
                              (and (not (char-whitespace? x))
                                   (not (word? x))))))))
        (let loop ((ch (advance buf)))
          (cond ((not ch)
                  (restore-pos buf pos)
                  (err buf))
                ((skip? ch)
                  (loop (advance buf)))
                (half
                  (cond ((positive? (buf-x buf))
                          (buf-set-x! buf (- (buf-x buf) 1)))
                        ((negative? (buf-x buf))
                          (backup buf)
                          (if (and (positive? (buf-x buf))
                                   (not (buf-cur-char buf)))
                              (buf-set-x! buf (- (buf-x buf) 1)))))
                  (buf-display buf)
                  'ok)
                (else
                  (let loop ((ch ch))
                    (cond ((not ch)
                            (restore-pos buf pos)
                            (err buf))
                          ((char-whitespace? ch)
                            (loop (advance buf)))
                          ((positive? c)
                            (c-loop (- c 1)))
                          (else
                            (buf-display buf)
                            'ok))))))))))

(define (move-end-of-word buf c big)
  (move-next-word buf (- c 1) big #f)
  (move-next-word buf 1 big #t))

(define (move-prev-word buf c big)
  (real-pos! buf)
  (let ((word? (if big
                   (case (buf-val buf bv-wordset)
                         ((1)  char-symbolic?)
                         ((2)  char-non-whitespace?)
                         ((3)  char-non-whitespace?)
                         (else char-non-whitespace?))
                   (case (buf-val buf bv-wordset)
                         ((1)  char-alphanumeric?)
                         ((2)  char-alphanumeric?)
                         ((3)  char-symbolic?)
                         (else char-alphanumeric?))))
        (pos   (save-pos buf)))
    (let c-loop ((c (- c 1)))
      (let loop ((ch (backup buf)))
        (cond ((not ch)
                (restore-pos buf pos)
                (err buf))
              ((char-whitespace? ch)
                (loop (backup buf)))
              (else
                (let ((skip? (if (word? ch)
                                 word?
                                 (lambda (x)
                                   (and (not (char-whitespace? x))
                                        (not (word? x)))))))
                  (let loop ((ch ch))
                    (cond ((and ch (skip? ch))
                            (loop (backup buf)))
                          ((positive? c)
                            (c-loop (- c 1)))
                          (else
                            (advance buf)
                            (if (negative? (buf-x buf))
                                (buf-set-x! buf 0))
                            (buf-display buf)
                            'ok))))))))))

(define (center-line buf c mode)
  (let ((s (if c
               (goto-line buf c)
               'ok)))
    (if (not (failed? s))
        (let* ((d (case mode
                        ((#\.) (quotient (text-lines) 2))
                        ((#\-) (- (text-lines) 1))
                        (else  0)))
               (z (if (negative? (- c d))
                      0
                      (- c d))))
          (buf-set-top! buf z)
          (buf-display buf)
          'ok)
        'failed)))

(define (goto-mark buf also-col)
  (let ((m (buf-mark buf)))
  (if (not m)
      (err buf "mark not set")
      (begin (center-line buf (car m) #\.)
             (if also-col
                 (goto-col buf (cadr m)))
             'ok))))

(define (move-to-mark buf also-col)
  (sync buf #f)
  (if (not (char=? (get-key buf #f) #\m))
      (if also-col
          (err buf "usage: [`][m]")
          (err buf "usage: ['][m]"))
      (goto-mark buf also-col)))

(define (move-to-first buf)
  (buf-set-x! buf 0)
  (let loop ((ch (buf-cur-char buf)))
    (if (and ch (char-whitespace? ch))
        (begin (buf-set-x! buf (+ 1 (buf-x buf)))
               (loop (buf-cur-char buf)))
        'ok)))

(define (move-down-first buf c)
  (move-down buf c)
  (move-to-first buf))

(define (move-up-first buf c)
  (move-up buf c)
  (move-to-first buf))

(define (match-rp buf visual)
  (let ((here (save-pos buf))
        (lim  (+ (text-lines) (buf-top buf))))
    (let loop ((ch (advance buf))
               (n  0))
      (cond ((not ch)
              (restore-pos buf here)
              (err buf))
            ((char=? ch LP)
              (loop (advance buf) (+ 1 n)))
            ((char=? ch RP)
              (cond ((zero? n)
                      (cond ((and visual
                                  (> (buf-x buf) (- (cols) 1)))
                              (restore-pos buf here)
                              (err buf))
                            (else
                              (if (>= (buf-y buf) lim)
                                  (let ((x (buf-x buf)))
                                    (center-line buf (buf-y buf) #\-)
                                    (buf-set-x! buf x)))
                              'ok)))
                    (else
                      (loop (advance buf) (- n 1)))))
            (else
              (loop (advance buf) n))))))

(define (match-lp buf visual)
  (let ((here (save-pos buf))
        (lim  (buf-top buf)))
    (let loop ((ch (backup buf))
               (n  0))
      (cond ((not ch)
              (restore-pos buf here)
              (err buf))
            ((char=? ch RP)
              (loop (backup buf) (+ 1 n)))
            ((char=? ch LP)
              (cond ((zero? n)
                      (cond ((and visual
                                  (> (buf-x buf) (- (cols) 1)))
                              (restore-pos buf here)
                              (err buf))
                            (else
                              (if (< (buf-y buf) lim)
                                  (let ((x (buf-x buf)))
                                    (center-line buf (buf-y buf) CR)
                                    (buf-set-x! buf x)))
                              'ok)))
                    (else
                      (loop (backup buf) (- n 1)))))
            (else
              (loop (backup buf) n))))))

(define (match-paren buf visual)
  (real-pos! buf)
  (cond ((not (char? (buf-cur-char buf))) (err buf))
        ((char=? LP (buf-cur-char buf))   (match-rp buf visual))
        ((char=? RP (buf-cur-char buf))   (match-lp buf visual))
        (else (err buf))))

(define (string-pos buf u s)
  (cond ((buf-prop? buf bp-regex)
          (let ((r (re-match (re-comp u) s)))
            (and r
                 (not (null? r))
                 (caar r))))
        ((buf-prop? buf bp-ignorecase)
          (string-ci-position u s))
        (else
          (string-locate u s))))

(define (find-next buf text)
  (real-pos! buf)
  (let ((text (if (string=? "" text)
                  (buf-searchbuf buf)
                  text)))
    (buf-set-searchbuf! buf text)
    (cond ((string=? "" text)
            (err buf "no previous search text"))
          ((zero? (buf-length buf))
            'failed)
          ((and (> (buf-cur-length buf) (buf-x buf))
                (string-pos buf text (substring (buf-cur-line buf)
                                               (+ 1 (buf-x buf))
                                               (buf-cur-length buf))))
            => (lambda (col)
                 (goto-col buf (+ 1 (buf-x buf) col))
                 'ok))
          (else
            (info buf "searching...")
            (let loop ((y (+ 1 (buf-y buf))))
              (cond ((>= y (buf-length buf))
                      (err buf "string not found"))
                    ((string-pos buf text (buf-line buf y))
                      => (lambda (col)
                           (if (buf-prop? buf bp-autocenter)
                               (center-line buf y #\.)
                               (goto-line buf y))
                           (goto-col buf col)
                           (info buf #f)
                           'ok))
                    (else
                      (loop (+ 1 y)))))))))

(define (search-forward buf)
  (buf-set-revsearch! buf #f)
  (let ((text (get-line (text-lines) buf "/" #f)))
    (if (not text)
        'failed
        (find-next buf text))))

(define (string-last-pos buf u s)
  (cond ((buf-prop? buf bp-regex)
          (let ((r (re-match (re-comp u) s 'all)))
            (and r
                 (not (null? r))
                 (caaar (reverse! r)))))
        ((buf-prop? buf bp-ignorecase)
          (string-ci-last-position u s))
        (else
          (string-last-position u s))))

(define (find-previous buf text)
  (real-pos! buf)
  (let ((text (if (string=? "" text)
                  (buf-searchbuf buf)
                  text)))
    (buf-set-searchbuf! buf text)
    (cond ((string=? "" text)
            (err buf "no previous search text"))
          ((zero? (buf-length buf))
            'failed)
          ((string-last-pos buf text (substring (buf-cur-line buf)
                                                0
                                                (buf-x buf)))
            => (lambda (col)
                 (goto-col buf col)
                 'ok))
          (else
            (info buf "searching...")
            (let loop ((y (- (buf-y buf) 1)))
              (cond ((negative? y)
                      (err buf "string not found"))
                    ((string-last-pos buf text (buf-line buf y))
                      => (lambda (col)
                           (if (buf-prop? buf bp-autocenter)
                               (center-line buf y #\.)
                               (goto-line buf y))
                           (goto-col buf col)
                           (info buf #f)
                           'ok))
                    (else
                      (loop (- y 1)))))))))

(define (search-backward buf)
  (buf-set-revsearch! buf #t)
  (let ((text (get-line (text-lines) buf "?" #f)))
    (if (not text)
        'failed
        (find-previous buf text))))

(define (search-again buf rev)
  (if (eq? (buf-revsearch buf) rev)
      (find-next buf "")
      (find-previous buf "")))

(define (move-prev-expr buf c)
  (real-pos! buf)
  (let ((pos  (save-pos buf)))
    (let c-loop ((c (- c 1)))
      (let loop ((ch (backup buf)))
        (cond ((not ch)
                (restore-pos buf pos)
                (err buf))
              ((not (char=? ch LP))
                (loop (backup buf)))
              (else
                (let loop ((ch ch))
                  (cond ((and ch (char=? LP ch))
                          (loop (backup buf)))
                        ((positive? c)
                          (c-loop (- c 1)))
                        (else
                          (advance buf)
                          (if (negative? (buf-x buf))
                              (buf-set-x! buf 0))
                          (buf-display buf)
                          'ok)))))))))

(define (move-next-expr buf c)
  (real-pos! buf)
  (let ((pos  (save-pos buf)))
    (let c-loop ((c (- c 1)))
      (let* ((ch (if (buf-cur-char buf)
                 (buf-cur-char buf)
                 #\space))
             (skip? (lambda (x)
                      (not (char=? RP x)))))
        (let loop ((ch (advance buf)))
          (cond ((not ch)
                  (restore-pos buf pos)
                  (err buf))
                ((skip? ch)
                  (loop (advance buf)))
                (else
                  (let loop ((ch ch))
                    (cond ((not ch)
                            (restore-pos buf pos)
                            (err buf))
                          ((and #f(char=? RP ch))
                            (loop (advance buf)))
                          ((positive? c)
                            (c-loop (- c 1)))
                          (else
                            (buf-display buf)
                            'ok))))))))))

(define (move-end-of-para buf c)
  (let ((org (save-pos buf)))
    (buf-set-x! buf 0)
    (let c-loop ((i (- c 1)))
      (let loop ()
        (if (and (< (buf-y buf) (buf-length buf))
                 (zero? (buf-cur-length buf)))
            (begin (buf-set-y! buf (+ 1 (buf-y buf)))
                   (loop))
            (let loop ()
              (if (and (< (buf-y buf) (buf-length buf))
                       (not (zero? (buf-cur-length buf))))
                  (begin (buf-set-y! buf (+ 1 (buf-y buf)))
                         (loop))
                  (cond ((= (buf-y buf) (buf-length buf))
                          (restore-pos buf org)
                          (err buf))
                        ((zero? i)
                          (buf-display buf)
                          'ok)
                        (else
                          (c-loop (- i 1)))))))))))

(define (move-top-of-para buf c)
  (let ((org (save-pos buf)))
    (buf-set-x! buf 0)
    (let c-loop ((i (- c 1)))
      (let loop ()
        (if (and (positive? (buf-y buf))
                 (zero? (buf-cur-length buf)))
            (begin (buf-set-y! buf (- (buf-y buf) 1))
                   (loop))
            (let loop ()
              (if (and (positive? (buf-y buf))
                       (not (zero? (buf-cur-length buf))))
                  (begin (buf-set-y! buf (- (buf-y buf) 1))
                         (loop))
                  (cond ((positive? (buf-cur-length buf))
                          (restore-pos buf org)
                          (err buf))
                        ((zero? i)
                          (buf-display buf)
                          'ok)
                        (else
                          (c-loop (- i 1)))))))))))

(define (find-next-char buf c onto prompt)
  (let ((ch (if prompt
                (get-key buf #f)
                (buf-scanchr buf))))
    (buf-set-scanchr! buf ch)
    (buf-set-revscan! buf #f)
    (buf-set-scan-onto! buf onto)
    (if (not ch)
        (err buf)
        (let c-loop ((x (+ 1 (buf-x buf)))
                     (i (- c 1)))
          (let loop ((x x))
            (cond ((or (and onto       (not (buf-char buf x)))
                       (and (not onto) (not (buf-char buf (+ 1 x)))))
                    (err buf))
                  ((or (and onto       (char=? ch (buf-char buf x)))
                       (and (not onto) (char=? ch (buf-char buf (+ 1 x)))))
                    (if (zero? i)
                        (begin (goto-col buf x)
                               'ok)
                        (c-loop (+ 1 x) (- i 1))))
                  (else
                    (loop (+ 1 x)))))))))

(define (find-prev-char buf c onto prompt)
  (let ((ch (if prompt
                (get-key buf #f)
                (buf-scanchr buf))))
    (buf-set-scanchr! buf ch)
    (buf-set-revscan! buf #t)
    (buf-set-scan-onto! buf onto)
    (if (not ch)
        (err buf)
        (let c-loop ((x (- (buf-x buf) 1))
                     (i (- c 1)))
          (let loop ((x x))
            (cond ((or (and onto       (not (buf-char buf x)))
                       (and (not onto) (not (buf-char buf (- x 1)))))
                    (err buf))
                  ((or (and onto       (char=? ch (buf-char buf x)))
                       (and (not onto) (char=? ch (buf-char buf (- x 1)))))
                    (if (zero? i)
                        (begin (goto-col buf x)
                               'ok)
                        (c-loop (- x 1) (- i 1))))
                  (else
                    (loop (- x 1)))))))))

(define (repeat-find-char buf nc)
  (if (buf-revscan buf)
      (find-prev-char buf nc (buf-scan-onto buf) #f)
      (find-next-char buf nc (buf-scan-onto buf) #f)))

(define (reverse-find-char buf nc)
  (if (buf-revscan buf)
      (find-next-char buf nc (buf-scan-onto buf) #f)
      (find-prev-char buf nc (buf-scan-onto buf) #f))
  (buf-set-revscan! buf (not (buf-revscan buf))))

(define (extract-ident buf)
  (if (or (not (buf-cur-char buf))
          (not (char-symbolic? (buf-cur-char buf))))
      #f
      (let loop ((i0 (buf-x buf)))
            (if (or (zero? i0)
                    (not (char-symbolic? (buf-char buf (- i0 1)))))
                (let loop ((iN (buf-x buf)))
                  (if (or (not (buf-char buf iN))
                          (not (char-symbolic? (buf-char buf iN))))
                      (list i0 iN)
                      (loop (+ 1 iN))))
                (loop (- i0 1))))))

(define (search-ident buf)
  (let ((pos2 (extract-ident buf)))
    (if (not pos2)
        (err buf)
        (find-next buf (apply substring (buf-cur-line buf) pos2)))))

(define (motion-command buf k c)
  (let ((nc (if c c 1)))
    (cond ((char=? k ^A)  (search-ident buf))
          ((char=? k ^H)  (move-left buf nc))
          ((char=? k ^J)  (move-down buf nc))
          ((char=? k CR)  (move-down-first buf nc))
          ((char=? k ^N)  (move-down buf nc))
          ((char=? k SP)  (move-right buf nc))
          ((char=? k #\0) (buf-set-x! buf 0) 'ok)
          ((char=? k #\$) (move-to-eol buf))
          ((char=? k #\b) (move-prev-word buf nc #f))
          ((char=? k #\e) (move-end-of-word buf nc #f))
          ((char=? k #\f) (find-next-char buf nc #t #t))
          ((char=? k #\h) (move-left buf nc))
          ((char=? k #\j) (move-down buf nc))
          ((char=? k #\k) (move-up buf nc))
          ((char=? k #\l) (move-right buf nc))
          ((char=? k #\n) (search-again buf #f))
          ((char=? k #\t) (find-next-char buf nc #f #t))
          ((char=? k #\w) (move-next-word buf nc #f #f))
          ((char=? k #\B) (move-prev-word buf nc #t))
          ((char=? k #\E) (move-end-of-word buf nc #t))
          ((char=? k #\F) (find-prev-char buf nc #t #t))
          ((char=? k #\G) (move-to-line buf c))
          ((char=? k #\H) (move-top buf nc))
          ((char=? k #\L) (move-bottom buf nc))
          ((char=? k #\M) (move-middle buf))
          ((char=? k #\N) (search-again buf #t))
          ((char=? k #\T) (find-prev-char buf nc #f #t))
          ((char=? k #\W) (move-next-word buf nc #t #f))
          ((char=? k #\%) (match-paren buf #t))
          ((char=? k #\') (move-to-mark buf #f))
          ((char=? k LP)  (move-prev-expr buf nc))
          ((char=? k RP)  (move-next-expr buf nc))
          ((char=? k #\+) (move-down-first buf nc))
          ((char=? k #\,) (reverse-find-char buf nc))
          ((char=? k #\-) (move-up-first buf nc))
          ((char=? k #\/) (search-forward buf))
          ((char=? k #\?) (search-backward buf))
          ((char=? k #\;) (repeat-find-char buf nc))
          ((char=? k #\^) (move-to-first buf))
          ((char=? k #\`) (move-to-mark buf #t))
          ((char=? k #\{) (move-top-of-para buf nc))
          ((char=? k #\|) (move-to-col buf nc))
          ((char=? k #\}) (move-end-of-para buf nc))
          (else           'no))))

(define (delete-by-col buf from to)
  (let ((line (buf-cur-line buf)))
    (let ((left   (substring line 0 from))
          (middle (substring line from to))
          (right  (substring line to (string-length line))))
      (log-del-chars buf middle)
      (buf-set-cur-line! buf (string-append left right)))))

(define (delete-char-forw buf c)
  (real-pos! buf)
  (if (> (+ c (buf-x buf)) (buf-cur-length buf))
      (err buf)
      (begin (log-new buf)
             (buf-clear-yanked! buf)
             (yank-by-col buf (buf-x buf) (+ (buf-x buf) c))
             (buf-add-yanked! buf 'col)
             (delete-by-col buf (buf-x buf) (+ (buf-x buf) c))
             (buf-modified! buf)
             (buf-display buf)
             'ok)))

(define (delete-char-backw buf c)
  (real-pos! buf)
  (if (< (buf-x buf) c)
      (err buf)
      (begin (buf-set-x! buf (- (buf-x buf) c))
             (delete-char-forw buf c))))

(define (insert-char ch tail)
  (addch ch)
  (addstr tail)
  ch)

(define (display-newline y o tail)
  (let ((y (+ y 1)))
    (cond ((> y (- (text-lines) 1))
            (clrtoeol)
            (move 0 0)
            (deleteln)
            (move (- (text-lines) 1) 0)
            (clrtoeol)
            (addstr (make-string o #\space))
            (addstr tail))
          (else
            (clrtoeol)
            (move y 0)
            (insertln)
            (addstr (make-string o #\space))
            (addstr tail)))))

(define (offset s)
  (let ((k (string-length s)))
    (let loop ((i 0))
      (if (or (>= i k)
              (not (char=? #\space (string-ref s i))))
          i
          (loop (+ 1 i))))))

(define (add-offset n a)
  (if (zero? n)
      a
      (cons #\space (add-offset (- n 1) a))))

(define (new-offset s old)
  (let loop ((s s)
             (n 0))
    (cond ((null? s)
            old)
          ((char=? #\newline (car s))
            n)
          ((char=? #\space (car s))
            (loop (cdr s) (+ 1 n)))
          (else
            (loop (cdr s) 0)))))

(define (trim-blank-lines text tail)
  (letrec
    ((trim
       (lambda (ln)
         (let loop ((x ln))
           (cond ((null? x)
                   '())
                 ((not (memv (car x) '(#\space #\newline)))
                   ln)
                 (else
                   (loop (cdr x))))))))
    (let loop ((in  text)
               (ln  '())
               (out '()))
      (cond ((null? in)
              (if (string=? "" tail)
                  (append out (trim (reverse! ln)))
                  (append out (reverse! ln))))
            ((char=? #\newline (car in))
              (let* ((ln  (trim (reverse! ln)))
                     (out (append out ln '(#\newline))))
                (loop (cdr in) '() out)))
            (else
              (loop (cdr in) (cons (car in) ln) out))))))

(define (find-prefix s words)
  (let ((k (string-length s)))
    (let loop ((w words)
               (r '()))
      (cond ((null? w)
              (let ((lim (if (null? r)
                             0
                             (apply min (map string-length r)))))
                (let loop ((i k))
                  (cond ((>= i lim)
                          (if (zero? lim)
                              ""
                              (substring (car r) 0 i)))
                        ((let ((c* (map (lambda (x)
                                          (string-ref x i))
                                        r)))
                           (and (> (length c*) 1)
                                (not (apply char-ci=? c*))))
                          (substring (car r) 0 i))
                        (else
                          (loop (+ 1 i)))))))
            ((and (<= k (string-length (car w)))
                  (string-ci=? (substring (car w) 0 k) s))
              (loop (cdr w) (cons (car w) r)))
            (else
              (loop (cdr w) r))))))

(define (extract-last-symbol s)
  (do ((y '() (cons (car s) y))
       (s s   (cdr s)))
      ((or (null? s)
           (not (char-symbolic? (car s))))
        (list->string y))))

(define (insert-mode buf tail init-ch init-off)
  (mode buf "insert")
  (let loop ((y (screen-line buf))
             (x (if init-off
                    (+ init-off (buf-x buf))
                    (buf-x buf)))
             (s (if init-off
                    (string->list (make-string init-off #\space))
                    '()))
             (o (if (buf-prop? buf bp-autoindent)
                    (if init-off
                        init-off
                        (offset (buf-cur-line buf)))
                    0)))
    (move y x)
    (let ((k (if (null? init-ch)
                 (if *Repeat*
                     'ignore
                     (get-key buf #f))
                 (car init-ch))))
      (if (not (null? init-ch))
          (set! init-ch (cdr init-ch)))
      (cond (*Repeat*
              (command-mode buf)
              (cadr (buf-lastcmd buf)))
            ((char=? k ESC)
              (command-mode buf)
              (let ((text (list->string
                            (trim-blank-lines (reverse! s) tail))))
                (if (not *Repeat*)
                    (buf-set-lastcmd! buf (list (car (buf-lastcmd buf))
                                                text)))
                text))
            ((char=? k ^H)
              (cond ((or (null? s)
                         (char=? #\newline (car s)))
                      (err buf)
                      (loop y x s o))
                    (else
                      (mvaddstr y (- x 1) tail)
                      (addch #\space)
                      (loop y (- x 1) (cdr s) o))))
            ((char=? k CR)
              (let ((o (if (buf-prop? buf bp-autoindent)
                           (new-offset s o)
                           0)))
                (display-newline y o tail)
                (buf-status buf)
                (loop (min (- (text-lines) 1) (+ y 1))
                      o
                      (add-offset o (cons #\newline s))
                      o)))
            ((char=? k TAB)
              (let* ((symb   (extract-last-symbol s))
                     (kt     (string-length symb))
                     (prefix (if (zero? kt)
                                 ""
                                 (find-prefix symb *Completion-symbols*)))
                     (kp     (and (not (zero? kt))
                                  (string-length prefix))))
                (if (and kp (> kp kt))
                    (set! init-ch (string->list (substring prefix kt kp)))
                    (if (and (zero? kt)
                             (< x (- (cols) 8)))
                        (set! init-ch (list ^T))))
                (loop y x s o)))
            ((and (< x (- (cols) 1))
                  (<= 32 (char->integer k) 126))
              (loop y (+ x 1) (cons (insert-char k tail) s) o))
            ((and (< x (- (cols) 8))
                  (char=? ^T k))
              (let tab-loop ((i 0)
                             (n (- 8 (remainder x 8)))
                             (s s))
                (if (= i n)
                    (loop y (+ x n) s o)
                    (begin (move y (+ i x))
                           (tab-loop (+ 1 i)
                                     n
                                     (cons (insert-char #\space tail)
                                           s))))))
            (else
              (err buf)
              (loop y x s o))))))

(define (insert-lines buf y n)
  (if (>= (+ n (buf-length buf))
          (buf-size buf))
      (insert-into-buf! buf (+ (buf-size buf) n) ""))
  (let loop ((i (buf-length buf)))
    (if (>= i y)
        (begin (buf-set-line! buf
                              (+ n i)
                              (buf-line buf i))
               (loop (- i 1)))))
  (buf-set-length! buf (+ (buf-length buf) n))
  (buf-set-line! buf y ""))

(define (insert-text buf s)
  (if (zero? (buf-length buf))
      (buf-set-length! buf 1))
  (log-insert buf s)
  (let ((text* (if (string? s)
                   (string-split #\newline s)
                   s)))
    (if (> (length text*) 1)
        (insert-lines buf
                      (+ 1 (buf-y buf))
                      (- (length text*) 1)))
    (let loop ((text* text*))
      (cond ((null? text*)
              (if (>= (buf-y buf)
                      (+ (text-lines) (buf-top buf)))
                  (buf-set-top! buf (+ 1 (- (buf-y buf)
                                            (text-lines)))))
              (buf-display buf))
            (else
              (let* ((pre (substring (buf-cur-line buf)
                                     0
                                     (buf-x buf)))
                     (suf (substring (buf-cur-line buf)
                                     (buf-x buf)
                                     (buf-cur-length buf)))
                     (new (string-append pre
                                         (car text*)
                                         (if (null? (cdr text*))
                                             suf
                                             ""))))
                (buf-set-cur-line! buf new)
                (buf-set-x! buf (+ (string-length (car text*))
                                   (buf-x buf)))
                (if (not (null? (cdr text*)))
                    (begin (buf-set-y! buf (+ 1 (buf-y buf)))
                           (buf-set-x! buf 0)
                           (buf-set-cur-line! buf suf)))
                (loop (cdr text*))))))))

(define (insert-at-point buf c init-ch)
  (buf-modified! buf)
  (let ((tail (substring (buf-cur-line buf)
                         (buf-x buf)
                         (buf-cur-length buf))))
    (let ((s (insert-mode buf tail init-ch #f)))
      (log-new buf)
      (let loop ((c c))
        (cond ((not (zero? c))
                (insert-text buf s)
                (loop (- c 1)))
              (else
                (if (positive? (buf-x buf))
                    (buf-set-x! buf (- (buf-x buf) 1)))
                'ok))))))

(define (insert-at-bol buf c)
  (move-to-first buf)
  (insert-at-point buf c '()))

(define (append-at-point buf c)
  (cond ((>= (buf-x buf) (- (cols) 1))
          (err buf))
        (else
          (if (buf-cur-char buf)
              (buf-set-x! buf (+ 1 (buf-x buf))))
          (insert-at-point buf c '()))))

(define (append-at-eol buf c init-ch)
  (cond ((failed? (move-to-eol buf))
          (err buf))
        (else
          (if (buf-cur-char buf)
              (buf-set-x! buf (+ 1 (buf-x buf))))
          (insert-at-point buf c init-ch))))

(define (open-line buf c above)
  (if above
      (begin (buf-set-x! buf 0)
             (move (screen-line buf) 0)
             (if (= (screen-line buf) (- (text-lines) 1))
                 (begin (move (- (text-lines) 1) 0)
                        (clrtoeol))
                 (display-newline (screen-line buf)
                                  0
                                  (buf-cur-line buf)))
             (buf-modified! buf)
             (buf-status buf)
             (let ((s (insert-mode buf "" '() (offset (buf-cur-line buf)))))
               (log-new buf)
               (fast-mode buf)
               (let loop ((c c))
                 (cond ((not (zero? c))
                         (insert-text buf (string-append
                                          s
                                          (string #\newline)))
                         (loop (- c 1)))
                       (else
                         (move-up buf 1)
                         (move-to-eol buf)
                         (slow-mode buf)
                         'ok)))))
      (begin (log-new buf)
             (append-at-eol buf c (list CR)))))

(define (delete-lines buf y n)
  (let ((k (buf-length buf)))
    (let loop ((i (+ n y)))
      (if (< i k)
          (begin (buf-set-line! buf
                                (- i n)
                                (buf-line buf i))
                 (loop (+ 1 i)))))
    (buf-set-length! buf (- (buf-length buf) n))
    (if (zero? (buf-length buf))
        (buf-set-line! buf 0 ""))))

(define (trim-left s)
  (let ((k (string-length s)))
    (let loop ((i 0))
      (cond ((>= i k)
              "")
            ((char-whitespace? (string-ref s i))
              (loop (+ 1 i)))
            (else
              (substring s i k))))))

(define (join-lines buf c trim)
  (if (>= (+ (buf-y buf) c) (buf-length buf))
      (err buf)
      (let loop ((i   c)
                 (y   (+ 1 (buf-y buf)))
                 (log '()))
        (cond ((zero? i)
                (delete-lines buf (+ 1 (buf-y buf)) c)
                (let* ((x   (buf-cur-length buf))
                       (new (cons (buf-cur-line buf)
                                  (reverse! (map trim-left log))))
                       (log (cons (buf-cur-line buf)
                                  (reverse! log)))
                       (new (if trim
                                (string-unsplit #\space new)
                                (apply string-append log))))
                  (log-join buf (cons trim log))
                  (buf-set-cur-line! buf new)
                  (buf-set-x! buf x))
                (buf-display buf)
                'ok)
              (else
                (loop (- i 1)
                      (+ y 1)
                      (cons (buf-line buf y) log)))))))

(define (join-command buf c)
  (buf-modified! buf)
  (log-new buf)
  (join-lines buf c #t))

(define (break-line buf)
  (let* ((line   (buf-cur-line buf))
         (upper  (substring line 0 (buf-x buf)))
         (lower  (substring line (+ 1 (buf-x buf)) (buf-cur-length buf)))
         (lower  (trim-left lower))
         (indent (if (buf-prop? buf bp-autoindent)
                     (offset (buf-cur-line buf))
                     0))
         (lower  (string-append (make-string indent #\space) lower)))
    (buf-modified! buf)
    (log-new buf)
    (log-break buf line)
    (insert-lines buf (+ 1 (buf-y buf)) 1)
    (buf-set-cur-line! buf upper)
    (buf-set-line! buf (+ 1 (buf-y buf)) lower)
    (move-down buf 1)
    (move-to-first buf)
    (buf-display buf)
    'ok))

(define (replace-cols buf new)
  (let* ((line   (buf-cur-line buf))
         (x      (buf-x buf))
         (k      (string-length new))
         (left   (substring line 0 x))
         (right  (if (>= (+ x k) (buf-cur-length buf))
                     ""
                     (substring line (+ x k) (buf-cur-length buf)))))
    (log-new buf)
    (log-replace buf (list (buf-cur-line buf) new))
    (buf-set-line! buf
                   (buf-y buf)
                   (string-append left new right))
    (if (> k 1)
        (move-right buf (- k 1)))))

(define (replace-char buf c)
  (real-pos! buf)
  (if (> (+ (buf-x buf) c) (buf-cur-length buf))
      (err buf)
      (let ((k (begin (mode buf "replace char")
                      (if *Repeat*
                          (cadr (buf-lastcmd buf))
                          (get-key buf #t)))))
        (if (not *Repeat*)
            (buf-set-lastcmd! buf (list (car (buf-lastcmd buf)) k)))
        (buf-modified! buf)
        (command-mode buf)
        (cond ((char=? k CR)
                (break-line buf))
              ((<= 32 (char->integer k) 126)
                (replace-cols buf (make-string c k))
                (buf-display buf)
                'ok)
              (else
                (err buf))))))

(define (replace-text buf c)
  (real-pos! buf)
  (if c
      (err buf "#R: not supported")
      (let ((new (if *Repeat*
                     (cadr (buf-lastcmd buf))
                     (get-line (screen-line buf)
                               buf
                               (substring (buf-cur-line buf)
                                          0
                                          (buf-x buf))
                               (substring (buf-cur-line buf)
                                          (buf-x buf)
                                          (buf-cur-length buf))))))
        (buf-set-lastcmd! buf (list (car (buf-lastcmd buf)) new))
        (replace-cols buf new)
        (buf-display buf)
        'ok)))

(define (delete-to-eol buf)
  (real-pos! buf)
  (if (zero? (buf-cur-length buf))
      (err buf)
      (begin (log-new buf)
             (buf-modified! buf)
             (buf-clear-yanked! buf)
             (yank-by-col buf (buf-x buf) (buf-cur-length buf))
             (buf-add-yanked! buf 'col)
             (delete-by-col buf (buf-x buf) (buf-cur-length buf))
             (if (positive? (buf-x buf))
                 (buf-set-x! buf (- (buf-x buf) 1)))
             (buf-display buf)
             'ok)))

(define (delete-by-line buf c)
  (if (> (+ c (buf-y buf)) (buf-length buf))
      (err buf)
      (let loop ((i   c)
                 (y   (buf-y buf))
                 (log '()))
        (cond ((zero? i)
                (buf-set-x! buf 0)
                (log-del-lines buf log)
                (delete-lines buf (buf-y buf) c)
                (cond ((>= (buf-y buf) (buf-length buf))
                        (buf-set-y! buf (max 0 (- (buf-length buf) 1))))
                      ((and (positive? (buf-y buf))
                            (>= (buf-y buf) (buf-length buf)))
                        (move-up buf 1)))
                (buf-display buf)
                'ok)
              (else
                (loop (- i 1)
                      (+ y 1)
                      (cons (buf-line buf y) log)))))))

(define-syntax swap!
  (syntax-rules ()
    ((_ a b)
      (let ((t a))
        (set! a b)
        (set! b t)))))

(define (line-motion? x k)
  (or (and (zero? x)
           (memv k '(#\{ #\}))
           #t)
      (and (memv k '(#\' #\j #\k #\H #\L #\M #\G))
           #t)))

(define (one-more-char? k)
  (or (and (memv k '(#\% #\f #\t))
           #t)
      (and (not *Repeat*)
           (memv k '(#\; #\,))
           #t)))

(define (delete-region k buf origin)
  (fast-mode buf)
  (let ((pos (save-pos buf)))
    (yank-region k buf origin)
    (reset-pos buf pos)
    (buf-modified! buf)
    (let ((y0 (saved-y origin))
          (x0 (saved-x origin))
          (dy (buf-y buf))
          (dx (buf-x buf)))
      (if (> y0 dy)
          (begin (swap! y0 dy)
                 (swap! x0 dx)))
      (if (and (= y0 dy)
               (> x0 dx))
          (swap! x0 dx))
      (let ((dx (if (one-more-char? k)
                    (+ 1 dx)
                    dx)))
        (cond ((line-motion? x0 k)
                (goto-line buf y0)
                (log-new buf)
                (delete-by-line buf (+ 1 (- dy y0)))
                (if (< (saved-y origin) (saved-y pos))
                    (restore-pos buf origin))
                (slow-mode buf)
                'ok)
              ((= y0 dy)
                (goto-col buf x0)
                (delete-char-forw buf (- dx x0))
                (slow-mode buf)
                'ok)
              (else
                (goto-line buf y0)
                (goto-col buf x0)
                (log-new buf)
                (delete-by-col buf (buf-x buf) (buf-cur-length buf))
                (buf-set-y! buf (+ 1 (buf-y buf)))
                (delete-by-line buf (- dy y0 1))
                (delete-by-col buf 0 dx)
                (buf-set-y! buf (- (buf-y buf) 1))
                (join-lines buf 1 #f)
                (if (< (saved-y origin) (saved-y pos))
                    (restore-pos buf origin))
                (slow-mode buf)
                'ok))))))

(define (delete-from-here buf c)
  (real-pos! buf)
  (mode buf "delete")
  (let* ((kc (if *Repeat*
                 (cadr (buf-lastcmd buf))
                 (get-cmd buf)))
         (k  (car kc))
         (c  (if (cadr kc)
                 (cadr kc)
                 (if (char=? k #\G)
                     #f
                     c)))
         (p  (save-pos buf)))
    (let ((saved-kc (case (car kc)
                          ((#\/ #\?)         `(#\n #f))
                          ((#\f #\F #\t #\T) `(#\; #f))
                          (else      kc))))
      (if (not *Repeat*)
          (buf-set-lastcmd! buf (list (car (buf-lastcmd buf))
                                      saved-kc))))
    (command-mode buf)
    (cond ((char=? k #\d)
            (log-new buf)
            (buf-clear-yanked! buf)
            (yank-by-line buf c)
            (buf-modified! buf)
            (delete-by-line buf c))
          ((char=? k ESC))
          (else
            (case (motion-command buf k c)
                  ((no) (err buf "usage: #[d]{[d]|<motion>}"))
                  ((ok) (delete-region k buf p))
                  (else 'failed))))))

(define (middle x)
  (cdr (reverse! (cdr (reverse x)))))

(define (last x)
  (car (reverse x)))

(define (paste-text buf yy c before)
  (log-new buf)
  (fast-mode buf)
  (let ((here (save-pos buf)))
    (let loop ((i c))
      (cond ((zero? i)
              (reset-pos buf here)
              (slow-mode buf))
            ((eq? 'col (car yy))
              (if (and (buf-cur-char buf)
                       (not before))
                  (buf-set-x! buf (+ 1 (buf-x buf))))
              (insert-text buf (cadr yy))
              (if (>= (length yy) 4)
                      (insert-text buf
                                   (string-unsplit
                                     #\newline
                                     (cons "" (middle (cdr yy))))))
              (if (>= (length yy) 3)
                  (insert-text buf (string-append (string #\newline)
                                                  (last yy))))
              (loop (- i 1)))
            (else
              (if (not before)
                  (begin (buf-set-x! buf (buf-cur-length buf))
                         (insert-text buf
                                      (string-unsplit #\newline
                                                      (append '("") yy))))
                  (insert-text buf
                               (string-unsplit #\newline (append yy '("")))))
              (reset-pos buf here)
              (if (not before)
                  (if (eq? 'col (car yy))
                      (move-right buf 1)
                      (begin (move-down buf 1)
                             (buf-set-x! buf 0))))
              (set! here (save-pos buf))
              (loop (- i 1)))))))

(define (paste-command buf c before)
  (let ((yy  (buf-yanked buf)))
    (if (null? yy)
        (err buf "nothing yanked yet")
        (begin (buf-modified! buf)
               (real-pos! buf)
               (paste-text buf yy c before)))))

(define (insdel-command buf k c)
  (let ((pos  (save-pos buf))
        (last (buf-lastcmd buf)))
    (real-pos! buf)
    (if (not *Repeat*)
        (buf-set-lastcmd! buf (list (list k c))))
    (let ((nc (if c c 1)))
      (cond ((char=? k #\a) (append-at-point buf nc))
            ((char=? k #\d) (delete-from-here buf nc))
            ((char=? k #\i) (insert-at-point buf nc '()))
            ((char=? k #\o) (open-line buf nc #f))
            ((char=? k #\p) (paste-command buf nc #f))
            ((char=? k #\r) (replace-char buf nc))
            ((char=? k #\x) (delete-char-forw buf nc))
            ((char=? k #\A) (append-at-eol buf nc '()))
            ((char=? k #\D) (delete-to-eol buf))
            ((char=? k #\I) (insert-at-bol buf nc))
            ((char=? k #\J) (join-command buf nc))
            ((char=? k #\O) (open-line buf nc #t))
            ((char=? k #\P) (paste-command buf nc #t))
            ((char=? k #\R) (replace-text buf c))
            ((char=? k #\X) (delete-char-backw buf nc))
            (else           (reset-pos buf pos)
                            (buf-set-lastcmd! buf last)
                            'no)))))

(define (go-backward buf c)
  (let ((here (save-pos buf)))
    (if (zero? (buf-y buf))
        (err buf)
        (begin (move-top buf 1)
               (cond ((negative? (- (buf-y buf) c))
                       (goto-line buf 0)
                       (if (= (saved-top here) (buf-top buf))
                           'failed
                           'ok))
                     (else
                       (move-up buf c)
                       'ok))))))

(define (move-ppage buf c)
  (if (ok? (go-backward buf (* c (- (text-lines) 1))))
      (move-bottom buf 1))
  'ok)

(define (go-forward buf c)
  (let ((here (save-pos buf)))
    (if (>= (buf-y buf) (- (buf-length buf) 1))
        (err buf)
        (begin (move-bottom buf 1)
               (cond ((>= (+ c (buf-y buf))
                          (buf-length buf))
                       (goto-line buf (- (buf-length buf) 1))
                       (if (= (saved-top here) (buf-top buf))
                           'failed
                           'ok))
                     (else
                       (move-down buf c)
                       'ok))))))

(define (move-npage buf c)
  (if (ok? (go-forward buf (* c (- (text-lines) 1))))
      (move-top buf 1))
  'ok)

(define (repaint buf)
  (clear)
  (buf-status buf)
  (buf-display buf)
  'ok)

(define (scroll-down buf c)
  (let ((y (screen-line buf)))
    (if (ok? (go-forward buf (if c c (buf-val buf bv-scroll))))
        (move-top buf (+ 1 y)))))

(define (scroll-up buf c)
  (let ((y (screen-line buf)))
       (if (ok? (go-backward buf (if c c (buf-val buf bv-scroll))))
        (move-top buf (+ 1 y)))))

(define (set-mark buf)
  (real-pos! buf)
  (if (not (char=? (get-key buf #f) #\m))
      (err buf "usage: [m][m]")
      (begin (buf-set-mark! buf (list (buf-y buf) (buf-x buf)))
             'ok)))

(define (center-command buf c)
  (let ((mode (get-key buf #f))
        (c    (if c
                  (- c 1)
                  (buf-y buf))))
    (if (not (memv mode (list #\. #\- CR)))
        (err buf "usage: #[z]{[.]|[-]|[CR]}")
        (center-line buf c mode))))

(define (yank-by-col buf from to)
  (buf-add-yanked! buf (substring (buf-cur-line buf) from to)))

(define (yank-to-eol buf)
  (real-pos! buf)
  (if (zero? (buf-cur-length buf))
      (err buf)
      (begin (buf-clear-yanked! buf)
             (yank-by-col buf (buf-x buf) (buf-cur-length buf))
             (buf-add-yanked! buf 'col)
             'ok)))

(define (yank-by-line buf c)
  (if (> (+ c (buf-y buf)) (buf-length buf))
      (err buf)
      (let loop ((i   c)
                 (y   (buf-y buf))
                 (lns '()))
        (cond ((zero? i)
                (for-each (lambda (x)
                            (buf-add-yanked! buf x))
                          lns)
                'ok)
              (else
                (loop (- i 1)
                      (+ y 1)
                      (cons (buf-line buf y) lns)))))))

(define (yank-region k buf origin)
  (let ((y0  (saved-y origin))
        (x0  (saved-x origin))
        (dy  (buf-y buf))
        (dx  (buf-x buf))
        (pos (save-pos buf)))
    (if (> y0 dy)
        (begin (swap! y0 dy)
               (swap! x0 dx)))
    (if (and (= y0 dy)
             (> x0 dx))
        (swap! x0 dx))
    (let ((dx (if (one-more-char? k)
                  (+ 1 dx)
                  dx)))
      (cond ((line-motion? x0 k)
              (goto-line buf y0)
              (buf-clear-yanked! buf)
              (yank-by-line buf (+ 1 (- dy y0)))
              (restore-pos buf origin))
            ((= y0 dy)
              (goto-col buf x0)
              (buf-clear-yanked! buf)
              (yank-by-col buf x0 dx)
              (buf-add-yanked! buf 'col)
              (restore-pos buf origin))
            (else
              (buf-clear-yanked! buf)
              (buf-set-y! buf dy)
              (yank-by-col buf 0 dx)
              (buf-set-y! buf (+ 1 y0))
              (yank-by-line buf (- dy y0 1))
              (goto-line buf y0)
              (goto-col buf x0)
              (yank-by-col buf (buf-x buf) (buf-cur-length buf))
              (buf-add-yanked! buf 'col)
              (restore-pos buf origin)
              (buf-display buf)
              'ok)))))

(define (yank-from-here buf c)
  (real-pos! buf)
  (mode buf "yank")
  (let* ((kc (get-cmd buf))
         (k  (car kc))
         (c  (if (cadr kc)
                 (cadr kc)
                 (if (char=? k #\G)
                     #f
                     c)))
         (p  (save-pos buf)))
    (command-mode buf)
    (cond ((char=? k #\y)
            (buf-clear-yanked! buf)
            (yank-by-line buf c))
          ((char=? k ESC))
          (else
            (case (motion-command buf k c)
                  ((no) (err buf "usage: #[y]{[y]|<motion>}"))
                  ((ok) (yank-region k buf p))
                  (else 'failed))))))

(define (unsaved-buffers? buf)
  (and (memq #t (map buf-modified? (remq buf *Buffers*)))
       #t))

(define (disconnect!)
  (close-output-port (cadr *Session*))
  (catch-errors #t)
  (send-signal (caddr *Session*))
  (wait-for-process)
  (catch-errors #f)
  (set! *Session* #f))

(define (find-transient-buffer prop)
  (let loop ((b *Buffers*))
    (cond ((null? b)
            #f)
          ((buf-prop? (car b) prop)
            (car b))
          (else
            (loop (cdr b))))))
  
(define (open-transient-buffer buf title prop init-new)
  (let ((tb (find-transient-buffer prop)))
    (if tb
        tb
        (let ((new (new-buffer `(,prop
                                 ,bp-transient
                                 ,bp-readonly
                                 ,@(clean-up-props buf))
                               (buf-values buf))))
          (swap-buffers!)
          (init-new new)
          (if title
              (buf-set-name! new title))
          new))))

(define (goto-transient-buffer buf title prop init-new)
  (let ((tb (open-transient-buffer buf title prop init-new)))
    (delete-buffer tb)
    (set! *Buffers* (cons tb *Buffers*))
    tb))

(define (open-scheme-buffer buf)
  (open-transient-buffer buf
                         " *Scheme* "
                         bp-tag-scmint
                         (lambda (ignore)
                           (load-scheme-buffer))))

(define (goto-scheme-buffer buf)
  (goto-transient-buffer buf
                         " *Scheme* "
                         bp-tag-scmint
                         (lambda (ignore)
                           (load-scheme-buffer))))

(define (save-scheme-buffer)
  (let* ((home   (getenv "HOME"))
         (path   (if home
                     (string-append home "/.arse.int")))
         (intbuf (if home
                     (find-transient-buffer bp-tag-scmint))))
    (if (and home
             intbuf
             (buf-prop? intbuf bp-saveintbuf))
        (buf-write! intbuf path))))

(define (load-scheme-buffer)
  (let* ((home   (getenv "HOME"))
         (path   (if home
                     (string-append home "/.arse.int")))
         (intbuf (if home
                     (open-scheme-buffer (car *Buffers*)))))
    (if (and home
             (buf-prop? intbuf bp-saveintbuf))
        (buf-load! intbuf path))))

(define (quit)
  (save-scheme-buffer)
  (move (- (lines) 1) 0)
  (clrtoeol)
  (refresh)
  (endwin)
  (if *Session*
      (disconnect!))
  'quit)        

(define (save+exit buf)
  (let ((ch (get-key buf #f)))
    (cond ((and (unsaved-buffers? buf))
            (err buf "there are unsaved buffers! use :w :q! to discard them"))
          ((and (buf-modified? buf)
                (not (buf-name buf)))
            (err buf "buffer has no name! use \":w name\" to supply one"))
          ((char=? ch #\Z)
            (if (buf-modified? buf)
                (if (eq? 'ok (buf-save! buf #f))
                    (quit))
                (quit)))
          (else
            (err buf "usage: [Z][Z]")))))

(define (change-block buf from to proc . args)
  (if (positive? (buf-length buf))
      (begin (if (> from to)
                 (swap! from to))
             (fast-mode buf)
             (goto-line buf from)
             (log-new buf)
             (delete-by-line buf (+ 1 (- to from)))
             (let* ((text (reverse (log-what (car (buf-undo-log buf)))))
                    (text (apply proc buf text args)))
               (buf-set-y! buf from)
               (if (> (buf-y buf) (buf-length buf))
                   (buf-set-y! buf (buf-length buf)))
               (insert-text buf (append text (if (zero? (buf-length buf))
                                                 '()
                                                 '(""))))
               (buf-set-y! buf from)
               (slow-mode buf)
               'ok))))

(define (run-filter buf text command)
  (real-pos! buf)
  (let ((s (spawn-shell-command command)))
    (for-each (lambda (x)
                (display x (cadr s))
                (newline (cadr s)))
              text)
    (close-output-port (cadr s))
    (map expand-tabs (read-file (car s)))))

(define (filter-command buf)
  (real-pos! buf)
  (let* ((y0 (buf-y buf))
         (kc (get-cmd buf))
         (dy (cond ((char=? (car kc) #\!)
                     y0)
                   ((char=? (car kc) ESC)
                     #f)
                   ((eq? 'ok (apply motion-command buf kc))
                     (buf-y buf))
                   (else
                     (err buf "usage: [!]<motion>filter command[CR]")
                     #f))))
    (let ((cmd (and dy (get-line (text-lines) buf "!" #f))))
      (if (and cmd dy (positive? (string-length cmd)))
          (begin (buf-modified! buf)
                 (change-block buf y0 dy run-filter cmd))))))

(define (run-indent buf text indent)
  (let ((pre (make-string indent #\space)))
    (map (lambda (x)
           (if (string=? "" x)
               x
               (string-append pre x)))
         text)))

(define (run-outdent buf text outdent)
  (let ((outdent (if outdent outdent 2)))
    (let ((pre (make-string outdent #\space)))
      (let ((new (map (lambda (x)
                        (cond ((string=? "" x)
                                "")
                              ((< (string-length x) outdent)
                                #f)
                              ((not (string=? pre (substring x 0 outdent)))
                                #f)
                              (else
                                (substring x outdent (string-length x)))))
                      text)))
        (if (memq #f new)
            (begin (err buf)
                   text)
            new)))))

(define (in/outdent-command buf c cmd-ch)
  (real-pos! buf)
  (let ((c   (if c c (buf-val buf bv-indent)))
        (pos (save-pos buf)))
    (let* ((y0 (buf-y buf))
           (kc (get-cmd buf))
           (dy (cond ((char=? (car kc) cmd-ch)
                       (if (memv (buf-cur-char buf) '(#\( #\)))
                           (begin (match-paren buf #f)
                                  (buf-y buf))
                           y0))
                     ((char=? (car kc) ESC)
                       #f)
                     ((eq? 'ok (apply motion-command buf kc))
                       (buf-y buf))
                     (else
                       (if (char=? cmd-ch #\<)
                           (err buf "usage: #[<]{[<]|<motion>}")
                           (err buf "usage: #[>]{[>]|<motion>}"))
                       #f))))
      (if dy
          (begin (buf-modified! buf)
                 (change-block buf
                               y0
                               dy
                               (if (char=? cmd-ch #\>)
                                   run-indent
                                   run-outdent)
                               c)
                 (reset-pos buf pos)
                 (let ((inc (if (char=? cmd-ch #\<) - +)))
                   (buf-set-x! buf (inc (buf-x buf) c))))))))

(define (run-change-case buf text ignore)
  (map (lambda (x)
         (let* ((k (string-length x))
                (n (make-string k)))
           (let loop ((i 0))
             (if (>= i k)
                 n
                 (let ((c (string-ref x i)))
                   (string-set! n i (if (char-upper-case? c)
                                        (char-downcase c)
                                        (char-upcase c)))
                   (loop (+ 1 i)))))))
       text))

(define (change-case-command buf c)
  (real-pos! buf)
  (let* ((y0 (buf-y buf))
         (kc (get-cmd buf))
         (dy (cond ((char=? (car kc) #\~)
                     y0)
                   ((char=? (car kc) ESC)
                     #f)
                   ((eq? 'ok (apply motion-command buf kc))
                     (buf-y buf))
                   (else
                     (err buf "usage: #[~~]{[~~]|<motion>}")
                     #f))))
    (if dy
        (begin (buf-modified! buf)
               (change-block buf y0 dy run-change-case c)))))

(define (count-chars buf)
  (mode buf "busy")
  (let ((chars (apply +
                      (buf-length buf)
                      (map string-length
                           (vector->list (buf-buffer buf))))))
    (command-mode buf)
    chars))

(define (percent n n100)
  (if (or (zero? n100)
          (= n n100))
      100
      (quotient (* n 100) n100)))

(define (start-info buf)
  (if (buf-prop? buf bp-showmode)
      (move (text-lines) (- (cols) 1))
      (begin (move (text-lines) 0)
             (so buf)
             (addstr "-*-*-*-")
             (se buf)))
  (scrollok #t)
  (addstr (string (integer->char 10) (integer->char 13))))

(define (crlf)
  (addstr (string (integer->char 10) (integer->char 13))))

(define (end-info buf)
  (addstr "Press ENTER to return to ARSE: ")
  (scrollok #f)
  (getch)
  (buf-display buf)
  (buf-status buf)
  'ok)

(define (long-status buf)
  (let ((chars (count-chars buf)))
    (start-info buf)
    (addstr (format #f "~S~A~A: ~D characters, line ~D of ~D (~D%), col ~D"
                       (cond ((buf-name buf)
                               => (lambda (x) x))
                             (else
                               '*anonymous*))
                       (cond ((buf-transient? buf) ": transient")
                             ((buf-modified? buf)  ": modified")
                             (else                 ""))
                       (if (buf-readonly? buf)
                           ": read-only"
                           "")
                       chars
                       (+ 1 (buf-y buf))
                       (buf-length buf)
                       (percent (buf-y buf)
                                (- (buf-length buf) 1))
                       (+ 1 (buf-x buf))))
    (crlf)
    (end-info buf)))

(define (prepare-last-line buf where)
  (let loop ()
    (if (>= (saved-y where) (buf-length buf))
        (begin (buf-set-length! buf (+ 1 (buf-length buf)))
               (buf-set-line! buf (last-line buf) "")
               (loop)))))

(define (trim-last-line buf)
  (if (zero? (string-length (buf-line buf (last-line buf))))
      (begin (buf-set-length! buf (- (buf-length buf) 1))
             (if (>= (buf-y buf) (buf-length buf))
             (buf-set-y! buf (last-line buf))))))

(define (undo-insc buf where what)
  (let ((what (if (string? what)
                  (string-split #\newline what)
                  what)))
    (if (> (length what) 1)
        (prepare-last-line buf where))
    (restore-pos buf where)
    (delete-by-col buf (saved-x where)
                       (+ (string-length (car what))
                          (saved-x where)))
    (if (> (length what) 2)
        (begin (buf-set-y! buf (+ 1 (saved-y where)))
               (delete-by-line buf (- (length what) 2))))
    (if (> (length what) 1)
        (begin (buf-set-y! buf (+ 1 (saved-y where)))
               (delete-by-col buf 0 (string-length (last what)))
               (goto-line buf (saved-y where))
               (if (< (+ (buf-y buf) 1) (buf-length buf))
                   (join-lines buf 1 #f))
               (trim-last-line buf)))
    (buf-display buf)
    'ok))

(define (undo-delc buf where what)
  (reset-pos buf where)
  (insert-text buf what)
  'ok)

(define (undo-deln buf where what)
  (prepare-last-line buf where)
  (restore-pos buf where)
  (insert-text buf (append (reverse what)
                           (if (zero? (buf-length buf))
                               '()
                               '(""))))
  (trim-last-line buf)
  (goto-line buf (car where))
  'ok)

(define (undo-brkl buf where what)
  (reset-pos buf where)
  (buf-set-y! buf (+ 1 (saved-y where)))
  (delete-by-line buf 1)
  (reset-pos buf where)
  (buf-set-cur-line! buf what)
  (buf-display buf)
  'ok)

(define (undo-join buf where what)
  (reset-pos buf where)
  (delete-by-line buf 1)
  (restore-pos buf where)
  (buf-set-x! buf 0)
  (insert-text buf (append (cdr what) '("")))
  (restore-pos buf where))

(define (undo-repc buf where what)
  (reset-pos buf where)
  (buf-set-cur-line! buf (car what))
  (buf-display buf)
  'ok)

(define (find-NEXT-op log)
  (cond ((null? log)
          (error "no NEXT op in undo/redo log -- should not happen!"))
        ((eq? 'NEXT (log-op (car log)))
          (car log))
        (else
          (find-NEXT-op (cdr log)))))

(define (undo buf)
  (fast-mode buf)
  (let loop ((redo-log (cons (find-NEXT-op (buf-undo-log buf))
                             (buf-redo-log buf))))
    (let* ((log (buf-undo-log buf))
           (act (car log)))
      (if (not (eq? (log-op act) 'NEXT))
          (begin
            (case (log-op act)
                  ((INSC) (undo-insc buf (log-where act) (log-what act)))
                  ((DELC) (undo-delc buf (log-where act) (log-what act)))
                  ((DELN) (undo-deln buf (log-where act) (log-what act)))
                  ((BRKL) (undo-brkl buf (log-where act) (log-what act)))
                  ((JOIN) (undo-join buf (log-where act) (log-what act)))
                  ((REPC) (undo-repc buf (log-where act) (log-what act)))
                  (else   'failed))
            (buf-set-undo-log! buf log)
            (let ((next-act (car (buf-undo-log buf))))
              (buf-set-undo-log! buf (cdr (buf-undo-log buf)))
              (loop (cons next-act redo-log))))
          (begin
            (reset-pos buf (log-where act))
            (buf-set-undo-log! buf (cdr (buf-undo-log buf)))
            (buf-set-redo-log! buf redo-log)
            (slow-mode buf))))))

(define (redo-insc buf where what)
  (prepare-last-line buf where)
  (restore-pos buf where)
  (insert-text buf what)
  (trim-last-line buf)
  (buf-display buf)
  'ok)

(define (redo-delc buf where what)
  (restore-pos buf where)
  (delete-by-col buf (buf-x buf)
                     (+ (buf-x buf)
                        (string-length what)))
  (buf-display buf)
  'ok)

(define (redo-deln buf where what)
  (prepare-last-line buf where)
  (restore-pos buf where)
  (delete-by-line buf (length what))
  (trim-last-line buf)
  (buf-display buf)
  'ok)

(define (redo-brkl buf where what)
  (restore-pos buf where)
  (break-line buf))

(define (redo-join buf where what)
  (restore-pos buf where)
  (join-lines buf (- (length what) 2) (car what)))

(define (redo-repc buf where what)
  (restore-pos buf where)
  (replace-cols buf (cadr what))
  (buf-display buf))

(define (redo buf)
  (fast-mode buf)
  (let loop ((undo-log (cons (find-NEXT-op (buf-redo-log buf))
                             (buf-undo-log buf))))
    (let* ((log (buf-redo-log buf))
           (act (car log)))
      (if (not (eq? (log-op act) 'NEXT))
          (begin
            (case (log-op act)
                  ((INSC) (redo-insc buf (log-where act) (log-what act)))
                  ((DELC) (redo-delc buf (log-where act) (log-what act)))
                  ((DELN) (redo-deln buf (log-where act) (log-what act)))
                  ((BRKL) (redo-brkl buf (log-where act) (log-what act)))
                  ((JOIN) (redo-join buf (log-where act) (log-what act)))
                  ((REPC) (redo-repc buf (log-where act) (log-what act)))
                  (else   'failed))
            (buf-set-redo-log! buf log)
            (let ((next-act (car (buf-redo-log buf))))
              (buf-set-redo-log! buf (cdr (buf-redo-log buf)))
              (loop (cons next-act undo-log))))
          (begin
            (reset-pos buf (log-where act))
            (buf-set-redo-log! buf (cdr (buf-redo-log buf)))
            (buf-set-undo-log! buf undo-log)
            (slow-mode buf))))))

(define (undo-mode buf dir)
  (buf-modified! buf)
  (let loop ((k #\.)
             (dir dir))
    (cond ((char=? k #\.)
              (if (eq? dir 'undo)
                (if (null? (buf-undo-log buf))
                    (err buf)
                    (undo buf))
                (if (null? (buf-redo-log buf))
                    (err buf)
                    (redo buf)))
            (loop (get-key buf #t)
                  dir))
          ((char=? k #\u)
            (loop #\.
                  (if (eq? dir 'undo)
                      'redo
                      'undo)))
          (else
              (ungetch (char->integer k))
              dir))))

(define (undo-command buf)
  (if (and (null? (buf-undo-log buf))
           (null? (buf-redo-log buf)))
      (err buf "nothing done yet")
      (let ((dir (undo-mode buf (buf-log-dir buf))))
        (buf-set-log-dir! buf (if (eq? dir 'undo)
                                  'redo
                                  'undo))
        'ok)))

(define (repeat-last buf)
  (if (not (buf-lastcmd buf))
      (err buf "nothing to repeat")
      (begin (set! *Repeat* #t)
             (run-command buf (car (buf-lastcmd buf)))
             (set! *Repeat* #f)
             'ok)))

(define (scheme-pretty-print buf . options)
  (real-pos! buf)
  (if (or (eqv? LP (buf-cur-char buf))
          (and (eqv? RP (buf-cur-char buf))
               (match-lp buf #f)))
      (let ((here (save-pos buf))
            (yy   (buf-yanked buf)))
        (fast-mode buf)
        (if (and (ok? (match-paren buf #f))
                 (ok? (delete-region #\% buf here)))
            (let ((formatted (apply pp-string (cdr (buf-yanked buf))
                                              'indent: (buf-x buf)
                                              options)))
              (reset-pos buf here)
              (buf-set-yanked! buf yy)
              (insert-text buf formatted)
              (reset-pos buf here)
              (slow-mode buf))
            (buf-set-yanked! buf yy)))
      (err buf)))

(define (send-to-repl s)
  (catch-errors #t)
  (display s (cadr *Session*))
  (newline (cadr *Session*))
  (catch-errors #f))

(define (flush-repl)
  (let ((done-magic (string-append "(done "
                                   (number->string (unix-time))
                                   ")")))
    (send-to-repl
      (string-append (string #\newline)
                     "(newline)"
                     (string #\newline)
                     "'"
                     done-magic))
    (catch-errors #t)
    (flush-output-port (cadr *Session*))
    (catch-errors #f)
    done-magic))

(define (make-reader input-fd)
  (let ((buffer #f)
        (limit  0)
        (next   0))
    (lambda chars-left?
      (cond ((not (null? chars-left?))
              (< next limit))
            ((>= next limit)
              (let* ((next-buffer (fd-read input-fd 10240))
                     (k           (string-length next-buffer)))
                (if (zero? k)
                    #f
                    (begin (set! buffer next-buffer)
                           (set! limit k)
                           (set! next 1)
                           (string-ref buffer 0)))))
            (else
              (let ((c (string-ref buffer next)))
                (set! next (+ 1 next))
                c))))))

(define (read-line-from-repl reader)
  (letrec
    ((collect-chars
       (lambda (c s)
         (cond ((not c)
                 (if (null? s)
                     c
                     (expand-tabs (list->string (reverse! s)))))
               ((char=? c #\newline)
                 (expand-tabs (list->string (reverse! s))))
               (else
                 (collect-chars (reader)
                                (cons c s)))))))
    (collect-chars (reader) '())))

(define (goto-scmhelp-buffer buf)
  (goto-transient-buffer buf
                         " *Scheme Help* "
                         bp-tag-scmhelp
                         (lambda (x) x)))

(define (discard-magic-newline text)
  (if (and (not (null? text))
           (string=? "" (car text)))
      (cdr text)
      text))

(define (user-interrupt?)
  (nodelay #t)
  (let ((k (getch)))
    (nodelay #f)
    (eqv? 3 k)))

(define (get-repl-output buf quiet skip-comments)
  (let ((done-magic (flush-repl))
        (reader     (make-reader (car *Session*))))
    (info buf "waiting for REPL")
    (set! *Message* #f)
    (let loop ((output '()))
      (cond
        ((and (not (reader 'check))
              (not (fd-select (list (buf-val buf bv-repl-timeout) 0)
                              (list (car *Session*))
                              '())))
          (disconnect!)
          (err buf "REPL stalled"))
        ((user-interrupt?)
          (disconnect!)
          (err buf "interrupted"))
        (else
          (let ((s (read-line-from-repl reader)))
            (cond ((or (not s)
                       (string=? done-magic s))
                    (if (or (> (length output) 1)
                            (and (= (length output) 1)
                                 (not (string=? "" (car output)))))
                        (let ((intbuf (open-scheme-buffer buf))
                              (output (discard-magic-newline output)))
                          (buf-set-y! intbuf (max 0 (- (buf-length intbuf) 1)))
                          (buf-set-x! intbuf (buf-cur-length intbuf))
                          (log-new intbuf)
                          (fast-mode buf)
                          (insert-text intbuf (append '("") (reverse! output)))
                          (slow-mode buf)
                          (if (and (not quiet)
                                   (not (buf-prop? buf bp-tag-scmint)))
                              (info buf "REPL output received"))))
                    (if (not s)
                        (begin (disconnect!)
                               (err buf "error(s) found"))
                        (if *Message*
                            *Message*
                            'ok)))
                  ((and skip-comments
                        (> (string-length s) 1)
                        (char=? #\; (string-ref s 0)))
                      (loop output))
                  (else
                      (loop (cons s output))))))))))

(define (hello-scheme?)
  (let* ((magic  (flush-repl))
         (k      (string-length magic))
         (reader (make-reader (car *Session*))))
    (let ((s (begin (read-line-from-repl reader)
                    (read-line-from-repl reader))))
      (and (string? s)
           (>= (string-length s) k)
           (string=? magic (substring s 0 k))))))

(define (make-conn fd-conn)
  (list (car fd-conn)
        (make-output-port (cadr fd-conn))
        (caddr fd-conn)))

(define (run-scheme-command buf)
  (let* ((s    (string-parse " " (buf-val buf bv-scheme-repl)))
         (path (getenv "PATH"))
         (cmd  (search-path (car s) (if path path "")))
         (args (cdr s)))
    (spawn-command/fd cmd args)))

(define (reconnect-scheme! buf)
  (let ((here (save-pos buf)))
    (if (not *Session*)
        (begin (catch-errors #t)
               (let* ((fd-conn (run-scheme-command buf))
                      (e      (errno)))
                 (catch-errors #f)
                 (if fd-conn
                     (set! *Session* (make-conn fd-conn)))
                 (cond ((not fd-conn)
                         (err buf (format #f "failed to start Scheme: ~A"
                                             (errno->string e)))
                         #f)
                       ((begin (send-to-repl (buf-val buf bv-scheme-init))
                               (hello-scheme?))
                         (let ((r (scheme-autoload buf)))
                           (restore-pos buf here)
                           (ok? r)))
                       (else
                         (disconnect!)
                         (err buf (string-append
                                    "failed to start Scheme"
                                    " (check \"scheme-repl\" option)"))
                         #f))))
        #t)))

(define (scheme-reload buf)
  (let* ((code-marker (buf-val buf bv-code-marker))
         (cm-re       (or (re-comp code-marker)
                          (begin (err "bad RE in \"code-marker\" option")
                                 "")))
         (docmode     (not (string=? "" code-marker)))
         (send        (not docmode)))
    (cond ((reconnect-scheme! buf)
            (info buf "reloading...")
            (let loop ((i 0)
                       (k (buf-length buf)))
               (cond ((and docmode
                           (< i k)
                           (re-match cm-re (buf-line buf i)))
                       (set! send (not send))
                       (loop (+ 1 i) k))
                     ((< i k)
                       (if send
                           (send-to-repl (buf-line buf i)))
                       (loop (+ 1 i) k))
                     ((ok? (get-repl-output buf #t #t))
                       (info buf "reloaded")
                       'ok)
                     (else
                       'failed))))
          (else
            'failed))))

(define (scheme-autoload buf)
  (let loop ((b* *Buffers*))
    (cond ((null? b*)
            'ok)
          ((and (not (eq? buf (car b*)))
                (buf-prop? (car b*) bp-autoload))
            (info buf (format #f "auto-loading ~A" (buf-name buf)))
            (if (ok? (scheme-reload (car b*)))
                (loop (cdr b*))
                (err buf *Message*)))
          (else
            (loop (cdr b*))))))

(define (find-definition buf)
  (let ((here (save-pos buf)))
    (let loop ()
      (cond ((and (>= (- (buf-cur-length buf) (buf-x buf)) 8)
                  (string=? "(define " (substring (buf-cur-line buf) ; #\)
                                                  (buf-x buf)
                                                  (+ (buf-x buf) 8))))
              (let ((defn (save-pos buf)))
                (if (ok? (match-rp buf #f))
                    (begin (restore-pos buf defn)
                           #t)
                    (begin (restore-pos buf here)
                           #f))))
            ((ok? (move-prev-expr buf 1))
              (loop))
            (else
              (restore-pos buf here)
              #f)))))

(define (pass-to-scheme buf begin-msg end-msg)
  (info buf begin-msg)
  (if (char=? RP (buf-cur-char buf))
      (match-lp buf #f))
  (let ((origin (save-pos buf))
        (yy     (buf-yanked buf)))
    (match-rp buf #f)
    (yank-region #\% buf origin)
    (for-each send-to-repl
              (cdr (buf-yanked buf)))
    (if (ok? (get-repl-output buf #f #f))
        (info buf end-msg))
    (buf-set-yanked! buf yy)))

(define (scheme-recompile buf)
  (let ((here (save-pos buf))
        (res  'ok))
    (fast-mode buf)
    (cond ((and (reconnect-scheme! buf)
                (find-definition buf))
            (pass-to-scheme buf "compiling..." "compiled"))
          (else
            (set! res 'failed)))
    (restore-pos buf here)
    (slow-mode buf)
    res))

(define (scheme-eval buf)
  (let ((here (save-pos buf))
        (res  'ok))
    (fast-mode buf)
    (cond ((and (reconnect-scheme! buf)
                (buf-cur-char buf)
                (memv (buf-cur-char buf) (list LP RP)))
            (pass-to-scheme buf "eval..." "done"))
          (else
            (set! res 'failed)))
    (restore-pos buf here)
    (slow-mode buf)
    res))

(define (scheme-help buf)
  (let ((help-path (find-help-path)))
    (if (not help-path)
        (err buf "help pages not found")
        (let ((pos2 (extract-ident buf)))
          (if (not pos2)
              (err buf)
              (let* ((topic (apply substring (buf-cur-line buf) pos2))
                     (path  (string-append help-path
                                           "/"
                                           (string-downcase
                                             (name->file-name topic)))))
                (if (not (file-exists? path))
                    (err buf (format #f "~A: no help page found" topic))
                    (let ((helpbuf (goto-scmhelp-buffer buf)))
                      (buf-load! helpbuf path)
                      (buf-set-name! helpbuf " *Scheme Help* ")
                      (set! *Help-Stack* (cons (cons path (save-pos helpbuf))
                                               *Help-Stack*))
                      (goto-line helpbuf 0)
                      helpbuf))))))))

(define (scheme-prev-help buf)
  (cond ((or (null? *Help-Stack*)
             (null? (cdr *Help-Stack*)))
          (err buf "no previous topic"))
        ((not (buf-prop? buf bp-tag-scmhelp))
          (err buf "not in Scheme help buffer"))
        (else
          (buf-load! buf (car (cadr *Help-Stack*)))
          (buf-set-name! buf " *Scheme Help* ")
          (restore-pos buf (cdr (car *Help-Stack*)))
          (set! *Help-Stack* (cdr *Help-Stack*))
          (buf-display buf)
          'ok)))

(define (scheme-new-repl buf)
  (if *Session*
      (disconnect!))
  (if (reconnect-scheme! buf)
      (info buf "new REPL")))

(define (scheme-add-completion-symbol buf)
  (let ((pos2 (extract-ident buf)))
    (if (not pos2)
        (err buf)
        (set! *Completion-symbols*
              (sort string-ci<?
                    (cons (apply substring (buf-cur-line buf) pos2)
                          *Completion-symbols*))))))

(define (scheme-interface buf)
  (let ((k (get-key buf #t)))
    (cond ((char=? k #\b) (scheme-prev-help buf))
          ((char=? k #\c) (scheme-recompile buf))
          ((char=? k #\e) (scheme-eval buf))
          ((char=? k #\f) (scheme-pretty-print buf 'data))
          ((char=? k #\h) (scheme-help buf))
          ((char=? k #\i) (goto-scheme-buffer buf))
          ((char=? k #\n) (scheme-new-repl buf))
          ((char=? k #\o) (scheme-add-completion-symbol buf))
          ((char=? k #\p) (scheme-pretty-print buf))
          ((char=? k #\r) (scheme-reload buf))
          (else  (err buf)))))

(define (buf-display-with-hl-range buf bgn end)
  (let ((y0 (saved-y bgn))
        (x0 (saved-x bgn))
        (yN (saved-y end))
        (xN (saved-x end)))
    (let loop ((i  (buf-top buf))
               (y  0))
      (if (< y (text-lines))
          (begin (move y 0)
                 (clrtoeol)
                 (if (< i (buf-length buf))
                     (cond ((< y0 i yN)
                             (attr-bold)
                             (addstr (clip-right (buf-line buf i) (cols)))
                             (attr-normal))
                           ((= y0 i yN)
                             (let ((l (substring (buf-line buf i) 0 x0))
                                   (m (substring (buf-line buf i) x0 (+ 1 xN)))
                                   (r (substring (buf-line buf i)
                                                 (+ 1 xN)
                                                 (min (cols)
                                                      (string-length
                                                        (buf-line buf i))))))
                               (addstr l)
                               (attr-bold)
                               (addstr m)
                               (attr-normal)
                               (addstr r)))
                           ((= y0 i)
                             (let ((l (substring (buf-line buf i) 0 x0))
                                   (r (substring (buf-line buf i)
                                                 x0
                                                 (min (cols)
                                                      (string-length
                                                        (buf-line buf i))))))
                               (addstr l)
                               (attr-bold)
                               (addstr r)
                               (attr-normal)))
                           ((= i yN)
                             (let ((l (substring (buf-line buf i) 0 (+ 1 xN)))
                                   (r (substring (buf-line buf i)
                                                 (+ 1 xN)
                                                 (min (cols)
                                                      (string-length
                                                        (buf-line buf i))))))
                               (attr-bold)
                               (addstr l)
                               (attr-normal)
                               (addstr r)))
                           (else
                             (addstr (clip-right (buf-line buf i) (cols))))))
                 (loop (+ 1 i) (+ 1 y)))))))

(define (highlight-expr buf pos)
  (if (not pos)
      (err buf)
      (let ((lparen (car pos))
            (here   (save-pos buf))
            (top    (buf-top buf))
            (bot    (min (+ 1 (buf-length buf))
                         (+ (buf-y buf) (text-lines)))))
        (reset-pos buf (car pos))
        (match-rp buf #f)
        (let* ((rparen (save-pos buf))
               (bot    (min bot (+ 1 (saved-y rparen)))))
          (restore-pos buf here)
          (buf-display-with-hl-range buf lparen rparen)
          (let ((k (get-key buf #t)))
            (buf-display buf)
            (ungetch (char->integer k)))))))

(define (visual-expression buf)
  (real-pos! buf)
  (let ((parens (make-hash-table))
        (pos    (save-pos buf)))
    (buf-set-x! buf 0)
    (buf-set-y! buf (buf-top buf))
    (let loop ((level 0))
      (cond ((or (> (buf-y buf) (saved-y pos))
                 (and (= (buf-y buf) (saved-y pos))
                      (> (buf-x buf) (saved-x pos))))
              (reset-pos buf pos)
              (highlight-expr buf (hash-table-ref parens (- level 1))))
            ((eqv? LP (buf-cur-char buf))
              (hash-table-set! parens level (save-pos buf))
              (advance buf)
              (loop (+ 1 level)))
            ((eqv? RP (buf-cur-char buf))
              (advance buf)
              (loop (- level 1)))
            (else
              (advance buf)
              (loop level))))))

(define (test buf)
  (clear)
  (mvaddstr 0 0 (format #f "~S" (buf-lastcmd buf)))
  (getch)
  (clear)
  (buf-display buf)
  (buf-status buf))

(define (other-command buf k c)
  (let ((nc (if c c 1)))
    (cond ((char=? k ^B)  (move-ppage buf nc))
          ((char=? k ^D)  (scroll-down buf c))
          ((char=? k ^F)  (move-npage buf nc))
          ((char=? k ^G)  (long-status buf))
          ((char=? k ^L)  (repaint buf))
          ((char=? k ^R)  (repaint buf))
          ((char=? k ^T)  (test buf))
          ((char=? k ^U)  (scroll-up buf c))
          ((char=? k ESC) (err buf))
          ((char=? k #\!) (filter-command buf))
          ((char=? k #\.) (repeat-last buf))
          ((char=? k #\<) (in/outdent-command buf c #\<))
          ((char=? k #\>) (in/outdent-command buf c #\>))
          ((char=? k #\~) (change-case-command buf c))
          ((char=? k #\m) (set-mark buf))
          ((char=? k #\u) (undo-command buf))
          ((char=? k #\v) (visual-expression buf))
          ((char=? k #\y) (yank-from-here buf nc))
          ((char=? k #\z) (center-command buf c))
          ((char=? k #\Y) (yank-to-eol buf))
          (else           'no))))

(define (in? x set)
  (and (not (null? x))
       (memv (car x) set)
       #t))

(define digits  '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\. #\' #\$))
(define pos-set (append digits '(#\' #\$)))

(define (parse-pos buf in)
  (cond ((in? in '(#\'))
          (if (and (buf-mark buf)
                   (in? (cdr in) '(#\m)))
              (list (car (buf-mark buf)) (cddr in))
              (list #f #f)))
        ((in? in '(#\$))
          (list (end-of-buffer buf) (cdr in)))
        ((in? in '(#\.))
          (list (buf-y buf) (cdr in)))
        (else
          (let loop ((in  in)
                     (out '()))
            (if (in? in digits)
                (loop (cdr in)
                      (cons (car in) out))
                (list (let ((n (string->number
                                 (list->string (reverse! out)))))
                        (if n (- n 1) n))
                      in))))))

(define (parse-op buf in)
  (let loop ((in  in)
             (out '()))
    (cond ((and (not (null? in))
                (char-alphabetic? (car in)))
            (loop (cdr in) (cons (car in) out)))
          ((and (not (null? in))
                (char=? #\space (car in)))
            (list (list->string (reverse! out))
                  (cdr in)))
          ((not (null? in))
            (list (list->string (reverse! (cons (car in) out)))
                  (cdr in)))
          (else
            (list (list->string (reverse! out))
                  in)))))

(define (colon-quit buf yes!)
  (cond ((and (buf-modified? buf)
              (not yes!))
          (err buf (string-append "buffer modified but not saved!"
                                  " :w = write, :q! = quit anyway")))
        ((and (unsaved-buffers? buf)
              (not yes!))
          (err buf (string-append "there are unsaved buffers!"
                                  " :wall = write all, :q! = quit anyway")))
        (else
          (quit))))

(define (colon-write buf yes! from to file)
  (cond ((null? file)
          (cond ((not (buf-name buf))
                  (err buf
                       "buffer has no name! use \":w name\" to supply one"))
                ((buf-transient? buf)
                  (err buf "buffer is transient!"))
                ((and (zero? from)
                       (= to (end-of-buffer buf)))
                  (buf-save! buf yes!)
                  'ok)
                (yes!
                  (buf-write! buf (buf-name buf) from to)
                  'ok)
                (else
                  (err buf (string-append "partial file not written! use :w!"
                                          " if you are sure")))))
        ((> (length file) 1)
          (err buf "too many file names"))
        ((and (not yes!)
              (file-exists? (car file)))
          (err buf "file exists! use :w! to overwrite"))
        (else
          (buf-write! buf (car file) from to)
          (if (and (not (buf-name buf))
                   (zero? from)
                   (= to (- (buf-length buf) 1)))
              (begin (buf-set-name! buf (car file))
                     (buf-rem-prop! buf bp-modified)))
          'ok)))

(define (colon-write-all buf yes!)
  (let ((failed  #f)
        (written 0))
    (for-each (lambda (x)
                (if (and (not failed)
                         (buf-modified? x))
                    (case (buf-save! x yes!)
                          ((failed) (set! failed #t))
                          ((ok)     (set! written (+ 1 written))))))
              *Buffers*)
    (info buf (format #f "~D buffer~:P written" written))
    buf))

(define (colon-read buf file)
  (real-pos! buf)
  (cond ((null? file)
          (err buf "missing file name"))
        ((> (length file) 1)
          (err buf "too many file names"))
        ((not (file-exists? (car file)))
          (err buf (string-append (car file) ": cannot open file")))
        (else
          (buf-modified! buf)
          (let ((text (map expand-tabs
                           (with-input-from-file
                             (car file)
                             read-file))))
            (buf-set-y! buf (+ 1 (buf-y buf)))
            (log-new buf)
            (let ((pos (save-pos buf)))
              (insert-text buf (append text '("")))
              (restore-pos buf pos)
              'ok)))))

(define (timestamp time)
  (if (> (- (unix-time) time) 86400)
      (format-time "~4y-~2:m-~2d"
                   (unix-time->time time))
      (format-time "  ~2h:~2m:~2s"
                   (unix-time->time time))))
                                              
(define (fill-dir-buffer dir path)
  (catch-errors #t)
  (let* ((files (read-directory path))
         (files (and files
                     (cons ".." (sort string<? files)))))
    (catch-errors #f)
    (if (not files)
        (err dir (format #f "cannot read directory: ~A"
                            (errno->string (errno))))
        (let loop ((y     0)
                   (files files))
          (if (null? files)
              (begin (buf-set-length! dir y)
                     (info dir #f)
                     'ok)
              (let* ((file (string-append path "/" (car files)))
                     (stat (stat-file file))
                     (desc (format #f "~C~A  ~A  ~8D  ~A"
                                      (if (directory? file)
                                          #\d
                                          #\-)
                                      (mode->string (cdr (assq 'mode stat)))
                                      (timestamp (cdr (assq 'mtime stat)))
                                      (cdr (assq 'size stat))
                                      (basename file))))
                (if (zero? (remainder y 10))
                    (info dir (format #f "loading: ~D" y)))
                (insert-into-buf! dir y desc)
                (loop (+ 1 y) (cdr files))))))))

(define (dir-browser buf path)
  (let ((res #f)
        (dir (new-buffer (append (clean-up-props buf)
                                 (list bp-transient
                                       bp-readonly))
                         (buf-values buf))))
    (mode dir "directory browser")
    (let loop ((refill path))
      (if refill
          (if (ok? (fill-dir-buffer dir refill))
              (begin (set! path refill)
                     (buf-set-y! dir 0)
                     (buf-set-top! dir 0)
                     (buf-display dir))))
      (buf-set-name! dir path)
      (buf-status dir)
      (sync dir #f)
      (so dir)
      (mvaddstr (screen-line dir)
                0
                (clip-right (buf-cur-line dir) (cols)))
      (let ((kc (get-cmd dir)))
        (sync dir #f)
        (se dir)
        (mvaddstr (screen-line dir)
                  0
                  (clip-right (buf-cur-line dir) (cols)))
        (cond ((char=? (car kc) ESC)
                (set! res #f))
              ((char=? (car kc) CR)
                (let ((d    (buf-char dir 0))
                      (name (last (string-parse " " (buf-cur-line dir)))))
                  (cond ((string=? ".." name)
                          (loop (dirname path)))
                        ((char=? d #\d)
                          (loop (string-append path "/" name)))
                        (else
                          (set! res (string-append path "/" name))))))
              ((char=? (car kc) ^F)
                (move-npage dir 1)
                (loop #f))
              ((char=? (car kc) ^B)
                (move-ppage dir 1)
                (loop #f))
              ((char=? (car kc) ^L)
                (clear)
                (buf-display dir)
                (loop #f))
              ((not (eq? 'no (apply motion-command dir kc)))
                (loop #f))
              (else
                (err dir
                     (string-append
                       "usage: <motion> = move cursor"
                       "  CR = select  ESC = quit"))
                (loop #f)))))
    (delete-buffer dir)
    (command-mode buf)
    (buf-display buf)
    (buf-status buf)
    res))

(define (colon-edit buf yes! file)
  (cond ((null? file)
          (if (and (buf-modified? buf)
                   (not yes!))
              (err buf "buffer is modified! save with :w or discard with :e!")
              (let ((file (dir-browser buf (getcwd))))
                (if file
                    (colon-edit buf yes! (list file))
                    'failed))))
        ((> (length file) 1)
          (err buf "too many file names"))
        ((and (buf-modified? buf)
              (not yes!))
          (err buf "buffer is modified! save with :w or discard with :e!"))
        (else
          (buf-set-x! buf 0)
          (buf-set-y! buf 0)
          (buf-set-length! buf 0)
          (vector-fill! (buf-buffer buf) "")
          (cond ((file-exists? (car file))
                  (buf-rem-prop! buf bp-transient)
                  (buf-rem-prop! buf bp-readonly)
                  (buf-load! buf (car file)))
                (else
                  (info buf (format #f "~A: new file" (car file)))))
          (buf-rem-prop! buf bp-modified)
          (buf-display buf)
          'ok)))

(define (colon-shell buf cmd)
  (move 0 0)
  (deleteln)
  (move (text-lines) 0)
  (refresh)
  (endwin)
  (catch-errors #t)
  (run-shell-command cmd)
  (catch-errors #f)
  (display "Press ENTER to return to ARSE: ")
  (flush-output-port)
  (read-line)
  (initscr)
  (raw)
  (noecho)
  (nonl)
  (buf-status buf)
  (buf-display buf)
  'ok)

(define (colon-exit buf yes!)
  (if (buf-modified? buf)
      (buf-save! buf yes!))
  (if (not (buf-modified? buf))
      (quit)
      'failed))

(define (colon-help buf)
  (let ((helpfile (locate-file "arse.help")))
    (if (not helpfile)
        (err buf "could not locate help file")
        (goto-transient-buffer buf
                               #f
                               bp-tag-help
                               (lambda (new)
                                 (buf-load! new helpfile)
                                 (buf-set-name! new " *Help* "))))))

(define (list-buffers buf)
  (let ((n 1))
    (start-info buf)
    (for-each (lambda (x)
                (addstr (format #f "~D: ~5D ~C ~S"
                                   n
                                   (buf-length x)
                                   (cond ((buf-modified? x)  #\M)
                                         ((buf-transient? x) #\T)
                                         (else               #\space))
                                   (if (buf-name x)
                                       (buf-name x)
                                       '*anonymous*)))
                (crlf)
                (set! n (+ 1 n)))
              *Buffers*)
    (end-info buf)))

(define (buffer-open buf args)
  (if (not (= (length args) 2))
      (err buf "usage: buffer open #")
      (let ((n (string->number (cadr args))))
        (if (and n (<= 1 n (length *Buffers*)))
            (let* ((nb (list-ref *Buffers* (- n 1)))
                   (b  (cons nb (remq nb *Buffers*))))
              (set! *Buffers* b)
              nb)
            (err buf "~A: no such buffer" (cadr args))))))

(define (small-buffers buf)
  (list (buf-yanked buf)
        (buf-searchbuf buf)
        (buf-revsearch buf)))

(define (set-small-buffers! buf sb)
  (buf-set-yanked! buf    (car sb))
  (buf-set-searchbuf! buf (cadr sb))
  (buf-set-revsearch! buf (caddr sb)))

(define (copy-globals src dest)
  (for-each (lambda (prop)
              (if (buf-prop? src prop)
                  (buf-add-prop! dest prop)
                  (buf-rem-prop! dest prop)))
            (list bp-saveintbuf
                  bp-sharebuffers)))

(define (buffer-switch how buf)
  (let ((sb (small-buffers buf)))
    (if (null? (cdr *Buffers*))
        (err buf "there is only one buffer!")
        (let ((new (how)))
          (copy-globals buf new)
          (if (buf-prop? buf bp-sharebuffers)
              (set-small-buffers! new sb))
          new))))

(define (buffer-rotate buf)
  (buffer-switch rotate-buffers! buf))

(define (buffer-swap buf)
  (buffer-switch swap-buffers! buf))

(define (colon-buffer buf args)
  (if (null? args)
      (err buf "usage: buffer command ...")
      (cond ((member (car args) '("c" "close"))
              (cond ((null? (cdr *Buffers*))
                      (err buf "there is only one buffer!"))
                    ((buf-modified? buf)
                      (err buf
                           (string-append "buffer is unsaved! use :w to save"
                                          "it or :bc! to close it anyway")))
                    (else
                      (delete-buffer buf))))
            ((member (car args) '("c!" "close!"))
              (cond ((null? (cdr *Buffers*))
                      (err buf "there is only one buffer!"))
                    (else
                      (delete-buffer buf))))
            ((member (car args) '("l" "list"))
                  (list-buffers buf))
            ((member (car args) '("n" "new"))
                  (new-buffer (clean-up-props buf) (buf-values buf)))
            ((member (car args) '("o" "open"))
                  (buffer-open buf args))
            ((member (car args) '("r" "rotate"))
              (buffer-rotate buf))
            ((member (car args) '("s" "swap"))
              (buffer-swap buf))
            (else
              (err buf "~A: buffer: unknown sub-command" (car args))))))

(define (string-subst buf s p0 old new flags)
  (let* ((ko (string-length old))
         (kn (string-length new))
         (ks (string-length s))
         (u  (and (< (+ p0 ko) ks)
                  (string-pos buf old (substring s p0 ks)))))
    (if u
        (let* ((u (+ p0 u))
               (n (string-append (substring s 0 u)
                                 new
                                 (substring s (+ u ko) ks))))
          (if (memv #\g (string->list flags))
              (string-subst buf n (- (+ 1 u kn) ko) old new flags)
              n))
        s)))

(define (regex-subst buf s cre new flags)
  (let ((new (apply re-subst cre s new flags)))
    (if new new s)))

(define (subst-block buf text old new flags)
  (let ((cre  (if (buf-prop? buf bp-regex)
                  (re-comp old)
                  #t))
        (opts (if (memv #\g (string->list flags))
                  '(all)
                  '())))
    (if (not cre)
        (begin (err buf "invalid regular expression")
               text)
        (map (lambda (x)
               (if (buf-prop? buf bp-regex)
                   (regex-subst buf x cre new opts)
                   (string-subst buf x 0 old new flags)))
             text))))

(define (substitute buf from to op args)
  (real-pos! buf)
  (buf-modified! buf)
  (let* ((flag-ch* '(#\g))
         (dlm      (string-ref op (- (string-length op) 1)))
         (args     (string-split dlm args))
         (old      (if (null? args)
                       #f
                       (car args)))
         (new      (if (< (length args) 2)
                       ""
                       (cadr args)))
         (flags    (if (< (length args) 3)
                       ""
                       (caddr args)))
         (flags-ok (not (memq #f (map (lambda (x)
                                        (memv x flag-ch*))
                                      (string->list flags))))))
    (if (or (not old)
            (not flags-ok)
            (string=? "" old)
            (> (length args) 3))
        (err buf "usage: [<range>]s/<old>/[<new>/][g]")
        (change-block buf from to subst-block old new flags))))

(define (colon-version buf)
  (start-info buf)
  (addstr "ARSE is a Recursive Scheme Editor")
  (addstr " (beta version, expect bugs!)")
  (crlf)
  (end-info buf))

(define (set-boolean-option buf opt args)
  (if (not (= 1 (length args)))
      (err buf (format #f "usage: :set [no]~A" (car (pt-names opt))))
      (let* ((no   (and (= (length args) 1)
                        (>= (string-length (car args)) 2)
                        (string=? "no" (substring (car args) 0 2))))
             (setr (if no
                       buf-rem-prop!
                       buf-add-prop!))
             (args (cdr args)))
      (setr buf (pt-prop opt)))))

(define (extract-string-arg s)
  (let* ((s (substring s
                      (+ 1 (string-position "=" s))
                      (string-length s)))
         (k (string-length s))
         (s (if (and (positive? k)
                     (char=? #\" (string-ref s 0))
                     (char=? #\" (string-ref s (- k 1))))
                (substring s 1 (- k 1))
                s)))
    s))

(define (set-option-value buf opt args s-arg)
  (if (not (= 2 (length args)))
      (err buf (format #f "usage: :set ~A=value" (car (pt-names opt))))
      (let ((val (case (pt-type opt)
                       ((integer)
                         (cond ((string->number (cadr args))
                                 => (lambda (x) x))
                               (else
                                 (err buf (format #f "~A: number expected"
                                                     (car (pt-names opt)))))))
                       (else
                         (extract-string-arg s-arg)))))
        (if (failed? val)
            val
            (begin (buf-set-val! buf (pt-prop opt) val)
                   (if (eq? 'string (pt-type opt))
                       'done
                       'ok))))))

(define (set-option-2 buf args str-arg)
  (let ((name (car args)))
    (let loop ((p *val-table*))
      (cond ((null? p)
              (err buf "~A: unknown option" name))
            ((member name (pt-names (car p)))
              (set-option-value buf (car p) args str-arg))
            (else
              (loop (cdr p)))))))

(define (set-option buf args str-arg)
  (let* ((args (string-split #\= args))
         (name (car args)))
    (let loop ((p *prop-table*))
      (cond ((null? p)
              (set-option-2 buf args str-arg))
            ((or (member name (pt-names (car p)))
                 (and (> (string-length name) 2)
                      (string=? "no" (substring name 0 2))
                      (member (substring name 2 (string-length name))
                              (pt-names (car p)))))
              (set-boolean-option buf (car p) args)
              'ok)
            (else
              (loop (cdr p)))))))

(define (list-options buf)
  (start-info buf)
  (let* ((options (split *prop-table*))
         (opts1   (car options))
         (opts2   (if (< (length (cadr options))
                         (length (car options)))
                  (append (cadr options) '(#f))
                  (cadr options))))
    (for-each (lambda (x1 x2)
                (addstr
                  (if x2
                      (format #f "~A~30A~A~A"
                                 (if (not (buf-prop? buf (pt-prop x1)))
                                     "no"
                                     "  ")
                                 (car (pt-names x1))
                                 (if (not (buf-prop? buf (pt-prop x2)))
                                     "no"
                                     "  ")
                                 (car (pt-names x2)))
                      (format #f "~A~A"
                                 (if (not (buf-prop? buf (pt-prop x1)))
                                     "no"
                                     "  ")
                                 (car (pt-names x1)))))
                (crlf))
              opts1
              opts2))
  (for-each (lambda (x)
              (let ((s (format #f (if (eq? 'integer (pt-type x))
                                      "~A=~A"
                                      "~A=\"~A\"")
                                  (car (pt-names x))
                                  (buf-val buf (pt-prop x)))))
                (addstr s)
                (crlf)))
            *val-table*)
  (end-info buf)
  'ok)

(define (colon-set buf all-args)
  (if (and (string? all-args)
           (string=? "all" all-args))
      (list-options buf)
      (let ((args (string-parse " " all-args)))
        (let loop ((args args))
          (if (null? args)
              'ok
              (case (set-option buf (car args) all-args)
                    ((ok)     (loop (cdr args)))
                    ((done)   'ok)
                    ((failed) 'failed)))))))

(define (extract-symbols-from-file path)
  (with-input-from-file
    path
    (lambda ()
      (let loop ((line (read-line))
                 (syms '()))
        (if (or (eof-object? line)
                (string=? "" line))
            (if (null? syms)
                '()
                (reverse! (list->set syms)))
            (let* ((s* (string-split LP line))
                   (s* (if (> (length s*) 1)
                           (cadr s*)
                           ""))
                   (s* (string-parse (string #\space RP) s*))
                   (s* (if (not (null? s*))
                           (car s*)
                           "")))
              (loop (read-line) (cons s* syms))))))))

(define (find-completion-symbols)
  (let* ((hpath  (find-help-path))
         (files  (if hpath
                     (sys:readdir hpath)
                     '()))
         (files  (apply append
                        (map (lambda (x)
                               (let ((file (string-append hpath "/" x)))
                                 (if (sys:lstat-regular? file)
                                     (list x)
                                     '())))
                             files)))
         (topics (apply append
                        (map (lambda (file)
                               (extract-symbols-from-file
                                 (string-append hpath "/" file)))
                             files)))
         (topics (remove "" (sort string-ci<=? topics))))
    topics))

(define (make-completion-symbols)
  (let* ((home (getenv "HOME"))
         (syms (if home (find-completion-symbols)))
         (path (if home (string-append home "/.arse.symbols"))))
    (catch-errors #t)
    (if home
        (begin (if (file-exists? path)
                   (remove-file path))
               (with-output-to-file
                 path
                 (lambda ()
                   (set! *Completion-symbols* syms)
                   (for-each (lambda (x)
                               (display x)
                               (newline))
                             *Completion-symbols*)))))
    (catch-errors #f)))

(define (colon-rehash buf)
  (info buf "collecting completion symbols...")
  (make-completion-symbols)
  (info buf (format #f "rehashed ~A symbols"
                       (length *Completion-symbols*))))

(define (colon-command buf)
  (let ((cmd    (get-line (text-lines) buf ":" #f))
        (s-cmds '("s/" "s|" "s,")))
    (if (not cmd)
        buf
        (let* ((next (string->list cmd))
               (next (if (in? next pos-set)
                         (parse-pos buf next)
                         (list #f next)))
               (bgn  (if (in? (cadr next) '(#\%))
                         0
                         (car next)))
               (next (if (in? (cadr next) '(#\,))
                         (parse-pos buf (cdadr next))
                         (list #f (cadr next))))
               (end  (if (in? (cadr next) '(#\%))
                         (end-of-buffer buf)
                         (car next)))
               (next (if (in? (cadr next) '(#\%))
                         (list #f (cdadr next))
                         (list #f (cadr next))))
               (next (parse-op buf (cadr next)))
               (op   (car next))
               (rarg (if (member op s-cmds)
                         (list->string (cadr next))
                         (trim-left (list->string (cadr next)))))
               (args (string-parse " " (list->string (cadr next)))))
          (let ((bgn (if bgn
                         bgn
                         (if (member op s-cmds)
                             (buf-y buf)
                             0)))
                (end (if end
                         end
                         (if bgn
                             bgn
                             (if (member op s-cmds)
                                 (buf-y buf)
                                 (end-of-buffer buf))))))
            (if (> bgn end)
                (swap! bgn end))
            (cond ((string=? op "")
                    'ok)
                  ((member op '("!"))
                    (colon-shell buf rarg))
                  ((member op '("b" "buf" "buffer"))
                    (colon-buffer buf args))
                  ((member op '("bc"))
                    (colon-buffer buf '("c")))
                  ((member op '("bc!"))
                    (colon-buffer buf '("c!")))
                  ((member op '("bl"))
                    (colon-buffer buf '("l")))
                  ((member op '("bn"))
                    (colon-buffer buf '("n")))
                  ((member op '("br"))
                    (colon-buffer buf '("r")))
                  ((member op '("bs"))
                    (colon-buffer buf '("s")))
                  ((member op '("bo"))
                    (colon-buffer buf (cons "o" args)))
                  ((member op '("e" "edit"))
                    (colon-edit buf #f args))
                  ((member op '("e!" "edit!"))
                    (colon-edit buf #t args))
                  ((member op '("h" "help"))
                    (colon-help buf))
                  ((member op '("q" "quit"))
                    (colon-quit buf #f))
                  ((member op '("q!" "quit!"))
                    (colon-quit buf #t))
                  ((member op '("r" "read"))
                    (colon-read buf args))
                  ((member op '("rehash"))
                    (colon-rehash buf))
                  ((member op s-cmds)
                    (substitute buf bgn end op rarg))
                  ((member op '("set"))
                    (colon-set buf rarg))
                  ((member op '("ver" "version"))
                    (colon-version buf))
                  ((member op '("wall" "writeall"))
                    (colon-write-all buf #f))
                  ((member op '("wall!" "writeall!"))
                    (colon-write-all buf #t))
                  ((member op '("w" "write"))
                    (colon-write buf #f bgn end args))
                  ((member op '("w!" "write!"))
                    (colon-write buf #t bgn end args))
                  ((member op '("x" "xit"))
                    (colon-exit buf #f))
                  ((member op '("x!" "xit!"))
                    (colon-exit buf #t))
                  (else
                    (err buf (string-append
                               ":"
                               op
                               ": unknown command"
                               " -- type :h for help")))))))))

(define (buffer-command buf k c)
  (let ((nc (if c c 1)))
    (cond ((char=? k TAB) (buffer-rotate buf))
          ((char=? k ^^)  (buffer-swap buf))
          ((char=? k #\:) (colon-command buf))
          ((char=? k #\=) (scheme-interface buf))
          ((char=? k #\Z) (save+exit buf))
          (else           'no))))

(define (run-command buf kc)
  (or (not (eq? 'no (apply motion-command buf kc)))
      (not (eq? 'no (apply insdel-command buf kc)))
      (not (eq? 'no (apply other-command buf kc)))
      (let ((retval (apply buffer-command buf kc)))
        (and (not (eq? 'no retval))
             retval))
      (err buf "~A: unknown command -- type :h for help"
           (unctrl (char->integer (car kc))))))

(define (command-loop buf repaint)
  (if repaint
      (buf-display buf))
  (buf-status buf)
  (let ((val (run-command buf (get-cmd buf))))
    (cond ((eq? val 'quit) (if #f #f))
          ((vector? val)   (command-loop val #t))
          (else            (command-loop buf #f)))))

(define (edit buf)
  (command-loop buf #t))

(define (read-config! buf)
  (let ((home (getenv "HOME")))
    (if home
        (let ((dotfile (string-append home "/.arserc")))
          (if (file-readable? dotfile)
              (let loop ((in (with-input-from-file dotfile read-file)))
                (cond ((null? in))
                      ((string=? "" (car in))
                        (loop (cdr in)))
                      ((char=? #\; (string-ref (car in) 0))
                        (loop (cdr in)))
                      ((eq? 'ok (set-option buf
                                            (car (string-split #\space
                                                               (car in)))
                                            (car in)))
                        (loop (cdr in)))
                      (else
                        (buf-status buf)
                        (getch)
                        (loop (cdr in))))))))))

(define (load-completion-symbols)
  (let* ((home (getenv "HOME"))
         (path (if home (string-append home "/.arse.symbols"))))
    (if (and home (file-exists? path))
        (set! *Completion-symbols*
              (with-input-from-file path read-file)))))

(define (arse . args)
  (initscr)
  (raw)
  (noecho)
  (nonl)
  (idlok #t)
  (scrollok #f)
  (keypad #t)
  (let* ((name    (if (null? args)
                      #f
                      (car args)))
         (options (if (null? args)
                      '()
                      (cdr args))))
    (let ((buf (new-buffer))
          (options (apply append (map string->list options))))
      (buf-add-prop! buf bp-autoload)
      (read-config! buf)
      (load-completion-symbols)
      (set! *default-prop* (buf-prop buf))
      (if (memv #\r options)
          (buf-add-prop! buf bp-readonly))
      (if name
          (if (not (buf-load! buf name))
              (begin (buf-set-name! buf name)
                     (info buf "new file")))
          (info buf (string-append "Welcome to ARSE! This is a beta version,"
                                   " expect bugs! Type :h for help")))
      (edit buf))))
