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

;;;; ucs.scm - unicode operations


;;XXX all hopelessly ugly and inefficient

(define (string->ucs str)
  (let* ((len (string-length str))
         (ucs (make-u16vector len)))
    (do ((i 0 (add1 i)))
        ((>= i len) ucs)
      (u16vector-set! ucs i (char->integer (string-ref str i))))))

(define (symbol->ucs-symbol sym)
  (ucs-string->symbol (string->ucs (symbol->string sym))))

(define (ucs->string uv)
  (let* ((len (u16vector-length uv))
         (str (make-string len)))
    (do ((i 0 (add1 i)))
        ((>= i len) str)
      (let ((c (u16vector-ref uv i)))
        (if (> c 255)
            (error 'ucs->string "can not convert UCS character to string" c)
            (string-set! str i (integer->char c)))))))

;; only for testing
(define (ucs->ascii-string uv)
  (string-concatenate
   (map (lambda (c)
          (if (< c 256) 
              (string (integer->char c))
              (sprintf "{~x}" c)))
        (u16vector->list uv))))

(define (ucs->raw-string uv)
  (blob->string (u16vector->blob/shared uv)))

(define ucs-length u16vector-length)

(define (ucs-append u1 u2)
  (let* ((len1 (u16vector-length u1))
         (len2 (u16vector-length u2))
         (u (make-u16vector (+ len1 len2))))
    (do ((i 0 (add1 i)))
        ((>= i len1))
      (u16vector-set! u i (u16vector-ref u1 i)))
    (do ((i 0 (add1 i)))
        ((>= i len2))
      (u16vector-set! u (+ len1 i) (u16vector-ref u2 i)))
    u))

(define (utf8-string->ucs str)
  (list->u16vector (utf8->list str)))

(define (ucs-string->symbol uv)
  (string->symbol (ucs->raw-string uv)))


;;; This is taken from Alex Shinn's UTF8 egg:

(define (ucs->utf8 i)
  (cond ((fx<= i #x7F)
         (string (integer->char i)) )
        ((fx<= i #x7FF)
         (string (integer->char (fxior #b11000000 (fxshr i 6)))
                 (integer->char (fxior #b10000000 (fxand i #b111111)))) )
        ((fx<= i #xFFFF)
         (string (integer->char (fxior #b11100000 (fxshr i 12)))
                 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
                 (integer->char (fxior #b10000000 (fxand i #b111111)))) )
        ((fx<= i #x1FFFFF)
         (string (integer->char (fxior #b11110000 (fxshr i 18)))
                 (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
                 (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
                 (integer->char (fxior #b10000000 (fxand i #b111111)))) )
        (else
         (error 'char->utf8 "UTF-8 codepoint out of range" i) ) ) )

(define (string-int-ref s i)
  (char->integer (string-ref s i)))

(define utf8-start-byte->length
  (let ((table '#(
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 0x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 1x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 2x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 3x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 4x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 5x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 6x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 7x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 8x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 9x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; ax
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; bx
2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; cx
2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; dx
3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 ; ex
4 4 4 4 4 4 4 4 5 5 5 5 6 6 0 0 ; fx
)))
    (lambda (i) (vector-ref table i))))

(define (extract-bit-field size position n)
  (bitwise-and (bitwise-not (arithmetic-shift -1 size))
               (arithmetic-shift n (- position))))

(define (utf8-ref s off)
  (let* ((c (string-int-ref s off))
         (len (utf8-start-byte->length c))
         (limit (string-length s)))
    (if (<= len 1)
        c
        (let ((end (+ off len)))
          (if (> end limit)
              (error 'utf8-ref "utf8 trailing char overflow" s off)
              (let loop ((i (+ off 1)) (res (extract-bit-field (- 7 len) 0 c)))
                (if (= i end)
                    res
                    (loop (+ i 1)
                          (bitwise-ior (arithmetic-shift res 6)
                                       (bitwise-and #b00111111
                                                    (string-int-ref s i)))))))))))

(define (utf8->list str)
  (let ((limit (string-length str)))
    (let lp ((i 0) (res '()))
      (if (>= i limit)
          (reverse res)
          (lp (+ i (utf8-start-byte->length (string-int-ref str i)))
              (cons (utf8-ref str i) res))))))