(in-package :de.anvi.croatoan)

(defun ascii-byte-p (octet)
  "Return t if octet is a single-byte 7-bit ASCII char.

The most significant bit is 0, so the allowed pattern is 0xxx xxxx."
  (assert (typep octet 'integer))
  (assert (<= (integer-length octet) 8))
  (let ((bitmask  #b10000000)
        (template #b00000000))
    ;; bitwise and the with the bitmask #b11000000 to extract the first two bits.
    ;; check if the first two bits are equal to the template #b10000000.
    (= (logand bitmask octet) template)))

(defun multi-byte-p (octet)
  "Return t if octet is a part of a multi-byte UTF-8 sequence.

The multibyte pattern is 1xxx xxxx.

A multi-byte can be either a lead byte or a trail byte."
  (assert (typep octet 'integer))
  (assert (<= (integer-length octet) 8))
  (let ((bitmask  #b10000000)
        (template #b10000000))
    ;; bitwise and the with the bitmask #b11000000 to extract the first two bits.
    ;; check if the first two bits are equal to the template #b10000000.
    (= (logand bitmask octet) template)))

(defun lead-byte-p (octet)
  "Return t if octet is one of the leading bytes of an UTF-8 sequence, nil otherwise.

Allowed leading byte patterns are 0xxx xxxx, 110x xxxx, 1110 xxxx and 1111 0xxx."
  (assert (typep octet 'integer))
  (assert (<= (integer-length octet) 8))
  (let ((bitmasks  (list #b10000000 #b11100000 #b11110000 #b11111000))
        (templates (list #b00000000 #b11000000 #b11100000 #b11110000)))
    (some #'(lambda (a b) (= (logand a octet) b)) bitmasks templates)))

;; http://stackoverflow.com/questions/14380143/matching-binary-patterns-in-c
(defun n-trail-bytes (octet)
  "Take a leading utf-8 byte, return the number of continuation bytes 1-3."
  (assert (typep octet 'integer))
  (assert (<= (integer-length octet) 8))
  (let ((bitmasks  (list #b10000000 #b11100000 #b11110000 #b11111000))
        (templates (list #b00000000 #b11000000 #b11100000 #b11110000)))
    (loop for i from 0 to 3
       when (= (nth i templates) (logand (nth i bitmasks) octet))
       return i)))

(defun trail-byte-p (octet)
  "Return t if octet is the continuation byte of an UTF-8 sequence.

The allowed continuation byte pattern is 10xx xxxx."
  (assert (typep octet 'integer))
  (assert (<= (integer-length octet) 8))
  (let ((bitmask  #b11000000)
        (template #b10000000))
    ;; bitwise and the with the bitmask #b11000000 to extract the first two bits.
    ;; check if the first two bits are equal to the template #b10000000.
    (= (logand bitmask octet) template)))

#|

Lower   Upper    Binary
bound   bound    Pattern
----------------------------------------------------
0x00000 0x00007F 0xxxxxxx
0x00080 0x0007FF 110xxxxx 10xxxxxx
0x00800 0x00FFFF 1110xxxx 10xxxxxx 10xxxxxx
0x10000 0x10FFFF 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx

Unicode code points Range     Encoding Binary value
------------------  --------  --------------------------
U+000000-U+00007f   0xxxxxxx  0xxxxxxx

U+000080-U+0007ff   110yyyxx  00000yyy xxxxxxxx
                    10xxxxxx

U+000800-U+00ffff   1110yyyy  yyyyyyyy xxxxxxxx
                    10yyyyxx
                    10xxxxxx

U+010000-U+10ffff   11110zzz  000zzzzz yyyyyyyy xxxxxxxx
                    10zzyyyy
                    10yyyyxx
                    10xxxxxx
|#

;; two helper functions from the internal to the external format.
;; inside the app, we use lisp chars, we only convert from utf-8 on input and
;; to utf-8 on output.

(defun utf-8-to-unicode (byte-list)
  "Take a list of one to four utf-8 encoded bytes (octets), return a code point.

Since this decoder will only used for reading keyboard input, the sequences are
not checked for illegal bytes.

Since security is not considered, this decoder should not be used for anything
else."
  (let ((b1 (car byte-list)))
    (cond ((ascii-byte-p b1) b1) ; if a single byte, just return it.
          ((multi-byte-p b1)
           (if (lead-byte-p b1)
               (let ((n (n-trail-bytes b1))
                     ;; Content bits we want to extract from each lead byte.
                     (lead-templates (list #b01111111 #b00011111 #b00001111 #b00000111))
                     ;; Content bits we want to extract from each trail byte.
                     (trail-template #b00111111))
                 (if (= n (1- (list-length byte-list)))
                     ;; add lead byte
                     (+ (ash (logand (nth 0 byte-list) (nth n lead-templates)) (* 6 n))
                        ;; and the trail bytes
                        (loop for i from 1 to n sum
                             (ash (logand (nth i byte-list) trail-template) (* 6 (- n i)))))
                     (error "calculated number of bytes doesnt match the length of the byte list")))
               (error "first byte in the list isnt a lead byte"))))))

#|
(defun utf-8-to-unicode (byte-list)
  "Take a list of one to four utf-8 encoded bytes (octets), return the shortest possible unicode code point."
  (let ((b1 (car byte-list)))
    (if (lead-byte-p b1)
        (let ((n (n-trail-bytes b1)))
          (if (= n (1- (list-length byte-list)))

              (case n
                ;; if 0, we have simple ascii, so just get the char.
                (0 b1)
                ;; if 1, we have to convert 110yyyxx 10xxxxxx                   to 00000yyyxxxxxxxx
                (1 (+ (ash (logand (nth 0 byte-list) #b00011111) 6)
                      (ash (logand (nth 1 byte-list) #b00111111) 0)))
                ;; if 2, we have to convert 1110yyyy 10yyyyxx 10xxxxxx          to yyyyyyyyxxxxxxxx
                (2 (+ (ash (logand (nth 0 byte-list) #b00001111) 12)
                      (ash (logand (nth 1 byte-list) #b00111111) 6)
                      (ash (logand (nth 2 byte-list) #b00111111) 0)))
                ;; if 3, we have to convert 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx to 000zzzzz yyyyyyyy xxxxxxxx
                (3 (+ (ash (logand (nth 0 byte-list) #b00000111) 18)
                      (ash (logand (nth 1 byte-list) #b00111111) 12)
                      (ash (logand (nth 2 byte-list) #b00111111) 6)
                      (ash (logand (nth 3 byte-list) #b00111111) 0))))

              (error "calculated number of bytes doesnt match the length of the byte list")))
        (error "first byte in the list isnt a lead byte"))))
|#

#|
;; we also can determine the number of required bytes by the bit-length of the code point.
(n-bits (integer-length int))
         (n-trail-bytes (cond (                   (<= n-bits  7)  0)
                              ((and (> n-bits  7) (<= n-bits 11)) 1)
                              ((and (> n-bits 11) (<= n-bits 16)) 2)
                              ((and (> n-bits 16) (<= n-bits 21)) 3)))
|#

;; we can also just print the char to a string, and output the string.
;; this is easier than utf-8 single char input.
(defun unicode-to-utf-8 (int)
  "Take a unicode code point, return a list of one to four UTF-8 encoded bytes (octets)."
  (assert (<= (integer-length int) 21))
  (let ((n-trail-bytes (cond ((<= #x00000 int #x00007F) 0)
                             ((<= #x00080 int #x0007FF) 1)
                             ((<= #x00800 int #x00FFFF) 2)
                             ((<= #x10000 int #x10FFFF) 3)))
        (lead-templates (list #b00000000 #b11000000 #b11100000 #b11110000))
        (trail-template #b10000000)
        ;; number of content bits in the lead byte.
        (n-lead-bits (list 7 5 4 3))
        ;; number of content bits in the trail byte.
        (n-trail-bits 6)
        ;; list to put the UTF-8 encoded bytes in.
        (byte-list nil))
    (if (= n-trail-bytes 0)
        ;; if we need 0 trail bytes, ist just an ascii single byte.
        (push int byte-list)
        (progn
          ;; if we need more than one byte, first fill the trail bytes with 6 bits each.
          (loop for i from 0 to (1- n-trail-bytes)
             do (push (+ trail-template
                         (ldb (byte n-trail-bits (* i n-trail-bits)) int))
                      byte-list))
          ;; then copy the remaining content bytes to the lead byte.
          (push (+ (nth n-trail-bytes lead-templates)
                   (ldb (byte (nth n-trail-bytes n-lead-bits) (* n-trail-bytes n-trail-bits)) int))
                byte-list)))
    ;; return the list of UTF-8 encoded bytes.
    byte-list))

#|

;; %wgetch returns chars <255 and keycodes >255.
;; %wget_wch returns wide chars <255 and >255, and keycodes >255.
;; it also returns KEY_CODE_YES to designate that a >255 char is a keycode.
(defun get-char- (window &key y x)
  ""
  (let* ((winptr (winptr window))
         (byte-list nil)
         ;; get the first byte
         (b1 (%wgetch winptr)))
    ;; -1 means "no event", >255 means function key.
    ;; TODO: problem, when we return b1>255, how do we know that it is a function key and not a unicode code point??
    ;; we have to return function keywords _before_ we assemble a code point from utf-8.
    ;; we have to merge get-char and get-event.
    (when (= b1 -1) (return-from get-char- (values b1 nil)))
    (when (> b1 255) (return-from get-char- (values b1 t)))
    ;; normal 8-bit octets in the range 0-255.
    (if (lead-byte-p b1)
        (progn
          (push b1 byte-list)
          ;;(princ b1 window)
          (let ((n (n-trail-bytes b1)))
            (loop repeat n do
                 (let ((ch (%wgetch winptr)))
                   ;;(princ ch window)
                   (push ch byte-list)))))
        (error "First byte isnt a lead byte."))
    ;;(princ (utf-8-to-unicode (reverse byte-list)) window)
    (values (utf-8-to-unicode (reverse byte-list)) nil)))

(defun get-event- (window)
  (multiple-value-bind (code-point function-key-p) (get-char window)
    (cond
      ;; -1 means no key has been pressed.
      ((= code-point -1) nil)
      ;; 0-255 are regular chars, whch can be converted to lisp chars with code-char.
      ((and (>= code-point 0) (not function-key-p)) (code-char code-point))
      ;; if the code belongs to a known function key, return a keyword symbol.
      ((and (>= code-point 0) function-key-p)
       (let ((ev (function-key code-point)))
         (if (eq ev :mouse)
             (multiple-value-bind (mev y x) (get-mouse-event)
               (values mev y x)) ; returns 3 values, see mouse.lisp
             ev)))
      ;; todo: unknown codes, like mose, resize and unknown function keys.
      (t (error "invalid value of char received from ncurses.")))))

|#

;; return t if the chosen unicode points are encoded and decoded correctly.
(defun test-utf-8 ()
  (let* ((unicodes-orig (list 65 246 1046 8364 119070))
         (unicodes-test (mapcar #'(lambda (x) (utf-8-to-unicode (unicode-to-utf-8 x)))
                                unicodes-orig)))
    (mapcar #'(lambda (x)
                (format t
                        "code point: ~A, character ~A, utf8 ~A, correct enc-dec ~A~%"
                        x
                        (code-char x)
                        (unicode-to-utf-8 x)
                        (= x (utf-8-to-unicode (unicode-to-utf-8 x)))))
            unicodes-orig)
    ;; return t if all are t
    (every #'= unicodes-orig unicodes-test)))

;; reading utf-8 chars from the keyboard works.
;; tested in t03.
;; to make t16c work too, we have to similarly be able to extract utf-8 from a window.
;; characters are saved by ncurses as wchar_t or wint_t.

;; instead of get-char, use read-byte and gray streams

;; part 2 will be correctly implementing get_wch und winwch.
;; then we do not need utf-8 conversion.

;; read one (first) char from the stream
;; check how many chars we have to read if it is an utf8 char
;; read additional n (0-3) octets.
;; combine 1-4 octets into one lisp utf-8 char and return that char.

;; all bytes here are octets.

#|
(defun get-utf-8-char (byte-list)
  "Take a list of chars, return the first UTF-8 encoded char.

Signal an error if there are malformatted octets before the first char
is successfully read."
  (let ((one-char-list nil)
        (b1 (car byte-list)))
    (if (lead-byte-p b1)
        (progn
          (push b1 one-char-list)
          (let ((n (n-trail-bytes b1)))
            (loop for i from 1 to n do (push (nth i byte-list) one-char-list))))
        (error "First byte isnt a lead byte."))
    (reverse one-char-list)))
|#

;; (code-char (utf-8-to-unicode (bytes))) => #\a

;; char-code and code-char translate between lisp chars and unicode code points.
;; so we have to return wchar_t compatible 32-bit integers.

#|
;; instead of stream, we have to use window as an argument here.
(defun get-utf-8-char (stream)
  (let ((bytes nil)
        (ch (get-char window)))
    ;; check whether single-byte or multi-byte.
    ;; if single-byte: return ch
    ;; if multi-byte: read continuation bytes, combine bytes, return ch
    (if (lead-byte-p ch)
        (let ((n (n-trail-bytes ch)))
          (if (= n 0)
              (push ch bytes)
              (loop repeat n do (push (get-char window)))))
        (error "trail byte without lead byte"))))
|#

#|
(defun utf-8-number-of-bytes (first-byte)
  "returns the length of the utf-8 code in number of bytes, based on the first byte.
The length can be a number between 1 and 4."
  (declare (fixnum first-byte))
  (cond ((=       0 (ldb (byte 1 7) first-byte)) 1)
        ((=   #b110 (ldb (byte 3 5) first-byte)) 2)
        ((=  #b1110 (ldb (byte 4 4) first-byte)) 3)
        ((= #b11110 (ldb (byte 5 3) first-byte)) 4)
        (t (error "unknown number of utf-8 bytes for ~a" first-byte))))

(defun utf-8-decode-unicode-character-code-from-stream (stream)
  "Decodes byte values, from a binary byte stream, which describe a character
encoded using UTF-8.
Returns the character code and the number of bytes read."
  (let* ((first-byte (read-byte stream))
         (number-of-bytes (utf-8-number-of-bytes first-byte)))
    (declare (fixnum first-byte number-of-bytes))
    (ecase number-of-bytes
      (1 (values (ldb (byte 7 0) first-byte)
                 1))
      (2 (values (logior (ash (ldb (byte 5 0) first-byte) 6)
                         (ldb (byte 6 0) (read-byte stream)))
                 2))
      (3 (values (logior (ash (ldb (byte 5 0) first-byte) 12)
                         (ash (ldb (byte 6 0) (read-byte stream)) 6)
                         (ldb (byte 6 0) (read-byte stream)))
                 3))
      (4 (values (logior (ash (ldb (byte 3 0) first-byte) 18)
                         (ash (ldb (byte 6 0) (read-byte stream)) 12)
                         (ash (ldb (byte 6 0) (read-byte stream)) 6)
                         (ldb (byte 6 0) (read-byte stream)))
                 4))
      (t (error "wrong UTF-8 encoding for file position ~a of stream ~s"
                (file-position stream)
                stream)))))

(mapcar #'(lambda (x) (princ (code-char (utf-8-to-unicode (unicode-to-utf-8 x))))) (list 65 246 1046 8364 119070))

=> (#\A #\LATIN_SMALL_LETTER_O_WITH_DIAERESIS #\CYRILLIC_CAPITAL_LETTER_ZHE #\EURO_SIGN #\MUSICAL_SYMBOL_G_CLEF)
|#
