#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) ""] ; just ignore it
            [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)
  ;; FIXME: this is lazy and incorrect
  (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)))

;; TODO: Appendix H
(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))]))