#lang racket/base
(require racket/contract
racket/sequence
racket/vector
"private/bits.rkt"
"private/constants.rkt"
"private/version.rkt")
(provide
(struct-out qr-segment)
(struct-out numeric)
(struct-out alpha)
(struct-out 8bit)
(struct-out eci)
(struct-out kanji)
character-count-bits
encoder
(contract-out
[data-minimum-version (-> qr-data? (one-of/c 'L 'M 'Q 'H) exact-positive-integer?)]
[string->qr-data (->* (string?)
(#:version (or/c #f (integer-in 1 40)))
qr-data?)]
[qr-data? (-> any/c boolean?)]
[qr-data->bits (-> qr-data? (integer-in 1 40) (listof boolean?))]
[qr-data->string (-> qr-data? string?)]))
(struct qr-segment () #:transparent)
(define-values (prop:character-count-bits character-count-bits? character-count-bits)
(make-struct-type-property 'character-count-bits))
(define-values (prop:encoder encoder? encoder)
(make-struct-type-property 'encoder))
(struct numeric qr-segment
(data)
#:guard
(lambda (data name)
(cond
[(number? data) (number->string data)]
[(and (string? data)
(sequence-andmap (lambda (c)
(char<=? #\0 c #\9))
data))
data]
[else
(error name "not a string of decimal digits: ~a" data)]))
#:transparent
#:property prop:character-count-bits
(lambda (version)
(cond
[(< version 10) 10]
[(< version 27) 12]
[else 14]))
#:property prop:encoder
(lambda (segment version)
(append (integer->bits #b0001 4)
(integer->bits (string-length (numeric-data segment))
((character-count-bits struct:numeric) version))
(let ([str (numeric-data segment)])
(let loop ([n (string-length str)]
[i 0])
(cond
[(zero? n) '()]
[(= n 1) (integer->bits (string->number
(substring str i))
4)]
[(= n 2) (integer->bits (string->number
(substring str i))
7)]
[else (append (integer->bits (string->number
(substring str i (+ i 3)))
10)
(loop (- n 3) (+ i 3)))]))))))
(struct alpha qr-segment (data)
#:guard
(lambda (data name)
(unless (string? data)
(error name "not a string: ~a" data))
(let ([updata (string-upcase data)])
(unless (sequence-andmap (lambda (c)
(vector-memv c qr-alpha-charset))
updata)
(error name "contains invalid characters: ~a" data))
updata))
#:transparent
#:property prop:character-count-bits
(lambda (version)
(cond
[(< version 10) 9]
[(< version 27) 11]
[else 13]))
#:property prop:encoder
(lambda (segment version)
(append (integer->bits #b0010 4)
(integer->bits (string-length (alpha-data segment))
((character-count-bits struct:alpha) version))
(let loop ([cs (map (lambda (c)
(vector-memv c qr-alpha-charset))
(string->list (alpha-data segment)))])
(cond
[(null? cs) '()]
[(null? (cdr cs)) (integer->bits (car cs) 6)]
[else (append (integer->bits (+ (* (car cs) 45)
(cadr cs))
11)
(loop (cddr cs)))])))))
(struct 8bit qr-segment (data)
#:guard
(lambda (data name)
(unless (bytes? data)
(error name "not bytes: ~a" data))
data)
#:transparent
#:property prop:character-count-bits
(lambda (version)
(cond
[(< version 10) 8]
[else 16]))
#:property prop:encoder
(lambda (segment version)
(append (integer->bits #b0100 4)
(integer->bits (bytes-length (8bit-data segment))
((character-count-bits struct:8bit) version))
(bytes->bits (8bit-data segment)))))
(struct eci qr-segment (mode)
#:guard
(lambda (mode name)
(cond
[(exact-nonnegative-integer? mode) mode]
[else
(error name "not a non-negative integer: ~a" mode)]))
#:transparent
#:property prop:encoder
(lambda (segment version)
(append (integer->bits #b0111 4)
(let ([m (eci-mode segment)])
(cond
[(< m 128) (list* #f (integer->bits m 7))]
[(< m 16384) (list* #t #f (integer->bits m 14))]
[else (list* #t #t #f (integer->bits m 21))])))))
(struct kanji qr-segment (data)
#:guard
(lambda (data name)
(error "not implemented"))
#:transparent
#:property prop:character-count-bits
(lambda (version)
(cond
[(< version 10) 8]
[(< version 27) 10]
[else 12]))
#:property prop:encoder
(lambda (segment version)
(append (integer->bits #b1000 4)
(integer->bits (string-length (kanji-data segment))
((character-count-bits struct:kanji) version))
(error "not implemented"))))
(define (qr-data? datum)
(or (qr-segment? datum)
(and (list? datum)
(andmap qr-segment? datum))))
(define (qr-data->string data)
(cond
[(null? data) ""]
[(list? data)
(apply string-append
(map qr-data->string data))]
[else (cond
[(numeric? data) (numeric-data data)]
[(alpha? data) (alpha-data data)]
[(kanji? data) (kanji-data data)]
[(8bit? data) (bytes->string/utf-8 (8bit-data data))]
[(eci? data) ""] [else (error "unsupported data type" (car data))])]))
(define (qr-data->bits data version)
(cond
[(null? data) '()]
[(qr-segment? data)
((encoder data) data version)]
[else
(apply append
(map (lambda (segment)
((encoder segment) segment version))
data))]))
(define (data-minimum-version data edc-level)
(let* ([bits (length (qr-data->bits data 40))]
[words (quotient (+ bits 7) 8)])
(for/first ([v (in-range 1 41)]
#:when (<= words (qr-data-word-count v edc-level)))
v)))
(define (string->qr-data str #:version [version #f])
(cond
[(sequence-andmap (lambda (c)
(char<=? #\0 c #\9))
str)
(numeric str)]
[(sequence-andmap (lambda (c)
(vector-memv c qr-alpha-charset))
(string-upcase str))
(alpha (string-upcase str))]
[else (8bit (string->bytes/utf-8 str))]))