cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2024-12-22 23:47:56 +01:00
Code Issues

- fixed 'starting-emoji'.

Browse Source
This commit is contained in:
cage 2023-06-04 15:31:56 +02:00
parent c9f7fcb12e
commit 4100891dd5
2 changed files with 37 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
src/emoji-matcher.lisp
View File

@ -54,6 +54,15 @@
(find-if (lambda (a) (match-codepoint-p chars a))
',(extract-emojis-codepoints "https://unicode.org/Public/emoji/13.1/emoji-zwj-sequences.txt"))))
(defun fetch-max-codepoints-emoji-lengths ()
(length (reduce (lambda (a b)
(if (> (length a) (length b))
a
b))
(text-utils::extract-emojis-codepoints "https://unicode.org/Public/emoji/13.1/emoji-zwj-sequences.txt"))))
(alexandria:define-constant +max-codepoints-emoji-lengths+ 10 :test #'=)
;;;; expansion of (gen-matcher-sequences)
(defun emoji-sequences-p (chars)
@ -1302,7 +1311,13 @@
(defgeneric starting-emoji (object))
(defmethod starting-emoji ((object list))
(emojip object))
(loop for end from 1 to +max-codepoints-emoji-lengths+
when (>= (length object) end) do
(alexandria:when-let* ((sample (subseq object 0 end))
(emoji-list (emojip sample)))
(return-from starting-emoji emoji-list)))
nil)
(defmethod starting-emoji ((object string))
(emojip (coerce object 'list)))
(let ((chars-list (coerce object 'list)))
(starting-emoji chars-list)))

20
src/gui/client/main-window.lisp
View File

@ -541,6 +541,26 @@
(format nil "~a~a" prefix-other link-name))))))
(values link-rendered-label link-name link-value)))
(defun colorize-emoji (main-window line-index color &optional (start 0))
(with-accessors ((ir-lines ir-lines)
(ir-rendered-lines ir-rendered-lines)
(gemtext-widget gemtext-widget)) main-window
(let ((line (coerce (elt ir-rendered-lines line-index) 'list)))
(loop for i from start below (length line)
with skip-index = 0
do
(let ((emoji-code-points (starting-emoji (subseq line skip-index))))
(if emoji-code-points
(let ((tag (gui:tag-create gemtext-widget
(gui::create-tag-name)
`(:char ,i :line ,(1+ line-index))
`(:char ,(1+ i) :line ,(1+ line-index)))))
(gui:tag-configure gemtext-widget
tag
:foreground color))
(incf skip-index (length emoji-code-points)))
(incf skip-index))))))
(defun render-ir-lines (request-iri main-window)
(with-accessors ((ir-lines ir-lines)
(ir-rendered-lines ir-rendered-lines)