Changeset 25848 in project
- Timestamp:
- 02/01/12 14:14:43 (9 years ago)
- Location:
- release/4/kitaaba/trunk
- Files:
-
- 3 added
- 3 deleted
- 5 edited
-
defkeys.scm (modified) (2 diffs)
-
keybd.scm (modified) (2 diffs)
-
kitaaba.meta (added)
-
kitaaba.scm (added)
-
kitaaba.setup (added)
-
ktab.meta (deleted)
-
ktab.scm (deleted)
-
ktab.setup (deleted)
-
sdl.scm (modified) (3 diffs)
-
test.scm (modified) (2 diffs)
-
text.scm (modified) (10 diffs)
Legend:
- Unmodified
- Added
- Removed
-
release/4/kitaaba/trunk/defkeys.scm
r25842 r25848 38 38 |# 39 39 (map-key 8 (lambda _ (backspace))) ; backspace 40 (map-key 13 (lambda _ (insert-char 10) (process-line))) ; return40 (map-key 13 (lambda _ (insert-char 10))) ; return 41 41 (map-key 27 (lambda _ (exit))) ; esc 42 42 (map-key 276 (lambda _ (move-cursor -1))) ; left … … 44 44 (map-key 280 (lambda _ (scroll-up))) ; page-up 45 45 (map-key 281 (lambda _ (scroll-down))) ; page-down 46 (map-key '(CTRL #\a) (lambda _ (set! cursor-column left-margin)))46 (map-key '(CTRL #\a) (lambda _ (set! cursor-column (left-margin)))) 47 47 (map-key '(CTRL #\e) (lambda _ (set! cursor-column (u16vector-length (line-text cursor-line))))) 48 48 49 #;( overstrike49 #;(map-overstrike 50 50 '((#x235d #x2218 #x2229) ; up shoe jot (comment) 51 51 )) -
release/4/kitaaba/trunk/keybd.scm
r25842 r25848 51 51 (hash-table-set! keycode-map kc mapping))) 52 52 53 (define ( overstrike lst)53 (define (map-overstrike lst) 54 54 (for-each 55 55 (match-lambda … … 69 69 lst)) 70 70 71 72 (include "defkeys") 71 (define (run-event-loop #!key idle) 72 (do () (#f) 73 (cond (((if idle peek-event get-next-event)) 74 (case (event-code-type (event-type)) 75 ((QUIT) (exit)) 76 ((KEYDOWN) (decode-key-event)) 77 ((VIDEORESIZE) 78 (resize-screen (event-w) (event-h)))) 79 (redraw)) 80 (else (idle))))) -
release/4/kitaaba/trunk/sdl.scm
r25842 r25848 35 35 36 36 37 (define screen #f) ; POINTER 38 (define font #f) ; POINTER 39 37 (define screen #f) 38 (define font #f) 39 40 (define (screen-surface) screen) 41 (define line-height (make-parameter 1)) 42 43 (define (screen-size) 44 (values (surface-width screen) 45 (surface-height screen))) 40 46 41 47 (define (open-font ttf size) … … 50 56 "return(w);") 51 57 font)) 52 (set! line-height size)) ;XXX configurable 53 54 ;;XXX use indexed color mode 55 (define (open-screen w h) 58 (line-height size)) 59 60 (define (open-screen w h #!key) ;XXX fullscreen, fixed-size, etc. 56 61 (set! screen 57 62 ((foreign-lambda* c-pointer ((int w) (int h)) … … 61 66 "SDL_EnableUNICODE(1);" 62 67 "return(SDL_SetVideoMode(w, h, 8, SDL_RESIZABLE));") 63 w h)) 64 (print "h: " (surface-height screen))) 68 w h))) 65 69 66 70 (define (resize-screen w h) 67 71 (set! screen 68 72 ((foreign-lambda* c-pointer ((int w) (int h)) 69 "return(SDL_SetVideoMode(w, h, 8, SDL_RESIZABLE));") 70 w h)) 71 (print "h: " (surface-height screen))) 73 "return(SDL_SetVideoMode(w, h, 8, SDL_RESIZABLE));") ;XXX flags (s.a.) 74 w h))) 72 75 73 76 (define release-surface 74 77 (foreign-lambda void "SDL_FreeSurface" c-pointer)) 75 78 76 (define flip 79 (define flip-screen 77 80 (foreign-lambda void "SDL_Flip" c-pointer)) 78 81 -
release/4/kitaaba/trunk/test.scm
r25842 r25848 2 2 3 3 4 (use k tab)4 (use kitaaba matchable) 5 5 6 6 7 7 (open-screen 640 480) ;XXX 8 (open-font " fonts/apl385.ttf" 20) ;XXX8 (open-font "monos.ttf" 20) ;XXX 9 9 10 (insert #"Hello.\nThis is a test.\n\n") ;XXX10 (insert-text "\tHello.\nThis is a test.\n\n") ;XXX 11 11 12 12 (match (command-line-arguments) … … 15 15 (do ((i (string->number from) (add1 i))) 16 16 ((>= i to)) 17 (insert-string (sprintf "#x~x -> " i)) 18 (insert (u16vector i 10))))) 17 (insert-text 18 (sprintf "#x~x -> " i) 19 (u16vector i 10))))) 19 20 (_ #f)) 20 21 21 (define (process-line) 22 ;;... 23 #f 24 ) 22 (run-event-loop) 25 23 26 (do () (#f)27 (redraw)28 (when (get-next-event)29 (case (event-code-type (event-type))30 ((QUIT) (exit))31 ((KEYDOWN) (decode-key-event))32 ((VIDEORESIZE)33 (resize-screen (event-w) (event-h)))))) -
release/4/kitaaba/trunk/text.scm
r25842 r25848 1 ;;;; te st.scm1 ;;;; text.scm 2 2 3 3 … … 13 13 (define top-line first-line) 14 14 (define column 0) 15 (define line-height 1)16 15 (define char-width 1) 17 (define left-margin 0) 18 16 (define left-margin (make-parameter 0)) 17 (define do-redraw #t) 18 19 20 (define text-color (make-parameter (color 'black))) 21 (define background-color (make-parameter (color 'white))) 22 (define cursor-color (make-parameter (color 'black))) 23 24 (define (with-delayed-redraw thunk) 25 (fluid-let ((do-redraw #f)) 26 (begin0 (thunk) (redraw)))) 19 27 20 28 (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))) 29 (when do-redraw 30 (let* ((w (surface-width screen)) 31 (h (surface-height screen)) 32 (maxchars (* 2 (quotient w char-width))) 33 (lh (line-height))) 34 (match-let ((#(tr tg tb) (color (text-color))) 35 (#(br bg bb) (color (background-color)))) 36 (fill screen 0 0 w h br bg bb) 37 (let loop ((ln top-line) (y 0)) 38 (when (and ln (< y h)) 39 (let* ((str (line-text ln)) 40 (len (u16vector-length str))) 41 (when (eq? ln cursor-line) (draw-cursor y)) 42 (when (< column len) 43 (let* ((ucs 44 (ucs-append 45 (subu16vector str column (min len maxchars)) 46 (u16vector 0))) 47 (txt (render-ucs-text ucs tr tg tb))) 48 (when txt 49 (let ((tw (surface-width txt)) 50 (th (surface-height txt))) 51 (blit txt 0 y) 52 (release-surface txt))))) 53 (loop (line-next ln) (+ y lh))))) 54 (flip-screen screen))))) 43 55 44 56 (define (columns) … … 46 58 47 59 (define (rows) 48 (quotient (surface-height screen) line-height))60 (quotient (surface-height screen) (line-height))) 49 61 50 62 (define (draw-cursor y) 51 63 (let ((x (* (- cursor-column column) char-width))) 52 64 (when (< x (surface-width screen)) 53 (fill screen x y char-width line-height 255 255 255)))) ;XXX color 65 (match-let ((#(cr cg cb) (color (cursor-color)))) 66 (fill screen x y char-width (line-height) cr cg cb))))) 54 67 55 68 (define (scroll-up) … … 58 71 (when (and ln2 (positive? lnn)) 59 72 (set! top-line ln2) 60 (loop (sub1 lnn)))))) 73 (loop (sub1 lnn))))) 74 (redraw)) 61 75 62 76 (define (scroll-down) … … 65 79 (when (and ln2 (positive? lnn)) 66 80 (set! top-line ln2) 67 (loop (sub1 lnn)))))) 81 (loop (sub1 lnn))))) 82 (redraw)) 68 83 69 84 (define (focus) … … 73 88 (redraw)))) 74 89 75 (define (load-text filename) 90 (define (load-text filename) ;XXX only accepts 8-bit chars 76 91 (let loop ((lns (string-split (read-all filename) "\n" #t)) (prev #f)) 77 92 (unless (null? lns) … … 83 98 (set! first-line ln)) 84 99 (loop (cdr lns) ln)))) 85 (set! cursor-line first-line)) ; "top-line" now invalid! 100 (set! cursor-line first-line) ; "top-line" now invalid! 101 (redraw)) 86 102 87 103 (define (insert ucs #!optional overwrite) … … 128 144 (insert-char 10))) 129 145 146 (define (insert-text . xs) 147 (for-each 148 (match-lambda 149 ((? string? s) (insert-string s)) 150 ((? u16vector? s) (insert s)) 151 ((? char? c) (insert-char (char->integer c))) 152 (x (insert-string (->string x)))) 153 xs) 154 (redraw)) 155 130 156 (define (replace-char code) (insert (u16vector code) #t)) 131 157 … … 140 166 141 167 (define (backspace) 142 (when (> cursor-column left-margin)168 (when (> cursor-column (left-margin)) 143 169 (let* ((old (line-text cursor-line)) 144 170 (len (u16vector-length old))) … … 148 174 (subu16vector old 0 (sub1 cursor-column)) 149 175 (subu16vector old cursor-column len))) 150 (dec! cursor-column)))) 176 (dec! cursor-column)) 177 (redraw))) 151 178 152 179 (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))))) 180 (let ((lh (line-height))) 181 (set! top-line 182 (let loop ((y (- (surface-height screen) lh)) 183 (ln cursor-line)) 184 (let ((prev (line-prev ln))) 185 (if prev 186 (let ((y2 (- y lh))) 187 (if (negative? y2) 188 ln 189 (loop y2 prev))) 190 ln)))))) 163 191 164 192 (define (clear-line) 165 193 (line-text-set! 166 194 cursor-line 167 (subu16vector (line-text cursor-line) 0 cursor-column))) 195 (subu16vector (line-text cursor-line) 0 cursor-column)) 196 (redraw)) 168 197 169 198 (define (clear) 170 199 (set! top-line (make-line)) 171 200 (set! cursor-line top-line) 172 (set! first-line top-line)) 201 (set! first-line top-line) 202 (redraw)) 173 203 174 204 (define (move-cursor c) 175 205 (set! cursor-column 176 (max left-margin206 (max (left-margin) 177 207 (min (u16vector-length (line-text cursor-line)) 178 (+ cursor-column c))))) 208 (+ cursor-column c)))) 209 (redraw)) 210
Note: See TracChangeset
for help on using the changeset viewer.
