Changeset 25848 in project


Ignore:
Timestamp:
02/01/12 14:14:43 (9 years ago)
Author:
felix winkelmann
Message:

basically working but needs more features

Location:
release/4/kitaaba/trunk
Files:
3 added
3 deleted
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/kitaaba/trunk/defkeys.scm

    r25842 r25848  
    3838|#
    3939(map-key 8 (lambda _ (backspace)))      ; backspace
    40 (map-key 13 (lambda _ (insert-char 10) (process-line))) ; return
     40(map-key 13 (lambda _ (insert-char 10))) ; return
    4141(map-key 27 (lambda _ (exit)))                          ; esc
    4242(map-key 276 (lambda _ (move-cursor -1)))               ; left
     
    4444(map-key 280 (lambda _ (scroll-up)))                    ; page-up
    4545(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))))
    4747(map-key '(CTRL #\e) (lambda _ (set! cursor-column (u16vector-length (line-text cursor-line)))))
    4848
    49 #;(overstrike
     49#;(map-overstrike
    5050 '((#x235d #x2218 #x2229)               ; up shoe jot (comment)
    5151   ))
  • release/4/kitaaba/trunk/keybd.scm

    r25842 r25848  
    5151    (hash-table-set! keycode-map kc mapping)))
    5252
    53 (define (overstrike lst)
     53(define (map-overstrike lst)
    5454  (for-each
    5555   (match-lambda
     
    6969   lst))
    7070
    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  
    3535
    3636
    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)))
    4046
    4147(define (open-font ttf size)
     
    5056       "return(w);")
    5157     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.
    5661  (set! screen
    5762    ((foreign-lambda* c-pointer ((int w) (int h))
     
    6166       "SDL_EnableUNICODE(1);"
    6267       "return(SDL_SetVideoMode(w, h, 8, SDL_RESIZABLE));")
    63      w h))
    64   (print "h: " (surface-height screen)))
     68     w h)))
    6569
    6670(define (resize-screen w h)
    6771  (set! screen
    6872    ((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)))
    7275
    7376(define release-surface
    7477  (foreign-lambda void "SDL_FreeSurface" c-pointer))
    7578
    76 (define flip 
     79(define flip-screen
    7780  (foreign-lambda void "SDL_Flip" c-pointer))
    7881
  • release/4/kitaaba/trunk/test.scm

    r25842 r25848  
    22
    33
    4 (use ktab)
     4(use kitaaba matchable)
    55
    66
    77(open-screen 640 480)                   ;XXX
    8 (open-font "fonts/apl385.ttf" 20)       ;XXX
     8(open-font "monos.ttf" 20)      ;XXX
    99
    10 (insert #"Hello.\nThis is a test.\n\n") ;XXX
     10(insert-text "\tHello.\nThis is a test.\n\n") ;XXX
    1111
    1212(match (command-line-arguments)
     
    1515     (do ((i (string->number from) (add1 i)))
    1616         ((>= 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)))))
    1920  (_ #f))
    2021
    21 (define (process-line)
    22   ;;...
    23   #f
    24   )
     22(run-event-loop)
    2523
    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 ;;;; test.scm
     1;;;; text.scm
    22
    33
     
    1313(define top-line first-line)
    1414(define column 0)
    15 (define line-height 1)
    1615(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))))
    1927
    2028(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)))))
    4355
    4456(define (columns)
     
    4658
    4759(define (rows)
    48   (quotient (surface-height screen) line-height))
     60  (quotient (surface-height screen) (line-height)))
    4961
    5062(define (draw-cursor y)
    5163  (let ((x (* (- cursor-column column) char-width)))
    5264    (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)))))
    5467
    5568(define (scroll-up)
     
    5871      (when (and ln2 (positive? lnn))
    5972        (set! top-line ln2)
    60         (loop (sub1 lnn))))))
     73        (loop (sub1 lnn)))))
     74  (redraw))
    6175
    6276(define (scroll-down)
     
    6579      (when (and ln2 (positive? lnn))
    6680        (set! top-line ln2)
    67         (loop (sub1 lnn))))))
     81        (loop (sub1 lnn)))))
     82  (redraw))
    6883
    6984(define (focus)
     
    7388      (redraw))))
    7489
    75 (define (load-text filename)
     90(define (load-text filename)            ;XXX only accepts 8-bit chars
    7691  (let loop ((lns (string-split (read-all filename) "\n" #t)) (prev #f))
    7792    (unless (null? lns)
     
    8398            (set! first-line ln))
    8499        (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))
    86102
    87103(define (insert ucs #!optional overwrite)
     
    128144    (insert-char 10)))
    129145
     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
    130156(define (replace-char code) (insert (u16vector code) #t))
    131157
     
    140166
    141167(define (backspace)
    142   (when (> cursor-column left-margin)
     168  (when (> cursor-column (left-margin))
    143169    (let* ((old (line-text cursor-line))
    144170           (len (u16vector-length old)))
     
    148174        (subu16vector old 0 (sub1 cursor-column))
    149175        (subu16vector old cursor-column len)))
    150       (dec! cursor-column))))
     176      (dec! cursor-column))
     177    (redraw)))
    151178
    152179(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))))))
    163191
    164192(define (clear-line)
    165193  (line-text-set!
    166194   cursor-line
    167    (subu16vector (line-text cursor-line) 0 cursor-column)))
     195   (subu16vector (line-text cursor-line) 0 cursor-column))
     196  (redraw))
    168197
    169198(define (clear)
    170199  (set! top-line (make-line))
    171200  (set! cursor-line top-line)
    172   (set! first-line top-line))
     201  (set! first-line top-line)
     202  (redraw))
    173203
    174204(define (move-cursor c)
    175205  (set! cursor-column
    176     (max left-margin
     206    (max (left-margin)
    177207         (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.