:-)

binary-buffer

binary-buffer

integer->utf-8



(define integer->utf-8

(lambda (c)

(cond

((and (>= c 0) (<= c #x7f)) (list c))

((and (>= c #x80) (<= c #x7ff))

(list (bits-or #xc0 (bits-shift-right c 6))

(bits-or #x80 (bits-and c #x3f))))

((and (>= c #x800) (<= c #xffff))

(list (bits-or #xe0 (bits-shift-right c 12))

(bits-or #x80 (bits-and (bits-shift-right c 6) #x3f))

(bits-or #x80 (bits-and c #x3f))))

((and (>= c #x10000) (<= c #x1fffff))

(list (bits-or #xf0 (bits-shift-right c 18))

(bits-or #x80 (bits-and (bits-shift-right c 12) #x3f))

(bits-or #x80 (bits-and (bits-shift-right c 6) #x3f))

(bits-or #x80 (bits-and c #x3f))))

((and (>= c #x200000) (<= c #x3ffffff))

(list (bits-or #xf8 (bits-shift-right c 24))

(bits-or #x80 (bits-and (bits-shift-right c 18) #x3f))

(bits-or #x80 (bits-and (bits-shift-right c 12) #x3f))

(bits-or #x80 (bits-and (bits-shift-right c 6) #x3f))

(bits-or #x80 (bits-and c #x3f))))

((and (>= c #x4000000) (<= c #x7fffffff))

(list (bits-or #xfc (bits-shift-right c 30))

(bits-or #x80 (bits-and (bits-shift-right c 24) #x3f))

(bits-or #x80 (bits-and (bits-shift-right c 18) #x3f))

(bits-or #x80 (bits-and (bits-shift-right c 12) #x3f))

(bits-or #x80 (bits-and (bits-shift-right c 6) #x3f))

(bits-or #x80 (bits-and c #x3f))))

(else '()))))



(define utf-8->integer

(lambda (ls)

(define invalid?

(lambda (n ls)

(if (not (= (length ls) n))

#t

(let loop ((ls (cdr ls)))

(if (null? ls)

#f

(if (not (= (bits-and (car ls) #xc0) #x80))

#t

(loop (cdr ls))))))))

(define bond

(lambda (ls acc)

(if (null? ls)

acc

(bond (cdr ls)

(bits-or (bits-shift-left acc 6)

(bits-and (car ls) #x3f))))))



(if (or (null? ls) (not (pair? ls)))

-1

(let ((lead (car ls)))

(cond

((zero? (bits-and lead #x80))

(if (null? (cdr ls)) lead -1))

((= (bits-and lead #xe0) #xc0)

(if (invalid? 2 ls)

-1

(bond (cdr ls) (bits-and (car ls) #x1f))))

((= (bits-and lead #xf0) #xe0)

(if (invalid? 3 ls)

-1

(bond (cdr ls) (bits-and (car ls) #x0f))))

((= (bits-and lead #xf8) #xf0)

(if (invalid? 4 ls)

-1

(bond (cdr ls) (bits-and (car ls) #x07))))

((= (bits-and lead #xfc) #xf8)

(if (invalid? 5 ls)

-1

(bond (cdr ls) (bits-and (car ls) #x03))))

((= (bits-and lead #xfe) #xfc)

(if (invalid? 6 ls)

-1

(bond (cdr ls) (bits-and (car ls) #x01))))

(else -1))))))



> (integer->char (utf-8->integer (integer->utf-8 (char->integer #\Z))))

#\Z

> (integer->char (utf-8->integer (integer->utf-8 (char->integer #\南))))

#\南

> (integer->char (utf-8->integer (integer->utf-8 (char->integer #\無))))

#\無

> (integer->char (utf-8->integer (integer->utf-8 (char->integer #\λ))))

#\λ

>



byte

unsigned char

malloc



> (load "unicode.scm")



binary-buffer

;



> (define core (binary-buffer-create #x100000)) ;1Mバイトのバイナリバッファを確保します

> core

*binary-buffer*



> (binary-buffer-size core) ;サイズを取得します

1048576

> (binary-buffer-store! core #x00000 #x01234567 'tetra) ;4バイトの整数を格納します

> (binary-buffer-store! core #x00004 #x89abcdef 'tetra)

> (binary-buffer-store! core #x00008 #x03bb 'wyde) ;2バイトの整数を格納します

> (binary-buffer-store! core #x0000c #xce 'byte) ;1バイトの整数を格納します

> (binary-buffer-store! core #x0000d #xbb 'byte)

> (binary-buffer-load core #x00000 'tetra) ;4バイト読み出します

19088743

> (integer->hex-string (binary-buffer-load core #x00000 'tetra) 8) ;16進文字列に変換します

"#x01234567"

> (binary-buffer-load core #x00004 'tetra) ;MSBが立っていると符号はマイナスになります

-1985229329

> (integer->hex-string (binary-buffer-load core #x00004 'tetra) 8)

"#x89abcdef"

> ;2バイトの整数を読み出して、それを UNICODE と解釈し、文字に変換して表示する

(begin

(display

(integer->char (binary-buffer-load core #x00008 'wyde)))

(newline))

λ

> ; UTF-8 をデコードする

(integer->char

(utf-8->integer

(list (binary-buffer-load core #x0000c 'byte)

(binary-buffer-load core #x0000d 'byte))))

#\λ

>

(binary-buffer-create n )

n

(binary-buffer-size core )

(binary-buffer-store! core offset val sym )

core

offset

val

sym

byte, wyde, tetra

1, 2, 4

(binary-buffer-load core offset sym )

core

offset

val

sym

byte, wyde, tetra

1, 2, 4



(let ((port (open-file "binary.dat" "wb"))

(n 16))

(binary-write port core n)

(close-port port))



binary.dat

(open-file path "wb")

path

wb

(binary-write port core n )

core

n

(close-port port )



> (define another-core (binary-buffer-create 16))

> ;

(let ((port (open-file "binary.dat" "rb"))

(n 16))

(binary-read port another-core n)

(close-port port))



> (integer->hex-string (binary-buffer-load another-core #x00000 'wyde) 8)

"#x00000123"

> (integer->hex-string (binary-buffer-load another-core #x00000 'tetra) 8)

"#x01234567"

> (integer->hex-string (binary-buffer-load another-core #x00004 'tetra) 8)

"#x89abcdef"

> (integer->hex-string (binary-buffer-load another-core #x0000c 'wyde) 4)

"#xcebb"

>



(open-file path "rb")

path

close-port

(binary-read port core n )

port

core

n



(define char-start #x21)

(define char-stop #x10000)

(define line-max 40)

(define core-max

(let ((n (- char-stop char-start)))

(+ (* n 3) (* (quotient n line-max) 2))))



(load "unicode.scm")



(define core-fill

(lambda (core)

(let loop ((c char-start) (pos 0))

(if (>= c char-stop)

(cons core pos)

(loop (+ c 1)

(if (= c #x7f)

pos

(let loop ((u (integer->utf-8 c)) (pos pos))

(if (null? u)

(if (not

(zero?

(remainder

(- c -1 char-start (if (> c #x7f) 1 0))

line-max)))

pos

(begin

(binary-buffer-store! core pos #x0d 'byte)

(binary-buffer-store!

core (+ pos 1) #x0a 'byte)

(+ pos 2)))

(begin

(binary-buffer-store! core pos (car u) 'byte)

(loop (cdr u) (+ pos 1)))))))))))



(define write-core

(lambda (core-and-size path)

(let ((core (car core-and-size))

(size (cdr core-and-size))

(port (open-file path "wb")))

(binary-write port core size)

(close-port port))))



(write-core

(core-fill (binary-buffer-create core-max))

"utf8chars.txt")



load