;;;; text-buffer.scm -- Emacs-style text buffers
;;
;; Copyright (c) 2004 Alex Shinn
;; All rights reserved.
;;
;; BSD-style license: http://www.debian.org/misc/bsd.license

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Requires R5RS Scheme with SRFI-6 string-ports and SRFI-9 records.

;; Documentation forthcoming.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compatibility syntax

;; SRFI-2
(define-syntax and-let*
  (syntax-rules ()
    ((and-let* () . b) (begin . b))
    ((and-let* (((x ...)) . r) . b) (and (x ...) (and-let* r . b)))
    ((and-let* ((v x) . r) . b) (let ((v x)) (and v (and-let* r . b))))))

;; SRFI-26 (Al* Petrofsky's version, alpha reduced)
(define-syntax %cut
  (syntax-rules (<> <...>)
    ((%cut (s ...) (f x ...)) (lambda (s ...) ((begin f) x ...)))
    ((%cut (s ...) (f x ...) <...>) (lambda (s ... . r) (apply f x ... r)))
    ((%cut (s ...) (pos ...) <> . se) (%cut (s ... x) (pos ... x) . se))
    ((%cut (s ...) (pos ...) nse . se) (%cut (s ...) (pos ... nse) . se))))
(define-syntax cut (syntax-rules () ((cut . rest) (%cut () () . rest))))

;; more descriptive conditionals
(define-syntax when
  (syntax-rules () ((when test . body) (if test (begin . body)))))

(define-syntax unless
  (syntax-rules () ((unless test . body) (when (not test) . body))))

;; optional argument parsing
(define-syntax get-optional
  (syntax-rules ()
    ((get-optional opt default) (if (pair? opt) (car opt) default))))

(define-syntax let-optionals*
  (syntax-rules ()
    ((let-optionals* (expr ...) . args)
     (let ((tmp (expr ...)))
       (let-optionals* tmp . args)))
    ((let-optionals* ls () . body)
     (begin . body))
    ((let-optionals* ls ((var default) . rest) . body)
     (let ((var (if (pair? ls) (car ls) default)))
       (let-optionals* (if (pair? ls) (cdr ls) '())
           rest . body)))
    ((let-optionals* ls (var . rest) . body)
     (let-optionals* ls ((var #f) . rest) . body))
    ((let-optionals* ls rest . body)
     (let ((rest ls)) . body))))

;; nice if you can provide this optimization
(define-syntax define-inline
  (syntax-rules () ((define-inline . args) (define . args))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFIs

;; comment out if you have SRFI-1
(define (filter pred ls)
  (let lp ((ls ls) (acc '()))
    (cond ((null? ls) (reverse acc))
          ((pred (car ls)) (lp (cdr ls) (cons (car ls) acc)))
          (else (lp (cdr ls) acc)))))
(define (delete x ls . opt)
  (let ((eq (get-optional opt equal?)))
    (filter (lambda (y) (not (eq x y))) ls)))

;; comment out if you have SRFI-13
(define-inline (substring/shared s from . o)
  (substring s from (get-optional o (string-length s))))
(define-inline (string-concatenate-reverse ls)
  (apply string-append (reverse ls)))
(define-inline (string-reverse s)
  (list->string (reverse (string->list s))))
(define (string-index str pred)
  (let ((limit (string-length str)))
    (let lp ((i 0))
      (cond ((= i limit) #f)
            ((pred (string-ref str i)) i)
            (else (lp (+ i 1)))))))
(define (string-index-right str pred)
  (let lp ((i (- (string-length str) 1)))
    (cond ((negative? i) #f)
          ((pred (string-ref str i)) i)
          (else (lp (- i 1))))))

;; comment out if you have SRFI-13, otherwise you won't be able to
;; search by strings
(define (make-kmp-restart-vector s . opt) #f)
(define (string-kmp-partial-search pat rv s i . opt) 0)

;; comment out if you have SRFI-14, otherwise you won't be able to
;; search by char-sets
(define (char-set? obj) #f)
(define (char-set-contains? cs x) #f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities

;; requires current-error-port or translation to native warning
(define (warn . args)
  ;;(for-each (cut display <> (current-error-port)) args)
  ;;(newline (current-error-port))
  #f)

(define (port->string . opt)
  (let ((in (get-optional opt (current-input-port)))
        (out (open-output-string)))
    (let lp ()
      (let ((c (read-char in))) ;; XXXX read bigger chunks
        (if (eof-object? c)
          (get-output-string out)
          (begin (display c out) (lp)))))))

(define (x->string obj)
  (cond ((string? obj) obj)
        ((symbol? obj) (symbol->string obj))
        ((number? obj) (number->string obj))
        (else
         (let ((out (open-output-string)))
           (display obj out)
           (get-output-string out)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compatibility encoding routines, specify these to handle multiple
;; encodings

(define (with-input-from-encoded-file file enc thunk)
  (with-input-from-file file thunk))

(define (with-output-to-encoded-file file enc thunk)
  (with-output-to-file file thunk))

(define (detect-file-encoding file)
  #f)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;; No customizations below here should be required. ;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; representation

(define-record-type <text>
  (%make-text segments point file file-encoding)
  text?
  (segments text-segments set-text-segments!)
  (point    text-point    set-text-point!)
  (file     text-file     set-text-file!)
  (file-encoding text-file-encoding set-text-file-encoding!))

(define-record-type <text-segment>
  (%make-text-segment source next prev)
  text-segment?
  (source  ts-source  set-ts-source!)
  (length  ts-length  set-ts-length!)
  (prev    ts-prev    set-ts-prev!)
  (next    ts-next    set-ts-next!)
  (markers ts-markers set-ts-markers!))

(define-record-type <text-marker>
  (%make-text-marker segment offset)
  text-marker?
  (segment tm-segment set-tm-segment!)
  (offset  tm-offset  set-tm-offset!)
  (data    tm-data    set-tm-data!)
  (gravity tm-gravity set-tm-gravity!))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; construction

(define (insert-sorted! ls elt . opt<)
  (let ((sort< (get-optional opt< <)))
    (if (null? ls)
      (list elt)
      (let loop ((l ls))
        (let ((first (car l)))
          (if (sort< elt first)
            (begin
              (set-cdr! l (cons first (cdr l)))
              (set-car! l elt)
              ls)
            (let ((rest (cdr l)))
              (if (null? rest)
                (begin
                  (set-cdr! l (list elt))
                  ls)
                (loop rest)))))))))

(define (tm<? a b)
  (or (< (tm-offset a) (tm-offset b))
      (and (= (tm-offset a) (tm-offset b))
           (eq? (tm-gravity a) 'left)
           (eq? (tm-gravity b) 'right))))

(define (make-text-segment src next prev)
  (let ((t (%make-text-segment src next prev)))
    (set-ts-length! t (if (string? src) (string-length src) 0))
    (set-ts-markers! t '())
    t))

(define (make-text-marker seg off . opt)
  (let-optionals* opt ((gravity 'right)
                       (data #f))
    (let ((tm (%make-text-marker seg off)))
      (set-tm-gravity! tm gravity)
      (set-tm-data! tm data)
      (set-ts-markers! seg (insert-sorted! (ts-markers seg) tm tm<?))
      tm)))

(define (make-text . opt)
  (let* ((src (get-optional opt ""))
         (seg (make-text-segment src #f #f))
         (point (make-text-marker seg 0)))
    (%make-text seg point #f #f)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; file access

(define (text-from-file file . opt)
  (define (file-text enc)
    (if enc
      (with-input-from-encoded-file file enc port->string)
      (with-input-from-file file port->string)))
  (let-optionals* opt ((enc (detect-file-encoding file)))
    (let ((t (make-text (file-text enc))))
      (when enc (set-text-file-encoding! t enc))
      (set-text-file! t file)
      t)))

(define (text-save text)
  (and-let* ((file (text-file text)))
    (let ((enc (text-file-encoding text)))
      (if enc
        (with-output-to-encoded-file file enc (cut text-display text))
        (with-output-to-file file (cut text-display text))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; text segment operations

;; gets output string if a port segment
(define (ts-normalize! ts)
  (let ((d (ts-source ts)))
    (when (output-port? d)
      (set-ts-source! ts (get-output-string d)))))

(define-inline (ts-source/string! ts)
  (ts-normalize! ts)
  (ts-source ts))

(define-inline (ts-source/string ts)
  (let ((d (ts-source ts)))
    (if (output-port? d) (get-output-string d) d)))

;; drop and return markers after off on ts, guaranteed to act
;; destructively
(define (ts-drop-markers! ts off new)
  (define (shift m)
    (unless (text-segment? new) (warn "bad new segment: " new))
    (set-tm-offset! m (- (tm-offset m) off))
    (set-tm-segment! m new))
  (let ((markers (ts-markers ts)))
    (if (pair? markers)
      (cond
        ((or (> (tm-offset (car markers)) off)
             (and (= (tm-offset (car markers)) off)
                  (eq? (tm-gravity (car markers)) 'right)))
         (set-ts-markers! ts '())
         (for-each shift markers)
         markers)
        (else
         (let loop ((ls markers))
           (cond
             ((null? (cdr ls)) '())
             ((or (> (tm-offset (cadr ls)) off)
                  (and (= (tm-offset (cadr ls)) off)
                       (eq? (tm-gravity (cadr ls)) 'right)))
              (let ((res (cdr ls)))
                (set-cdr! ls '())
                (for-each shift res)
                res))
             (else (loop (cdr ls)))))))
      '())))

(define (ts-split! ts off)
  (ts-normalize! ts)
  (let* ((src (ts-source ts))
         (new (make-text-segment (substring/shared src off)
                                 (ts-next ts) ts)))
    (set-ts-source! ts (substring/shared src 0 off))
    (set-ts-length! ts off)
    (set-ts-next! ts new)))

;; returns length appended
(define (ts-append! ts obj)
  (define d (ts-source ts))
  (cond ((output-port? d)
         (let* ((str (x->string obj))
                (len (ts-length ts))
                (new-len (+ len (string-length str))))
           (display str d)
           (for-each
            (lambda (m) (set-tm-offset! m new-len))
            (filter (lambda (m)
                      (or (> (tm-offset m) len)
                          (and (= (tm-offset m) len)
                               (eq? (tm-gravity m) 'right))))
                    (ts-markers ts)))
           (set-ts-length! ts new-len)
           len))
        (else
         (let* ((str (x->string obj))
                (len (string-length str))
                (out (open-output-string))
                (next (ts-next ts))
                (new (make-text-segment out next ts)))
           (set-ts-markers! new (ts-drop-markers! ts (ts-length ts) new))
           (for-each (lambda (m) (set-tm-offset! m len)) (ts-markers new))
           (display str out)
           (set-ts-length! new len)
           (when next (set-ts-prev! next new))
           (set-ts-next! ts new)
           len))))

;; returns new offset past pos
(define (ts-insert! ts pos obj)
  (let ((l (ts-length ts))
        (d (ts-source ts)))
    (cond
      ((= l pos) ;; append
       (+ pos (ts-append! ts obj)))
      ((and (zero? pos) (ts-prev ts))
       (ts-append! (ts-prev ts) obj))
      ((> pos l) ;; recurse
       (let ((next (ts-next ts)))
         (cond (next
                (ts-insert! next (- pos l) obj))
               (else
                (warn "inserting past end of text")
                (- (ts-insert! ts l obj) (- pos l))))))
      (else ;; split
       (ts-split! ts pos)
       (ts-append! ts obj)))))

(define (ts-delete! ts pos i)
  (let ((l (ts-length ts)))
    (cond
      ((> pos l) ;; recurse
       (let ((next (ts-next ts)))
         (if next
           (ts-delete! (ts-next ts) (- pos l) i)
           (warn "deleting past end of text"))))
      ((zero? pos) ;; delete here
       (cond
         ((< i l) ;; don't delete the whole thing
          (ts-normalize! ts)
          (set-ts-source! ts (substring/shared (ts-source ts) i))
          (set-ts-length! ts (- (ts-length ts) i)))
         (else ;; skip and maybe recurse
          (set-ts-source! ts "")
          (set-ts-length! ts 0)
          (unless (= i l)
            (let ((next (ts-next ts)))
              (if next
                (ts-delete! next 0 (- i l))
                (warn "deleting past end of text")))))))
      (else ;; split and delete from right end
       (ts-split! ts pos)
       (ts-delete! (ts-next ts) 0 i)))))

;; count from point 0 of ts, negative pos means count backwards, sticks
;; to start/end of buffer if pos is out of range
(define (call-with-ts+offset-at-pos ts pos proc)
  (if (negative? pos)
    (let lp ((t ts)
             (i (- pos)))
      (let ((prev (ts-prev t)))
        (if prev
          (let ((len (ts-length prev)))
            (if (<= i len)
              (proc prev (- len i))
              (lp prev (- i len))))
          (proc t 0))))
    (let lp ((t ts)
             (i pos))
      (let ((len (ts-length t)))
        (if (<= i len)
          (proc t i)
          (cond
            ((ts-next t)
             => (cut lp <> (- i len)))
            (else (proc t (ts-length t)))))))))

;; acts on all successive segments
(define (ts-display ts . opt)
  (let ((out (get-optional opt (current-output-port))))
    (let lp ((x ts))
      (when x
        (let ((s (ts-source x)))
          (display (if (output-port? s) (get-output-string s) s) out))
        (lp (ts-next x))))))

(define (ts->string ts)
  (let ((out (open-output-string)))
    (ts-display ts out)
    (get-output-string out)))

(define (ts-leftmost ts)
  (let ((prev (ts-prev ts)))
    (if prev (ts-leftmost prev) ts)))

(define (ts-rightmost ts)
  (let ((next (ts-next ts)))
    (if next (ts-rightmost next) ts)))

(define (ts-dump ts)
  (let ((out (open-output-string)))
    (let lp ((t (ts-leftmost ts)))
      (when t
        (display (if (eq? t ts) "[" "(") out)
        (and-let* ((s (ts-source t)))
          (display (if (output-port? s) (get-output-string s) s) out))
        (display (if (eq? t ts) "]" ")") out)
        (display ":" out)
        (display (ts-length t) out)
        (and-let* ((next (ts-next t)))
          (display "->" out)
          (lp next))))
    (get-output-string out)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; marks

(define-inline (tm-insert! tm obj)
  (ts-insert! (tm-segment tm) (tm-offset tm) obj))

(define-inline (tm-delete! tm count)
  (ts-delete! (tm-segment tm) (tm-offset tm) count))

(define-inline (tm-unlink! tm)
  (let ((seg (tm-segment tm)))
    (set-ts-markers! seg (delete tm (ts-markers seg) eq?))))

(define (tm-move! tm new-seg new-off)
  (unless (text-segment? new-seg) (warn "bad new segment: " new-seg))
  (tm-unlink! tm)
  (set-tm-segment! tm new-seg)
  (set-tm-offset! tm new-off)
  (set-ts-markers! new-seg (insert-sorted! (ts-markers new-seg) tm tm<?)))

(define (tm-swap! a b)
  (let ((tmp-seg (tm-segment a))
        (tmp-off (tm-offset a)))
    (tm-move! a (tm-segment b) (tm-offset b))
    (tm-move! b tmp-seg tmp-off)))

(define (tm-before? a b)
  (let ((ts-b (tm-segment b))
        (ts-a (tm-segment a)))
    (if (eq? ts-a ts-b)
      (< (tm-offset a) (tm-offset b))
      (let loop ((ts ts-a))
        (cond ((eq? ts ts-b) #t)
              ((ts-next ts) => loop)
              (else #f))))))

(define-inline (tm-after? a b) (tm-before? b a))

;; same location, not full equality
(define-inline (tm-same? a b)
  (and (eq? (tm-segment a) (tm-segment b))
       (= (tm-offset a) (tm-offset b))))

(define-inline (tm-copy tm)
  (make-text-marker (tm-segment tm) (tm-offset tm)))

(define (tm-forward-char tm i)
  (let* ((off (tm-offset tm))
         (new-off (+ off i))
         (ts (tm-segment tm)))
    (cond
      ((or (< new-off 0) (> new-off (ts-length ts)))
       (call-with-ts+offset-at-pos ts new-off
         (lambda (ts2 off2) (tm-move! tm ts2 off2))))
      (else
       (set-tm-offset! tm new-off)
       (set-ts-markers!
        ts (insert-sorted! (delete tm (ts-markers ts) eq?) tm tm<?))))))

(define (tm-backward-char tm i)
  (tm-forward-char tm (- i)))

(define (tm-end tm)
  (let ((ts (ts-rightmost (tm-segment tm))))
    (make-text-marker ts (ts-length ts))))

(define (tm-start tm)
  (let ((ts (ts-leftmost (tm-segment tm))))
    (make-text-marker ts 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; misc

(define-inline (text-mark text)
  (tm-copy (text-point text)))

(define (text-save-excursion text thunk)
  (let* ((tmp (text-mark text))
         (res (thunk)))
    (tm-move! (text-point text) (tm-segment tmp) (tm-offset tmp))
    (tm-unlink! tmp)
    res))

;; move to a point then call a procedure on the resulting region
(define (text-with-selector text move proc)
  (let ((start (text-mark text)))
    (move text)
    (let* ((end (text-point text))
           (res (if (tm-before? start end)
                  (proc start end)
                  (proc end start))))
      (tm-move! (text-point text) (tm-segment start) (tm-offset start))
      (tm-unlink! start)
      res)))

(define-inline (text-insert! text obj)
  (tm-insert! (text-point text) obj))

(define-inline (text-delete! text . opt)
  (tm-delete! (text-point text) (get-optional opt 1)))

(define (text-char-after text . opt)
  (let* ((tm (get-optional opt (text-point text)))
         (seg (tm-segment tm))
         (off (tm-offset tm))
         (len (ts-length seg)))
    (cond
      ((>= off len)
       (and-let* ((next (ts-next seg))
                  ((> (ts-length next) 0)))
         (ts-normalize! next)
         (string-ref (ts-source next) 0)))
      (else
       (ts-normalize! seg)
       (string-ref (ts-source seg) (tm-offset tm))))))

(define (text-delete-region! start end)
  (let ((last-seg (tm-segment end))
        (last-off (tm-offset end)))
    (let loop ((ts (tm-segment start))
               (off (tm-offset start)))
      (cond
        ((eq? ts last-seg) ; allow reverse start/end
         (let ((lo (min off last-off))
               (hi (max off last-off)))
           (ts-delete! ts lo (- hi lo))))
        (else
         (ts-delete! ts off (- (ts-length ts) off))
         (and-let* ((next (ts-next ts)))
           (loop next 0)))))))

;; takes start marker & either end marker or length
(define (region->string start . opt)
  (let ((end (get-optional opt #f)))
    (cond
      ((number? end)
       (let ((end-tm (tm-copy start)))
         (tm-forward-char end-tm end)
         (let ((res (region->string start end-tm)))
           (tm-unlink! end-tm)
           res)))
      ((not end)
       (let* ((end-tm (tm-end start))
              (res (region->string start end-tm)))
         (tm-unlink! end-tm)
         res))
      (else
       (let ((last-ts (tm-segment end))
             (last-off (tm-offset end)))
         (let loop ((ts (tm-segment start))
                    (off (tm-offset start))
                    (res '()))
           (ts-normalize! ts)
           (cond
             ((eq? ts last-ts)
              (string-concatenate-reverse
               (cons (substring/shared (ts-source ts) off last-off) res)))
             (else
              (and-let* ((next (ts-next ts))
                         (str (substring/shared
                               (ts-source ts) off (ts-length ts))))
                (loop next 0 (cons str res)))))))))))

(define (text->string text)
  (ts->string (ts-leftmost (text-segments text))))

(define (text-display text)
  (ts-display (ts-leftmost (text-segments text))))

(define (text-dump text)
  (string-append "text (" (or (text-file text) "-") "): "
                 (ts-dump (ts-leftmost (text-segments text)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; movement

(define (text-current-position text)
  (let* ((point (text-point text))
         (seg (tm-segment point)))
    (let loop ((ts (ts-leftmost (text-segments text)))
               (acc 0))
      (if (eq? ts seg)
        (+ acc (tm-offset point))
        (loop (ts-next ts) (+ acc (ts-length ts)))))))

(define (text-goto-char text i)
  (call-with-ts+offset-at-pos (ts-leftmost (text-segments text)) i
    (lambda (ts off) (tm-move! (text-point text) ts off))))

(define (text-beginning-of-buffer text)
  (text-goto-char text 0))

(define (text-end-of-buffer text)
  (let* ((point (text-point text))
         (ts1 (tm-segment point))
         (ts2 (ts-rightmost ts1)))
    (tm-move! point ts2 (ts-length ts2))))

(define (text-forward-char text . opt)
  (tm-forward-char (text-point text) (get-optional opt 1)))

(define (text-backward-char text . opt)
  (tm-backward-char (text-point text) (get-optional opt 1)))

(define (text-search-forward-char text pred)
  (let ((point (text-point text)))
    (let lp ((ts (tm-segment point))
             (off (tm-offset point))
             (sum 0))
      (let ((str (substring/shared (ts-source/string ts) off)))
        (cond ((string-index str pred)
               => (lambda (index)
                    (tm-move! point ts (+ off index))
                    sum))
              ((ts-next ts)
               => (cut lp <> 0 (+ sum (ts-length ts))))
              (else #f))))))

(define (text-search-forward-string text str . opt)
  (let* ((eq (get-optional opt eqv?))
         (rv (make-kmp-restart-vector str eq))
         (point (text-point text)))
    (let lp ((i 0) 
             (ts (tm-segment point))
             (off (tm-offset point)))
      (let* ((buf (substring/shared (ts-source/string ts) off))
             (i (string-kmp-partial-search str rv buf i)))
        (cond ((negative? i) (tm-move! point ts (- i)))
              ((ts-next ts) => (cut lp i <> 0))
              (else #f))))))

(define (text-search-forward text search)
  (cond ((char? search)
         (text-search-forward-char text (cut eq? <> search)))
        ((char-set? search)
         (text-search-forward-char text (cut char-set-contains? search <>)))
        ((procedure? search)
         (text-search-forward-char text search))
        ((string? search)
         (text-search-forward-string text search))
        (else (error "ivalid search parameter:" search))))

(define (text-search-backward-char text pred)
  (let* ((point (text-point text))
         (start-seg (tm-segment point))
         (start-offset (- (tm-offset point) 1)))
    (when (negative? start-offset)
      (set! start-seg (ts-prev start-seg))
      (if start-seg (set! start-offset (ts-length start-seg))))
    (and
     start-seg
     (let lp ((ts start-seg)
              (off start-offset)
              (sum 0))
       (let* ((str1 (ts-source/string ts))
              (str (substring/shared str1 0 (min (string-length str1)
                                                 (+ off 1)))))
         (let ((index (string-index-right str pred)))
           (cond (index
                  (tm-move! point ts index)
                  sum)
                 ((ts-prev ts)
                  => (lambda (prev)
                       (lp prev (ts-length prev) (+ sum off))))
                 (else #f))))))))

(define (text-search-backward-string text str . opt)
  (let* ((eq (get-optional opt eqv?))
         (pat (string-reverse str))
         (rv (make-kmp-restart-vector pat eq))
         (point (text-point text)))
    (let lp ((i 0) 
             (ts (tm-segment point))
             (off (tm-offset point)))
      (let* ((buf (string-reverse (substring/shared (ts-source/string ts) off)))
             (i (string-kmp-partial-search pat rv buf i)))
        (cond ((negative? i) (tm-move! point ts (- i)))
              ((ts-next ts) => (cut lp i <> 0))
              (else #f))))))

(define (text-search-backward text search)
  (cond ((char? search)
         (text-search-backward-char text (cut eq? <> search)))
        ((char-set? search)
         (text-search-backward-char text (cut char-set-contains? search <>)))
        ((procedure? search)
         (text-search-backward-char text search))
        ((string? search)
         (text-search-backward-string text search))
        (else (error "ivalid search parameter:" search))))

(define (text-beginning-of-line text . opt)
  (let loop ((i (get-optional opt 1)))
    (cond ((zero? i) (text-forward-char text))
          ((text-search-backward text #\newline)
           => (lambda (k) (loop (- i 1))))
          (else (text-beginning-of-buffer text)))))

(define (text-end-of-line text . opt)
  (let lp ((i (get-optional opt 1)))
    (or (zero? i)
        (and (text-search-forward text #\newline)
             (lp (- i 1)))
        (text-end-of-buffer text))))

(define (text-current-position text)
  (let* ((point (text-point text))
         (seg (tm-segment point))
         (off (tm-offset point)))
    (let loop ((ts (ts-leftmost seg))
               (pos 0))
      (if (eq? ts seg)
        (+ pos off)
        (loop (ts-next ts) (+ pos (ts-length ts)))))))

(define (text-current-column text)
  (let ((start (text-current-position text)))
    (text-save-excursion text
      (lambda ()
        (text-beginning-of-line text)
        (- start (text-current-position text))))))

(define (text-current-line-length text)
  (text-save-excursion text
    (lambda ()
      (text-end-of-line text)
      (text-current-column text))))

(define (text-next-line text . opt)
  (let ((col (text-current-column text)))
    (text-end-of-line text (get-optional opt 1))
    (text-forward-char text 1)
    (let ((col2 (text-current-line-length text)))
      (text-forward-char text (min col col2)))))

(define (text-previous-line text . opt)
  (let ((col (text-current-column text)))
    (text-beginning-of-line text (+ 1 (get-optional opt 1)))
    (let ((col2 (text-current-line-length text)))
      (text-forward-char text (min col col2)))))

(define (text-kill-line text . opt)
  (let ((start (text-current-column text))
        (end (text-save-excursion text
               (lambda ()
                 (text-end-of-line text)
                 (text-current-column text)))))
    (text-delete! text (- end start))))

(define (text-end-of-buffer? text)
  (let* ((tm (text-point text))
         (seg (tm-segment tm)))
    (and (not (ts-next seg))
         (>= (tm-offset tm) (ts-length seg)))))

(define (text-start-of-buffer? text)
  (let ((tm (text-point text)))
    (and (not (ts-prev (tm-segment tm)))
         (zero? (tm-offset tm)))))