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

Last change on this file since 25842 was 25842, checked in by felix winkelmann, 9 years ago

added kitaaba (work in progress, far from finished)

  • Property svn:executable set to *
File size: 4.6 KB
Line 
1;;;; test.scm
2
3
4(defstruct line
5  (text '#u16())                        ; U16VECTOR
6  (next #f)                             ; LINE
7  (prev #f))                            ; LINE
8
9
10(define first-line (make-line))
11(define cursor-line first-line)
12(define cursor-column 0)
13(define top-line first-line)
14(define column 0)
15(define line-height 1)
16(define char-width 1)
17(define left-margin 0)
18
19
20(define (redraw)
21  (let* ((w (surface-width screen))
22         (h (surface-height screen))
23         (maxchars (* 2 (quotient w char-width))))
24    (fill screen 0 0 w h 0 0 0)         ;XXX background color
25    (let loop ((ln top-line) (y 0))
26      (when (and ln (< y h))
27        (let* ((str (line-text ln))
28               (len (u16vector-length str)))
29          (when (eq? ln cursor-line) (draw-cursor y))
30          (when (< column len)
31            (let* ((ucs
32                    (ucs-append
33                     (subu16vector str column (min len maxchars))
34                     (u16vector 0)))
35                   (txt (render-ucs-text ucs 255 255 255))) ;XXX color
36              (when txt
37                (let ((tw (surface-width txt))
38                      (th (surface-height txt)))
39                  (blit txt 0 y)
40                  (release-surface txt)))))
41          (loop (line-next ln) (+ y line-height)))))
42    (flip screen)))
43
44(define (columns) 
45  (quotient (surface-width screen) char-width))
46
47(define (rows)
48  (quotient (surface-height screen) line-height))
49
50(define (draw-cursor y)
51  (let ((x (* (- cursor-column column) char-width)))
52    (when (< x (surface-width screen))
53      (fill screen x y char-width line-height 255 255 255)))) ;XXX color
54
55(define (scroll-up)
56  (let loop ((lnn (rows)))
57    (let ((ln2 (line-prev top-line)))
58      (when (and ln2 (positive? lnn))
59        (set! top-line ln2)
60        (loop (sub1 lnn))))))
61
62(define (scroll-down)
63  (let loop ((lnn (rows)))
64    (let ((ln2 (line-next top-line)))
65      (when (and ln2 (positive? lnn))
66        (set! top-line ln2)
67        (loop (sub1 lnn))))))
68
69(define (focus)
70  (let ((tl top-line))
71    (adjust-top-line)
72    (unless (eq? tl top-line)
73      (redraw))))
74
75(define (load-text filename)
76  (let loop ((lns (string-split (read-all filename) "\n" #t)) (prev #f))
77    (unless (null? lns)
78      (let ((ln (make-line 
79                 text: (string->ucs (tabexpand (car lns)))
80                 prev: prev)))
81        (if prev
82            (line-next-set! prev ln)
83            (set! first-line ln))
84        (loop (cdr lns) ln))))
85  (set! cursor-line first-line))        ; "top-line" now invalid!
86
87(define (insert ucs #!optional overwrite)
88  (let ((len (u16vector-length ucs)))
89    (define (scan s p)
90      (cond ((>= p len) (ins (subu16vector ucs s len)))
91            ((= 10 (u16vector-ref ucs p))
92             (ins (subu16vector ucs s p))
93             (set! cursor-column 0)
94             ;;XXX should we just move to next line in overwrite mode?
95             (let* ((cln (line-next cursor-line))
96                    (ln (make-line 
97                         prev: cursor-line
98                         next: cln)))
99               (line-next-set! cursor-line ln)
100               (when cln
101                 (line-prev-set! cln ln))
102               (set! cursor-line ln)    ;XXX scrolling
103               (scan (add1 p) (add1 p))))
104            (else (scan s (add1 p)))))
105    (define (ins ucs)
106      (let* ((old (line-text cursor-line))
107             (ucslen (u16vector-length ucs))
108             (oldlen (u16vector-length old)))
109        (line-text-set! 
110         cursor-line
111         (ucs-append
112          (subu16vector old 0 cursor-column)
113          (ucs-append
114           ucs
115           (subu16vector 
116            old
117            (min oldlen (+ cursor-column (if overwrite ucslen 0)))
118            oldlen))))
119        (inc! cursor-column ucslen)))
120    (scan 0 0)
121    (adjust-top-line)))
122
123(define (insert-char code) (insert (u16vector code)))
124(define (insert-string str) (insert (string->ucs str)))
125
126(define (insert-fresh-line)
127  (when (positive? cursor-column)
128    (insert-char 10)))
129
130(define (replace-char code) (insert (u16vector code) #t))
131
132(define (current-line) cursor-line)
133
134(define (current-char)
135  (let* ((text (line-text cursor-line))
136         (len (u16vector-length text)))
137    (if (>= cursor-column len)
138        (char->integer #\space)
139        (u16vector-ref text cursor-column))))
140
141(define (backspace)
142  (when (> cursor-column left-margin)
143    (let* ((old (line-text cursor-line))
144           (len (u16vector-length old)))
145      (line-text-set!
146       cursor-line
147       (ucs-append
148        (subu16vector old 0 (sub1 cursor-column))
149        (subu16vector old cursor-column len)))
150      (dec! cursor-column))))
151
152(define (adjust-top-line)
153  (set! top-line
154    (let loop ((y (- (surface-height screen) line-height))
155               (ln cursor-line))
156      (let ((prev (line-prev ln)))
157        (if prev
158            (let ((y2 (- y line-height)))
159              (if (negative? y2)
160                  ln
161                  (loop y2 prev)))
162            ln)))))
163
164(define (clear-line)
165  (line-text-set!
166   cursor-line
167   (subu16vector (line-text cursor-line) 0 cursor-column)))
168
169(define (clear)
170  (set! top-line (make-line))
171  (set! cursor-line top-line)
172  (set! first-line top-line))
173
174(define (move-cursor c)
175  (set! cursor-column
176    (max left-margin
177         (min (u16vector-length (line-text cursor-line))
178              (+ cursor-column c)))))
Note: See TracBrowser for help on using the repository browser.