;;; Copyright (C) 2026 UBports Foundation
;;; SPDX-License-Identifier: Unicode-3.0

(use-modules
  (ice-9 peg)
  (ice-9 textual-ports)
  (ice-9 match)
  (srfi srfi-1)
  (sxml simple))

(setlocale LC_ALL "C.UTF-8")

;;; outputs an XML containing a list of emoji, grouped by common base for use with GNU AutoGen
;;; based on UTS #51 - https://www.unicode.org/reports/tr51
;;; with some logic from
;;;   https://github.com/unicode-org/cldr/blob/main/tools/cldr-code/src/main/java/org/unicode/cldr/util/Annotations.java
;;;   https://github.com/unicode-org/cldr/blob/main/tools/cldr-code/src/main/java/org/unicode/cldr/util/Emoji.java
;;; last updated for Unicode 17.0

;; emoji-test.txt is made for testing keyboards, but it's also the only source
;; of the recommended keyboard ordering
(define emoji-test-file
  (call-with-input-file "/usr/share/unicode/emoji/emoji-test.txt" get-string-all))
(define emoji-data-file
  (call-with-input-file "/usr/share/unicode/emoji/emoji-data.txt" get-string-all))

;; turns out you can't escape some hardcoded rules after 17+ versions of a standard
(define *light-tone* #x1F3FB)
(define *woman* #x1F469)
(define *man* #x1F468)
(define *person* #x1F9D1)

(define-peg-string-patterns
  "emoji-test <- (group-comment/comment/emoji-test-line/NL)*
emoji-test-line <-- code-points SEP status SP* (comment/NL*)

emoji-data <- (comment/emoji-data-line/NL)*
emoji-data-line <-- (code-point-range/code-points) SEP property SP* (comment/NL*)

group-comment <- GRP group NL
comment < HS (! NL .)* NL
property <-- [a-zA-Z_]+
status <-- 'component'/'fully-qualified'/'minimally-qualified'/'unqualified'
code <-- [A-F0-9]+
code-points <-- (code SP?)+
code-point-range <-- code DOTDOT code
text <- (!NL !DSP !';' !HS .)*
group <-- text

GRP < HS SP 'group:' SP
SEP < SP* ';' SP
DSP < SP SP
HS < '#'
SP < ' '
DOTDOT < '..'
NL < '\n'")

(define (map-apply proc target)
  (map (lambda (line) (apply proc line)) target))

(define (expand-code-range start end tail)
  (map
    (lambda (code) (cons (list code) tail))
    (iota (+ 1 (- end start)) start)))

(define (code->number code)
  (string->number (second code) 16))

;; this primarily expands ranges, eg. (ABCD..ABCF) -> (ABCD, ABCE, ABCF)
;; copies the rest of the line to each new entry and ensures code points are
;; always a list of numbers
(define (normalize-lines line)
  (match line
    ((_ ('code-point-range start end) tail ...)
     (expand-code-range (code->number start) (code->number end) tail))
    ((_ ('code-points codes ...) tail ...)
     (list (cons (map code->number codes) tail)))
    (('group group)
     (list line))))

(define (has-property? code property)
  (member (list code (list 'property property)) parsed-data))
(define (is-component? code)
  (has-property? (list code) "Emoji_Component"))
(define (is-modifier? code)
  (has-property? (list code) "Emoji_Modifier"))
(define (eq-first? a b)
  (equal? (first a) (first b)))

;; the base for variants is the result of removing modifiers (skin tones) and joiners
(define (not-base? code)
  (or (is-modifier? code) (memv code '(#x200D #xFE0F))))

;; the light skin tone is removed from clusters that have multiple skin tones so that it
;; groups with the variant without skin tone
;; TODO: remove when keyboard can handle more than 6 variants, have a proper pair selector
(define (light-tone-subdivision tones base)
  (if (or (> 2 (length tones)) (= *light-tone* (first tones)))
      base
      (cons (first tones) base)))

(define (sign->gender sign)
  (match sign
    (#x2640 *woman*)
    (#x2642 *man*)))
(define (skip-light-tone tone)
  (if (or (null? tone) (= *light-tone* (first tone)))
      '()
      tone))
(define (join-base tone gender1 gender2 joiner)
  (append
    (skip-light-tone (list tone))
    (list gender1)
    joiner
    (list gender2)))
(define (join-131-base tone gender joiner)
  (join-base tone gender gender joiner))

;;; these operate on bases, so don't actually contain ZWJ or variation selector-16
;; Unicode 12.0, turn fixed-gender emoji into new ZWJ sequence bases
(define (fix-120-base codes gender1 gender2 . joiner)
  (match codes
    ((_) (join-base *light-tone* gender1 gender2 joiner))
    ((_ tone) (join-base tone gender1 gender2 joiner))))
;; Unicode 13.1/17.0, fixed-gender + sign-format gendered into ZWJ sequence bases
(define (fix-131-base codes . joiner)
  (match codes
    ((_) (join-131-base *light-tone* *person* joiner))
    ((_ tone) (join-131-base tone *person* joiner))
    ((_ #x200D sign #xFE0F)
     (join-131-base *light-tone* (sign->gender sign) joiner))
    ((_ tone #x200D sign #xFE0F)
     (join-131-base tone (sign->gender sign) joiner))))
;; Unicode 14.0, turn handshake into ZWJ sequence base
(define (fix-handshake-base codes)
  (append
    (skip-light-tone (cdr codes))
    (list #x1FAF1 #x1FAF2)))

;; the match fixes inconsistencies introduced with Unicode 12.0, 13.1 and 17.0 based
;; on the logic in the Java files mentioned above
(define (derive-base codes category)
  (let* ((tones (filter is-modifier? codes))
         (base (remove not-base? codes))
         (subdivided-base (light-tone-subdivision tones base)))
    (list
      (match base
        ((#x1F46D) (fix-120-base codes *woman* *woman* #x1F91D)) ; 👭 -> 👩+🤝+👩
        ((#x1F46C) (fix-120-base codes *man* *man* #x1F91D))     ; 👬 -> 👨+🤝+👨
        ((#x1F46B) (fix-120-base codes *woman* *man* #x1F91D))   ; 👫 -> 👩+🤝+👨
        ((#x1F48F . sign) (fix-131-base codes #x2764 #x1F48B))   ; 💏 -> 🧑+❤️+💋+🧑
        ((#x1F491 . sign) (fix-131-base codes #x2764))           ; 💑 -> 🧑+❤️+🧑
        ((#x1F93C . sign) (fix-131-base codes #x1FAEF))          ; 🤼 -> 🧑+🫯+🧑
        ((#x1F46F . sign) (fix-131-base codes #x1F430))          ; 👯 -> 🧑+🐰+🧑
        ((#x1F9DE . sign) '(#x1F9DE))                            ; [🧞🧞‍♂️🧞‍♀️]
        ((#x1F9DF . sign) '(#x1F9DF))                            ; [🧟🧟‍♂️🧟‍♀️]
        ((#x1F91D . tone) (fix-handshake-base codes))            ; 🤝 -> 🫱+🫲
        (_ (light-tone-subdivision tones base)))
      codes
      category)))

;; the comments in emoji-test.txt are the only source of up-to-date categories,
;; this keeps the last seen group in the accumulator and assigns it to the emoji
;; that follow
;; it also filters out any not fully-qualified emoji since keyboards are not
;; supposed to display those
(define (fold-emoji line acc)
  (let ((group (first acc))
        (emoji (second acc)))
    (match line
      (('group new-group)
       (list new-group emoji))
      ((code ('status "fully-qualified"))
       (list group (cons (list code group) emoji)))
      (_ acc))))

;; folding the list generated with fold-emoji to gather unique category names
;; with their starting indices
(define (fold-categories line acc)
  (let ((pos (+ 1 (first acc)))
        (current-group (second acc))
        (groups (third acc))
        (line-group (third line)))
    (cond
      ((eq? current-group line-group)
       (list pos current-group groups))
      ((eq? current-group "") ; first category, set starting index to 0
       (list pos line-group (cons (list line-group 0) groups)))
      (else
       (list pos line-group (cons (list line-group pos) groups))))))

(define parsed-data
  (append-map normalize-lines (peg:tree (match-pattern emoji-data emoji-data-file))))
(define parsed-test
  (append-map normalize-lines (peg:tree (match-pattern emoji-test emoji-test-file))))
(define with-categories
  (reverse (second (fold fold-emoji (list "" (list)) parsed-test))))
(define with-bases (map-apply derive-base with-categories))
(define unique-bases (delete-duplicates with-bases eq-first?))
(define categories (third (fold fold-categories (list 0 "" (list)) unique-bases)))

(define (codes->xml tag codes)
  (list tag (list->string (map integer->char (second codes)))))
(define (codes->xml-variant codes) (codes->xml 'variant codes))
(define (category->xml name start)
  (list 'category
    (list '@ (list 'name name)
             (list 'start start))))
(define (variants->xml codes)
  (define (same-base line)
    (eq-first? line codes))
  (list 'variants
    (codes->xml 'base codes)
    (map codes->xml-variant (filter same-base with-bases))))

(define out-variants (map variants->xml unique-bases))
(define out-categories (reverse (map-apply category->xml categories)))

(define out (open-output-file "emojidata.xml"))
(sxml->xml
  (list 'emoji
    (list '@ (list 'template "emojidata.tpl"))
    out-variants
    out-categories)
  out)
