source: project/release/4/kitaaba/trunk/text.scm @ 25842

;;;; test.scm


(defstruct line
  (text '#u16())                        ; U16VECTOR
  (next #f)                             ; LINE
  (prev #f))                            ; LINE


(define first-line (make-line))
(define cursor-line first-line)
(define cursor-column 0)
(define top-line first-line)
(define column 0)
(define line-height 1)
(define char-width 1)
(define left-margin 0)


(define (redraw)
  (let* ((w (surface-width screen))
         (h (surface-height screen))
         (maxchars (* 2 (quotient w char-width))))
    (fill screen 0 0 w h 0 0 0)         ;XXX background color
    (let loop ((ln top-line) (y 0))
      (when (and ln (< y h))
        (let* ((str (line-text ln))
               (len (u16vector-length str)))
          (when (eq? ln cursor-line) (draw-cursor y))
          (when (< column len)
            (let* ((ucs
                    (ucs-append
                     (subu16vector str column (min len maxchars))
                     (u16vector 0)))
                   (txt (render-ucs-text ucs 255 255 255))) ;XXX color
              (when txt
                (let ((tw (surface-width txt))
                      (th (surface-height txt)))
                  (blit txt 0 y)
                  (release-surface txt)))))
          (loop (line-next ln) (+ y line-height)))))
    (flip screen)))

(define (columns) 
  (quotient (surface-width screen) char-width))

(define (rows)
  (quotient (surface-height screen) line-height))

(define (draw-cursor y)
  (let ((x (* (- cursor-column column) char-width)))
    (when (< x (surface-width screen))
      (fill screen x y char-width line-height 255 255 255)))) ;XXX color

(define (scroll-up)
  (let loop ((lnn (rows)))
    (let ((ln2 (line-prev top-line)))
      (when (and ln2 (positive? lnn))
        (set! top-line ln2)
        (loop (sub1 lnn))))))

(define (scroll-down)
  (let loop ((lnn (rows)))
    (let ((ln2 (line-next top-line)))
      (when (and ln2 (positive? lnn))
        (set! top-line ln2)
        (loop (sub1 lnn))))))

(define (focus)
  (let ((tl top-line))
    (adjust-top-line)
    (unless (eq? tl top-line)
      (redraw))))

(define (load-text filename)
  (let loop ((lns (string-split (read-all filename) "\n" #t)) (prev #f))
    (unless (null? lns)
      (let ((ln (make-line 
                 text: (string->ucs (tabexpand (car lns)))
                 prev: prev)))
        (if prev
            (line-next-set! prev ln)
            (set! first-line ln))
        (loop (cdr lns) ln))))
  (set! cursor-line first-line))        ; "top-line" now invalid!

(define (insert ucs #!optional overwrite)
  (let ((len (u16vector-length ucs)))
    (define (scan s p)
      (cond ((>= p len) (ins (subu16vector ucs s len)))
            ((= 10 (u16vector-ref ucs p))
             (ins (subu16vector ucs s p))
             (set! cursor-column 0)
             ;;XXX should we just move to next line in overwrite mode?
             (let* ((cln (line-next cursor-line))
                    (ln (make-line 
                         prev: cursor-line
                         next: cln)))
               (line-next-set! cursor-line ln)
               (when cln
                 (line-prev-set! cln ln))
               (set! cursor-line ln)    ;XXX scrolling
               (scan (add1 p) (add1 p))))
            (else (scan s (add1 p)))))
    (define (ins ucs)
      (let* ((old (line-text cursor-line))
             (ucslen (u16vector-length ucs))
             (oldlen (u16vector-length old)))
        (line-text-set! 
         cursor-line
         (ucs-append
          (subu16vector old 0 cursor-column)
          (ucs-append
           ucs
           (subu16vector 
            old
            (min oldlen (+ cursor-column (if overwrite ucslen 0)))
            oldlen))))
        (inc! cursor-column ucslen)))
    (scan 0 0)
    (adjust-top-line)))

(define (insert-char code) (insert (u16vector code)))
(define (insert-string str) (insert (string->ucs str)))

(define (insert-fresh-line)
  (when (positive? cursor-column)
    (insert-char 10)))

(define (replace-char code) (insert (u16vector code) #t))

(define (current-line) cursor-line)

(define (current-char)
  (let* ((text (line-text cursor-line))
         (len (u16vector-length text)))
    (if (>= cursor-column len)
        (char->integer #\space)
        (u16vector-ref text cursor-column))))

(define (backspace)
  (when (> cursor-column left-margin)
    (let* ((old (line-text cursor-line))
           (len (u16vector-length old)))
      (line-text-set!
       cursor-line
       (ucs-append
        (subu16vector old 0 (sub1 cursor-column))
        (subu16vector old cursor-column len)))
      (dec! cursor-column))))

(define (adjust-top-line)
  (set! top-line
    (let loop ((y (- (surface-height screen) line-height))
               (ln cursor-line))
      (let ((prev (line-prev ln)))
        (if prev
            (let ((y2 (- y line-height)))
              (if (negative? y2)
                  ln
                  (loop y2 prev)))
            ln)))))

(define (clear-line)
  (line-text-set!
   cursor-line
   (subu16vector (line-text cursor-line) 0 cursor-column)))

(define (clear)
  (set! top-line (make-line))
  (set! cursor-line top-line)
  (set! first-line top-line))

(define (move-cursor c)
  (set! cursor-column
    (max left-margin
         (min (u16vector-length (line-text cursor-line))
              (+ cursor-column c)))))